⟦dd8d4b39d⟧

Mikados K File

PROGRAM AFSLPROD;
(*SLETTER PRODUKTIONSORDRELINIER OG DESSINOPERATIONSLINIER, MEN MARKERER KUN
PRODUKTIONSORDREPOSTEN MED SLUTDATO*)
(*TILPASSES TIL SPECIELLE REGISTERVEDLIGEHOLDELSER, UDEN HÆGTER, DER BRUGER
INDLÆSNINGSPROCEDURERNE, MEN IKKE ALM. REGVEDL*)
CONST MAXRECSIZE=10;
(*@@*)
      PROGRAMNR=8;
TYPE
PARMARRAY=PACKED ARRAY (1..39) OF CHAR;
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;
       USERNIVEAU:NIVEAU;
       F:STRING(18);
       QUQ:^INTEGER;
       IER,IREC,STATUSER,MODE,REMUSERS,
       FILNR,I:INTEGER;
       FNAVN,DESCNAVN:STRING(18);
       SEMAFOR:NAME;
       FILEINIT:BOOLEAN;
       SNYD:AR;
       CPPCB:PCB;
       COMREC:POINTREC;
       BESKED:MESSAGE;
(*$P*)
(*$L-*)
PROCEDURE BAD(IDENT,STATUS:INTEGER);
BEGIN
  GOTOXY(1,23);
  WRITE('BAD',IDENT:5,STATUS:5);
  READLN
END;
(*$P*)
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*)
(*$L+*)
PROCEDURE REGVEDL;
CONST MAXFELTER=30;
      MAXNØGLER=9;
(*@@*)
      MAXPOST=10;
      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;
LONGINT = ARRAY (1..2) OF INTEGER;
(*@@EVT. TOTAL POSTERKLÆRING,FLERE POSTER*)
DOPE=RECORD
      AA:ARAR;A:AR;AAA:RAR;
      TOTTID:REAL;
      ONR:LONGINT;
      OPNR:INTEGER;
END;
PRODORDRE=RECORD
      AA:ARAR;A:AR;AAA:RAR;
      ONR,
      STDATO,
      SLDATO:LONGINT;
END;
PROROLIN=RECORD
      AA:ARAR;A:AR;AAA:RAR;
      ANTAL:REAL;
      ONR:LONGINT;
      DNR,
      FNR: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:PRODORDRE;
    POST1:PROROLIN;
    POST2:DOPE;
    HÆGTEREC:ARRAY (1..MAXHÆGTER) OF HPOST;
    CH:STRING(1);
(*$P*)
PROCEDURE ERROR(VAR REC:AR);
VAR CH:STRING(1);
    I:INTEGER;
BEGIN
  IF LINES>0 THEN PAGE(LIST);                                          (*$R-*)
  WRITELN('FEJL I REGISTER ',REC(-3),' FEJLKODE ',IER,' RETURN');      (*$R+*)
  CH:=' ';EDIT(CH);
  ICLOSE(POST.A);
  ICLOSE(POST1.A);
  ICLOSE(POST2.A);
(*@@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*)
(*$L-*)
(*$IHLÆSDESC*)
(*$P*)
(*$IMOVETOLI*)
(*$P*)
(*$L+*)
PROCEDURE MAINTAIN;
VAR J,NØGLENR,HNR,HINDEKS:INTEGER;
    CH:STRING(1);
BEGIN (*MAINTAIN*)
  NULPOST;
  LÆSFELT(PICTURE(1));SKRIVFELT(PICTURE(1));
  GETRECX(POST.A);
  IF NOT (-IER IN (.0,6.)) THEN ERROR(POST.A);
  IF IER=0 THEN
  BEGIN
    SKRIVPOST;
    REPEAT
      GOTOXY(1,23);
      IF POST.STDATO(1)=0 THEN CH:='J' ELSE CH:='N';
      WRITE('Rigtig post J/N ');
      EDIT(CH) 
    UNTIL CH(1) IN (.'J','N','j','n'.);
    IF CH(1) IN (.'N','n'.) THEN 
    BEGIN
      GETREC(POST.A);          (*FOR AT FJERNE XCLUSIV-STATUS*)
      IF IER<>0 THEN ERROR(POST.A)
    END
    ELSE
    BEGIN
      LÆSFELT(PICTURE(3));SKRIVFELT(PICTURE(3));
      POST1.ONR:=POST.ONR;
      POST1.DNR:=0;
      POST1.FNR:=0;
      NEXTRECX(POST1.A);
      IF NOT (-IER IN (.1,2,9.)) THEN ERROR(POST1.A);
      IER:=0;
      WHILE (IER=0) AND (POST1.ONR=POST.ONR) DO DELETEX(POST1.A); 
      IF NOT (-IER IN (.0..2,9.)) THEN ERROR(POST1.A);
      GETREC(POST1.A);          (*FOR AT FJERNE XCLUSIV-STATUS*)
      IF IER<>0 THEN ERROR(POST1.A);
      POST2.ONR:=POST.ONR;
      POST2.OPNR:=0;
      NEXTRECX(POST2.A);
      IF NOT (-IER IN (.1,2,9.)) THEN ERROR(POST2.A);
      IER:=0;
      WHILE (IER=0) AND (POST2.ONR=POST.ONR) DO DELETEX(POST2.A); 
      IF NOT (-IER IN (.0..2,9.)) THEN ERROR(POST2.A);
      GETREC(POST2.A);          (*FOR AT FJERNE XCLUSIV-STATUS*)
      IF IER<>0 THEN ERROR(POST2.A);
      PUTREC(POST.A);
      IF IER<>0 THEN ERROR(POST.A) 
    END
  END 
  ELSE
  BEGIN
    GOTOXY(1,23);
    WRITE('Posten eksisterer ikke, RETURN ');READLN
  END
END;
(*$P*)
BEGIN (*REGVEDL*)
  CLEARSCREEN;
(*$XT*) WRITELN('MEMAVAIL ',MEMAVAIL); (*$X-*)
  LÆSDESC;
(*$XT*) WRITELN('MEMAVAIL ',MEMAVAIL);READLN; (*$X-*)
  MODE:=3;(*SKRIV*)
  LINES:=100;                                                    (*$R-*)
  POST.A(-3):=10;
  IOPEN(POST.A);IF IER<>0 THEN OFEJL(POST.A);
  POST1.A(-3):=11;
  IOPEN(POST1.A);IF IER<>0 THEN OFEJL(POST1.A);
  POST2.A(-3):=12;
  IOPEN(POST2.A);IF IER<>0 THEN OFEJL(POST2.A);                    (*$R+*)
(*@@EVT. ÅBNING AF ANDRE DATAFILER*)
  REPEAT
    CLEARSCREEN;
    GOTOXY(10,10);
    WRITELN('Afslutning af produktionsordrer');
    GOTOXY(10,12);
    WRITE('Flere ordrer J/N ');
    CH:='J';
    EDIT(CH);
    IF CH(1) IN (.'J','j'.) THEN MAINTAIN 
  UNTIL CH(1) IN (.'N','n'.);
  IF LINES<>100 THEN PAGE(LIST);
  ICLOSE(POST.A);
  ICLOSE(POST1.A);
  ICLOSE(POST2.A);
(*@@EVT. LUKNING AF ANDRE DATAFILER*)
  CLEARSCREEN;
  IF IER<>0 THEN BAD(6,IER)
END;
(*$P*)
BEGIN
  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*)
  DESCNAVN:='AFSLPROD:P2:05:J';
  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.
DataMuseum.dk

MIKADOS

⟦dd8d4b39d⟧ TextFile

Derivation

Mikados K File

Full view
