|
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: 25568 (0x63e0)
Types: TextFile
Notes: Mikados_K
Names: »OVERFØRE.K«
└─⟦fbcea1992⟧ Bits:30009008 blank (Pascal program "OVERFØRE")
└─⟦this⟧ »OVERFØRE.K«
PROGRAM OVERFØRE;
(*OVERFØRSEL AF DATA MELLEM 2 FILER VED TILFØJELSE AF FELTER*)
(*UDVIDELSE AF FILEN ELLER ANDET OVERFØRSLEN FOREGÅR VED AT*)
(*INDLÆSE DE TO DESCRIPTION FILER OG ANGIVE FILNUMRENE SAMT*)
(*INDTASTE SAMMENHÆNGENE MELLEM DE ENKELTE FELTNUMRE*)
CONST LNGTH=20;
TIMER=120;
MAXRECSIZE=1000;
(*@@*)
PROGRAMNR=3;
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 BAD(IDENT,STATUS:INTEGER);
BEGIN
GOTOXY(1,23);
WRITE('BAD',IDENT:5,STATUS:5);
READLN
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;
(*$P*)
(*$IUDFØR*)
(*$IFISFPROC*)
(*$P*)
PROCEDURE REGVEDL;
CONST MAXFELTER=30;
MAXNØGLER=9;
(*@@*)MAXFIL=3;
MAXPOST=500;
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;
(*@@*)
TEK4=PACKED ARRAY (1..4) OF CHAR;
TEK30=PACKED ARRAY (1..30) OF CHAR;
ARAR=PACKED ARRAY (-11..-10) OF CHAR;
RAR=ARRAY (0..0) OF REAL;
(*@@EVT. TOTAL POSTERKLÆRING,FLERE POSTER*)
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..MAXFIL) OF ARRAY (1..MAXFELTER) OF NFELT;
NØGLER:ARRAY (1..MAXFIL) OF ARRAY (1..MAXNØGLER) OF NFELT;
HÆGTER:ARRAY (1..MAXFIL) OF ARRAY (1..MAXHÆGTER) OF NFELT;
IDENT:ARRAY (1..MAXFIL) OF ARRAY (1..MAXIDENT) OF NFELT;
ANTALIDENT,ANTALFELTER,ANTALNØGLER,ANTALHÆGTER:ARRAY (1..MAXFIL) OF
INTEGER;
LINES,OPTION,I,J:INTEGER;
CH:STRING(1);
LINE:STRING;
POST:ARRAY (1..MAXFIL) OF PPOST;
HÆGTEREC:ARRAY (1..MAXFIL) OF ARRAY (1..MAXHÆGTER) OF HPOST;
(*@@*)
FRAFIL,TILFIL:INTEGER;
OK,STOP:BOOLEAN;
FRAFELT:ARRAY (1..MAXFELTER) OF INTEGER;
(*$P*)
PROCEDURE ERROR(VAR REC:AR);
VAR CH:STRING(1);
J,I:INTEGER;
BEGIN
IF LINES>0 THEN PAGE(LIST); (*$R-*)
WRITELN('FEJL I REGISTER ',REC(-3),' FEJLKODE ',IER,' RETURN'); (*$R+*)
CH:=' ';EDIT(CH);
FOR J:=2 TO MAXFIL DO
BEGIN
ICLOSE(POST(J).A);
END;
(*@@LUK EVT. ANDRE DATAFILER*)
EXIT(REGVEDL)
END;
PROCEDURE OFEJL(VAR REC:AR);
VAR I:INTEGER;
BEGIN
GOTOXY(1,20); (*$R-*)
WRITELN('REGISTERFEJL ',IER,' I ',REC(-3),
' . SITUATIONEN ER FORSØGT REDDET.'); (*$R+*)
WRITELN('TAST 0, HVIS DER SKAL FORTSÆTTES');
REPEAT GOTOXY(40,21);READLN;READ(I) UNTIL IORESULT=0;
IF I<>0 THEN ERROR(REC);
CLEARSCREEN
END;
(*$P*)
PROCEDURE LÆSDESC(NR9:INTEGER);
TYPE
FELTFIL=FILE OF FELTBESKRIVELSE;
VAR
FFIL:FELTFIL;
I:INTEGER;
BEGIN
RESET(FFIL,DESCNAVN);
I:=IORESULT;
IF I<>0 THEN BAD(7,I);
GET(FFIL);
I:=0;
ANTALNØGLER(NR9):=0;
ANTALHÆGTER(NR9):=0;
ANTALIDENT(NR9):=0;
WHILE FFIL^.INDPOS.X>0 DO
BEGIN
I:=I+1;
CASE FFIL^.FELTTYPE OF
REEL:NEW(PICTURE(NR9,I),FELTDESC,REEL);
HELTAL,DOBBTAL,TEKST:NEW(PICTURE(NR9,I),FELTDESC,HELTAL)
END;
FELT:=PICTURE(NR9,I);
WITH PICTURE(NR9,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(NR9):=ANTALNØGLER(NR9)+1;
NØGLER(NR9,ANTALNØGLER(NR9)):=PICTURE(NR9,I)
END;
LEDETEKST:=FFIL^.LEDETEKST;
FØLGETEKST:=FFIL^.FØLGETEKST;
EDITERING:=FFIL^.EDITERING;
FELTTYPE:=FFIL^.FELTTYPE;
INDEKS:=FFIL^.INDEKS;
LÆNGDE:=FFIL^.LÆNGDE;
HÆGTE:=FFIL^.HÆGTE;
IF HÆGTE>0 THEN
BEGIN
ANTALHÆGTER(NR9):=ANTALHÆGTER(NR9)+1;
HÆGTER(NR9,ANTALHÆGTER(NR9)):=PICTURE(NR9,I); (*$R-*)
HÆGTEREC(NR9,ANTALHÆGTER(NR9)).A(-3):=HÆGTE (*$R+*)
END
ELSE
IF HÆGTE<0 THEN
BEGIN
ANTALIDENT(NR9):=ANTALIDENT(NR9)+1;
IDENT(NR9,ANTALIDENT(NR9)):=PICTURE(NR9,I)
END;
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(NR9):=I
END;
(*$P*)
PROCEDURE MOVETOLINE(VAR F:NFELT;NR9:INTEGER);
VAR CH:STRING(1);
TAL,DECS,I:INTEGER;
RESULT,DM,DD:REAL;
BEGIN
CH:=' ';
CASE F^.FELTTYPE OF
HELTAL:BEGIN
LINE:=''; (*$R-*)
TAL:=ABS(POST(NR9).A(F^.INDEKS)); (*$R+*)
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); (*$R-*)
IF POST(NR9).A(F^.INDEKS)<0 THEN LINE:=CONCAT('-',LINE) (*$R+*)
END;
DOBBTAL:BEGIN
LINE:=''; (*$R-*)
RESULT:=ABS(POST(NR9).A(F^.INDEKS)*10000.0
+POST(NR9).A(F^.INDEKS+1));
(*$R+*)
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);
(*$R-*)
IF POST(NR9).A(F^.INDEKS)*10000.0+POST(NR9).A(F^.INDEKS+1)<0.0
THEN
LINE:=CONCAT('-',LINE) (*$R+*)
END;
TEKST:BEGIN
LINE:='';
FOR I:=F^.INDEKS TO F^.INDEKS+F^.LÆNGDE-1 DO
BEGIN (*$R-*)
CH(1):=POST(NR9).AA(I); (*$R+*)
LINE:=CONCAT(LINE,CH)
END
END;
REEL:BEGIN (*$R-*)
RESULT:=ABS(POST(NR9).AAA(F^.INDEKS)); (*$R+*)
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; (*$R-*)
IF POST(NR9).AAA(F^.INDEKS)<0.0 THEN LINE:=CONCAT('-',LINE)
(*$R+*)
END
END
END;
(*$P*)
PROCEDURE NULPOST(NR9:INTEGER);
VAR I,J:INTEGER;
BEGIN
FOR J:=1 TO ANTALFELTER(NR9) DO WITH PICTURE(NR9,J)^ DO
BEGIN
CASE FELTTYPE OF (*$R-*)
HELTAL:POST(NR9).A(INDEKS):=0;
DOBBTAL:BEGIN
POST(NR9).A(INDEKS):=0;
POST(NR9).A(INDEKS+1):=0
END;
REEL:POST(NR9).AAA(INDEKS):=0.0;
TEKST:FOR I:=INDEKS TO LÆNGDE+INDEKS-1 DO
POST(NR9).AA(I):=' '; (*$R+*)
END
END
END;
(*$P*)
PROCEDURE LÆSFELT(VAR F:NFELT;NR9:INTEGER);
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);
WRITE(' ':LENGTH(F^.LEDETEKST)+LENGTH(F^.FØLGETEKST)+F^.LÆNGDE+2);
GOTOXY(F^.INDPOS.X,F^.INDPOS.Y);
WRITE(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,NR9);
EDIT(LINE:F^.LÆNGDE); (*$R-*)
WHILE LINE(LENGTH(LINE))=' ' DO LINE(0):=CHR(ORD(LINE(0))-1) (*$R+*)
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 (*$R-*)
HELTAL:POST(NR9).A(F^.INDEKS):=TAL;
DOBBTAL:BEGIN
POST(NR9).A(F^.INDEKS):=TAL;
POST(NR9).A(F^.INDEKS+1):=TAL1
END;
REEL:POST(NR9).AAA(F^.INDEKS):=RESULT;
TEKST:FOR I:=1 TO F^.LÆNGDE DO
POST(NR9).AA(I+F^.INDEKS-1):=LINE(I) (*$R+*)
END
END
END;
(*$P*)
PROCEDURE SÆTKEY(NR,NR1,NR2,NR3:INTEGER);
VAR HINDEKS:INTEGER;
BEGIN
CASE PICTURE(NR2,NR)^.FELTTYPE OF
(*$R-*)
HELTAL:POST(NR3).A(PICTURE(NR3,NR1)^.INDEKS):=
POST(NR2).A(PICTURE(NR2,NR)^.INDEKS);
DOBBTAL:BEGIN
POST(NR3).A(PICTURE(NR3,NR1)^.INDEKS):=
POST(NR2).A(PICTURE(NR2,NR)^.INDEKS);
POST(NR3).A(PICTURE(NR3,NR1)^.INDEKS+1):=
POST(NR2).A(PICTURE(NR2,NR)^.INDEKS+1);
END;
TEKST:FOR HINDEKS:=1 TO PICTURE(NR2,NR)^.LÆNGDE DO
POST(NR3).AA(PICTURE(NR3,NR1)^.INDEKS-1+HINDEKS):=
POST(NR2).AA(PICTURE(NR2,NR)^.INDEKS-1+HINDEKS);
REEL:POST(NR3).AAA(PICTURE(NR3,NR1)^.INDEKS):=
POST(NR2).AAA(PICTURE(NR2,NR)^.INDEKS);
(*$R+*)
END
END;
(*$P*)
PROCEDURE INT(TYP,NR,FELT:INTEGER;VAR HJÆLP:INTEGER);
BEGIN
(*$R-*)
CASE TYP OF
1:HJÆLP:=POST(NR).A(PICTURE(NR,FELT)^.INDEKS);
2:POST(NR).A(PICTURE(NR,FELT)^.INDEKS):=HJÆLP;
END;
(*$R+*)
END;
(*$P*)
PROCEDURE SKRIVHOVED;
BEGIN
CLEARSCREEN;
GOTOXY(10,1);
WRITELN('F I L T R A N S ');
END;
(*$P*)
PROCEDURE ÅBEN(NR9,FILNR:INTEGER);
BEGIN
(*$XT*) WRITELN('MEMAVAIL ',MEMAVAIL); (*$X-*)
LÆSDESC(NR9);
(*$XT*) WRITELN('MEMAVAIL ',MEMAVAIL);READLN; (*$X-*)
MODE:=3;(*SKRIV*)
LINES:=100; (*$R-*)
POST(NR9).A(-3):=FILNR; (*$R+*)
IOPEN(POST(NR9).A);IF IER<>0 THEN OFEJL(POST(NR9).A);
END;
PROCEDURE LUK(NR9:INTEGER);
BEGIN
ICLOSE(POST(NR9).A);
END;
BEGIN (*REGVEDL*)
CLEARSCREEN;
SKRIVHOVED;
DESCNAVN:='OVERFØRE:P2:05:J';
LÆSDESC(1);
NULPOST(1);
LÆSFELT(PICTURE(1,1),1);
LÆSFELT(PICTURE(1,2),1);
MOVETOLINE(PICTURE(1,1),1);
DESCNAVN:=LINE;INT(1,1,2,FRAFIL);
ÅBEN(2,FRAFIL);
LÆSFELT(PICTURE(1,3),1);
LÆSFELT(PICTURE(1,4),1);
MOVETOLINE(PICTURE(1,3),1);
DESCNAVN:=LINE;INT(1,1,4,TILFIL);
ÅBEN(3,TILFIL);
(*@@EVT. ÅBNING AF ANDRE ANDRE DATAFILER*)
FOR I:=1 TO ANTALFELTER(3) DO
BEGIN
REPEAT
OK:=TRUE;
GOTOXY(1,22);
WRITELN('Nu behandles feltnr : ',I:3);
LÆSFELT(PICTURE(1,5),1);
INT(1,1,5,FRAFELT(I));
IF (FRAFELT(I)>0) AND (FRAFELT(I)<=MAXFELTER) THEN
IF PICTURE(2,FRAFELT(I))^.FELTTYPE<>PICTURE(3,I)^.FELTTYPE THEN
OK:=FALSE;
UNTIL OK;
END;
GOTOXY(1,23);
CH:='J';
WRITELN('Ønskes overførsel (J/N)',' ':50);
GOTOXY(31,23);EDIT(CH);
IF (CH='J') OR (CH='j') THEN
BEGIN
NULPOST(2);
STOP:=FALSE;
WHILE NOT(STOP) DO
BEGIN
NEXTREC(POST(2).A);
IF NOT(-IER IN(.0..2,9.)) THEN ERROR(POST(2).A);
IF IER=-9 THEN STOP:=TRUE;
IF IER=-2 THEN
STOP:=TRUE
ELSE
BEGIN
NULPOST(3);
FOR I:=1 TO ANTALFELTER(3) DO
BEGIN
IF FRAFELT(I)<>0 THEN SÆTKEY(FRAFELT(I),I,2,3)
END;
IF NOT FILEINIT THEN
BEGIN
FILEINIT:=TRUE;
REPEAT
GOTOXY(1,23);
WRITELN('ANTAL INITIALISERINGSPOSTER');
GOTOXY(30,23);
READLN;READ(IREC);
UNTIL (IORESULT=0) AND (IREC>0);
INITIATE(POST(3).A);
IF IER<>0 THEN ERROR(POST(3).A);
END;
INSERT(POST(3).A);
IF IER<>0 THEN ERROR(POST(3).A);
END
END
END;
LUK(2);
LUK(3);
(*@@ LUKNING AF EVENTUELLE ANDRE FILER*)
SKRIVHOVED;
IF IER<>0 THEN BAD(6,IER);
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);
(*@@TILPASSES*)
REGVEDL;
UDFØR(PAFMELD,SNYD);
UDFØRT(PAFMELD,SNYD);
IF IER<>0 THEN BAD(2,IER);
FNAVN:=' ';
FOR I:=1 TO 7 DO FNAVN(I):=PARM^(I);
CHAIN('L *1',CONCAT('HOVED:P1,',FNAVN),QUQ);
IF IORESULT<>0 THEN WRITELN('IORESULT ',IORESULT)
END.