|
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: 15168 (0x3b40)
Types: TextFile
Notes: Mikados_K
Names: »SMAFSLUT.K«
└─⟦eb89399bc⟧ Bits:30008990 SOM ISFORIG, MEN KUN K-FILER
└─⟦this⟧ »SMAFSLUT.K«
PROGRAM MÅNEDSAFSLUTNING;
CONST DK=8;
(*$IISFHEAD*)
KPOST=RECORD
A:AR;
NR:ARRAY(1..23) OF INTEGER;
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
END;
ZONE= RECORD
H:ISFHEAD;
T:ARRAY(1..918) OF INTEGER
END;
VPOST=RECORD
A :AR;
HELTAL:ARRAY (1..11) OF INTEGER;
(*VARENR,LVRNDØR,OPRLAND,PAKENHED,FORVLEVU,DATSBES1,DATSBES2,DATSORD1,
DATSORD2,DÆKGRASÅ,ANAFTILG*)
NAVN:ARRAY (1..2) OF PACKED ARRAY(1..30) OF CHAR;
(*VARENAVN,NAVNHOSLEVERANDØR*)
REELTAL :ARRAY (1..15) OF REAL
(*PRIS,KOSTPRIS,TOLDPNR,FYSLAGER,PRIMOLAG,MINLAGER,RESAFLAG,IORDRE,
RESAFIORDRE,STASBEST,ASOLGTIÅ,ASOLGTSÅ,OMSIÅR,OMSSÅR,DÆKBIDTD*)
END;
VZONE= RECORD
H:ISFHEAD;
T:ARRAY(1..451) OF INTEGER
END;
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;
LANDFILE=FILE OF PACKED ARRAY (1..30) OF CHAR;
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;
BETAPOST=RECORD
A:AR;
NR:ARRAY (1..3) OF INTEGER;
(*KNR1,KNR2,LAND*)
NAVN:ARRAY (1..3) OF PACKED ARRAY (1..30) OF CHAR;
(*NAVN,UDVNAVN,ADR*)
LANDSBY:PACKED ARRAY (1..20) OF CHAR;
POSTNR:PACKED ARRAY (1..25) OF CHAR;
TLF:PACKED ARRAY (1..10) OF CHAR
END;
BETAZONE=RECORD
H:ISFHEAD;
T:ARRAY(1..374) OF INTEGER
END;
RORPOST=RECORD
A:AR;
(* KNR1,KNR2,
VNR,
DAT1,DAT2:INTEGER;*) HEAD:ARRAY(1..5) OF INTEGER;
ANTAL:REAL
END;
RORZONE=RECORD
H:ISFHEAD;
T:ARRAY(1..327) OF INTEGER
END;
PROCSTAT=RECORD
NP,NROSTART:INTEGER
END;
NPFILE=FILE OF PROCSTAT;
VAR FBETA,FVAR,FROR,FPOST,FKUN:ISF;
BZ:BETAZONE;
BETA:BETAPOST;
VZ:VZONE;
VARE:VPOST;
SYSFIL:SYSFILE;
PZ:POSTZONE;
PPOST:POSTPOST;
LINE:ARRAY (1..22) OF STRING(72);
TEKST:ARRAY(1..4) OF STRING(72);
RZ:RORZONE;
LANDFIL:LANDFILE;
RESTORD:RORPOST;
NRPF,CF:NPFILE;
QUQ:^INTEGER;
CH:CHAR;
KZ:ZONE;
FILNAVN2:STRING(20);
LINIE,J,IER,I:INTEGER;
KUNDE:KPOST;
PTYPE:ARRAY (0..10) OF PACKED ARRAY (1..15) OF CHAR;
NAME:PACKED ARRAY (1..26) OF CHAR;
R,TOTAL:REAL;
F:TEXT;
NOFIND:BOOLEAN;
(*$L-*)
(*$R-,IEXCOMCOP*)
(*$ISÆTØG*)
(*$IREADPROC*)
(*$IFINDPOST*)
(*$IFORSKYD*)
(*$INEXTREC*)
(*$IDELETE*)
(*$IINSERT*)
(*$IIOPEN*)
(*$IICLOSE*)
(*$IPUTGET*)
(*$R+*)
(*$L+*)
PROCEDURE ERROR;
BEGIN
WRITELN('FEJL I KUNDEREG ',IER);
ICLOSE(KZ.H,FKUN);
ICLOSE(PZ.H,FPOST);
ICLOSE(RZ.H,FROR);
ICLOSE(VZ.H,FVAR);
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 HEAD(J:INTEGER);
VAR I:INTEGER;
BEGIN
FOR I:=1 TO 9 DO WRITELN(LIST);
WITH KUNDE DO
IF NOFIND THEN
BEGIN
FOR I:=1 TO 11 DO WRITELN(LIST);
WRITELN(LIST,NR(1)*10000.0+NR(2):9:-2,' ':52,SYSFIL^.HELTAL(1)*10000.0+
SYSFIL^.HELTAL(2):10:-2);
WRITELN(LIST)
END
ELSE
BEGIN
IF (NR(3)=1) AND (J=1) THEN
BEGIN
I:=0;
REPEAT I:=I+1
UNTIL (I=4) OR (BETA.NAVN(1,I)<>' ');
IF BETA.NAVN(1,I)=' ' THEN
BEGIN
MOVELEFT(BETA.NAVN(1,5),NAME,26);
WRITE(LIST,' ':6,NAME,' ':14)
END
ELSE
WRITE(LIST,' ':6,BETA.NAVN(1),' ':10);
I:=0;
REPEAT I:=I+1
UNTIL (I=4) OR (NAVN(1,I)<>' ');
IF NAVN(1,I)=' ' THEN
BEGIN
MOVELEFT(NAVN(1,5),NAME,26);
WRITELN(LIST,NAME)
END
ELSE
WRITELN(LIST,NAVN(1));
WRITELN(LIST,' ':6,BETA.NAVN(2),' ':10,NAVN(2));
WRITELN(LIST,' ':6,BETA.NAVN(3),' ':10,NAVN(3));
WRITELN(LIST,' ':6,BETA.LANDSBY,' ':20,LANDSBY);
WRITELN(LIST,' ':6,BETA.POSTNR,' ':15,POSTNR);
IF BETA.NR(3)=DK THEN
WRITE(LIST,' ':46)
ELSE
BEGIN
SEEK(LANDFIL,BETA.NR(3));
GET(LANDFIL);
WRITE(LIST,' ':6,LANDFIL^,' ':10)
END;
IF NR(7)=DK THEN
WRITELN(LIST)
ELSE
BEGIN
SEEK(LANDFIL,NR(7));
GET(LANDFIL);
WRITELN(LIST,LANDFIL^)
END
END
ELSE
BEGIN
I:=0;
REPEAT I:=I+1
UNTIL (I=4) OR (NAVN(1,I)<>' ');
IF NAVN(1,I)=' ' THEN
BEGIN
MOVELEFT(NAVN(1,5),NAME,26);
WRITELN(LIST,' ':6,NAME)
END
ELSE
WRITELN(LIST,' ':6,NAVN(1));
WRITELN(LIST,' ':6,NAVN(2));
WRITELN(LIST,' ':6,NAVN(3));
WRITELN(LIST,' ':6,LANDSBY);
WRITELN(LIST,' ':6,POSTNR);
IF NR(7)=DK THEN
WRITELN(LIST)
ELSE
BEGIN
SEEK(LANDFIL,NR(7));
GET(LANDFIL);
WRITELN(LIST,' ':6,LANDFIL^)
END
END;
FOR I:=1 TO 5 DO WRITELN(LIST);
WRITELN(LIST,NR(1)*10000.0+NR(2):9:-2,' ':52,SYSFIL^.HELTAL(1)*10000.0+
SYSFIL^.HELTAL(2):10:-2);
WRITELN(LIST)
END
END;
PROCEDURE PRKUNOPL;
BEGIN
IF NOFIND THEN WRITELN(LIST) ELSE
WITH KUNDE DO
BEGIN
WRITE(LIST,SALDOKØB(7)/100:9:2,
(SALDOKØB(1)+SALDOKØB(2))/100:12:2,
(SALDOKØB(3)+SALDOKØB(4))/100:12:2,
(SALDOKØB(5)+SALDOKØB(6))/100:13:2);
IF PPOST.REEL(1)<0.0 THEN
WRITELN(LIST,' ':13,-PPOST.REEL(1)/100:13:2)
ELSE
WRITELN(LIST,PPOST.REEL(1)/100:13:2);
END;
WRITELN(LIST);
WRITELN(LIST);
IF KUNDE.SALDOKØB(1)+KUNDE.SALDOKØB(2)+KUNDE.SALDOKØB(3)+
KUNDE.SALDOKØB(4)+KUNDE.SALDOKØB(5)+KUNDE.SALDOKØB(6)<>PPOST.REEL(1)
THEN WRITELN(LIST,'****** FEJL I KONTOUDTOG, UDSENDES IKKE ******')
ELSE
WRITELN(LIST);
END;
PROCEDURE BREV;
BEGIN
HEAD(1);
FOR I:=1 TO 22 DO WRITELN(LIST,' ':4,LINE(I));
FOR I:=1 TO 4 DO WRITELN(LIST)
END;
PROCEDURE SKRIVLIN;
BEGIN
LINIE:=LINIE+1;
IF LINIE=20 THEN
BEGIN
FOR I:=1 TO 103 DO WRITELN(LIST);
HEAD(1);
LINIE:=1
END;
WITH PPOST DO
BEGIN
WRITE(LIST,HELTAL(3)*10000.0+HELTAL(4):9:-2,
HELTAL(6)*10000.0+HELTAL(7):7:-2,' ':2,
PTYPE(HELTAL(5)),' ':13);
IF REEL(1)>0 THEN
BEGIN
WRITELN(LIST,REEL(1)/100:13:2);
IF (TOTAL<0.0) AND (REEL(2)>0.0) THEN
BEGIN
REEL(2):=REEL(2)+TOTAL;
IF REEL(2)<=0.0 THEN
BEGIN
KUNDE.NR(12):=KUNDE.NR(12)+1;
REEL(2):=0.0
END
END;
TOTAL:=TOTAL+REEL(1)
END
ELSE
BEGIN
WRITELN(LIST,' ':13,-REEL(1)/100:13:2);
REEL(2):=0.0;
TOTAL:=TOTAL+REEL(1)
END
END
END;
PROCEDURE KONTOUDT;
VAR RENT:BOOLEAN;
BEGIN
LINIE:=0;
WITH PPOST,KUNDE DO
BEGIN
WHILE (HELTAL(5)<>10) AND (IER=0) AND (HELTAL(1)=NR(1)) AND
(HELTAL(2)=NR(2)) DO NEXTREC(PZ.H,FPOST,PPOST.A);
IF (IER<>0) AND (IER<>-2) THEN ERROR;
TOTAL:=0.0;
RENT:=FALSE;
HEAD(1);
IF (HELTAL(1)<>NR(1)) OR (HELTAL(2)<>NR(2)) OR (IER=-2) THEN
BEGIN
HELTAL(1):=NR(1);
HELTAL(2):=NR(2);
FOR I:=3 TO 7 DO HELTAL(I):=0;
HELTAL(5):=-1;
NEXTREC(PZ.H,FPOST,PPOST.A);
IF IER<>-1 THEN ERROR;IER:=0
END
ELSE
BEGIN
SKRIVLIN;
DELETE(PZ.H,FPOST,PPOST.A);
END;
WHILE (IER=0) AND (NR(1)=HELTAL(1)) AND (NR(2)=HELTAL(2)) DO
BEGIN
IF HELTAL(5)=9 THEN RENT:=TRUE;
SKRIVLIN;
PUTREC(PZ.H,FPOST,PPOST.A);
NEXTREC(PZ.H,FPOST,PPOST.A)
END;
IF (IER<>-2) AND (IER<>0) THEN ERROR;
IF NOFIND THEN REPEAT WRITELN(LIST);LINIE:=LINIE+1 UNTIL LINIE=26
ELSE
BEGIN
HELTAL(1):=NR(1);
HELTAL(2):=NR(2);
HELTAL(3):=SYSFIL^.HELTAL(1);
HELTAL(4):=SYSFIL^.HELTAL(2);
HELTAL(5):=10;
HELTAL(6):=0;
HELTAL(7):=0;
REEL(1):=0.0;
FOR I:=1 TO 6 DO REEL(1):=REEL(1)+SALDOKØB(I);
REEL(2):=REEL(1);
INSERT(PZ.H,FPOST,PPOST.A);
WHILE LINIE<18 DO
BEGIN
WRITELN(LIST);
LINIE:=LINIE+1
END;
LINIE:=LINIE+1;
IF REEL(1)<>TOTAL THEN
WRITELN(LIST,' ':18,'JUSTERING',' ':19,(REEL(1)-TOTAL)/100:13:2)
ELSE WRITELN(LIST);
IF RENT THEN
BEGIN
WRITELN(LIST,' ',TEKST(3));
WRITELN(LIST,' ',TEKST(4))
END
ELSE
BEGIN
WRITELN(LIST);
WRITELN(LIST)
END;
WRITELN(LIST);
LINIE:=LINIE+3;
PRKUNOPL;
R:=SALDOKØB(5);
SALDOKØB(5):=SALDOKØB(6)+SALDOKØB(4);
SALDOKØB(6):=R;
SALDOKØB(4):=SALDOKØB(3);
SALDOKØB(3):=SALDOKØB(2);
SALDOKØB(2):=SALDOKØB(1);
SALDOKØB(1):=0.0;
SALDOKØB(8):=0.0;
END
END
END;
PROCEDURE RESTORDRER;
BEGIN
RESTORD.HEAD(1):=KUNDE.NR(1);
RESTORD.HEAD(2):=KUNDE.NR(2);
RESTORD.HEAD(3):=-1;
NEXTREC(RZ.H,FROR,RESTORD.A);
LINIE:=0;
HEAD(0);
IF (IER=-1) OR (IER=-2) OR (IER=-9) THEN IER:=0 ELSE ERROR;
IF (RESTORD.HEAD(1)=KUNDE.NR(1)) AND (RESTORD.HEAD(2)=KUNDE.NR(2))
THEN
REPEAT
LINIE:=LINIE+1;
IF LINIE=22 THEN
BEGIN
FOR I:=1 TO 101 DO WRITELN(LIST);
HEAD(0);
LINIE:=1
END;
VARE.HELTAL(1):=RESTORD.HEAD(3);
GETREC(VZ.H,FVAR,VARE.A);
IF (IER<>0) AND (IER<>-6) THEN ERROR;
IF IER=0 THEN
BEGIN
WRITE(LIST,RESTORD.HEAD(3):9,' ':3,VARE.NAVN(1):30,' ':4);
WRITELN(LIST,RESTORD.ANTAL:6:-2,RESTORD.HEAD(4)*10000.0+
RESTORD.HEAD(5):12:-2);
END
ELSE
WRITELN(LIST,RESTORD.HEAD(3):9,' ':3,'FINDES IKKE');
NEXTREC(RZ.H,FROR,RESTORD.A)
UNTIL (IER<>0) OR (RESTORD.HEAD(1)<>KUNDE.NR(1)) OR
(RESTORD.HEAD(2)<>KUNDE.NR(2));
IF LINIE=0 THEN
BEGIN
WRITELN(LIST,' ':12,'Ingen restordrer');
LINIE:=1
END;
WHILE LINIE<21 DO BEGIN WRITELN(LIST);LINIE:=LINIE+1 END;
WRITELN(LIST,' ',TEKST(1));
WRITELN(LIST,' ',TEKST(2));
FOR I:=1 TO 3 DO WRITELN(LIST);
IF (IER<>0) AND (IER<>-2) AND (IER<>-9) THEN ERROR;
END;
PROCEDURE INITTEXT;
BEGIN
PTYPE(0):='Fejl-postering ';
PTYPE(1):='Faktura ';
PTYPE(2):='Kreditnota ';
PTYPE(3):='Indbetaling ';
PTYPE(4):='Udbetaling ';
PTYPE(5):='Kasserabat ';
PTYPE(6):='Rabatrettelse ';
PTYPE(7):='Renterettelse ';
PTYPE(9):='Rentenota ';
PTYPE(10):='Sidste udtog ';
TEKST(1):=
'Dette er en ny ajourført liste over Deres restordrer, som leveres så ';
TEKST(2):=
'snart varerne igen er på lager. Bedes gemt til de modtager en ny. ';
TEKST(3):=
'Da vi har konstateret, at De har overskredet vore betalingsbetingelser, ';
TEKST(4):=
'har vi tilladt os at debitere Dem renter jvnf. ovenstående. ';
REPEAT
CLEARSCREEN;
WRITELN('Rentetekst');
WRITELN(TEKST(3));
WRITELN(TEKST(4));
GOTOXY(1,2);EDIT(TEKST(3));
GOTOXY(1,3);EDIT(TEKST(4));
WRITELN('Restordretekst');
WRITELN(TEKST(1));
WRITELN(TEKST(2));
GOTOXY(1,5);EDIT(TEKST(1));
GOTOXY(1,6);EDIT(TEKST(2));
WRITELN('Tilfreds (J/N)');
REPEAT
GOTOXY(17,7);READLN;READ(CH)
UNTIL (IORESULT=0) AND ((CH='J') OR (CH='N') OR (CH='j') OR (CH='n'));
UNTIL (CH='J') OR (CH='j');
END;
BEGIN
FILNAVN2:='BREV:P1:0:K';
RESET(F,FILNAVN2);
READLN(F);
FOR I:=1 TO 22 DO READLN(F,LINE(I));
CLOSE(F);
FILNAVN2:='PROCSTAT:P2:0:I';
(*$C-*)
REPEAT
REWRITE(NRPF,FILNAVN2);
SEEK(NRPF,1)
UNTIL IORESULT=0;
(*$C+*)
GET(NRPF);
NRPF^.NP:=1;
SEEK(NRPF,1);
PUT(NRPF);
REPEAT
GOTOXY(1,20);
WRITELN('Sæt plade 1 i drev 1 og tryk RETURN');
READLN;
(*$C-*)
REWRITE(CF,'C1:P1:0:J');
SEEK(CF,1)
(*$C+*)
UNTIL IORESULT=0;
CLOSE(CF);
CLOSE(NRPF);
FILNAVN2:='KUNDERG:P2:1338:I';
REWRITE(FKUN,FILNAVN2);
IOPEN(KZ.H,FKUN,SKRIV);
IF IER<>0 THEN OFEJL;
FILNAVN2:='LANDEREG:P2:0:I';
REWRITE(LANDFIL,FILNAVN2);
FILNAVN2:='BETAREG:P2:0000:I';
RESET(FBETA,FILNAVN2);
IOPEN(BZ.H,FBETA,LÆS);
FILNAVN2:='REGVARE:P1:0000:I';
RESET(FVAR,FILNAVN2);
IOPEN(VZ.H,FVAR,LÆS);IF IER<>0 THEN ERROR;
FILNAVN2:='RESTREG:P2:0000:I';
RESET(FROR,FILNAVN2);
IOPEN(RZ.H,FROR,LÆS);IF IER<>0 THEN ERROR;
FILNAVN2:='POSTREG:P2:0000:I';
REWRITE(FPOST,FILNAVN2);
IOPEN(PZ.H,FPOST,SKRIV);
IF IER<>0 THEN ERROR;
FILNAVN2:='SYSREG:P2:1:I';
RESET(SYSFIL,FILNAVN2);
SEEK(SYSFIL,1);
GET(SYSFIL);
CLOSE(SYSFIL);
INITTEXT;
FOR I:=1 TO 7 DO PPOST.HELTAL(I):=0;
NEXTREC(PZ.H,FPOST,PPOST.A);
IF IER<>-1 THEN ERROR;IER:=0;
WHILE IER=0 DO
WITH PPOST,KUNDE DO
BEGIN
NOFIND:=FALSE;
NR(1):=HELTAL(1);
NR(2):=HELTAL(2);
GETREC(KZ.H,FKUN,KUNDE.A);
IF (IER<>0) AND (IER<>-6) THEN ERROR;
IF IER=-6 THEN BEGIN NOFIND:=TRUE;IER:=0 END;
IF NR(3)=1 THEN
BEGIN
BETA.NR(1):=NR(1);
BETA.NR(2):=NR(2);
GETREC(BZ.H,FBETA,BETA.A);
IF IER<>0 THEN IF IER=-6 THEN BEGIN NOFIND:=TRUE;IER:=0 END
ELSE ERROR;
END;
IF NOT NOFIND THEN
FOR I:=1 TO 6 DO
IF SALDOKØB(I)<>0.0 THEN
BEGIN
KONTOUDT;
BREV;
RESTORDRER;
PUTREC(KZ.H,FKUN,KUNDE.A);
I:=6;
END;
NEXTREC(PZ.H,FPOST,PPOST.A)
END;
IF IER<>-2 THEN ERROR;
ICLOSE(KZ.H,FKUN);
ICLOSE(PZ.H,FPOST);
CLEARSCREEN;
WRITELN('ICLOSE ',IER,I:7);
CHAIN('INTRE *1','HOVSA:P1',QUQ)
END.