DataMuseum.dk

top - download

    Length: 12640 (0x3160)
    Types: TextFile
    Notes: Mikados_K
    Names: »LIMPSPØR.K«

└─⟦6c21327e0⟧ Bits:30008986 LINIMATIC K-FILER (IKKE HELT UPTODTATE)
    └─⟦this⟧ »LIMPSPØR.K« 

Mikados K File

PROGRAM LIMPSPØR;
(*PRODUKTFORESPØRGSEL, OPRYDNING I EFTERKALKULATIONER*)
(*$L-*)
CONST MAXRECSIZE=1000;
(*@@*)
      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,REGNAVN,DESCNAVN:STRING(18);
       SEMAFOR:NAME;
       FILEINIT:BOOLEAN;
       SNYD:AR;
       CPPCB:PCB;
       COMREC:POINTREC;
       BESKED:MESSAGE;
(*$P*)
(*$L-*)
PROCEDURE D(FRA,NR:INTEGER);
VAR I:INTEGER;
BEGIN
  GOTOXY(1,FRA);
  FOR I:=1 TO NR DO WRITELN(' ':79);
  GOTOXY(1,FRA)
END;
PROCEDURE NONEXIST(S:STRING);
BEGIN
  D(23,1);
  WRITE(S,' findes ikke, RETURN ');
  READLN;D(23,1) 
END;
PROCEDURE BAD(IDENT,STATUS:INTEGER);
BEGIN
  D(23,1);
  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;
(*$IRESPRINT*)
(*$P*)
(*$IUDFØR*)
(*$IFISFPROC*)
(*$P*)
PROCEDURE REGVEDL;
CONST MAXFELTER=30;
(*@@*)
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*)
(*$P*)
KUNDPOST=RECORD
  AA:ARAR;
  A:AR;
  AAA:RAR;
  NR                 :LONGINT;
  NAVN               :PACKED ARRAY (1..26) OF CHAR;
  KONTAKT1,
  KONTAKT2,
  KONTAKT3,
  KONTAKT4           :PACKED ARRAY (1..30) OF CHAR
END;
EMNEPOST=RECORD
  AA:ARAR;
  A:AR;
  AAA:RAR;
  ÅRSFORBR,
  NETTOVÆG,
  BRUTTOVÆ,
  SAMSALG,
  DÆKBID,
  DÆKBIDSÅ,
  SAMSALGS          :REAL;
  NR,
  FORMNR            :INTEGER;
  KUNDENR           :LONGINT;
  MASKINE           :INTEGER;
  TILDATO           :LONGINT;
  MATNR,
  SVIND,
  SMELTTIL,
  STKHSA,
  STKHBA            :INTEGER;
  BEMÆRK,
  BETEGN,
  ALTERNP           :PACKED ARRAY (1..30) OF CHAR;
  TEGNNR            :PACKED ARRAY (1..20) OF CHAR
END;
EFTEPOST=RECORD
  AA:ARAR;
  A:AR;
  AAA:RAR;
  BESANTAL,
  LEVANTAL,
  MATOMK,
  LØNOMK,
  MASKOMK,
  SALGSPRI,
  PLUSMINU        :REAL;
  EMNENR          :INTEGER;
  DATO            :LONGINT;
  ORDRENR         :INTEGER 
END;
SYSRPOST=RECORD
  AA:ARAR;
  A:AR;
  AAA:RAR;
  AKKTIME          :ARRAY (1..9) OF REAL;
  NR               :INTEGER;
  DAGSDATO,                 
  PERSTDAT         :LONGINT;
  ARBTIMDA,         
  ORDRENR          :INTEGER 
END;
VAR FELT:NFELT;
    PICTURE:ARRAY (1..MAXFELTER) OF NFELT;
    OPTION,LINES,
    I,J,ANTALFELTER:INTEGER;
    LINE:STRING;
    KUNDE:KUNDPOST;
    POST:EMNEPOST;
    EFTE:EFTEPOST;
    SYSTEM:SYSRPOST;
    LONGNUL:LONGINT;
    CH:CHAR;
    NEJ,JA,JAOGNEJ:SET OF CHAR;
