|
DataMuseum.dkPresents historical artifacts from the history of: MIKADOS |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about MIKADOS Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - download
Length: 8736 (0x2220)
Types: TextFile
Notes: Mikados_K
Names: »BOGJOU.K«
└─⟦eb89399bc⟧ Bits:30008990 SOM ISFORIG, MEN KUN K-FILER
└─⟦this⟧ »BOGJOU.K«
PROGRAM BOGHOLDERIJOURNAL;
(*$IISFHEAD*)
KPOST=RECORD
A:AR;
NR:ARRAY (1..23) OF INTEGER;
(*KNR1,KNR2,ANDBETADR,KÆDENR1,KÆDENR2,RESTORDRE,LAND,BETAKODE,LEVKODE,
RENTKODE,KREDDAGE,ANTFAKT,SIDFAKD1,SIDFAKD2,EMBALLAGE,BRÆKAGE,RABAT,
EXPORT,RFSALDO,PERTRENT,NPOSTNR1,NPOSTNR2*)
(* NAVN,UDVNAVN,LEVADR*)NAVN:ARRAY(1..3) OF PACKED ARRAY (1..30) OF CHAR;
LANDSBY:PACKED ARRAY (1..20) OF CHAR;
POSTNR:PACKED ARRAY (1..25) OF CHAR;
TLF:PACKED ARRAY (1..10) OF CHAR;
SALDOKØB :ARRAY (1..9) OF REAL;
(*SALDO1-6,ÅRKØB,MÅNKØB,SIDÅRKØB*)
END;
JOURPOST=RECORD
KONTONR1,KONTONR2,
DATO1,DATO2,
TEKSTKODE,
BILAG1,BILAG2,
KGB :INTEGER;
BELØB :REAL
END;
JOURFILE=FILE OF JOURPOST;
SYSPOST=RECORD
HELTAL:ARRAY(1..24) OF INTEGER;
KGB:ARRAY (1..5) OF REAL;
BETADAT:PACKED ARRAY (1..13) OF CHAR;
KODE:ARRAY (1..2) OF PACKED ARRAY (1..10) OF CHAR
END;
SYSFILE=FILE OF SYSPOST;
POSTPOST=RECORD
A:AR;
(*KNR1-2,DATO1-2,TEKSTKODE,BILAGSNR1-2*) HELTAL:ARRAY(1..7) OF INTEGER;
(*BELØB,RESTBELØB*) REEL:ARRAY (1..2) OF REAL
END;
POSTZONE=RECORD
H:ISFHEAD;
T:ARRAY (1..508) OF INTEGER
END;
KZONE=RECORD
H:ISFHEAD;
T:ARRAY(1..918) OF INTEGER
END;
VAR FPOST,FKUN : ISF;
JOURFIL:JOURFILE;
SYSFIL:SYSFILE;
KZ:KZONE;
PZ:POSTZONE;
PPOST:POSTPOST;
KUNDE:KPOST;
FNAVN:STRING(20);
IER,I,K,LINIE,SIDE
:INTEGER;
QUQ:^INTEGER;
R1:REAL;
DKB1,DKB:ARRAY (1..5) OF REAL;
TEKST:ARRAY (1..10) OF PACKED ARRAY (1..15) OF CHAR;
KONTO:ARRAY (1..5) OF PACKED ARRAY (1..5) OF CHAR;
(*$L-*)
(*$R-,IEXCOMCOP*)
(*$IIOPEN*)
(*$ISÆTØG*)
(*$IREADPROC*)
(*$IFINDPOST*)
(*$IFORSKYD*)
(*$IICLOSE*)
(*$IPUTGET*)
(*$IINSERT*)
(*$INEXTREC*)
(*$R+*)
(*$L+*)
PROCEDURE ERROR;
BEGIN
WRITELN('FEJL I REGISTER ',IER);
ICLOSE(KZ.H,FKUN);
ICLOSE(PZ.H,FPOST);
WRITELN('ICLOSE ',IER);
I:=I DIV 0
END;
PROCEDURE OFEJL;
BEGIN
GOTOXY(1,20);
WRITELN('REGISTERFEJL ',IER,' . SITUATIONEN ER FORSØGT REDDET.');
WRITELN('TAST 0, HVIS DER SKAL FORTSÆTTES');
REPEAT GOTOXY(40,21);READLN;READ(I) UNTIL IORESULT=0;
IF I<>0 THEN ERROR;
CLEARSCREEN
END;
PROCEDURE NEDTÆLÆLDSTE;
BEGIN
WITH KUNDE,PPOST DO
BEGIN
HELTAL(1):=KUNDE.NR(1);
HELTAL(2):=KUNDE.NR(2);
FOR I:=3 TO 7 DO HELTAL(I):=0;
NEXTREC(PZ.H,FPOST,A);
IF (IER<>-1) AND (IER<>-2) THEN ERROR;IER:=0;
WHILE (HELTAL(1)=NR(1)) AND (HELTAL(2)=NR(2)) AND (R1<0.0) DO
BEGIN
IF ((HELTAL(5)=1) OR (HELTAL(5)=4) OR (HELTAL(5)=9)) AND (REEL(2)>0)
THEN
BEGIN
REEL(2):=REEL(2)+R1;
IF REEL(2)<=0.0 THEN
BEGIN
R1:=REEL(2);
REEL(2):=0;
IF HELTAL(5)=1 THEN
BEGIN
NR(12):=NR(12)+1;
NR(11):=NR(11)+TRUNC(
JOURFIL^.DATO1*360.0+JOURFIL^.DATO2 DIV 100*30.0
+JOURFIL^.DATO2 MOD 100 -
HELTAL(3)*360.0-HELTAL(4) DIV 100*30.0-HELTAL(4) MOD 100);
END
END
ELSE R1:=0.0;
PUTREC(PZ.H,FPOST,A)
END
ELSE IF HELTAL(5)=10 THEN
BEGIN
REEL(2):=REEL(2)+JOURFIL^.BELØB;
IF REEL(2)<0 THEN REEL(2):=0
END;
NEXTREC(PZ.H,FPOST,A)
END
END
END;
PROCEDURE PRUT;
VAR I:INTEGER;
DIFFE:REAL;
BEGIN
DIFFE:=0.0;
FOR I:=1 TO 5 DO
BEGIN
WRITELN(LIST,LINIE:5,' ':5,KONTO(I),SIDE-1:22,' ':10,DKB1(I)/100:12:2);
LINIE:=LINIE+1;
DIFFE:=DIFFE+DKB1(I)-DKB(I)
END;
WRITELN(LIST);
WRITELN(LIST,'Difference',' ':37,DIFFE/100:12:2)
END;
PROCEDURE DOIT;
BEGIN
LINIE:=1;
FOR K:=1 TO SYSFIL^.HELTAL(16)-1 DO
BEGIN
GET(JOURFIL);
WITH JOURFIL^ DO
BEGIN
CASE TEKSTKODE OF
0: DKB1(KGB):=DKB1(KGB)+BELØB;
5,6,7,9,3,4:BEGIN
IF LINIE MOD 60=1 THEN
BEGIN
IF LINIE>1 THEN FOR I:=1 TO 8 DO WRITELN(LIST);
WRITELN(LIST,'B O G H O L D E R I J O U R N A L',' ':39,SIDE:5);
WRITELN(LIST);
WRITELN(LIST,'Linie',' ':5,'Tekst',' ':17,'Bilag',' ':5,'Debet',' ':7,
'Beløb',' ':4,'Kredit',SYSFIL^.HELTAL(1)*10000.0+
SYSFIL^.HELTAL(2):8:-2);
WRITELN(LIST);
SIDE:=SIDE+1
END;
DKB(KGB):=DKB(KGB)-BELØB;
KUNDE.NR(1):=KONTONR1;
KUNDE.NR(2):=KONTONR2;
GETREC(KZ.H,FKUN,KUNDE.A);
IF IER<>0 THEN ERROR;
WITH KUNDE DO
BEGIN
R1:=BELØB;
CASE TEKSTKODE OF
4,6,9:BEGIN
SALDOKØB(1):=SALDOKØB(1)+BELØB;
WRITELN(LIST,LINIE:5,' ':5,TEKST(TEKSTKODE),
BILAG1*10000.0+BILAG2:12:-2,
KONTONR1*10000.0+KONTONR2:10:-2,
BELØB/100:12:2,' ':4,KONTO(KGB),
DATO1*10000.0+DATO2:9:-2)
END;
3,5,7:BEGIN
SALDOKØB(6):=SALDOKØB(6)+BELØB;
I:=5;
WHILE (SALDOKØB(I+1)<0.0) AND (I>0) DO
BEGIN
SALDOKØB(I):=SALDOKØB(I)+SALDOKØB(I+1);
SALDOKØB(I+1):=0.0;
I:=I-1
END;
WRITELN(LIST,LINIE:5,' ':5,TEKST(TEKSTKODE),
BILAG1*10000.0+BILAG2:12:-2,' ':5,KONTO(KGB),
-BELØB/100:12:2,KONTONR1*10000.0+KONTONR2:9:-2,
DATO1*10000.0+DATO2:9:-2);
NEDTÆLÆLDSTE
END
END
END;
LINIE:=LINIE+1;
PUTREC(KZ.H,FKUN,KUNDE.A);
IF IER<>0 THEN ERROR;
WITH PPOST DO
BEGIN
HELTAL(1):=KONTONR1;
HELTAL(2):=KONTONR2;
HELTAL(3):=DATO1;
HELTAL(4):=DATO2;
HELTAL(5):=TEKSTKODE;
HELTAL(6):=BILAG1;
HELTAL(7):=BILAG2;
REEL(1):=BELØB;
REEL(2):=R1;
INSERT(PZ.H,FPOST,A);
IF IER<>0 THEN ERROR
END;
END
END;
END;
END;
PRUT
END;
BEGIN
FNAVN:='KUNDERG:P2:0000:I';
REWRITE(FKUN,FNAVN);
IOPEN(KZ.H,FKUN,SKRIV);IF IER<>0 THEN OFEJL;
FNAVN:='POSTREG:P2:0000:I';
REWRITE(FPOST,FNAVN);
IOPEN(PZ.H,FPOST,SKRIV);
IF IER<>0 THEN OFEJL;
FNAVN:='SYSREG:P2:1:I';
REWRITE(SYSFIL,FNAVN);
SEEK(SYSFIL,1);
GET(SYSFIL);
SIDE:=SYSFIL^.HELTAL(19);
FNAVN:='JOURKASS:P1:30:I';
REWRITE(JOURFIL,FNAVN);
FOR I:=1 TO 5 DO BEGIN DKB(I):=0.0;DKB1(I):=0.0 END;
KONTO(1):='Kasse';
KONTO(2):='Bank ';
KONTO(3):='Giro ';
KONTO(4):='Rabat';
KONTO(5):='Rente';
TEKST(3):='Indbetaling ';
TEKST(4):='Udbetaling ';
TEKST(5):='Kasserabat ';
TEKST(6):='Rabat-rettelse ';
TEKST(7):='Rente-rettelse ';
TEKST(9):='Rentenota ';
IF (SYSFIL^.HELTAL(16)-1>PZ.H.NREC-PZ.H.RECINUSE) THEN
WRITELN('Der er ikke plads til flere posteringer')
ELSE
BEGIN
SEEK(JOURFIL,1);
DOIT;
ICLOSE(KZ.H,FKUN);
ICLOSE(PZ.H,FPOST);
SYSFIL^.HELTAL(16):=1;
FOR I:=1 TO 5 DO
SYSFIL^.KGB(I):=SYSFIL^.KGB(I)+DKB1(I);
SYSFIL^.HELTAL(19):=SIDE;
SEEK(SYSFIL,1);
PUT(SYSFIL);
END;
CLOSE(JOURFIL);
CLOSE(SYSFIL);
CHAIN('INTRE *1','HOVSA:P1',QUQ)
END.