|
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: 12640 (0x3160)
Types: TextFile
Notes: Mikados_K
Names: »BTAVEDL.K«
└─⟦eb89399bc⟧ Bits:30008990 SOM ISFORIG, MEN KUN K-FILER
└─⟦this⟧ »BTAVEDL.K«
PROGRAM BTAVEDL;
(*$IISFHEAD*)
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;
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;
BZ:BETAZONE;
FILNAVN2:STRING(20);
IER,I:INTEGER;
KODE1,KODE2:STRING(10);
BETA:BETAPOST;
SYSFIL:SYSFILE;
R:REAL;
QUQ:^INTEGER;
(*$L-*)
(*$R-,IEXCOMCOP*)
(*$IIOPEN*)
(*$ISÆTØG*)
(*$IREADPROC*)
(*$IFINDPOST*)
(*$IFORSKYD*)
(*$IICLOSE*)
(*$IPUTGET*)
(*$IINSERT*)
(*$INEXTREC*)
(*$IDELETE*)
(*$R+*)
(*$L+*)
PROCEDURE PRBTAOPL(O,KODE:INTEGER);
PROCEDURE PR1;
BEGIN
WITH BETA DO
CASE O OF
1:BEGIN
GOTOXY(1,1);WRITE('1 KUNDENR');GOTOXY(30,1);
WRITELN(NR(1)*10000.0+NR(2):10:-2);
END;
2:BEGIN
GOTOXY(1,2);WRITE('2 KUNDENAVN');GOTOXY(30,2);WRITELN(NAVN(1));
END;
3:BEGIN
GOTOXY(1,3);WRITE('3 NAVNEUDVIDELSE');GOTOXY(30,3);WRITELN(NAVN(2));
END;
4:BEGIN
GOTOXY(1,4);WRITE('4 ADRESSE');GOTOXY(30,4);WRITELN(NAVN(3));
END;
5:BEGIN
GOTOXY(1,5);WRITE('5 LANDSBY');GOTOXY(30,5);WRITELN(LANDSBY);
END;
6:BEGIN
GOTOXY(1,6);WRITE('6 POSTNR');GOTOXY(30,6);WRITELN(POSTNR);
END;
7:BEGIN
GOTOXY(1,7);WRITE('7 TLF');GOTOXY(30,7);WRITELN(TLF);
END;
8:BEGIN
GOTOXY(1,8);WRITE('8 LAND, 8 FOR DANMARK');GOTOXY(30,8);
WRITELN(NR(3):10);
END;
END;
END;
BEGIN
IF O<>0 THEN
BEGIN
IF (1<=O) AND (O<=8) THEN PR1
ELSE
BEGIN
CLEARSCREEN;
FOR O:=1 TO 8 DO PR1;
END
END
END;
PROCEDURE STOP;
VAR I:INTEGER;
BEGIN I:=I DIV 0 END;
PROCEDURE BETAOPL(O:INTEGER);
VAR STRENG:STRING;
I:INTEGER;
R:REAL;
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;
BEGIN
WITH BETA DO
CASE O OF
1: BEGIN
REPEAT
R:=LÆS(30,1)
UNTIL (R>=10000.0) AND (R<100000.0);
NR(1):=TRUNC(R/10000);
NR(2):=TRUNC(R-NR(1)*10000.0)
END;
2: BEGIN REPEAT
GOTOXY(30,2);READLN;READ(STRENG)
UNTIL LENGTH(STRENG)<31;
FILLCHAR(NAVN(1),30,' ');
FOR I:= 1 TO LENGTH(STRENG) DO NAVN(1,I):=STRENG(I) END;
3: BEGIN REPEAT
GOTOXY(30,3);READLN;READ(STRENG)
UNTIL LENGTH(STRENG)<31;
FILLCHAR(NAVN(2),30,' ');
FOR I:=1 TO LENGTH(STRENG) DO NAVN(2,I):=STRENG(I) END;
4: BEGIN REPEAT
GOTOXY(30,4);READLN;READ(STRENG)
UNTIL LENGTH(STRENG)<31;
FILLCHAR(NAVN(3),30,' ');
FOR I:=1 TO LENGTH(STRENG) DO NAVN(3,I):=STRENG(I) END;
5: BEGIN REPEAT
GOTOXY(30,5);READLN;READ(STRENG)
UNTIL LENGTH(STRENG)<21;
FILLCHAR(LANDSBY,20,' ');
FOR I:=1 TO LENGTH(STRENG) DO LANDSBY(I):=STRENG(I) END;
6: BEGIN REPEAT
GOTOXY(30,6);READLN;READ(STRENG)
UNTIL LENGTH(STRENG)<26;
FILLCHAR(POSTNR,25,' ');
FOR I:=1 TO LENGTH(STRENG) DO POSTNR(I):=STRENG(I) END;
7: BEGIN REPEAT
GOTOXY(30,7);READLN;READ(STRENG)
UNTIL LENGTH(STRENG)<11;
FILLCHAR(TLF,10,' ');
FOR I:=1 TO LENGTH(STRENG) DO TLF(I):=STRENG(I) END;
8: REPEAT
GOTOXY(30,8);
READLN;READ(NR(3))
UNTIL (IORESULT=0) AND (NR(3)<1000) AND (NR(3)>=0);
END
END;
PROCEDURE ZERREC;
BEGIN
WITH BETA DO
BEGIN
FOR I:=1 TO 3 DO NR(I):=0;
FILLCHAR(NAVN(1),30,' ');
FILLCHAR(NAVN(2),30,' ');
FILLCHAR(NAVN(3),30,' ');
FILLCHAR(LANDSBY,20,' ');
FILLCHAR(POSTNR,25,' ');
FILLCHAR(TLF,10,' ')
END
END;
PROCEDURE ERROR;
BEGIN
WRITELN('FEJL I BETAREG ',IER);
ICLOSE(BZ.H,F);
WRITELN('ICLOSE ',IER);
STOP
END;
PROCEDURE MAINTAIN;
VAR I,O,P,KODE:INTEGER;
CHANGED:BOOLEAN;
STRENG:STRING;
STRENG1:STRING(10);
BEGIN
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
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));
WITH BETA DO
CASE P OF
1: BEGIN
ZERREC;
PRBTAOPL(-1,KODE);
FOR I:=1 TO 8 DO BETAOPL(I);
PRBTAOPL(-1,KODE);
REPEAT
GOTOXY(1,22);WRITELN('ÆNDRINGER, 0 FOR NEJ ELLERS FELTNR ');
GOTOXY(40,22);READLN;READ(O);
IF ((O>=1) AND (O<=8)) THEN BETAOPL(O);
PRBTAOPL(O,KODE)
UNTIL O=0;
REPEAT
INSERT(BZ.H,F,A);
IF IER=-7 THEN
BEGIN
GOTOXY(1,23);WRITELN('KUNDENR FINDES I FORVEJEN ');
BETAOPL(1)
END
ELSE
IF IER<>0 THEN ERROR
UNTIL IER=0;
END;
2: BEGIN
REPEAT
GOTOXY(1,23);WRITELN('KUNDENR ');
GOTOXY(30,23);READLN;READ(R)
UNTIL (IORESULT=0) AND (R>9999) AND (R<100000.0);
NR(1):=TRUNC(R/10000);
NR(2):=TRUNC(R-NR(1)*10000.0);
GETREC(BZ.H,F,A);
IF IER=-6 THEN WRITELN('KUNDEN EKSISTERER IKKE')
ELSE
IF IER<>0 THEN ERROR
ELSE
BEGIN
PRBTAOPL(-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
1 : 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
BETAOPL(O);CHANGED:=TRUE
END
END;
2,3,4,5,6,7,8 :BEGIN BETAOPL(O);CHANGED:=TRUE END
END;
PRBTAOPL(O,KODE)
UNTIL O=0;
IF CHANGED THEN PUTREC(BZ.H,F,A);
END
END;
3: BEGIN
REPEAT
GOTOXY(1,23);WRITELN('KUNDENR ');
GOTOXY(30,23);READLN;READ(R)
UNTIL (IORESULT=0) AND (R>9999) AND (R<100000.0);
NR(1):=TRUNC(R/10000);
NR(2):=TRUNC(R-NR(1)*10000.0);
GETREC(BZ.H,F,A);
IF IER=-6 THEN WRITELN('KUNDEN EKSISTERER IKKE')
ELSE
IF IER<>0 THEN ERROR
ELSE
BEGIN
PRBTAOPL(-1,KODE);
IF KODE=2 THEN
WITH BETA DO
BEGIN
REPEAT
GOTOXY(1,23);WRITELN('SKAL SLETNING UDFØRES (1), 0 FOR NEJ ');
GOTOXY(40,23);READLN;READ(O)
UNTIL (IORESULT=0) AND ((O=0) OR (O=1));
IF O=1 THEN
BEGIN
DELETE(BZ.H,F,A);
PRBTAOPL(-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
FILNAVN2:='SYSREG:P2:1:I';
REWRITE(SYSFIL,FILNAVN2);
SEEK(SYSFIL,1);
GET(SYSFIL);
KODE2:=' ';
KODE1:=' ';
FOR I:=1 TO 10 DO
BEGIN
KODE2(I):=SYSFIL^.KODE(2,I);
KODE1(I):=SYSFIL^.KODE(1,I)
END;
CLOSE(SYSFIL);
FILNAVN2:='BETAREG:P2:0:I';
REWRITE(F,FILNAVN2);
I:=IORESULT;
IF I<>0 THEN BEGIN WRITELN('REWRITE ',I);STOP END;
IOPEN(BZ.H,F,SKRIV);
IF IER<>0 THEN WRITE('IOPEN ',IER) ELSE
BEGIN
MAINTAIN;
END;
ICLOSE(BZ.H,F);
CLEARSCREEN;
WRITELN('ICLOSE ',IER);
CHAIN('INTRE *1','HOVSA:P1',QUQ)
END.