|
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: 30528 (0x7740)
Types: TextFile
Notes: Mikados_K
Names: »HOVED.K«
└─⟦6b1c9961a⟧ Bits:30008989 INDPERM P1
└─⟦this⟧ »HOVED.K«
PROGRAM HOVED;
CONST LNGTH=20;
TIMER=120;
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);
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;
C,CH :CHAR;
F:STRING(11);
QUQ:^INTEGER;
I:INTEGER;
FNAVN,REGNAVN,DESCNAVN:STRING;
(*$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:1:J';
REWRITE(F,FNAVN);
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
GOTOXY(1,23);
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;
CLOSE(F);
IF IORESULT<>0 THEN WRITELN('IORESULT ',IORESULT)
END;
(*$P*)
PROCEDURE SETUP(VAR BUFFER:DIRECTBUF;LENGTH:INTEGER);
EXTERNAL;
FUNCTION AVAIL:BOOLEAN;
EXTERNAL;
FUNCTION NEXT:CHAR;
EXTERNAL;
PROCEDURE FINIS;
EXTERNAL;
(*$P*)
PROCEDURE UR;
BEGIN
SETUP(DBUF,LNGTH);
C:=' ';
IF TÆNDT THEN
BEGIN
GOTOXY(62,1);WRITE('Alarm');
IF ALARM THEN BEGIN GOTOXY(72,1);WRITE(ALARMTIME) END;
GOTOXY(62,2);WRITE('Time');
END;
SV:=-1;
REPEAT
IF C<>CLOCK^.TIME(8) THEN
BEGIN
IF TÆNDT THEN
BEGIN
GOTOXY(67,2);
WRITE(CLOCK^.TIME);
END;
C:=CLOCK^.TIME(8);
OFFSET:=TIME;
IF STIMER>0 THEN STIMER:=STIMER-1
END;
IF TÆNDT THEN
BEGIN
GOTOXY(76,2);
WRITE((TIME-OFFSET) MOD 100:4);
END;
IF STOPWATCH THEN
BEGIN
IF (TIME<0) AND (TT>0) THEN
SEC100:=SEC100+(32767-TT)+(32767+TIME+2)
ELSE
SEC100:=SEC100+TIME-TT;
TT:=TIME;
SEC:=SEC+SEC100 DIV 100;SEC100:=SEC100 MOD 100;
MIN:=MIN+SEC DIV 60; SEC:=SEC MOD 60;
IF TÆNDT THEN
BEGIN
GOTOXY(60,3);
WRITE(MIN:4,SEC:3,SEC100:3);
END;
END;
IF ALARM THEN IF ALARMTIME<=CLOCK^.TIME THEN HOWL:=TRUE;
IF TÆNDT THEN
IF HOWL THEN WRITE(CHR(7));
IF AVAIL THEN
BEGIN
CH:=NEXT;
IF TÆNDT OR (CH='T') OR (CH IN (.'0'..'9'.)) THEN
CASE CH OF
'S':BEGIN
STOPWATCH:=NOT(STOPWATCH);
IF STOPWATCH THEN BEGIN MIN:=0;SEC:=0;SEC100:=0;TT:=TIME END;
END;
'U':BEGIN GOTOXY(67,2);FOR I:=1 TO 8 DO CLOCK^.TIME(I):=NEXT END;
'C':BEGIN STOPWATCH:=TRUE;TT:=TIME END;
'T':TÆNDT:=NOT TÆNDT;
'0','1','2','3','4','5','6','7','8','9':BEGIN FINIS;SV:=ORD(CH)-48;
WRITELN(SV) END;
'M':BEGIN
GOTOXY(70,3);
IF STOPWATCH THEN
WRITE(MIN:4,SEC:3,SEC100:3);
END;
'A':BEGIN
HOWL:=FALSE;
ALARM:=NOT(ALARM);
CLOCK^.DATE(9):='0';
IF ALARM THEN
BEGIN
CLOCK^.DATE(9):='1';
GOTOXY(72,1);
FOR I:=1 TO 8 DO BEGIN CLOCK^.DATE(I):=NEXT;
ALARMTIME(I):=CLOCK^.DATE(I)
END;
GOTOXY(72,1);WRITE(ALARMTIME)
END;
END;
END;
END;
UNTIL SV>-1
END;
(*$P*)
PROCEDURE REGVEDL;
CONST MAXFELTER=30;
MAXNØGLER=9;
MAXZONE=1000;
MAXPOST=250;
(*$IISFHEAD*)
ZZONE =RECORD
H:ISFHEAD;
T:ARRAY(1..MAXZONE) OF INTEGER
END;
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;
CASE DESCTYPE:BESKRIVELSESTYPE OF
FELTDESC:
(INDPOS,UDPOS:SKÆRMPOS;
KIKKENIVEAU,ÆNDRENIVEAU:NIVEAU;
EDITERING:INTEGER;
LEDETEKST,FØLGETEKST:STRING;
INDEKS:INTEGER;
LÆNGDE:INTEGER;
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;
FELTFIL=FILE OF FELTBESKRIVELSE;
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;
SYSPOST=RECORD
MINUTFAKTOR:ARRAY (1..5) OF REAL;
DAT1,DAT2:INTEGER
END;
SYSFILE=FILE OF SYSPOST;
VAR FELT:NFELT;
SF:SYSFILE;
HUSKNIV:NIVEAU;
PICTURE:ARRAY (1..MAXFELTER) OF NFELT;
NØGLER:ARRAY (1..MAXNØGLER) OF NFELT;
LINES,OPTION,IER,I,J,ANTALFELTER,ANTALNØGLER:INTEGER;
CH:STRING(1);
LINE:STRING;
FFIL:FELTFIL;
REGISTER:ISF;
ZONE:ZZONE;
POST:PPOST;
(*$L-*)
(*$R-,IEXCOMCOP*)
(*$IIOPEN*)
(*$ISÆTØG*)
(*$IREADPROC*)
(*$IFINDPOST*)
(*$IFORSKYD*)
(*$IICLOSE*)
(*$IPUTGET*)
(*$IINSERT*)
(*$INEXTREC*)
(*$IDELETE*)
(*$IINITIATE*)
(*$IREPORT*)
(*$L+*)
(*$P*)
PROCEDURE ERROR(VAR FIL:FILNAVN);
BEGIN
IF LINES>0 THEN PAGE(LIST);
WRITELN('FEJL I REGISTER ',FIL,' FEJLKODE ',IER,' RETURN');
CH:=' ';EDIT(CH);IF CH='R' THEN REPORT(ZONE.H,REGISTER,1);
ICLOSE(ZONE.H,REGISTER);
EXIT(REGVEDL)
END;
PROCEDURE OFEJL(VAR FIL:FILNAVN);
VAR I:INTEGER;
BEGIN
GOTOXY(1,20);
WRITELN('REGISTERFEJL ',IER,' I ',FIL,' . 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(FIL);
CLEARSCREEN
END;
(*$P*)
PROCEDURE LÆSDESC;
BEGIN
REWRITE(FFIL,DESCNAVN);
GET(FFIL);
I:=0;
ANTALNØGLER:=0;
WHILE FFIL^.INDPOS.X>0 DO
BEGIN
I:=I+1;
CASE FFIL^.FELTTYPE OF
REEL:NEW(PICTURE(I),FELTDESC,REEL);
HELTAL,DOBBTAL,TEKST:NEW(PICTURE(I),FELTDESC,HELTAL)
END;
FELT:=PICTURE(I);
WITH PICTURE(I)^ DO
BEGIN
DESCTYPE:=FELTDESC;
INDPOS.X:=FFIL^.INDPOS.X;
INDPOS.Y:=FFIL^.INDPOS.Y;
UDPOS.X:=FFIL^.UDPOS.X;
UDPOS.Y:=FFIL^.UDPOS.Y;
KIKKENIVEAU:=FFIL^.KIKKENIVEAU;
ÆNDRENIVEAU:=FFIL^.ÆNDRENIVEAU;
IF ÆNDRENIVEAU=UMULIUS THEN
BEGIN
ANTALNØGLER:=ANTALNØGLER+1;
NØGLER(ANTALNØGLER):=PICTURE(I)
END;
LEDETEKST:=FFIL^.LEDETEKST;
FØLGETEKST:=FFIL^.FØLGETEKST;
EDITERING:=FFIL^.EDITERING;
FELTTYPE:=FFIL^.FELTTYPE;
INDEKS:=FFIL^.INDEKS;
LÆNGDE:=FFIL^.LÆNGDE;
FORAN0:=FFIL^.FORAN0;
IF FELTTYPE=REEL THEN DEC:=FFIL^.DEC;
WHILE FFIL^.NÆSTEVAL<>NIL DO
BEGIN
GET(FFIL);
WITH FELT^ DO
CASE FFIL^.VALIDITETSTYPE OF
HINTERVAL:BEGIN
NEW(NÆSTEVAL,VALIDESC,HINTERVAL);
NÆSTEVAL^.MIN:=FFIL^.MIN;
NÆSTEVAL^.MAX:=FFIL^.MAX
END;
DINTERVAL:BEGIN
NEW(NÆSTEVAL,VALIDESC,DINTERVAL);
NÆSTEVAL^.MIN1:=FFIL^.MIN1;NÆSTEVAL^.MIN2:=FFIL^.MIN2;
NÆSTEVAL^.MAX1:=FFIL^.MAX1;NÆSTEVAL^.MAX2:=FFIL^.MAX2
END;
RINTERVAL:BEGIN
NEW(NÆSTEVAL,VALIDESC,RINTERVAL);
NÆSTEVAL^.RMIN:=FFIL^.RMIN;
NÆSTEVAL^.RMAX:=FFIL^.RMAX
END;
DATO,CPR:NEW(NÆSTEVAL,VALIDESC,DATO)
END;
FELT:=FELT^.NÆSTEVAL;
FELT^.DESCTYPE:=VALIDESC;
FELT^.VALIDITETSTYPE:=FFIL^.VALIDITETSTYPE
END;
FELT^.NÆSTEVAL:=NIL
END;
GET(FFIL)
END;
CLOSE(FFIL);
ANTALFELTER:=I
END;
(*$P*)
PROCEDURE MOVETOLINE(VAR F:NFELT);
VAR CH:STRING(1);
TAL,DECS,I:INTEGER;
RESULT,DM,DD:REAL;
BEGIN
CH:=' ';
CASE F^.FELTTYPE OF
HELTAL:BEGIN
LINE:='';
TAL:=ABS(POST.A(F^.INDEKS));
REPEAT
CH(1):=CHR(TAL MOD 10+48);
LINE:=CONCAT(CH,LINE);
TAL:=TAL DIV 10
UNTIL TAL=0;
WHILE LENGTH(LINE)<F^.FORAN0 DO LINE:=CONCAT('0',LINE);
IF POST.A(F^.INDEKS)<0 THEN LINE:=CONCAT('-',LINE)
END;
DOBBTAL:BEGIN
LINE:='';
RESULT:=ABS(POST.A(F^.INDEKS)*10000.0+POST.A(F^.INDEKS+1));
DM:=100000000.0;
REPEAT
I:=TRUNC(RESULT/DM)+48;
RESULT:=RESULT-DM*(I-48);
DM:=DM/10
UNTIL (I>48) OR (DM<1.0);
REPEAT
CH(1):=CHR(I);
LINE:=CONCAT(LINE,CH);
I:=TRUNC(RESULT/DM)+48;
RESULT:=RESULT-DM*(I-48);
DM:=DM/10.0
UNTIL DM<0.09;
WHILE LENGTH(LINE)<F^.FORAN0 DO LINE:=CONCAT('0',LINE);
IF POST.A(F^.INDEKS)*10000.0+POST.A(F^.INDEKS+1)<0.0 THEN
LINE:=CONCAT('-',LINE)
END;
TEKST:BEGIN
LINE:='';
FOR I:=F^.INDEKS TO F^.INDEKS+F^.LÆNGDE-1 DO
BEGIN
CH(1):=POST.AA(I);
LINE:=CONCAT(LINE,CH)
END
END;
REEL:BEGIN
RESULT:=ABS(POST.AAA(F^.INDEKS));
DECS:=F^.DEC;
IF DECS=0 THEN
DD:=0.0
ELSE
BEGIN
DD:=0.1;
FOR I:=1 TO DECS DO BEGIN RESULT:=RESULT*10.0;DD:=DD*10 END
END;
LINE:='';
IF F^.FORAN0=0 THEN
BEGIN
DM:=100000000000.0;
REPEAT
I:=TRUNC(RESULT/DM)+48;
RESULT:=RESULT-DM*(I-48);
DM:=DM/10.0
UNTIL (I>48) OR (DM<1.0) OR (DM=DD)
END
ELSE
BEGIN
DM:=1.0;
FOR I:=2 TO F^.FORAN0 DO DM:=DM*10.0;
I:=TRUNC(RESULT/DM)+48;
RESULT:=RESULT-DM*(I-48);
DM:=DM/10.0
END;
REPEAT
CH(1):=CHR(I);
LINE:=CONCAT(LINE,CH);
IF DM=DD THEN LINE:=CONCAT(LINE,'.');
I:=TRUNC(RESULT/DM)+48;
RESULT:=RESULT-DM*(I-48);
DM:=DM/10.0
UNTIL DM<0.09;
IF POST.AAA(F^.INDEKS)<0.0 THEN LINE:=CONCAT('-',LINE)
END
END
END;
(*$P*)
PROCEDURE NULPOST;
VAR I,J:INTEGER;
BEGIN
FOR J:=1 TO ANTALFELTER DO WITH PICTURE(J)^ DO
BEGIN
CASE FELTTYPE OF
HELTAL:POST.A(INDEKS):=0;
DOBBTAL:BEGIN
POST.A(INDEKS):=0;
POST.A(INDEKS+1):=0
END;
REEL:POST.AAA(INDEKS):=0.0;
TEKST:FOR I:=INDEKS TO LÆNGDE+INDEKS-1 DO
POST.AA(I):=' ';
END
END
END;
PROCEDURE SKRIVFELT(VAR F:NFELT);
BEGIN
IF USERNIVEAU>=F^.KIKKENIVEAU THEN
BEGIN
GOTOXY(F^.UDPOS.X,F^.UDPOS.Y);
WRITE(F^.LEDETEKST,' ');
MOVETOLINE(F);
WRITELN(LINE);
END
END;
PROCEDURE SKRIVPOST;
VAR I:INTEGER;
BEGIN
CLEARSCREEN;
FOR I:=1 TO ANTALFELTER DO SKRIVFELT(PICTURE(I));
END;
PROCEDURE PRINTPOST;
VAR I:INTEGER;
BEGIN
FOR I:=1 TO ANTALFELTER DO
BEGIN
WRITE(LIST,PICTURE(I)^.LEDETEKST,' ');
MOVETOLINE(PICTURE(I));
LINES:=LINES+1;
WRITELN(LIST,LINE)
END
END;
(*$P*)
PROCEDURE LÆSFELT(VAR F:NFELT);
VAR I,TAL,TAL1:INTEGER;
VAL:NFELT;
RESULT:REAL;
BUMMED:BOOLEAN;
(*$P*)
PROCEDURE LÆSLINIE;
VAR OK:BOOLEAN;
DECS,I,FORTEGN:INTEGER;
DM:REAL;
BEGIN
REPEAT
OK:=FALSE;
RESULT:=0.0;
TAL:=0;
TAL1:=0;
GOTOXY(F^.INDPOS.X,F^.INDPOS.Y);
WRITELN(F^.LEDETEKST,' ':F^.LÆNGDE+2,F^.FØLGETEKST);
GOTOXY(F^.INDPOS.X+LENGTH(F^.LEDETEKST)+1,F^.INDPOS.Y);
IF F^.EDITERING=0 THEN
BEGIN
READLN;READ(LINE)
END
ELSE
BEGIN
MOVETOLINE(F);
EDIT(LINE:F^.LÆNGDE);
WHILE LINE(LENGTH(LINE))=' ' DO LINE(0):=CHR(ORD(LINE(0))-1)
END;
CASE F^.FELTTYPE OF
TEKST:
IF LENGTH(LINE)<=F^.LÆNGDE THEN
BEGIN
OK:=TRUE;
WHILE LENGTH(LINE)<F^.LÆNGDE DO
IF F^.FORAN0=0 THEN
LINE:=CONCAT(LINE,' ')
ELSE
LINE:=CONCAT(' ',LINE)
END;
HELTAL,DOBBTAL:
IF LENGTH(LINE)>0 THEN
BEGIN
I:=0;
FORTEGN:=1;
IF LINE(1)='-' THEN
BEGIN
FORTEGN:=-1;
I:=1
END;
WHILE LENGTH(LINE)>I DO
BEGIN
OK:=TRUE;
I:=I+1;
IF NOT (LINE(I) IN (.'0'..'9'.)) THEN
BEGIN
OK:=FALSE;
I:=LENGTH(LINE)
END;
RESULT:=10*RESULT+ORD(LINE(I))-48
END;
RESULT:=RESULT*FORTEGN;
IF OK THEN
CASE F^.FELTTYPE OF
HELTAL:IF ABS(RESULT)<=32767 THEN TAL:=TRUNC(RESULT) ELSE OK:=FALSE;
DOBBTAL:IF ABS(RESULT)<=327679999.0 THEN
BEGIN
TAL:=TRUNC(RESULT/10000.0);
TAL1:=TRUNC(RESULT-10000.0*TAL)
END
ELSE OK:=FALSE
END
END ELSE OK:=TRUE;
REEL:
IF LENGTH(LINE)>0 THEN
BEGIN
I:=0;
FORTEGN:=1;
DECS:=-1;
IF LINE(1)='-' THEN
BEGIN
FORTEGN:=-1;
I:=1
END;
WHILE (LENGTH(LINE)>I) AND (DECS<0) DO
BEGIN
OK:=TRUE;
I:=I+1;
IF LINE(I) IN (.'0'..'9'.) THEN
RESULT:=10*RESULT+ORD(LINE(I))-48
ELSE
IF (LINE(I)='.') OR (LINE(I)=',') THEN
DECS:=0
ELSE
BEGIN
OK:=FALSE;
I:=LENGTH(LINE)
END
END;
DM:=1.0;
WHILE LENGTH(LINE)>I DO
BEGIN
I:=I+1;
DM:=DM/10.0;
IF LINE(I) IN (.'0'..'9'.) THEN
BEGIN
RESULT:=RESULT+DM*(ORD(LINE(I))-48);
DECS:=DECS+1
END
ELSE
BEGIN
OK:=FALSE;
I:=LENGTH(LINE)
END
END;
RESULT:=FORTEGN*RESULT;
IF DECS>F^.DEC THEN OK:=FALSE
END
ELSE OK:=TRUE
END
UNTIL OK
END;
(*$P*)
PROCEDURE CHECKVAL;
VAR I,DAT0,MÅNED,ÅR,MODULC:INTEGER;
CPN:ARRAY (1..10) OF INTEGER;
BEGIN
CASE VAL^.VALIDITETSTYPE OF
HINTERVAL:
BUMMED:=((TAL<VAL^.MIN) OR (TAL>VAL^.MAX));
DINTERVAL:
BUMMED:=((TAL*10000.0+TAL1<VAL^.MIN1*10000.0+VAL^.MIN2) OR
(TAL*10000.0+TAL1>VAL^.MAX1*10000.0+VAL^.MAX2));
RINTERVAL:
BUMMED:=((RESULT<VAL^.RMIN) OR (RESULT>VAL^.RMAX));
DATO:
IF LENGTH(LINE)=6 THEN
BEGIN
ÅR:=10*(ORD(LINE(1))-48)+ORD(LINE(2))-48;
MÅNED:=10*(ORD(LINE(3))-48)+ORD(LINE(4))-48;
DAT0:=10*(ORD(LINE(5))-48)+ORD(LINE(6))-48;
IF (DAT0<1) OR (MÅNED<1) OR (MÅNED>12) OR (DAT0>31) THEN BUMMED:=TRUE;
IF NOT BUMMED THEN
CASE MÅNED OF
4,6,9,11: IF DAT0>30 THEN BUMMED:=TRUE;
2: IF (DAT0>29) OR ((DAT0=29) AND (ÅR MOD 4 <>0)) THEN BUMMED:=TRUE
END
END
ELSE BUMMED:=TRUE;
CPR:
IF LENGTH(LINE)=10 THEN
BEGIN
FOR I:=1 TO 10 DO CPN(I):=ORD(LINE(I))-48;
DAT0:=CPN(1)*10+CPN(2);
MÅNED:=CPN(3)*10+CPN(4);
ÅR:=CPN(5)*10+CPN(6);
IF (DAT0<1) OR (MÅNED<1) OR (MÅNED>12) OR (DAT0>31) THEN BUMMED:=TRUE;
IF NOT BUMMED THEN
CASE MÅNED OF
4,6,9,11: IF DAT0>30 THEN BUMMED:=TRUE;
2: IF (DAT0>29) OR ((DAT0=29) AND (ÅR MOD 4<>0)) THEN BUMMED:=TRUE
END;
IF NOT BUMMED THEN
BEGIN
MODULC:=CPN(1)*4+CPN(2)*3+CPN(3)*2+CPN(4)*7+CPN(5)*6+CPN(6)*5+CPN(7)*4+
CPN(8)*3+CPN(9)*2+CPN(10);
IF MODULC MOD 11<>0 THEN BUMMED:=TRUE
END
END
ELSE BUMMED:=TRUE;
END
END;
(*$P*)
(*PROCEDURE LÆSFELT*)
BEGIN
IF USERNIVEAU>=F^.ÆNDRENIVEAU THEN
BEGIN
REPEAT
LÆSLINIE;
VAL:=F^.NÆSTEVAL;
BUMMED:=FALSE;
WHILE (VAL<>NIL) AND (NOT BUMMED) DO
BEGIN
CHECKVAL;
VAL:=VAL^.NÆSTEVAL
END
UNTIL NOT BUMMED;
CASE F^.FELTTYPE OF
HELTAL:POST.A(F^.INDEKS):=TAL;
DOBBTAL:BEGIN
POST.A(F^.INDEKS):=TAL;
POST.A(F^.INDEKS+1):=TAL1
END;
REEL:POST.AAA(F^.INDEKS):=RESULT;
TEKST:FOR I:=1 TO F^.LÆNGDE DO
POST.AA(I+F^.INDEKS-1):=LINE(I)
END
END
END;
(*$P*)
PROCEDURE MAINTAIN;
VAR J:INTEGER;
CH:STRING(1);
BEGIN
CLEARSCREEN;
IF OPTION<>4 THEN
BEGIN
HUSKNIV:=USERNIVEAU;
USERNIVEAU:=UMULIUS;
NULPOST;
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;
GETREC(ZONE.H,REGISTER,POST.A);
IF (IER<>0) AND (IER<>-6) THEN ERROR(ZONE.H.FILENAME);
IF EOF THEN
BEGIN
IF IER=-6 THEN
BEGIN
NEXTREC(ZONE.H,REGISTER,POST.A);
IF (IER<>-1) AND (IER<>-2) AND (IER<>-9) THEN
ERROR(ZONE.H.FILENAME)
END;
REPEAT
SKRIVPOST;
GOTOXY(1,23);
CH:='F';
WRITELN('Rigtig post R, Flere poster F, Stop S');
GOTOXY(39,23);
EDIT(CH);
IF CH='F' THEN
BEGIN
NEXTREC(ZONE.H,REGISTER,POST.A);
IF (IER<>0) AND (IER<>-2) AND (IER<>-9) THEN
ERROR(ZONE.H.FILENAME)
END
UNTIL CH<>'F';
GOTOXY(1,23);WRITELN(' ':77);
IF OPTION=2 THEN CH:='S'
END
ELSE
BEGIN
IF IER=0 THEN
BEGIN
CH:='R';
SKRIVPOST
END
ELSE
BEGIN
CH:='S';
GOTOXY(1,23);WRITELN('Posten findes ikke, RETURN');
GOTOXY(28,23);READLN
END
END
END;
IF (OPTION=4) OR (CH='R') THEN
CASE OPTION OF
1: BEGIN
REPEAT
REPEAT
GOTOXY(1,23);
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 LÆSFELT(PICTURE(J))
UNTIL J=0;
PUTREC(ZONE.H,REGISTER,POST.A);
IF IER<>0 THEN ERROR(ZONE.H.FILENAME)
END;
2: BEGIN WRITELN('Tryk RETURN');READLN END;
3: BEGIN
REPEAT
GOTOXY(1,23);
WRITELN('Antal poster, 0 for resten');
GOTOXY(28,23);
READLN;READ(J)
UNTIL (IORESULT=0) AND (J>=0) AND (J<=ZONE.H.RECINUSE);
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(ZONE.H,REGISTER,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(ZONE.H.FILENAME) ELSE IER:=0
END;
4: BEGIN
NULPOST;
SKRIVPOST;
HUSKNIV:=USERNIVEAU;
USERNIVEAU:=UMULIUS;
FOR J:=1 TO ANTALFELTER DO LÆSFELT(PICTURE(J));
USERNIVEAU:=HUSKNIV;
IF (NOT ZONE.H.FILEINIT) AND (ZONE.H.RECINUSE=0) THEN
BEGIN
GOTOXY(1,23);
WRITELN('ANTAL INITIALISERINGSPOSTER');
GOTOXY(30,23);
READLN;READ(J);
INITIATE(ZONE.H,REGISTER,J);
IF IER<>0 THEN ERROR(ZONE.H.FILENAME)
END;
INSERT(ZONE.H,REGISTER,POST.A);
IF IER<>0 THEN
IF IER=-7 THEN
BEGIN
WRITELN('Posten findes, RETURN');READLN
END
ELSE ERROR(ZONE.H.FILENAME)
END;
5: BEGIN
GOTOXY(1,20);
CH:='J';
WRITELN('Sletning korrekt J/N');
GOTOXY(22,20);EDIT(CH);
IF CH='J' THEN
BEGIN
DELETE(ZONE.H,REGISTER,POST.A);
IF IER=-9 THEN
BEGIN
WRITELN('Eneste post, kan ikke slettes, RETURN');
READLN;
IER:=0
END;
IF IER<>0 THEN ERROR(ZONE.H.FILENAME)
END
END
END
END;
(*$P*)
BEGIN
CLEARSCREEN;
IF REGNAVN='S' THEN
BEGIN
REWRITE(SF,FNAVN);
SEEK(SF,1);
GET(SF);
FOR I:=1 TO 5 DO POST.AAA(I):=SF^.MINUTFAKTOR(I);
POST.A(21):=SF^.DAT1;
POST.A(22):=SF^.DAT2;
LÆSDESC;
REPEAT
SKRIVPOST;
REPEAT
GOTOXY(1,23);
I:=0;
WRITELN('Feltnr, 0 for færdig ',I);
GOTOXY(22,23);READLN;
IF NOT (EOLN OR (INPUT^=' ')) THEN READ(I)
UNTIL (IORESULT=0) AND (I>=0) AND (I<=ANTALFELTER);
IF I>0 THEN LÆSFELT(PICTURE(I))
UNTIL I=0;
SEEK(SF,1);
FOR I:=1 TO 5 DO SF^.MINUTFAKTOR(I):=POST.AAA(I);
SF^.DAT1:=POST.A(21);
SF^.DAT2:=POST.A(22);
PUT(SF);
CLOSE(SF)
END
ELSE
BEGIN
LINES:=100;
ZONE.H.FILENAME:=' ';
FOR I:=1 TO POS(':',FNAVN)-1 DO ZONE.H.FILENAME(I):=FNAVN(I);
REWRITE(REGISTER,FNAVN);
IOPEN(ZONE.H,REGISTER,SKRIV);IF IER<>0 THEN OFEJL(ZONE.H.FILENAME);
(*$XT*) WRITELN('MEMAVAIL ',MEMAVAIL); (*$X-*)
LÆSDESC;
(*$XT*) WRITELN('MEMAVAIL ',MEMAVAIL);READLN; (*$X-*)
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');
REPEAT
GOTOXY(10,19);
WRITELN('Vælg 0-5');
GOTOXY(21,19);UR;
OPTION:=SV
UNTIL (OPTION>=0) AND (OPTION<=6);
IF OPTION>0 THEN
BEGIN
IF (OPTION=6) AND (USERNIVEAU>=HSM) THEN
BEGIN
WRITELN('REPORT, SBUC');READLN;READ(I);
IF I>0 THEN REPORT(ZONE.H,REGISTER,I)
END
ELSE
IF OPTION<6 THEN MAINTAIN
END
UNTIL OPTION=0;
IF LINES<>100 THEN PAGE(LIST);
ICLOSE(ZONE.H,REGISTER);
CLEARSCREEN;
WRITELN('ICLOSE ',IER)
END
END;
(*$P*)
PROCEDURE DOIT;
PROCEDURE PROGVALG;
BEGIN
WRITELN(' ':20,'0 Stop');
WRITELN;
WRITELN(' ':20,'1 Kartoteksvedligeholdelse');
WRITELN;
WRITELN(' ':20,'2 Forkalkulation');
WRITELN;
WRITELN(' ':20,'3 Registrering af arbejdssedler');
WRITELN;
WRITELN(' ':20,'4 Ordreforespørgsel');
WRITELN;
WRITELN(' ':20,'5 Afslutning af ordre');
WRITELN;
WRITELN(' ':20,'6 Lønliste');
WRITELN;
WRITELN(' ':20,'7 Produktforespørgsel');
WRITELN;
WRITELN(' ':20,'8 Indtast ny adgangskode');
IF USERNIVEAU>=GENERAL THEN
BEGIN
WRITELN;
WRITELN(' ':20,'9 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;
CLEARSCREEN
END;
(*$P*)
BEGIN
PROGVALG;
CASE I OF
9: IF USERNIVEAU>=GENERAL THEN
BEGIN
IF USERNIVEAU>=HSM THEN
BEGIN
WRITELN(' ':20,'1 Skærmbilledopbygning');
WRITELN
END;
WRITELN(' ':20,'2 Æ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<3);
CASE I OF
1: IF USERNIVEAU>=HSM THEN F:='SKÆRMBIL:P2';
2: KODEVEDL;
END
END;
8: 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;
1: IF USERNIVEAU>=OBERST THEN
BEGIN
WRITELN(' ':20,'0 Systemregister');
WRITELN;
WRITELN(' ':20,'1 Operationsregister');
WRITELN;
WRITELN(' ':20,'2 Medarbejderregister');
IF USERNIVEAU>=HSM THEN
BEGIN
WRITELN;
WRITELN(' ':20,'3 Ordreregister');
WRITELN;
WRITELN(' ':20,'4 Operationslinieregister');
WRITELN;
WRITELN(' ':20,'5 Registreringslinieregister');
WRITELN;
WRITELN(' ':20,'6 Historisk produktregister')
END;
WRITELN;
GOTOXY(1,20);WRITELN('Vælg register');
REPEAT
GOTOXY(15,20);READLN;READ(I)
UNTIL (IORESULT=0) AND (I>=0) AND (I<7);
CASE I OF
0: BEGIN
FNAVN:='SYSREG:P2:1:I';
DESCNAVN:='SYSRDESC:P2:0000:J';
REGNAVN:='S'
END;
1: BEGIN
FNAVN:='OPERAREG:P2:0000:I';
DESCNAVN:='OPERDESC:P2:0000:J';
REGNAVN:='O P E R A T I O N S -'
END;
2: BEGIN
FNAVN:='MEDARREG:P2:0000:I';
DESCNAVN:='MEDADESC:P2:0000:J';
REGNAVN:='M E D A R B E J D E R -'
END;
3: BEGIN
FNAVN:='ORDREREG:P2:0000:I';
DESCNAVN:='ORDRDESC:P2:0000:J';
REGNAVN:='O R D R E -'
END;
4: BEGIN
FNAVN:='OPLINREG:P2:0000:I';
DESCNAVN:='OPLIDESC:P2:0000:J';
REGNAVN:='OPERATIONSLINIE -'
END;
5: BEGIN
FNAVN:='REGLIREG:P2:0000:I';
DESCNAVN:='REGLDESC:P2:0000:J';
REGNAVN:='REGISTRERINGSLINIE -'
END;
6: BEGIN
FNAVN:='HISTOREG:P2:0000:I';
DESCNAVN:='HISTDESC:P2:0000:J';
REGNAVN:='H I S T O R I E -'
END
END;
IF (I<3) OR (USERNIVEAU>=HSM) THEN
BEGIN
MARK(QUQ);
REGVEDL;
RELEASE(QUQ)
END
END;
0: F:='STOP';
2: IF USERNIVEAU>=OBERST THEN F:='FORKALK:P2';
3: IF USERNIVEAU>=SERGENT THEN F:='TIDSFORB:P2';
4: F:='ORDSPØRG:P2';
5: IF USERNIVEAU>=OBERST THEN F:='ORDAFSLT:P2';
6: IF USERNIVEAU>=SERGENT THEN F:='LØNLISTE:P2';
7: F:='PROSPØRG:P2';
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;
I:=ORD(PARM^(1))-48;
USERNIVEAU:=MENIG;
WHILE I>0 DO
BEGIN
USERNIVEAU:=SUCC(USERNIVEAU);
I:=I-1
END;
REPEAT
F:=' ';
CLEARSCREEN;
DOIT;
UNTIL F<>' ';
IF F<>'STOP' THEN
BEGIN
FNAVN:=' ';
FNAVN(1):=PARM^(1);
CHAIN('L *1',CONCAT('INTRE,',F,',',FNAVN),QUQ);
IF IORESULT<>0 THEN WRITELN('IORESULT ',IORESULT)
END
END.