|
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: »NORMFAKT.K«
└─⟦eb89399bc⟧ Bits:30008990 SOM ISFORIG, MEN KUN K-FILER
└─⟦this⟧ »NORMFAKT.K«
PROGRAM NORMALFAKTURERING;
CONST TOPMARG=6; LMARG=9; DK=8;
(*$IISFHEAD*)
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;
PLUOLINE = RECORD
VNR :ARRAY (1..3) OF INTEGER;
(*VNR,LEVERET,BESTILT*)
PRIS: REAL
END;
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;
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;
RORPOST=RECORD
A:AR;
(* KNR1,KNR2,
VNR,
DAT1,DAT2:INTEGER;*) HEAD:ARRAY(1..5) OF INTEGER;
ANTAL:REAL
END;
FAKPOST= RECORD
FORSEND:INTEGER;
EMBAL,FRAGT:REAL;
HEAD:ARRAY (1..12) OF INTEGER;
LINE:ARRAY (1..2) OF PACKED ARRAY (1..30) OF CHAR;
DITTO:ARRAY (1..2) OF PACKED ARRAY (1..20) OF CHAR;
ORDRELIN: ARRAY(1..15) OF PLUOLINE
END;
FAKFILE=FILE OF FAKPOST;
JOURPOST=RECORD
(*KNR1,KNR2,
FAKTNR1-2,DAT1-2*) NR:ARRAY(1..6) OF INTEGER;
(*NETTO,
MOMS,
RABAT,
BRÆKAGEFORS,
FRAGT,
EMBALLAGE,
VARESALG *) REEL:ARRAY(1..7) OF REAL
END;
JOURFILE=FILE OF JOURPOST;
SYSPOST=RECORD
(*DATO1,DATO2,
UGENR,
MAXEXC,
ORDRENR1-2,
FAKTNR1-2,
KREDNTNR1-2,
BILAGSNR1-2,JOURFILNR*) HELTAL: ARRAY (1..24) OF INTEGER;
KGB:ARRAY (1..5) OF REAL;
BETADAT:PACKED ARRAY (1..13) OF CHAR;
(*KIKKODE,ÆNDKODE*) KODE:ARRAY (1..2) OF PACKED ARRAY (1..10) OF CHAR
END;
SYSFILE=FILE OF SYSPOST;
VZONE= RECORD
H:ISFHEAD;
T:ARRAY(1..451) OF INTEGER
END;
KZONE=RECORD
H:ISFHEAD;
T:ARRAY(1..918) OF INTEGER
END;
RORZONE=RECORD
H:ISFHEAD;
T:ARRAY(1..327) OF INTEGER
END;
BETAZONE=RECORD
H:ISFHEAD;
T:ARRAY(1..374) OF INTEGER
END;
LANDFILE=FILE OF PACKED ARRAY (1..30) OF CHAR;
VAR FBETA,FVAR,FROR,FKUN : ISF;
FAKFIL,EXPFIL :FAKFILE;
SYSFIL:SYSFILE;
LANDFIL:LANDFILE;
JOURFIL:JOURFILE;
T:TEXT;
NAME:PACKED ARRAY (1..26) OF CHAR;
VZ:VZONE;
BZ:BETAZONE;
RZ:RORZONE;
KZ:KZONE;
RESTORD:RORPOST;
VARE:VPOST;
KUNDE:KPOST;
BETA:BETAPOST;
FNAVN:STRING(20);
SENDTPR:ARRAY (1..20) OF PACKED ARRAY (1..30) OF CHAR;
IER,I,J,K,SIDE
:INTEGER;
R,R1,R2 :REAL;
QUQ:^INTEGER;
(*$L-*)
(*$R-,IEXCOMCOP*)
(*$IIOPEN*)
(*$ISÆTØG*)
(*$IREADPROC*)
(*$IFINDPOST*)
(*$IFORSKYD*)
(*$IICLOSE*)
(*$IPUTGET*)
(*$IINSERT*)
(*$R+,L+*)
PROCEDURE ERROR;
BEGIN
WRITELN('FEJL I REGISTER ',IER);
ICLOSE(VZ.H,FVAR);
ICLOSE(RZ.H,FROR);
ICLOSE(KZ.H,FKUN);
ICLOSE(BZ.H,FBETA);
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;
VAR I:INTEGER;
BEGIN
WITH KUNDE DO
BEGIN
WRITELN(T,'%P');
FOR I:=1 TO TOPMARG DO WRITELN(T);
IF NR(3)=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(T,' ':6,NAME,' ':14)
END
ELSE
WRITE(T,' ':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(T,NAME)
END
ELSE
WRITELN(T,NAVN(1));
WRITELN(T,' ':6,BETA.NAVN(2),' ':10,NAVN(2));
WRITELN(T,' ':6,BETA.NAVN(3),' ':10,NAVN(3));
WRITELN(T,' ':6,BETA.LANDSBY,' ':20,LANDSBY);
WRITELN(T,' ':6,BETA.POSTNR,' ':15,POSTNR);
IF BETA.NR(3)=DK THEN
WRITE(T,' ':46)
ELSE
BEGIN
SEEK(LANDFIL,BETA.NR(3));
GET(LANDFIL);
WRITE(T,' ':6,LANDFIL^,' ':10)
END;
IF NR(7)=DK THEN
WRITELN(T)
ELSE
BEGIN
SEEK(LANDFIL,NR(7));
GET(LANDFIL);
WRITELN(T,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(T,' ':6,NAME)
END
ELSE
WRITELN(T,' ':6,NAVN(1));
WRITELN(T,' ':6,NAVN(2));
WRITELN(T,' ':6,NAVN(3));
WRITELN(T,' ':6,LANDSBY);
WRITELN(T,' ':6,POSTNR);
IF NR(7)=DK THEN
WRITELN(T)
ELSE
BEGIN
SEEK(LANDFIL,NR(7));
GET(LANDFIL);
WRITELN(T,' ':6,LANDFIL^)
END
END;
WRITELN(T);WRITELN(T);
WRITELN(T,' ':53,'Fakturanummer ',
SYSFIL^.HELTAL(7)*10000.0+SYSFIL^.HELTAL(8):6:-2);
WRITELN(T);
WRITELN(T,' ':74,SIDE:2);
SIDE:=SIDE+1;
WRITE(T,NR(1)*10000.0+NR(2):9:-2);
WITH FAKFIL^ DO
WRITE(T,HEAD(3)*10000.0+HEAD(4):8:-2);
WRITELN(T,' ':2,SENDTPR(FAKFIL^.FORSEND),' ':14,SYSFIL^.HELTAL(1)*10000.0+
SYSFIL^.HELTAL(2):6:-2);
J:=1;
WRITELN(T)
END
END;
PROCEDURE LINES;
BEGIN
WITH KUNDE,FAKFIL^.ORDRELIN(I) DO
IF VNR(1)>1 THEN
BEGIN
VARE.HELTAL(1):=VNR(1);
GETREC(VZ.H,FVAR,VARE.A);
IF (IER<>0) AND (IER<>-6) THEN ERROR;
IF IER=0 THEN
BEGIN
IF J>22 THEN HEAD;
VARE.REELTAL(11):=VARE.REELTAL(11)+VNR(2);
VARE.REELTAL(13):=VARE.REELTAL(13)+VNR(2)*PRIS;
VARE.REELTAL(15):=VARE.REELTAL(15)+VNR(2)*(PRIS-VARE.REELTAL(2));
VARE.HELTAL(8):=SYSFIL^.HELTAL(1);
VARE.HELTAL(9):=SYSFIL^.HELTAL(2);
WRITELN(T,VNR(1):9,' ':2,VARE.NAVN(1),VNR(2):5,VNR(3)-VNR(2):5,
PRIS/100:10:2,VNR(2)*PRIS/100:12:2);
J:=J+1;
R:=R+VNR(2)*PRIS;
IF (VNR(2)<>VNR(3)) AND (FAKFIL^.HEAD(11)=0) THEN
WITH RESTORD DO
BEGIN
HEAD(1):=NR(1);
HEAD(2):=NR(2);
HEAD(3):=VNR(1);
HEAD(4):=0;HEAD(5):=0;ANTAL:=0;
GETREC(RZ.H,FROR,A);
ANTAL:=ANTAL+VNR(3)-VNR(2);
IF (FAKFIL^.HEAD(7)>HEAD(4)) OR
((FAKFIL^.HEAD(7)=HEAD(4)) AND (FAKFIL^.HEAD(8)>HEAD(5)))
THEN BEGIN
HEAD(4):=FAKFIL^.HEAD(7);
HEAD(5):=FAKFIL^.HEAD(8)
END;
IF IER=0 THEN PUTREC(RZ.H,FROR,RESTORD.A)
ELSE
IF IER=-6 THEN INSERT(RZ.H,FROR,RESTORD.A);
IF IER<>0 THEN ERROR;
END;
PUTREC(VZ.H,FVAR,VARE.A)
END
END;
END;
FUNCTION RUND(R:REAL):REAL;
VAR R1:REAL;
BEGIN
R1:=TRUNC(R/10000.0);
R1:=R1*10000.0;
RUND:=ROUND(R-R1)+R1
END;
PROCEDURE INIT;
BEGIN
SENDTPR(1):='Post ';
SENDTPR(2):='Luftpost ';
SENDTPR(3):='Bane ';
SENDTPR(4):='Fragtmand ';
SENDTPR(5):='Samson / Liniegods ';
SENDTPR(6):='Samson / Olson & Wright ';
SENDTPR(7):='Leman ';
SENDTPR(8):='Deres transportør ';
SENDTPR(9):='Skib ';
SENDTPR(10):='Veritas ';
SENDTPR(11):='DFDS ';
SENDTPR(12):='Faroe ship ';
SENDTPR(13):='Vogn / bil ';
SENDTPR(14):='Afhentet ';
FOR I:=15 TO 19 DO
SENDTPR(I):= ' ';
SENDTPR(20):='Brevdue ';
END;
PROCEDURE BOTTOM;
BEGIN
WITH KUNDE DO
BEGIN
IF FAKFIL^.EMBAL<>0 THEN
BEGIN
IF J>21 THEN HEAD;
WRITELN(T,' ':52,'Emballage',FAKFIL^.EMBAL/100:12:2);
WRITELN(T,' ':52,'Subtotal',(R+FAKFIL^.EMBAL)/100:13:2);
J:=J+2
END;
JOURFIL^.REEL(6):=FAKFIL^.EMBAL;
FOR I:=J TO 23 DO WRITELN(T);
IF KUNDE.NR(16)=1 THEN
BEGIN
R1:=RUND(R*0.0175);
WRITE(T,R1/100:10:2);
JOURFIL^.REEL(4):=R1;
R:=R+R1
END
ELSE BEGIN WRITE(T,' ':10);JOURFIL^.REEL(4):=0 END;
R:=R+FAKFIL^.EMBAL;
IF FAKFIL^.FRAGT<>0 THEN
BEGIN
WRITE(T,FAKFIL^.FRAGT/100:20:2);
R:=R+FAKFIL^.FRAGT
END
ELSE WRITE(T,' ':20);
JOURFIL^.REEL(5):=FAKFIL^.FRAGT;
WRITE(T,R/100:21:2);
IF (KUNDE.NR(18)=0) OR (KUNDE.NR(18)=99) THEN
BEGIN
R1:=RUND(R*SYSFIL^.HELTAL(14)/10000);
WRITE(T,R1/100:10:2);
R:=R+R1
END
ELSE
BEGIN
R1:=0;
WRITE(T,' ':10)
END;
JOURFIL^.REEL(1):=R;
JOURFIL^.REEL(2):=R1;
WRITELN(T,R/100:12:2);
WRITELN(T);
IF NR(8)=1 THEN WRITELN(T,' ':53,'E F T E R K R A V')
ELSE
IF NR(8)=2 THEN WRITELN(T,' ':53,'K O N T A N T')
ELSE
WRITELN(T,' ':53,SYSFIL^.BETADAT);
WITH JOURFIL^ DO
BEGIN
NR(1):=KUNDE.NR(1);
NR(2):=KUNDE.NR(2);
NR(3):=SYSFIL^.HELTAL(7);
NR(4):=SYSFIL^.HELTAL(8);
NR(5):=SYSFIL^.HELTAL(1);
NR(6):=SYSFIL^.HELTAL(2)
END;
PUT(JOURFIL);
SYSFIL^.HELTAL(8):=SYSFIL^.HELTAL(8)+1;
IF SYSFIL^.HELTAL(8)=10000 THEN
BEGIN
SYSFIL^.HELTAL(7):=SYSFIL^.HELTAL(7)+1;
SYSFIL^.HELTAL(8):=0
END;
END
END;
PROCEDURE BODY;
BEGIN
WITH KUNDE DO
BEGIN
IF NR(3)=1 THEN
BEGIN
BETA.NR(1):=NR(1);
BETA.NR(2):=NR(2);
GETREC(BZ.H,FBETA,BETA.A)
END;
R:=0;
SIDE:=1;
HEAD;
REPEAT
FOR I:=1 TO 15 DO LINES;
IF FAKFIL^.HEAD(5)<>99 THEN GET(FAKFIL) ELSE I:=0
UNTIL I=0;
IF J>21 THEN HEAD;
J:=J+2;
WRITELN(T,' ':11,FAKFIL^.LINE(1));
WRITELN(T,' ':11,FAKFIL^.LINE(2),' ':11,'Subtotal',R/100:13:2);
JOURFIL^.REEL(7):=R;
R1:=0;
IF FAKFIL^.HEAD(12)<>0 THEN
BEGIN
IF J>21 THEN HEAD;
R1:=RUND(R*FAKFIL^.HEAD(12)/100);
WRITELN(T,' ':52,'Rabat',R1/100:16:2);
R:=R-R1;
J:=J+2;
WRITELN(T,' ':52,'Subtotal',R/100:13:2)
END;
JOURFIL^.REEL(3):=R1;
IF (NR(8)=1) OR (NR(8)=2) THEN
BEGIN
IF J>21 THEN HEAD;
J:=J+2;
R1:=RUND(R*3/100);
R:=R-R1;
JOURFIL^.REEL(3):=R1+JOURFIL^.REEL(3);
WRITELN(T,' ':52,'Kt-rabat',R1/100:13:2);
WRITELN(T,' ':52,'Subtotal',R/100:13:2)
END;
BOTTOM;
SYSFIL^.HELTAL(13):=SYSFIL^.HELTAL(13)+1;
END;
GET(FAKFIL)
END;
BEGIN
CLEARSCREEN;
FNAVN:='REGVARE:P1:0000:I';
REWRITE(FVAR,FNAVN);
IOPEN(VZ.H,FVAR,SKRIV);IF IER<>0 THEN OFEJL;
FNAVN:='KUNDERG:P2:0000:I';
RESET(FKUN,FNAVN);
IOPEN(KZ.H,FKUN,LÆS);IF IER<>0 THEN OFEJL;
FNAVN:='RESTREG:P2:0000:I';
REWRITE(FROR,FNAVN);
IOPEN(RZ.H,FROR,SKRIV);IF IER<>0 THEN OFEJL;
FNAVN:='FAKREG:P2:30:I';
REWRITE(FAKFIL,FNAVN);
FNAVN:='SYSREG:P2:1:I';
REWRITE(SYSFIL,FNAVN);
SEEK(SYSFIL,1);
GET(SYSFIL);
FNAVN:='EXPREG:P2:30:I';
REWRITE(EXPFIL,FNAVN);
FNAVN:='JOURNAL:P2:30:I';
REWRITE(JOURFIL,FNAVN);
SEEK(JOURFIL,SYSFIL^.HELTAL(13));
FNAVN:='LANDEREG:P2:0:I';
RESET(LANDFIL,FNAVN);
WRITELN('BETA');
FNAVN:='BETAREG:P2:0000:I';
RESET(FBETA,FNAVN);
WRITELN(IORESULT:5);
IOPEN(BZ.H,FBETA,LÆS);
FNAVN:='FAKTEXT:P1:30:K';
REWRITE(T,FNAVN);
WRITELN('INIT');
INIT;
GET(FAKFIL);
WHILE (FAKFIL^.HEAD(1)<>0) OR (FAKFIL^.HEAD(2)<>0) DO
WITH KUNDE DO
BEGIN
NR(1):=FAKFIL^.HEAD(1);
NR(2):=FAKFIL^.HEAD(2);
GETREC(KZ.H,FKUN,A);
IF IER<>0 THEN ERROR;
IF NR(18)=1 THEN
BEGIN
REPEAT
EXPFIL^:=FAKFIL^;
PUT(EXPFIL);
GET(FAKFIL)
UNTIL EXPFIL^.HEAD(5)=99
END
ELSE
BODY
END;
SEEK(SYSFIL,1);
PUT(SYSFIL);
ICLOSE(VZ.H,FVAR);
ICLOSE(RZ.H,FROR);
ICLOSE(KZ.H,FKUN);
ICLOSE(BZ.H,FBETA);
EXPFIL^.HEAD(1):=0;
EXPFIL^.HEAD(2):=0;
PUT(EXPFIL);
CLOSE(T);
IF EXPFIL^.HEAD(5)<>99 THEN
BEGIN
FNAVN:='TOLDTXT:P1:30:K';
REWRITE(T,FNAVN);
CHAIN('INTRE *1','SKRIVFAK:P1',QUQ)
END
ELSE
BEGIN
WRITELN('CHAIN TOLDSORT');
CHAIN('INTRE *1','TOLDSORT:P1',QUQ)
END
END.