|
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: 10112 (0x2780)
Types: TextFile
Notes: Mikados_K
Names: »RESTVEDL.K«
└─⟦eb89399bc⟧ Bits:30008990 SOM ISFORIG, MEN KUN K-FILER
└─⟦this⟧ »RESTVEDL.K«
PROGRAM RESTORDREVEDLIGEHOLDELSE;
(*$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;
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;
RORPOST=RECORD
A:AR;
(* KNR1,KNR2,
VNR,
DAT1,DAT2:INTEGER;*) HEAD:ARRAY(1..5) OF INTEGER;
ANTAL:REAL
END;
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;
VAR FVAR,FROR,FKUN : ISF;
VZ:VZONE;
RZ:RORZONE;
SYSFIL:SYSFILE;
KZ:KZONE;
RESTORD:RORPOST;
VARE:VPOST;
KUNDE:KPOST;
FNAVN:STRING(20);
IER,I,J,K,I1
:INTEGER;
R,R1,R2 :REAL;
QUQ:^INTEGER;
(*$L-*)
(*$R-,IEXCOMCOP*)
(*$IIOPEN*)
(*$ISÆTØG*)
(*$IREADPROC*)
(*$IFINDPOST*)
(*$IFORSKYD*)
(*$IICLOSE*)
(*$IPUTGET*)
(*$IINSERT*)
(*$INEXTREC*)
(*$IDELETE*)
(*$R+,L+*)
PROCEDURE ERROR;
BEGIN
WRITELN('FEJL I REGISTER ',IER);
ICLOSE(VZ.H,FVAR);
ICLOSE(RZ.H,FROR);
ICLOSE(KZ.H,FKUN);
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 NANU(VAR T:STRING;VAR NU1,NU2 :INTEGER);
VAR I:INTEGER;
R:REAL;
BEGIN
R:=0.0;
FOR I:=1 TO 4 DO R:=R*29+ORD(T(I));
I:=TRUNC(R/89998.0);
R:=R-I*89998.0+10001;
NU1:=TRUNC(R/10000);
NU2:=TRUNC(R-NU1*10000.0)
END;
PROCEDURE FINDKUND;
VAR N1,N2,FIN:INTEGER;
KNAVN:STRING(4);
SVAR1:CHAR;
R1,R2:REAL;
BEGIN
REPEAT
I:=1;
SVAR1:='N';
CLEARSCREEN;
WRITELN('RESTORDREVEDLIGEHOLDELSE');
GOTOXY(1,4);
WRITELN('0 FOR AFSLUTNING, 1 FOR SØGNING MED NAVN');
REPEAT
R:=-1.0;
GOTOXY(1,3);
WRITELN('INDTAST KUNDENUMMER');
GOTOXY(25,3);READLN;READ(R)
UNTIL (IORESULT=0) AND (R>=0.0) AND (R<100000.0);
IF R=0.0 THEN EXIT(FINDKUND);
REPEAT
IF R=1.0 THEN
IF I=1 THEN
BEGIN
GOTOXY(1,4);
WRITELN('INDTAST KUNDENAVN',' ':60);
REPEAT
GOTOXY(20,4);
READLN;READ(KNAVN)
UNTIL LENGTH(KNAVN)=4;
NANU(KNAVN,N1,N2);
KUNDE.NR(1):=N1;
KUNDE.NR(2):=N2;
R1:=N1*10000.0+N2;
GETREC(KZ.H,FKUN,KUNDE.A);
IF IER=-6 THEN NEXTREC(KZ.H,FKUN,KUNDE.A);
IF (IER=-9) OR (IER=-2) OR (IER=-1) THEN IER:=0;
I:=0
END
ELSE
BEGIN
NEXTREC(KZ.H,FKUN,KUNDE.A);
IF (IER=-9) OR (IER=-2) OR (IER=-1) THEN IER:=0;
R2:=KUNDE.NR(1)*10000.0+KUNDE.NR(2);
IF (R2-R1>SYSFIL^.HELTAL(4)) OR (R2<R1) THEN IER:=-6;
END
ELSE
BEGIN
KUNDE.NR(1):=TRUNC(R/10000.0);
KUNDE.NR(2):=TRUNC(R-KUNDE.NR(1)*10000.0);
GETREC(KZ.H,FKUN,KUNDE.A)
END;
GOTOXY(1,5);
FIN:=1;
IF IER=0 THEN
BEGIN
WRITELN('KUNDENUMMER ',KUNDE.NR(1)*10000.0+KUNDE.NR(2):8:-2);
WRITELN;
WRITELN(KUNDE.NAVN(1));
WRITELN(KUNDE.NAVN(3));
WRITELN(KUNDE.POSTNR);
WRITELN;
WRITELN('TLF: ',KUNDE.TLF);
GOTOXY(40,6);WRITELN('RIGTIG KUNDE (J/N)');
REPEAT GOTOXY(60,6);READLN;READ(SVAR1) UNTIL (IORESULT=0) AND
((SVAR1='J') OR (SVAR1='N') OR (SVAR1='n') OR (SVAR1='j'));
IF ((SVAR1='N') OR (SVAR1='n')) AND (R=1.0) THEN FIN:=0
END
ELSE
IF IER=-6 THEN
BEGIN
IER:=0;
WRITELN(' ':80);
WRITELN('KUNDEN EKSISTERER IKKE, TRYK RETURN');
READLN
END
ELSE ERROR
UNTIL FIN=1
UNTIL (SVAR1='J') OR (R=0.0) OR (SVAR1='j')
END;
PROCEDURE FIX;
BEGIN
CASE I1 OF
1: BEGIN
GETREC(RZ.H,FROR,RESTORD.A);
IF IER=-6 THEN WRITELN('RESTORDREN FINDES IKKE')
ELSE
BEGIN
IF IER<>0 THEN ERROR;
VARE.HELTAL(1):=RESTORD.HEAD(3);
GETREC(VZ.H,FVAR,VARE.A);
IF IER=-6 THEN
BEGIN
DELETE(RZ.H,FROR,RESTORD.A);
IF IER<>0 THEN ERROR
END
ELSE
BEGIN
IF IER<>0 THEN ERROR;
VARE.REELTAL(9):=VARE.REELTAL(9)-RESTORD.ANTAL;
IF VARE.REELTAL(9)<0 THEN
BEGIN
VARE.REELTAL(7):=VARE.REELTAL(7)+VARE.REELTAL(9);
VARE.REELTAL(9):=0;
IF VARE.REELTAL(7)<0 THEN VARE.REELTAL(7):=0
END;
PUTREC(VZ.H,FVAR,VARE.A);
IF IER<>0 THEN ERROR;
DELETE(RZ.H,FROR,RESTORD.A);
IF IER<>0 THEN ERROR
END
END
END;
2: BEGIN
GETREC(RZ.H,FROR,RESTORD.A);
IF IER=0 THEN WRITELN('RESTORDREN FINDES')
ELSE
BEGIN
IF IER<>-6 THEN ERROR;
VARE.HELTAL(1):=RESTORD.HEAD(3);
GETREC(VZ.H,FVAR,VARE.A);
IF IER=-6 THEN WRITELN('VAREN FINDES IKKE')
ELSE
BEGIN
IF IER<>0 THEN ERROR;
GOTOXY(1,21);
WRITELN('DATO');
REPEAT
GOTOXY(7,21);
READLN;READ(R)
UNTIL (IORESULT=0) AND (R>800000.0) AND (R<850000.0);
RESTORD.HEAD(4):=TRUNC(R/10000);
RESTORD.HEAD(5):=TRUNC(R-RESTORD.HEAD(4)*10000.0);
REPEAT
GOTOXY(1,22);
WRITELN('ANTAL');
GOTOXY(8,22);
READLN;READ(RESTORD.ANTAL)
UNTIL (IORESULT=0) AND (RESTORD.ANTAL>0);
INSERT(RZ.H,FROR,RESTORD.A);
IF IER<>0 THEN ERROR;
VARE.REELTAL(9):=VARE.REELTAL(9)+RESTORD.ANTAL;
PUTREC(VZ.H,FVAR,VARE.A);
IF IER<>0 THEN ERROR
END
END
END;
END;
END;
BEGIN
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:='SYSREG:P2:1:I';
RESET(SYSFIL,FNAVN);
SEEK(SYSFIL,1);
GET(SYSFIL);
CLOSE(SYSFIL);
REPEAT
FINDKUND;
IF R<>0.0 THEN
REPEAT
CLEARSCREEN;
WRITELN('SLETNING (1) ELL. OPRETTELSE (2), 0 FOR STOP');
REPEAT
GOTOXY(50,1);READLN;READ(I1)
UNTIL (IORESULT=0) AND (I1<3) AND (I1>-1);
IF I1>0 THEN
BEGIN
CLEARSCREEN;
WRITELN('VARENR, 0 FOR OVERSIGT');
REPEAT
GOTOXY(40,1);READLN;READ(J)
UNTIL (IORESULT=0) AND ((J=0) OR ((J>999) AND (J<10000)));
RESTORD.HEAD(1):=KUNDE.NR(1);
RESTORD.HEAD(2):=KUNDE.NR(2);
RESTORD.HEAD(3):=J;
IF J=0 THEN WITH RESTORD DO
BEGIN
NEXTREC(RZ.H,FROR,A);
IF (IER=-1) OR (IER=-2) OR (IER=-9) THEN IER:=0 ELSE ERROR;
WHILE (IER=0) AND (HEAD(1)=KUNDE.NR(1)) AND (HEAD(2)=KUNDE.NR(2))DO
BEGIN
VARE.HELTAL(1):=HEAD(3);
GETREC(VZ.H,FVAR,VARE.A);
IF IER=0 THEN
WRITELN(HEAD(3):10,' ':4,VARE.NAVN(1),HEAD(4)*10000.0+
HEAD(5):12:-2,ANTAL:12:-2)
ELSE WRITELN(HEAD(3):10,' ':4,'EKSISTERER IKKE');
NEXTREC(RZ.H,FROR,A)
END;
REPEAT
GOTOXY(1,20);
WRITELN('VARENR');
GOTOXY(20,20);
READLN;READ(J)
UNTIL (IORESULT=0) AND (J<10000);
HEAD(1):=KUNDE.NR(1);
HEAD(2):=KUNDE.NR(2);
HEAD(3):=J;
END
END;
IF J>0 THEN
FIX;
UNTIL I1=0;
UNTIL R=0.0;
ICLOSE(VZ.H,FVAR);
ICLOSE(RZ.H,FROR);
ICLOSE(KZ.H,FKUN);
CHAIN('INTRE *1','HOVSA:P1',QUQ)
END.