(*$P*)
(*$L-*)
FUNCTION QJN(S:STRING):CHAR;
VAR CH:STRING(1);
BEGIN
  REPEAT
    D(23,1);
    WRITE(S,' J/N ');
    CH:='J';
    EDIT(CH)
  UNTIL CH(1) IN JAOGNEJ;
  QJN:=CH(1);
  D(23,1) 
END;
PROCEDURE ERROR(VAR REC:AR);
VAR CH:STRING(1);
    I:INTEGER;
BEGIN
  D(23,1);
                                                                     (*$R-*)
  WRITE('FEJL I REGISTER ',REC(-3),' FEJLKODE ',IER,' RETURN');      (*$R+*)
  CH:=' ';EDIT(CH);
  IF CH='Æ' THEN BEGIN IER:=0;EXIT(ERROR) END;
  ICLOSE(KUNDE.A);
  ICLOSE(POST.A);
  ICLOSE(EFTE.A);
  EXIT(REGVEDL)
END;
PROCEDURE CHECK0(VAR REC:AR);
BEGIN
  IF IER<>0 THEN ERROR(REC)
END;
(*$P*)
(*$L-*)
(*$IRLÆSDESC*)
(*$P*)
(*$IMOVETOLI*)
(*$P*)
(*$L+*)
PROCEDURE MAINTAIN;
VAR CH:CHAR;
    ANTEFTE:INTEGER;
 
PROCEDURE PRODSPØRG;
BEGIN
  WITH EFTE DO
  BEGIN
    LINES:=LINES+2;
    WRITELN(LIST);
    WRITELN(LIST,DATO(1)*10000.0+DATO(2):7:-2,ORDRENR:6,BESANTAL:12:-2,
                 LEVANTAL:12:-2,MATOMK:12:2,LØNOMK:12:2,MASKOMK:12:2,
                 MATOMK+LØNOMK+MASKOMK:12:2,SALGSPRI:12:2,PLUSMINU:12:2)
  END
END;
PROCEDURE SPRODSPØRG;
BEGIN
  WITH EFTE DO
  BEGIN
    WRITELN(DATO(1)*10000.0+DATO(2):7:-2,ORDRENR:6,BESANTAL:10:-2,
                 MATOMK:10:2,MASKOMK:10:2,
                 MATOMK+LØNOMK+MASKOMK:10:2,PLUSMINU:10:2);
    WRITELN(' ':13,LEVANTAL:10:-2,LØNOMK:10:2,SALGSPRI:20:2)
  END
END;
 
PROCEDURE HEADING;
BEGIN
  FOR LINES:=1 TO 2 DO WRITELN(LIST);
  WRITELN(LIST,'PRODUKTFORESPØRGSEL',
               ' ':11,'EMNENR', POST.NR:11,' ':47,' DATO',
               SYSTEM.DAGSDATO(1)*10000.0+SYSTEM.DAGSDATO(2):10:-2);
  WRITELN(LIST,'tegn. nr',' ':22,'benævnelse',' ':26,'kunde',
               ' ':31,'kundenr');
  WRITELN(LIST,POST.TEGNNR,' ':10,POST.BETEGN,' ':6  
              ,KUNDE.NAVN
              ,KUNDE.NR(1)*10000.0+KUNDE.NR(2):17:-2);
  WRITELN(LIST);
  WRITELN(LIST,'   DATO ORDNR    BESANTAL    LEVANTAL      MATOMK',   
       '      LØNOMK     MASKOMK    KOSTPRIS   SALGSPRIS         +/-');
  LINES:=7  
END;
 
PROCEDURE SHEADING;
BEGIN
  CLEARSCREEN;
  WRITELN('EMNE:',POST.NR:5,' ',POST.BETEGN,' KUNDE',
          KUNDE.NR(1)*10000.0+KUNDE.NR(2):6:-2,' ',KUNDE.NAVN:22);
  WRITELN('   DATO ORDNR  BESANTAL    MATOMK',
               '   MASKOMK  KOSTPRIS       +/-');
  WRITELN('               LEVANTAL    LØNOMK',
               '            SALGSPRI')
END;
 
