|
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: 25280 (0x62c0)
Types: TextFile
Notes: Mikados_K
Names: »HOVED.K«
└─⟦5630b2e42⟧ Bits:30009005 START APRIL 1985 aft april 1985 (PASCAL kildetekster)
└─⟦this⟧ »HOVED.K«
└─⟦6c21327e0⟧ Bits:30008986 LINIMATIC K-FILER (IKKE HELT UPTODTATE)
└─⟦this⟧ »HOVED.K«
PROGRAM HOVED;
CONST LNGTH=20;
TIMER=120;
MAXRECSIZE=1000;
PROGRAMNR=1;
TYPE
PARMARRAY=PACKED ARRAY (1..39) OF CHAR;
DIRECTBUF=PACKED ARRAY (1..LNGTH) OF CHAR;
CLOCKRECORD = RECORD
DATE:PACKED ARRAY (1..10) OF CHAR;
TIME:PACKED ARRAY (1..8) OF CHAR
END;
NIVEAU=(MENIG,SERGENT,LØJTNANT,KAPTAJN,MAJOR,OBERST,GENERAL,HSM,UMULIUS);
POSTADR=0..MAXRECSIZE;
COMMBUF =ARRAY (POSTADR) OF INTEGER;(*commbuf(0)=filnr,resten er posten*)
POINTREC=^COMMBUF;
NAME =STRING(10);
PCB =^INTEGER;
MESSAGETYPE=(ÅBEN,LUK,LÆSPOST,LÆSPOSTX,NÆSTE,NÆSTEX,SLET,SLETX,GEMPOST,
INDSÆT,INITIER,UTILMELD,UAFMELD,PTILMELD,PAFMELD,STOPSYS,
RETURNHEAD,RETURNSTAT);
MESSAGE =RECORD
KOMMANDO:MESSAGETYPE;
INFO,IREC:INTEGER
END;
AR=ARRAY (-4..-4) OF INTEGER;
VAR PARM:^PARMARRAY;
CLOCK:^CLOCKRECORD;
STIMER,SV,TT,OFFSET,MIN,SEC,SEC100:INTEGER;
TÆNDT,HOWL,ALARM,STOPWATCH:BOOLEAN;
ALARMTIME:PACKED ARRAY (1..8) OF CHAR;
DBUF:DIRECTBUF;
USERNIVEAU:NIVEAU;
F:STRING(18);
QUQ:^INTEGER;
IER,IREC,STATUSER,MODE,REMUSERS,
FILNR,I:INTEGER;
FNAVN,REGNAVN,DESCNAVN:STRING(18);
SEMAFOR:NAME;
FILEINIT:BOOLEAN;
SNYD:AR;
CPPCB:PCB;
COMREC:POINTREC;
BESKED:MESSAGE;
(*$P*)
PROCEDURE D23;
BEGIN
GOTOXY(1,23);WRITE(' ':79);GOTOXY(1,23)
END;
PROCEDURE BAD(IDENT,STATUS:INTEGER);
BEGIN
D23;
WRITE('BAD',IDENT:5,STATUS:5);
READLN
END;
(*$P*)
PROCEDURE KODEVEDL;
TYPE
ENTRY=RECORD
KODE:STRING(9);
NIV:INTEGER
END;
KODER=ARRAY (1..20) OF ENTRY;
KODEFIL=FILE OF KODER;
VAR F:KODEFIL;
FNAVN:STRING(20);
USERKODE:STRING(9);
NIVEAUD:ARRAY (0..6) OF STRING(8);
I,J:INTEGER;
BEGIN
NIVEAUD(0):='MENIG ';
NIVEAUD(1):='SERGENT ';
NIVEAUD(2):='LØJTNANT';
NIVEAUD(3):='KAPTAJN ';
NIVEAUD(4):='MAJOR ';
NIVEAUD(5):='OBERST ';
NIVEAUD(6):='GENERAL ';
FNAVN:='KODEFIL:P2:0:J';
REPEAT
(*$C-*)
REWRITE(F,FNAVN);
(*$C+*)
I:=IORESULT;
IF NOT (I IN (.0,6.)) THEN BAD(4,I)
UNTIL I=0;
SEEK(F,1);
GET(F);
CLEARSCREEN;
(*$XO*) FOR I:=1 TO 20 DO BEGIN F^(I).KODE:=' ';F^(I).NIV:=0 END;
(*$X-*)
IF PARM^(1)='0' THEN
BEGIN
USERKODE:=' ';
REPEAT
GOTOXY(1,1);
WRITELN('Indtast kode');
GOTOXY(14,1);EDIT(USERKODE:9);
FOR I:=1 TO 20 DO
IF F^(I).KODE=USERKODE THEN
BEGIN
PARM^(1):=CHR(F^(I).NIV+48);
I:=30
END
UNTIL I>30
END
ELSE
BEGIN
FOR I:=1 TO 20 DO WRITELN(F^(I).KODE,' ':10,NIVEAUD(F^(I).NIV));
REPEAT
D23;
WRITELN('Kode nr 0 for færdig');
GOTOXY(9,23);
READLN;READ(I);
IF (I>0) AND (I<21) THEN
BEGIN
GOTOXY(1,22);
USERKODE:=F^(I).KODE;
EDIT(USERKODE:9);
F^(I).KODE:=USERKODE;
REPEAT
GOTOXY(20,22);
USERKODE:=NIVEAUD(F^(I).NIV);
EDIT(USERKODE:8);
FOR J:=0 TO 6 DO
IF NIVEAUD(J)=USERKODE THEN
BEGIN
F^(I).NIV:=J;
J:=20
END
UNTIL J>20
END
UNTIL I=0;
SEEK(F,1);
PUT(F)
END;
(*$C-*)
CLOSE(F);
(*$C+*)
I:=IORESULT;
IF I<>0 THEN BAD(5,I)
END;
(*$P*)
PROCEDURE SETUP(VAR BUFFER:DIRECTBUF;LENGTH:INTEGER);
EXTERNAL;
FUNCTION AVAIL:BOOLEAN;
EXTERNAL;
FUNCTION NEXT:CHAR;
EXTERNAL;
PROCEDURE FINIS;
EXTERNAL;
PROCEDURE ALLOCA(VAR ADDRESS:POINTREC;LENGTH:INTEGER;
VAR STATUS:INTEGER);
EXTERNAL;
PROCEDURE DEALLO(ADDRESS:POINTREC;VAR STATUS:INTEGER);
EXTERNAL;
PROCEDURE SENDM(RECEIVER:PCB;VAR CONTENTS:MESSAGE;
LENGTH:INTEGER;VAR STATUS:INTEGER);
EXTERNAL;
PROCEDURE RECEIV(VAR SENDER:PCB;VAR CONTENTS:MESSAGE;
VAR LENGTH:INTEGER);
EXTERNAL;
PROCEDURE RESERV(RESOURCE:NAME;EXCLUSIVE,WAIT:BOOLEAN;
VAR STATUS:INTEGER);
EXTERNAL;
PROCEDURE RELEAS(RESOURCE:NAME;VAR STATUS:INTEGER);
EXTERNAL;
(*$IRESPRINT*)
(*$P*)
(*$IUR*)
(*$P*)
(*$IUDFØR*)
(*$IFISFPROC*)
(*$P*)
PROCEDURE REGVEDL;
CONST MAXFELTER=30;
MAXNØGLER=9;
MAXPOST=150;
MAXHÆGTER=9;
MAXHPOST=20;
MAXIDENT=9;
TYPE
NFELT=^FELTBESKRIVELSE;
SKÆRMPOS=RECORD
X,Y:INTEGER
END;
FTYPE=(HELTAL,DOBBTAL,REEL,TEKST);
VTYPE=(HINTERVAL,DINTERVAL,RINTERVAL,DATO,CPR);
BESKRIVELSESTYPE=(FELTDESC,VALIDESC);
FELTBESKRIVELSE=RECORD
NÆSTEVAL:NFELT;
FELTNAVN:STRING(8);
CASE DESCTYPE:BESKRIVELSESTYPE OF
FELTDESC:
(INDPOS,UDPOS:SKÆRMPOS;
KIKKENIVEAU,ÆNDRENIVEAU:NIVEAU;
EDITERING:INTEGER;
LEDETEKST,FØLGETEKST:STRING;
INDEKS,
LÆNGDE,
HÆGTE,
FORAN0:INTEGER;
CASE FELTTYPE:FTYPE OF
REEL:(DEC:INTEGER);
HELTAL,DOBBTAL,TEKST:());
VALIDESC:
(CASE VALIDITETSTYPE:VTYPE OF
HINTERVAL:(MIN,MAX:INTEGER);
DINTERVAL:(MIN1,MIN2,MAX1,MAX2:INTEGER);
RINTERVAL:(RMIN,RMAX:REAL);
DATO,CPR:())
END;
ARAR=PACKED ARRAY (-11..-10) OF CHAR;
RAR=ARRAY (0..0) OF REAL;
PPOST=RECORD
AA:ARAR;
A:AR;
AAA:RAR;
CONTENTS: ARRAY (1..MAXPOST) OF INTEGER
END;
HPOST=RECORD
AA:ARAR;
A:AR;
AAA:RAR;
CONTENTS: ARRAY (1..MAXHPOST) OF INTEGER
END;
VAR FELT:NFELT;
HUSKNIV:NIVEAU;
PICTURE:ARRAY (1..MAXFELTER) OF NFELT;
NØGLER:ARRAY (1..MAXNØGLER) OF NFELT;
HÆGTER:ARRAY (1..MAXHÆGTER) OF NFELT;
IDENT:ARRAY (1..MAXIDENT) OF NFELT;
ANTALIDENT,
LINES,OPTION,I,J,ANTALFELTER,ANTALNØGLER,ANTALHÆGTER:INTEGER;
LINE:STRING;
POST:PPOST;
HÆGTEREC:ARRAY (1..MAXHÆGTER) OF HPOST;
(*$P*)
PROCEDURE ERROR(VAR REC:AR);
VAR CH:STRING(1);
I:INTEGER;
BEGIN
D23;
(*$R-*)
WRITE('FEJL I REGISTER ',REC(-3),' FEJLKODE ',IER,' RETURN'); (*$R+*)
CH:=' ';EDIT(CH);
IF CH='Æ' THEN BEGIN IER:=0;EXIT(ERROR) END;
ICLOSE(POST.A);
FOR I:=1 TO ANTALHÆGTER DO ICLOSE(HÆGTEREC(I).A);
EXIT(REGVEDL)
END;
(*$P*)
(*$IHLÆSDESC*)
(*$P*)
(*$IMOVETOLI*)
(*$P*)
(*$L+*)
PROCEDURE GETSTATUS;
TYPE
ISFHEAD =RECORD
AA:ARAR;
A:AR;
AAA:RAR;
NBUC,NBLK,NREC,
BLKPRBUC,RECPRBUC,RECPRBLK,
KEYFLDS,
AZSIZE,BUTSIZE,BLTSIZE,BLKSIZE,RECSIZE,KEYSIZE,
SEGINFLH,SEGINBUT,SEGINBUC,SEGINBLT,SEGINBLK,
INITREC,BUCINUSE,BLKINUSE,RECINUSE,
FILEINIT,FILEOPEN:INTEGER;
KEYS : ARRAY (1..9,1..3) OF INTEGER
END;
VAR ISFPOST:ISFHEAD;
N:INTEGER;
PROCEDURE W(T:STRING;NR:INTEGER);
BEGIN
N:=N+1;
WRITE(' ',T,NR:6);
IF N=3 THEN
BEGIN
WRITELN;
N:=0
END
END;
BEGIN
WITH ISFPOST DO
BEGIN
(*$R-*)
A(-4):=51;
A(-3):=POST.A(-3);
(*$R+*)
UDFØR(RETURNHEAD,A);
UDFØRT(RETURNHEAD,A);
CLEARSCREEN;
WRITELN('FILEHEAD-INFORMATION');
N:=0;
W('NBUC :',NBUC);W('NBLK :',NBLK);
W('NREC :',NREC);
W('BLKPRBUC:',BLKPRBUC);
W('RECPRBUC:',RECPRBUC);
W('RECPRBLK:',RECPRBLK);
W('KEYFLDS :',KEYFLDS);
W('AZSIZE :',AZSIZE);
W('BUTSIZE :',BUTSIZE);
W('BLTSIZE :',BLTSIZE);
W('BLKSIZE :',BLKSIZE);
W('RECSIZE :',RECSIZE);
W('KEYSIZE :',KEYSIZE);
W('SEGINFLH:',SEGINFLH);
W('SEGINBUT:',SEGINBUT);
W('SEGINBUC:',SEGINBUC);
W('SEGINBLT:',SEGINBLT);
W('SEGINBLK:',SEGINBLK);
WRITELN('FILE-STATUS');
W('INITREC :',INITREC);
W('BUCINUSE:',BUCINUSE);
W('BLKINUSE:',BLKINUSE);
N:=2;
W('RECINUSE:',RECINUSE);
WRITE(' FILEINIT: ');
(*$R-*)
IF FILEINIT=1 THEN WRITE(' TRUE') ELSE WRITE('FALSE');
WRITE(' FILEOPEN: ');
IF FILEOPEN=1 THEN WRITELN(' TRUE') ELSE WRITELN('FALSE');
(*$R+*)
WRITELN;
WRITELN('KEY-DESCRIPTION');
WRITELN(' KEYFLD KEYPOS KEYLNG KEYSGN');
FOR I:=1 TO KEYFLDS DO
WRITELN(I:9,KEYS(I,1):9,KEYS(I,2):9,KEYS(I,3):9);
WRITE('Return ');READLN
END
END;
(*$P*)
PROCEDURE MAINTAIN;
VAR J,NØGLENR,HNR,HINDEKS:INTEGER;
HCHANGED,HÆGTSØG:BOOLEAN;
CH:STRING(1);
(*$P*)
(*$ISØGPOST*)
(*$P*)
PROCEDURE UDPÅLIST;
BEGIN
REPEAT
D23;
WRITE('Antal poster, 0 for resten ');
READLN;READ(J)
UNTIL (IORESULT=0) AND (J>=0);
REPEAT
IF (LINES+2+ANTALFELTER)>=72 THEN
BEGIN
IF LINES<>100 THEN PAGE(LIST);
WRITELN(LIST,REGNAVN,' UDSKRIFT');
WRITELN(LIST);
LINES:=2
END;
PRINTPOST;
J:=J-1;
WRITELN(LIST);WRITELN(LIST);LINES:=LINES+2;
NEXTREC(POST.A);
IF (IER=-2) AND (J>0) THEN IER:=0
UNTIL (J=0) OR (IER<>0);
IF (IER<>0) AND (IER<>-2) AND (IER<>-9) THEN
ERROR(POST.A) ELSE IER:=0
END;
(*$P*)
PROCEDURE SLETPOST;
BEGIN
REPEAT
D23;
CH:='J';
WRITE('Sletning korrekt J/N ');
EDIT(CH)
UNTIL CH(1) IN (.'J','N','j','n'.);
IF CH(1) IN (.'J','j'.) THEN
BEGIN
FOR HNR:=1 TO ANTALHÆGTER DO
BEGIN
SÆTHÆGTE;
SÆTNØGLE
END;
DELETE(POST.A);
IF IER=-9 THEN
BEGIN
D23;
WRITE('Eneste post, kan ikke slettes, RETURN');
READLN;
IER:=0
END
ELSE
FOR HNR:=1 TO ANTALHÆGTER DO
BEGIN
GETRECX(HÆGTEREC(HNR).A);
IF NOT (-IER IN (.0,6.)) THEN ERROR(HÆGTEREC(HNR).A);
DELETE(HÆGTEREC(HNR).A);
IF NOT (-IER IN (.0,6.)) THEN ERROR(HÆGTEREC(HNR).A);
IER:=0
END
END
ELSE GETREC(POST.A);
IF IER<>0 THEN ERROR(POST.A)
END;
(*$P*)
PROCEDURE OPRET;
BEGIN
NULPOST;
SKRIVPOST;
FOR J:=1 TO ANTALFELTER DO
BEGIN
IF PICTURE(J)^.ÆNDRENIVEAU=UMULIUS THEN
BEGIN
HUSKNIV:=USERNIVEAU;
USERNIVEAU:=UMULIUS
END;
LÆSFELT(PICTURE(J));
SKRIVFELT(PICTURE(J));
IF PICTURE(J)^.ÆNDRENIVEAU=UMULIUS THEN USERNIVEAU:=HUSKNIV
END;
USERNIVEAU:=HUSKNIV;
IF NOT FILEINIT THEN
BEGIN
FILEINIT:=TRUE;
REPEAT
D23;
WRITE('ANTAL INITIALISERINGSPOSTER ');
READLN;READ(IREC)
UNTIL (IORESULT=0) AND (IREC>0);
INITIATE(POST.A);
IF IER<>0 THEN ERROR(POST.A)
END;
INSERT(POST.A);
IF IER<>0 THEN
IF IER=-7 THEN
BEGIN
D23;
WRITE('Posten findes, RETURN ');READLN
END
ELSE ERROR(POST.A)
ELSE
FOR HNR:=1 TO ANTALHÆGTER DO
BEGIN
SÆTHÆGTE;
SÆTNØGLE;
INSERT(HÆGTEREC(HNR).A);
IF IER<>0 THEN ERROR(HÆGTEREC(HNR).A)
END
END;
(*$P*)
BEGIN (*MAINTAIN*)
CLEARSCREEN;
IF OPTION<>4 THEN
BEGIN
HUSKNIV:=USERNIVEAU;
USERNIVEAU:=UMULIUS;
NULPOST;
HÆGTSØG:=FALSE;
IF ANTALHÆGTER>0 THEN SØGPOST;
IF NOT HÆGTSØG THEN
BEGIN
J:=1;
LÆSFELT(NØGLER(J));
WHILE (J<ANTALNØGLER) AND NOT EOF DO
BEGIN
J:=J+1;
LÆSFELT(NØGLER(J))
END;
USERNIVEAU:=HUSKNIV;
IF OPTION IN (.1,5.) THEN
GETRECX(POST.A)
ELSE
GETREC(POST.A);
IF (IER<>0) AND (IER<>-6) THEN ERROR(POST.A);
IF EOF THEN
BEGIN
IF IER=-6 THEN
BEGIN
IF OPTION IN (.1,5.) THEN
NEXTRECX(POST.A)
ELSE
NEXTREC(POST.A);
IF (IER<>-1) AND (IER<>-2) AND (IER<>-9) THEN
ERROR(POST.A)
END;
REPEAT
SKRIVPOST;
D23;
CH:='F';
WRITE('Rigtig post R, Flere poster F, Stop S ');
EDIT(CH);
IF CH(1) IN (.'f','r','s'.) THEN
CH(1):=CHR(ORD(CH(1))-32);
IF CH='F' THEN
BEGIN
IF OPTION IN (.1,5.) THEN
NEXTRECX(POST.A)
ELSE
NEXTREC(POST.A);
IF (IER<>0) AND (IER<>-2) AND (IER<>-9) THEN
ERROR(POST.A)
END
UNTIL CH<>'F';
D23;
IF (OPTION IN (.1,5.)) AND (CH<>'R') THEN GETREC(POST.A);
(*FOR AT FJERNE XCLUSIV-STATUS*)
IF OPTION=2 THEN CH:='S'
END
ELSE
BEGIN
IF IER=0 THEN
BEGIN
CH:='R';
SKRIVPOST
END
ELSE
BEGIN
CH:='S';
D23;WRITE('Posten findes ikke, RETURN ');
READLN
END
END
END
END;
IF (OPTION=4) OR (CH='R') THEN
CASE OPTION OF
1: BEGIN
REPEAT
REPEAT
D23;
J:=0;
WRITELN('Feltnr, 0 for færdig ',J);
GOTOXY(22,23);READLN;
IF NOT (EOLN OR (INPUT^=' ')) THEN READ(J)
UNTIL (IORESULT=0) AND (J>=0) AND (J<=ANTALFELTER);
IF J>0 THEN BEGIN
HNR:=0;
IF PICTURE(J)^.HÆGTE>0 THEN
BEGIN
REPEAT
HNR:=HNR+1
UNTIL PICTURE(J)^.HÆGTE=HÆGTER(HNR)^.HÆGTE;
SÆTHÆGTE;
END;
LÆSFELT(PICTURE(J));SKRIVFELT(PICTURE(J));
HCHANGED:=FALSE;
IF HNR>0 THEN
BEGIN
CASE PICTURE(J)^.FELTTYPE OF (*$R-*)
HELTAL :HCHANGED:=(HÆGTEREC(HNR).A(1)<>
POST.A(PICTURE(J)^.INDEKS));
DOBBTAL:HCHANGED:=(
(HÆGTEREC(HNR).A(1)<>
POST.A(PICTURE(J)^.INDEKS)) OR
(HÆGTEREC(HNR).A(2)<>
POST.A(PICTURE(J)^.INDEKS+1)));
TEKST:FOR HINDEKS:=1 TO PICTURE(J)^.FORAN0 DO
IF HÆGTEREC(HNR).AA(HINDEKS)<>
POST.AA(PICTURE(J)^.INDEKS-1+HINDEKS)
THEN HCHANGED:=TRUE
END
END; (*$R+*)
IF HCHANGED THEN
BEGIN
SÆTNØGLE;
GETRECX(HÆGTEREC(HNR).A);
IF IER=0 THEN DELETE(HÆGTEREC(HNR).A);
SÆTHÆGTE;
SÆTNØGLE;
INSERT(HÆGTEREC(HNR).A);
IF IER<>0 THEN ERROR(HÆGTEREC(HNR).A)
END
END
UNTIL J=0;
PUTREC(POST.A);
IF IER<>0 THEN ERROR(POST.A)
END;
2: BEGIN GOTOXY(1,24);WRITE('Tryk RETURN ');READLN END;
3: UDPÅLIST;
4: OPRET;
5: SLETPOST
END
END;
(*$P*)
BEGIN (*REGVEDL*)
CLEARSCREEN;
(*$XT*) WRITELN('MEMAVAIL ',MEMAVAIL); (*$X-*)
LÆSDESC;
(*$XT*) WRITELN('MEMAVAIL ',MEMAVAIL);READLN; (*$X-*)
MODE:=3;(*SKRIV*)
FOR I:=1 TO ANTALHÆGTER DO
BEGIN
IOPEN(HÆGTEREC(I).A);
IF IER<>0 THEN ERROR(HÆGTEREC(I).A)
END;
LINES:=100; (*$R-*)
POST.A(-3):=FILNR; (*$R+*)
IOPEN(POST.A);IF IER<>0 THEN ERROR(POST.A);
REPEAT
CLEARSCREEN;
GOTOXY(10,10);
WRITELN(REGNAVN,' R E G I S T E R - V E D L I G E H O L D E L S E');
GOTOXY(10,12);
WRITELN('0 Færdig');
WRITELN(' ':9,'1 Ændring');
WRITELN(' ':9,'2 Udskrift på skærm');
WRITELN(' ':9,'3 Udskrift på printer');
WRITELN(' ':9,'4 Oprettelse');
WRITELN(' ':9,'5 Sletning');
IF USERNIVEAU>=GENERAL THEN
WRITELN(' ':9,'6 Status');
REPEAT
GOTOXY(10,19);
WRITE('Vælg 0-');IF USERNIVEAU<GENERAL THEN WRITE('5') ELSE WRITE('6');
GOTOXY(21,19);UR;
OPTION:=SV
UNTIL (OPTION>=0) AND ((OPTION<=5) OR
((OPTION=6) AND (USERNIVEAU>=GENERAL)));
IF OPTION=6 THEN GETSTATUS ELSE
IF OPTION>0 THEN MAINTAIN
UNTIL OPTION=0;
IF LINES<>100 THEN PAGE(LIST);
ICLOSE(POST.A);
FOR I:=1 TO ANTALHÆGTER DO ICLOSE(HÆGTEREC(I).A);
CLEARSCREEN;
IF IER<>0 THEN BAD(6,IER)
END;
(*$P*)
PROCEDURE DOIT;
TYPE
FILDESC=RECORD
FILNAVN,DESCNAVN,POSTNAVN,REGNAVN:STRING(18);
VEDLNIVEAU:NIVEAU;
ZONESIZE:INTEGER
END;
FILEDESC=FILE OF FILDESC;
PROGDESC=RECORD
PROGFIL,PROGNAVN:STRING(18);
PROGNIVEAU:NIVEAU
END;
PROGFILE=FILE OF PROGDESC;
VAR ISFFILES:FILEDESC;
PROGS:PROGFILE;
ISFFNAVN:STRING(18);
SCH:STRING(1);
J,I,AKNR:INTEGER;
PROCEDURE IOC;
VAR CH:STRING(1);
IOR:INTEGER;
BEGIN
IOR:=IORESULT;
IF IOR<>0 THEN
BEGIN
CLEARSCREEN;
D23;
WRITE('Pladefejl ',IOR:5,' RETURN ');
CH:=' ';
EDIT(CH);
IF CH<>'R' THEN EXIT(DOIT)
END
END;
(*$P*)
BEGIN
ISFFNAVN:='PROGFILE:P2:0000:S';
RESET(PROGS,ISFFNAVN);IOC;
REPEAT
SEEK(PROGS,1);IOC;
GET(PROGS);
CLEARSCREEN;
FILNR:=2;
WRITELN(' ':20,' 0 Stop');
WRITELN;
WRITELN(' ':20,' 1 Kartoteksvedligeholdelse');
WRITELN(' ':20,' 2 Listeprogrammer');
WHILE PROGS^.PROGNAVN(1)<>'@' DO
BEGIN
FILNR:=FILNR+1;
IF PROGS^.PROGNIVEAU<=USERNIVEAU THEN
WRITELN(' ':20,FILNR:3,PROGS^.PROGNAVN);
GET(PROGS);IOC
END;
WRITELN(' ':20,FILNR+1:3,' Indtast ny adgangskode');
IF USERNIVEAU>=GENERAL THEN
BEGIN
WRITELN;
WRITELN(' ':20,FILNR+2:3,' Privilegerede funktioner')
END;
GOTOXY(1,22);WRITELN('Vælg funktion');
GOTOXY(15,22);
STIMER:=TIMER;
UR;
IF STIMER=0 THEN BEGIN USERNIVEAU:=MENIG;PARM^(1):='0' END;
I:=SV;
IF (I>2) AND (I<=FILNR) THEN
BEGIN
SEEK(PROGS,I-2);IOC;
GET(PROGS);IOC;
IF PROGS^.PROGNIVEAU<=USERNIVEAU THEN
BEGIN
F:='';
SCH:=' ';
J:=0;
WHILE J<18 DO
BEGIN
J:=J+1;
IF PROGS^.PROGFIL(J)<>' ' THEN
BEGIN
SCH(1):=PROGS^.PROGFIL(J);
F:=CONCAT(F,SCH)
END
ELSE J:=18
END
END
END;
UNTIL (I IN (.0..2.)) OR (I=FILNR+1) OR (F<>' ') OR
((I=FILNR+2) AND (USERNIVEAU>=GENERAL));
CLOSE(PROGS);IOC;
IF I=FILNR+2 THEN
BEGIN
CLEARSCREEN;
IF USERNIVEAU>=HSM THEN
BEGIN
WRITELN(' ':20,'1 Skærmbilledopbygning');
WRITELN(' ':20,'2 Listedefinition')
END;
WRITELN(' ':20,'3 Ændring af adgangskoder');
GOTOXY(1,20);
WRITELN('Vælg funktion');
REPEAT
GOTOXY(15,20);
READLN;READ(I)
UNTIL (IORESULT=0) AND (I>0) AND (I<4);
CASE I OF
1: IF USERNIVEAU>=HSM THEN F:='INTRE,SKÆRMBIL:P2';
2: IF USERNIVEAU>=HSM THEN F:='INTRE,LISTEGEN:P2';
3: KODEVEDL;
END
END
ELSE
IF I=FILNR+1 THEN
BEGIN
PARM^(1):='0';
KODEVEDL;
I:=ORD(PARM^(1))-48;
USERNIVEAU:=MENIG;
WHILE I>0 DO
BEGIN
USERNIVEAU:=SUCC(USERNIVEAU);
I:=I-1
END
END
ELSE
CASE I OF
1:IF RESPRINT THEN
BEGIN
ISFFNAVN:='ISFFILES:P2:0000:S';
RESET(ISFFILES,ISFFNAVN);IOC;
REPEAT
CLEARSCREEN;
SEEK(ISFFILES,1);IOC;
GET(ISFFILES);IOC;
FILNR:=0;
WHILE ISFFILES^.FILNAVN(1)<>'@' DO
BEGIN
FILNR:=FILNR+1;
IF ISFFILES^.VEDLNIVEAU<=USERNIVEAU THEN
WRITELN(FILNR:4,' ',ISFFILES^.REGNAVN,'-register');
GET(ISFFILES);IOC
END;
REPEAT
D23;WRITE('Vælg register ');
READLN;READ(AKNR)
UNTIL (IORESULT=0) AND (AKNR>=0) AND (AKNR<=FILNR);
IF AKNR>0 THEN
BEGIN
SEEK(ISFFILES,AKNR);IOC;
GET(ISFFILES);IOC
END
UNTIL (AKNR=0) OR (ISFFILES^.VEDLNIVEAU<=USERNIVEAU);
CLOSE(ISFFILES);IOC;
IF AKNR>0 THEN
BEGIN
DESCNAVN:=ISFFILES^.DESCNAVN;
REGNAVN:=ISFFILES^.REGNAVN;
IF ISFFILES^.FILNAVN(1)='#' THEN
BEGIN
AKNR:=0;
I:=2;
WHILE ISFFILES^.FILNAVN(I) IN (.'0'..'9'.) DO
BEGIN
AKNR:=10*AKNR+ORD(ISFFILES^.FILNAVN(I))-48;
I:=I+1
END
END;
FILNR:=AKNR;
MARK(QUQ);
REGVEDL;
RELEASE(QUQ)
END;
FREEPR
END;
0:F:='STOP';
2:F:='CPLISTE *1'
END
END;
(*$P*)
BEGIN
ALARM:=CLOCK^.DATE(9)='1';
IF ALARM THEN FOR I:=1 TO 8 DO ALARMTIME(I):=CLOCK^.DATE(I);
HOWL:=FALSE;STOPWATCH:=FALSE;TÆNDT:=FALSE;
SEMAFOR:='ALLOCOMBUF';
I:=ORD(PARM^(1))-48;
USERNIVEAU:=MENIG;
WHILE I>0 DO
BEGIN
USERNIVEAU:=SUCC(USERNIVEAU);
I:=I-1
END; (*$R-*)
SNYD(-3):=0;
FOR I:=6 DOWNTO 2 DO SNYD(-3):=10*SNYD(-3)+ORD(PARM^(I))-48;
IF PARM^(7)='-' THEN SNYD(-3):=-SNYD(-3); (*$R+*)
UDFØR(PTILMELD,SNYD);
UDFØRT(PTILMELD,SNYD);
IF IER<>0 THEN BAD(1,IER);
REPEAT
F:=' ';
CLEARSCREEN;
DOIT
UNTIL F<>' ';
UDFØR(PAFMELD,SNYD);
UDFØRT(PAFMELD,SNYD);
IF IER<>0 THEN BAD(2,IER);
IF F<>'STOP' THEN
BEGIN
FNAVN:=' ';
FOR I:=1 TO 7 DO FNAVN(I):=PARM^(I);
IF LENGTH(F)>10 THEN
CHAIN('L *1',CONCAT(F,',',FNAVN),QUQ)
ELSE
CHAIN(F,FNAVN,QUQ);
IF IORESULT<>0 THEN WRITELN('IORESULT ',IORESULT)
END
ELSE
BEGIN
UDFØR(UAFMELD,SNYD);
UDFØRT(UAFMELD,SNYD);
IF IER<>0 THEN BAD(3,IER)
END
END.