|
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: 17472 (0x4440)
Types: TextFile
Notes: Mikados_K
Names: »LEVVEDL.K«
└─⟦eb89399bc⟧ Bits:30008990 SOM ISFORIG, MEN KUN K-FILER
└─⟦this⟧ »LEVVEDL.K«
PROGRAM LEVVEDL;
(*$IISFHEAD*)
LEVPOST=RECORD
A:AR;
NR,
SBESDAT1,SBESDAT2,
LAND1,LAND2:INTEGER;
KOSTPFAK:ARRAY(1..5) OF INTEGER;
ÅKØB,SÅKØB,SALDO:REAL;
NAVN1:PACKED ARRAY (1..40) OF CHAR;
NAVN2,
ADR1,
ADR2:PACKED ARRAY (1..30) OF CHAR;
BETABET,
LANDSBY1,LANDSBY2: PACKED ARRAY (1..20) OF CHAR;
POSTNR1,POSTNR2: PACKED ARRAY (1..25) OF CHAR;
TLF1,TLF2: PACKED ARRAY (1..10) OF CHAR;
END;
LEVZONE=RECORD
H:ISFHEAD;
T:ARRAY(1..382) OF INTEGER
END;
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;
VAR F:ISF;
CHAR1:CHAR;
LZ:LEVZONE;
FILNAVN1,FILNAVN2:STRING(20);
N1,N2,IER,I:INTEGER;
KODE1,KODE2:STRING(10);
R:REAL;
LEVER:LEVPOST;
SYSFIL:SYSFILE;
QUQ:^INTEGER;
(*$L-*)
(*$R-,IEXCOMCOP*)
(*$IIOPEN*)
(*$IINITIATE*)
(*$ISÆTØG*)
(*$IREADPROC*)
(*$IFINDPOST*)
(*$IFORSKYD*)
(*$IICLOSE*)
(*$IPUTGET*)
(*$IINSERT*)
(*$INEXTREC*)
(*$IDELETE*)
(*$R+*)
(*$L+*)
PROCEDURE STOP;
VAR I:INTEGER;
BEGIN I:=I DIV 0 END;
PROCEDURE ERROR;
BEGIN
WRITELN('FEJL I LEVERANDØRREG ',IER);
ICLOSE(LZ.H,F);
WRITELN('ICLOSE ',IER);
STOP
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 PRLEVOPL(O,KODE:INTEGER);
PROCEDURE PR1;
BEGIN
WITH LEVER DO
CASE O OF
1:BEGIN
GOTOXY(1,1);WRITE('1 Leverandørnr');GOTOXY(30,1);
WRITELN(NR);
END;
2:BEGIN
GOTOXY(1,2);WRITE('2 Navn-1');GOTOXY(30,2);WRITELN(NAVN1);
END;
3:BEGIN
GOTOXY(1,3);WRITE('3 Adresse');GOTOXY(30,3);WRITELN(ADR1);
END;
4:BEGIN
GOTOXY(1,4);WRITE('4 Landsby');GOTOXY(30,4);WRITELN(LANDSBY1);
END;
5:BEGIN
GOTOXY(1,5);WRITE('5 Postnr');GOTOXY(30,5);WRITELN(POSTNR1);
END;
7:BEGIN
GOTOXY(1,7);WRITE('7 Tlf');GOTOXY(30,7);WRITELN(TLF1);
END;
6:BEGIN
GOTOXY(1,6);WRITE('6 Land, 8 for Danmark');GOTOXY(30,6);
WRITELN(LAND1);
END;
8:BEGIN
GOTOXY(1,8);WRITE('8 Navn-2');GOTOXY(30,8);WRITELN(NAVN2);
END;
9:BEGIN
GOTOXY(1,9);WRITE('9 ADRESSE');GOTOXY(30,9);WRITELN(ADR2);
END;
10:BEGIN
GOTOXY(1,10);WRITE('10 LANDSBY');GOTOXY(30,10);WRITELN(LANDSBY2);
END;
11:BEGIN
GOTOXY(1,11);WRITE('11 POSTNR');GOTOXY(30,11);WRITELN(POSTNR2);
END;
13:BEGIN
GOTOXY(1,13);WRITE('13 TLF');GOTOXY(30,13);WRITELN(TLF2);
END;
12:BEGIN
GOTOXY(1,12);WRITE('12 LAND, 8 FOR DANMARK');GOTOXY(30,12);
WRITELN(LAND2);
END;
14:BEGIN
GOTOXY(1,14);WRITE('14 Betalingsbetingelser');GOTOXY(36,14);
WRITELN(BETABET);
END;
END;
END;
PROCEDURE PR2;
BEGIN
WITH LEVER DO
CASE O OF
15:BEGIN
GOTOXY(1,15);WRITE('15 Kostprisfakt1');GOTOXY(30,15);
WRITELN(KOSTPFAK(1));
END;
16:BEGIN
GOTOXY(40,15);WRITE('16 Kostprisfakt2');GOTOXY(65,15);WRITELN(KOSTPFAK(2));
END;
17:BEGIN
GOTOXY(1,16);WRITE('17 Kostprisfakt3');GOTOXY(30,16);WRITELN(KOSTPFAK(3));
END;
18:BEGIN
GOTOXY(40,16);WRITE('18 Kostprisfakt4');GOTOXY(65,16);WRITELN(KOSTPFAK(4));
END;
19:BEGIN
GOTOXY(1,17);WRITE('19 Kostprisfakt5');GOTOXY(30,17);WRITELN(KOSTPFAK(5));
END;
20: BEGIN
GOTOXY(1,18);WRITE('20 Saldo');GOTOXY(25,18);
WRITELN(SALDO/100:12:2);
END;
21: BEGIN
GOTOXY(1,19);WRITE('21 Årets køb');GOTOXY(25,19);
WRITELN(ÅKØB/100:12:2);
END;
END
END;
PROCEDURE PR3;
BEGIN
WITH LEVER DO
CASE O OF
22:BEGIN
GOTOXY(1,20);WRITE('22 Sidste års køb');GOTOXY(25,20);
WRITELN(SÅKØB/100:12:2);
END;
23:BEGIN
GOTOXY(1,21);WRITELN('23 S. best. dato',SBESDAT1*10000.0+SBESDAT2:14:-2);
END;
END
END;
BEGIN
IF O<>0 THEN
BEGIN
IF (1<=O) AND (O<=14) THEN PR1
ELSE
IF (15<=O) AND (O<=21) THEN PR2
ELSE
IF (22<=O) AND (O<=23) THEN PR3
ELSE
BEGIN
CLEARSCREEN;
FOR O:=1 TO 14 DO PR1;
FOR O:=15 TO 21 DO PR2;
FOR O:=22 TO 23 DO PR3
END
END
END;
PROCEDURE LEVOPL(O:INTEGER);
VAR STRENG:STRING;
I:INTEGER;
FUNCTION LÆS(X,Y:INTEGER):REAL;
VAR RES:REAL;
BEGIN
REPEAT
GOTOXY(X,Y);
READLN;
READ(RES)
UNTIL IORESULT=0;
LÆS:=RES
END;
PROCEDURE INCH(X,Y:INTEGER);
BEGIN
REPEAT
GOTOXY(X,Y);
READLN;
READ(CHAR1)
UNTIL (CHAR1='N') OR (CHAR1='J') OR (CHAR1='n') OR (CHAR1='j')
END;
PROCEDURE OPL1;
BEGIN
WITH LEVER DO
CASE O OF
1: BEGIN REPEAT
GOTOXY(25,1);READLN;READ(NR)
UNTIL (IORESULT=0);
END;
2: BEGIN
FILLCHAR(NAVN1,40,' ');
REPEAT
GOTOXY(30,2);READLN;READ(STRENG)
UNTIL LENGTH(STRENG)<41;
FOR I:=1 TO LENGTH(STRENG) DO NAVN1(I):=STRENG(I) END;
3: BEGIN REPEAT
GOTOXY(30,3);READLN;READ(STRENG)
UNTIL LENGTH(STRENG)<31;
FILLCHAR(ADR1,30,' ');
FOR I:=1 TO LENGTH(STRENG) DO ADR1(I):=STRENG(I) END;
4: BEGIN REPEAT
GOTOXY(30,4);READLN;READ(STRENG)
UNTIL LENGTH(STRENG)<21;
FILLCHAR(LANDSBY1,20,' ');
FOR I:=1 TO LENGTH(STRENG) DO LANDSBY1(I):=STRENG(I) END;
5: BEGIN REPEAT
GOTOXY(30,5);READLN;READ(STRENG)
UNTIL LENGTH(STRENG)<26;
FILLCHAR(POSTNR1,25,' ');
FOR I:=1 TO LENGTH(STRENG) DO POSTNR1(I):=STRENG(I) END;
7: BEGIN REPEAT
GOTOXY(30,7);READLN;READ(STRENG)
UNTIL LENGTH(STRENG)<11;
FILLCHAR(TLF1,10,' ');
FOR I:=1 TO LENGTH(STRENG) DO TLF1(I):=STRENG(I) END;
6: REPEAT
GOTOXY(30,6);READLN;READ(LAND1)
UNTIL (IORESULT=0) AND (LAND1>0) AND (LAND1<1000);
8: BEGIN
FILLCHAR(NAVN2,30,' ');
REPEAT
GOTOXY(30,8);READLN;READ(STRENG)
UNTIL LENGTH(STRENG)<31;
FOR I:=1 TO LENGTH(STRENG) DO NAVN2(I):=STRENG(I) END;
9: BEGIN REPEAT
GOTOXY(30,9);READLN;READ(STRENG)
UNTIL LENGTH(STRENG)<31;
FILLCHAR(ADR2,30,' ');
FOR I:=1 TO LENGTH(STRENG) DO ADR2(I):=STRENG(I) END;
10: BEGIN REPEAT
GOTOXY(30,10);READLN;READ(STRENG)
UNTIL LENGTH(STRENG)<21;
FILLCHAR(LANDSBY2,20,' ');
FOR I:=1 TO LENGTH(STRENG) DO LANDSBY2(I):=STRENG(I) END;
11: BEGIN REPEAT
GOTOXY(30,11);READLN;READ(STRENG)
UNTIL LENGTH(STRENG)<26;
FILLCHAR(POSTNR2,25,' ');
FOR I:=1 TO LENGTH(STRENG) DO POSTNR2(I):=STRENG(I) END;
END
END;
PROCEDURE OPL2;
BEGIN
WITH LEVER DO
CASE O OF
13: BEGIN REPEAT
GOTOXY(30,13);READLN;READ(STRENG)
UNTIL LENGTH(STRENG)<11;
FILLCHAR(TLF2,10,' ');
FOR I:=1 TO LENGTH(STRENG) DO TLF2(I):=STRENG(I) END;
12: REPEAT
GOTOXY(30,12);READLN;READ(LAND2)
UNTIL (IORESULT=0) AND (LAND2>0) AND (LAND2<1000);
14: BEGIN REPEAT
GOTOXY(30,14);READLN;READ(STRENG)
UNTIL LENGTH(STRENG)<21;
FILLCHAR(BETABET,20,' ');
FOR I:=1 TO LENGTH(STRENG) DO BETABET(I):=STRENG(I)
END;
15: BEGIN FOR I:=5 DOWNTO 2 DO KOSTPFAK(I):=KOSTPFAK(I-1);
REPEAT
GOTOXY(25,15);READLN;READ(KOSTPFAK(1))
UNTIL (IORESULT=0);
END;
16: REPEAT
GOTOXY(65,15);
READLN;READ(KOSTPFAK(2));
UNTIL IORESULT=0;
17: REPEAT
GOTOXY(25,16);
READLN;READ(KOSTPFAK(3));
UNTIL IORESULT=0;
18: REPEAT
GOTOXY(65,16);
READLN;READ(KOSTPFAK(4))
UNTIL IORESULT=0;
19:
REPEAT
GOTOXY(25,17);
READLN;READ(KOSTPFAK(5))
UNTIL IORESULT=0;
20:
SALDO:=LÆS(25,18)*100;
21:
ÅKØB:=LÆS(25,19)*100;
22:
SÅKØB:=LÆS(25,20)*100;
23: BEGIN REPEAT
R:=LÆS(1,21)
UNTIL (R>800000.0) AND (R<850000.0);
SBESDAT1:=TRUNC(R/10000);
SBESDAT2:=TRUNC(R-SBESDAT1*10000.0)
END;
END
END;
BEGIN
IF O<=11 THEN OPL1 ELSE OPL2
END;
PROCEDURE ZERREC;
BEGIN
WITH LEVER DO
BEGIN
NR:=0;
SBESDAT1:=0;
SBESDAT2:=0;
LAND1:=0;
LAND2:=0;
FOR I:=1 TO 5 DO KOSTPFAK(I):=0;
ÅKØB:=0.0;
SÅKØB:=0.0;
SALDO:=0.0;
FILLCHAR(NAVN1,40,' ');
FILLCHAR(NAVN2,30,' ');
FILLCHAR(ADR1,30,' ');
FILLCHAR(ADR2,30,' ');
FILLCHAR(BETABET,20,' ');
FILLCHAR(LANDSBY1,20,' ');
FILLCHAR(LANDSBY2,20,' ');
FILLCHAR(POSTNR1,25,' ');
FILLCHAR(POSTNR2,25,' ');
FILLCHAR(TLF1,10,' ');
FILLCHAR(TLF2,10,' ');
END
END;
PROCEDURE MAINTAIN;
VAR EXC,I,O,P,KODE:INTEGER;
CHANGED:BOOLEAN;
STRENG:STRING;
STRENG1:STRING(10);
BEGIN
(*INDLÆS KODE1 OG KODE2 FRA SYSREG*)
CLEARSCREEN;
GOTOXY(1,1);WRITELN('ADGANGSKODE');
GOTOXY(20,1);READLN;READ(STRENG1);
KODE:=0;
IF STRENG1=KODE1 THEN KODE:=1;
IF STRENG1=KODE2 THEN KODE:=2;
REPEAT
R:=1.0;
REPEAT
GOTOXY(1,22);WRITELN('OPRETTE, KIKKE ELLER SLETTE (1/2/3), 0 FOR STOP ');
GOTOXY(50,22);READLN;READ(P)
UNTIL (IORESULT=0) AND((P=1) OR (P=2) OR (P=0) OR (P=3));
CASE P OF
1: BEGIN
ZERREC;
PRLEVOPL(-1,KODE);
FOR I:=1 TO 15 DO LEVOPL(I);
PRLEVOPL(-1,KODE);
REPEAT
GOTOXY(1,22);WRITELN('ÆNDRINGER, 0 FOR NEJ ELLERS FELTNR ');
GOTOXY(40,22);READLN;READ(O);
IF ((O>=1) AND (O<=19)) THEN LEVOPL(O);
PRLEVOPL(O,KODE)
UNTIL O=0;
INSERT(LZ.H,F,LEVER.A);
END;
2: BEGIN
REPEAT
GOTOXY(1,1);
WRITELN('Leverandør-nr');
GOTOXY(20,1);
READLN;READ(LEVER.NR);
IF LEVER.NR=0 THEN BEGIN IER:=0;R:=0.0 END
ELSE
GETREC(LZ.H,F,LEVER.A)
UNTIL IER=0;
IF R<>0.0 THEN
BEGIN
PRLEVOPL(-1,KODE);
CHANGED:=FALSE;
REPEAT
REPEAT
GOTOXY(1,22);WRITELN('HVILKET FELT SKAL ÆNDRES, 0 FOR SLUT ');
GOTOXY(40,22);READLN;READ(O)
UNTIL IORESULT=0;
CASE O OF
20,21,22,16,17,18,19 : BEGIN
GOTOXY(1,23);
WRITELN('ÆNDRING IKKE TILLADT');
GOTOXY(25,23);
WRITELN('TRYK RETURN NÅR FORSTÅET');
GOTOXY(60,23);READLN;READ(STRENG);
IF STRENG='A' THEN
BEGIN
LEVOPL(O);CHANGED:=TRUE
END
END;
14,15,23: IF KODE=2 THEN
BEGIN
LEVOPL(O);CHANGED:=TRUE
END ELSE
BEGIN GOTOXY(1,23);
WRITELN('ÆNDRING IKKE TILLADT MED OPGIVEN ADGANGSKODE');
END;
2,3,4,5,6,7,8,9,10,11,12,13:BEGIN LEVOPL(O);CHANGED:=TRUE END
END;
PRLEVOPL(O,KODE)
UNTIL O=0;
IF CHANGED THEN PUTREC(LZ.H,F,LEVER.A);
END
END;
3: BEGIN
REPEAT
GOTOXY(1,1);
WRITELN('Leverandør-nr');
GOTOXY(20,1);
READLN;READ(LEVER.NR);
IF LEVER.NR=0 THEN BEGIN IER:=0;R:=0.0 END
ELSE
GETREC(LZ.H,F,LEVER.A)
UNTIL IER=0;
IF R<>0.0 THEN
BEGIN
PRLEVOPL(-1,KODE);
IF KODE=2 THEN
WITH LEVER DO
BEGIN
REPEAT
GOTOXY(1,23);WRITELN('SKAL SLETNING UDFØRES (1), 0 FOR NEJ ');
GOTOXY(40,23);READLN;READ(O)
UNTIL IORESULT=0;
IF O=4711 THEN
BEGIN
DELETE(LZ.H,F,LEVER.A);
PRLEVOPL(-1,KODE);
IF IER<>0 THEN ERROR
END
END
ELSE
BEGIN
GOTOXY(1,23);
WRITELN('SLETNING MÅ IKKE UDFØRES MED OPGIVEN NØGLE')
END
END
END
END
UNTIL P=0
END;
BEGIN
CLEARSCREEN;
FILNAVN2:='LEVERRG:P2:0000:I';
REWRITE(F,FILNAVN2);
IOPEN(LZ.H,F,SKRIV);IF IER<>0 THEN OFEJL;
IF NOT LZ.H.FILEINIT THEN
BEGIN
REPEAT
GOTOXY(1,1);
WRITELN('ANTAL POSTER VED INITIALISERING');
GOTOXY(40,1);
READLN;READ(I)
UNTIL (IORESULT=0) AND (I>0) AND (I<151);
INITIATE(LZ.H,F,I);
IF IER<>0 THEN ERROR
END;
FILNAVN1:='SYSREG:P2:1:I';
REWRITE(SYSFIL,FILNAVN1);
SEEK(SYSFIL,1);
GET(SYSFIL);
KODE1:=' ';
KODE2:=KODE1;
FOR I:=1 TO 10 DO
BEGIN
KODE1(I):=SYSFIL^.KODE(1,I);
KODE2(I):=SYSFIL^.KODE(2,I)
END;
CLOSE(SYSFIL);
IF IER<>0 THEN WRITE('IOPEN ',IER) ELSE
BEGIN
MAINTAIN;
END;
ICLOSE(LZ.H,F);
CLEARSCREEN;
WRITELN('ICLOSE ',IER);
CHAIN('INTRE *1','HOVSA:P1',QUQ)
END.