(*$P*)
BEGIN (*MAINTAIN*)
  REPEAT
    CLEARSCREEN;
    GOTOXY(1,20);
    WRITELN('PRODUKTFORESPØRGSEL');
    LÆSFELT(PICTURE(1));
    IF POST.NR>0 THEN
    BEGIN
      SKRIVFELT(PICTURE(1));
      GETREC(POST.A);
      IF IER=-6 THEN
        NONEXIST('Emnet')
      ELSE
      IF IER=0 THEN
      BEGIN
        CH:=QJN('Udskrift på printer');
        KUNDE.NR:=POST.KUNDENR;
        GETREC(KUNDE.A);CHECK0(KUNDE.A);
        EFTE.EMNENR:=POST.NR;
        EFTE.ORDRENR:=0;
        EFTE.DATO:=LONGNUL;
        LINES:=51;
        IF CH IN JA THEN HEADING ELSE SHEADING;
        ANTEFTE:=0;
        NEXTREC(EFTE.A);IF NOT (-IER IN (.1,2,9.)) THEN ERROR(EFTE.A);IER:=0;
        WHILE (IER=0) AND (EFTE.EMNENR=POST.NR) DO
        BEGIN
          ANTEFTE:=ANTEFTE+1;
          IF CH IN JA THEN
            PRODSPØRG
          ELSE
            SPRODSPØRG;
          NEXTREC(EFTE.A)
        END;
        IF NOT (-IER IN (.0,2,9.)) THEN ERROR(EFTE.A);
        IF CH IN NEJ THEN BEGIN GOTOXY(1,24);WRITE('RETURN ');READLN END;
        WHILE LINES<51 DO BEGIN WRITELN(LIST);LINES:=LINES+1 END;
        IF ANTEFTE>10 THEN
        BEGIN
          EFTE.EMNENR:=POST.NR;
          EFTE.ORDRENR:=0;
          EFTE.DATO:=LONGNUL;
          NEXTRECX(EFTE.A);IF NOT (-IER IN (.1,2,9.)) THEN
                           ERROR(EFTE.A);IER:=0;
          WHILE ANTEFTE>10 DO
          BEGIN
            DELETEX(EFTE.A);CHECK0(EFTE.A);ANTEFTE:=ANTEFTE-1
          END;
          GETREC(EFTE.A);CHECK0(EFTE.A)
        END
      END
      ELSE CHECK0(POST.A)
    END
  UNTIL POST.NR=0
END;
(*$P*)
BEGIN (*REGVEDL*)
  LONGNUL(1):=0;
  LONGNUL(2):=0;
  JA:=(.'J','j'.);
  NEJ:=(.'N','n'.);
  JAOGNEJ:=JA+NEJ;
  CLEARSCREEN;
  LÆSDESC;
  MODE:=3;(*SKRIV*)
  (*$R-*)
  KUNDE.A(-4):=0;
  POST.A(-4):=0;    
  SYSTEM.A(-4):=0;
  EFTE.A(-4):=0;
  KUNDE.A(-3):=1;
  POST.A(-3):=2;    
  SYSTEM.A(-3):=9;
  EFTE.A(-3):=17;
  (*$R+*)
  (*@@EVT. ÅBNING AF ANDRE ANDRE DATAFILER*)
  IOPEN(SYSTEM.A); CHECK0(SYSTEM.A); 
  SYSTEM.NR:=0;
  GETREC(SYSTEM.A);CHECK0(SYSTEM.A);
  ICLOSE(SYSTEM.A);
  IOPEN(POST.A);      CHECK0(POST.A);    
  IOPEN(KUNDE.A);     CHECK0(KUNDE.A);   
  IOPEN(EFTE.A);     CHECK0(EFTE.A);   
  MAINTAIN;
  ICLOSE(POST.A);    
  ICLOSE(KUNDE.A);    
  ICLOSE(EFTE.A);
  CLEARSCREEN 
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:='PSPØPESC:P2:05:J';
  IF RESPRINT THEN
  BEGIN
    REGVEDL; 
    FREEPR 
  END;
  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('HOVED   *1',FNAVN,QUQ);
  IF IORESULT<>0 THEN WRITELN('IORESULT ',IORESULT)
END.