DataMuseum.dk

top - download

    Length: 15168 (0x3b40)
    Types: TextFile
    Notes: Mikados_K
    Names: »LIMLØNLI.K«

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

Mikados K File

PROGRAM LIMLØNLI;
(*UDSKRIVNING AF LØNLISTE, SLETNING AF OMVENDT REGISTRERINGSLINIE*)
(*$L-*)
CONST MAXRECSIZE=1000;
(*@@*)
      PROGRAMNR=6;
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: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 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;
(*@@*)
TYPE
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*)
(*$L+*)
MEDAPOST=RECORD
  AA:ARAR;
  A:AR;
  AAA:RAR;
  TIMESATS,
  PERSTIME,
  TOTTIMLØ,
  PRODTIME,
  AKKORDLØ,
  AKKORDAR          :REAL;
  NR,
  AFDELING          :INTEGER;
  NAVN              :PACKED ARRAY (1..30) OF CHAR
END;
REGLPOST=RECORD
  AA:ARAR;
  A:AR;
  AAA:RAR;
  TID,
  MÆNGDE,
  LØN              :REAL;
  ORDRENR,
  EMNENR,
  OPERANR,
  MEDARBNR         :INTEGER;
  DATO             :LONGINT;
  RTYPE            :INTEGER
END;
OMVRPOST=RECORD
  AA:ARAR;
  A:AR;
  AAA:RAR;
  MEDARBNR,
  ORDRENR,
  EMNENR,
  OPERANR          :INTEGER;
  DATO             :LONGINT 
END;
SYSRPOST=RECORD
  AA:ARAR;
  A:AR;
  AAA:RAR;
  AKKTIME          :ARRAY (1..9) OF REAL;
  NR               :INTEGER;
  DAGSDATO,                 
  PERSTDAT         :LONGINT;
  ARBTIMDA,         
  ORDRENR          :INTEGER 
END;
(*$P*)
VAR HUSKNIV:NIVEAU;
    OPTION,LINES,
    I,J:INTEGER;
    LINE:STRING;
    MEDARB:MEDAPOST;
    POST:REGLPOST;
    OMVRREGL:OMVRPOST;
    SYSTEM:SYSRPOST;
    LONGNUL:LONGINT;
    CH:STRING(1);
    NEJ,JA,JAOGNEJ:SET OF CHAR;
(*$P*)
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 FORMULAR(I:INTEGER);
VAR LINES:INTEGER;
BEGIN
  CASE I OF
  1:BEGIN
      D(23,1);
      WRITE('Monter bredt 8.5" papir, RETURN ');
      READLN;
      WHILE QJN('Ønskes testprint') IN JA DO
      BEGIN
  WRITELN(LIST,'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX',
               'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX');
        FOR LINES:=2 TO 50 DO WRITELN(LIST);
  WRITELN(LIST,'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX',
               'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX')
      END 
    END;
  2:BEGIN
      D(23,1);
      WRITE('Monter generel formular, RETURN ');
      READLN;
      WHILE QJN('Ønskes testprint') IN JA DO
      BEGIN
        FOR LINES:=1 TO 4 DO WRITELN(LIST);
        WRITELN(LIST,' ':35,'XXXXXX');
        FOR LINES:=6 TO 72 DO WRITELN(LIST)
      END 
    END;
  3:BEGIN
      D(23,1);
      WRITE('Monter blankt A4 papir, RETURN ');
      READLN;
      WHILE QJN('Ønskes testprint') IN JA DO
      BEGIN
  WRITELN(LIST,'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX',
               'XXXXXXXXXXXXXXXXXXXXXXXX');
        FOR LINES:=2 TO 71 DO WRITELN(LIST);
  WRITELN(LIST,'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX',
               'XXXXXXXXXXXXXXXXXXXXXXXX')
      END 
    END
  END
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(MEDARB.A);  
  ICLOSE(POST.A); 
  ICLOSE(SYSTEM.A);
  ICLOSE(OMVRREGL.A);
  EXIT(REGVEDL)
END;
PROCEDURE CHECK0(VAR REC:AR);
BEGIN
  IF IER<>0 THEN ERROR(REC)
END;
(*$P*)
PROCEDURE MAINTAIN;
VAR LINES:INTEGER;
    TIDSUM,LØNSUM:REAL;
    AFREGN:BOOLEAN;
BEGIN
  CLEARSCREEN;
  AFREGN:=QJN('Ønskes afregning') IN JA;
  FORMULAR(3);
  WITH OMVRREGL DO
  BEGIN
    LINES:=72;
    MEDARB.NR:=0;
    MEDARBNR:=1;
    ORDRENR:=0;
    EMNENR:=0;
    OPERANR:=0;
    DATO:=LONGNUL;
    NEXTRECX(A);IF NOT (-IER IN (.1,2,9.)) THEN ERROR(A);
    IER:=0;
    WHILE (IER=0) AND (OMVRREGL.MEDARBNR>0) DO
    WITH POST DO
    BEGIN
      ORDRENR:=OMVRREGL.ORDRENR;
      EMNENR:=OMVRREGL.EMNENR;
      OPERANR:=OMVRREGL.OPERANR;
      MEDARBNR:=OMVRREGL.MEDARBNR;
      DATO:=OMVRREGL.DATO;
      IF DATO(1)<100 THEN
      BEGIN
        GETREC(A);CHECK0(A);
        IF (LINES>68) OR (MEDARB.NR<>MEDARBNR) THEN
        BEGIN
          IF MEDARB.NR<>MEDARBNR THEN
          BEGIN
            IF MEDARB.NR<>0 THEN
            BEGIN
              WRITELN(LIST,'TOTAL',' ':38,LØNSUM:11:2,TIDSUM:11:2);
              IF NOT AFREGN THEN
              BEGIN
                WRITELN(LIST,'****** I K K E   A F R E G N E T  ******');
                LINES:=LINES+1
              END;
              WRITELN(LIST);
              LINES:=LINES+2 
            END;
            TIDSUM:=0.0;
            LØNSUM:=0.0;
            MEDARB.NR:=MEDARBNR;
            GETREC(MEDARB.A);CHECK0(MEDARB.A) 
          END;
          WHILE LINES<72 DO
          BEGIN
            WRITELN(LIST);
            LINES:=LINES+1
          END;
          WRITELN(LIST);
          WRITELN(LIST,'LØNLISTE',' ':37,'UDSKRIFTSDATO',
                       SYSTEM.DAGSDATO(1)*10000.0+SYSTEM.DAGSDATO(2):7:-2);
          WRITELN(LIST);
          LINES:=3;
          WRITELN(LIST,'MEDARBEJDER');
          WRITELN(LIST,MEDARBNR:5,' ':10,MEDARB.NAVN);
          WRITELN(LIST,'ORDRE  EMNE  OPNR     DATO   MÆNGDE   PRSTK        ',
                       'LØN        TID');
          LINES:=LINES+3
        END;
        WRITE(LIST,ORDRENR:5,EMNENR:6,OPERANR:6,
                   (DATO(1) MOD 100)*10000.0+DATO(2):9:-2,MÆNGDE:9:-2);
        IF (ABS(RTYPE)=3) AND (MÆNGDE>0.0) THEN
          WRITE(LIST,(LØN-TID*MEDARB.PERSTIME)/MÆNGDE:8:2)
        ELSE
          WRITE(LIST,' ':8);
        WRITELN(LIST,LØN:11:2,TID:11:2);
        TIDSUM:=TIDSUM+TID;
        LØNSUM:=LØNSUM+LØN;
        LINES:=LINES+1
      END;
      IF AFREGN THEN
        DELETEX(OMVRREGL.A)
      ELSE
        NEXTRECX(OMVRREGL.A)
    END;
    IF NOT (-IER IN (.0,2,9.)) THEN ERROR(A);
    IF LINES<72 THEN  
    BEGIN
      WRITELN(LIST,'TOTAL',' ':38,LØNSUM:11:2,TIDSUM:11:2);
      IF NOT AFREGN THEN
      BEGIN
        WRITELN(LIST,'****** I K K E   A F R E G N E T  ******');
        LINES:=LINES+1
      END;
      LINES:=LINES+1
    END;
    WHILE LINES<72 DO BEGIN WRITELN(LIST);LINES:=LINES+1 END 
  END
END;
(*$P*)
BEGIN (*REGVEDL*)
  LONGNUL(1):=0;
  LONGNUL(2):=0;
  JA:=(.'J','j'.);
  NEJ:=(.'N','n'.);
  JAOGNEJ:=JA+NEJ;
  CLEARSCREEN;
  MODE:=3;(*SKRIV*)
  (*$R-*)
  MEDARB.A(-4):=0;  
  POST.A(-4):=0; 
  SYSTEM.A(-4):=0;
  OMVRREGL.A(-4):=0;         
  MEDARB.A(-3):=7;  
  POST.A(-3):=16;(*REGL*)
  SYSTEM.A(-3):=9;
  OMVRREGL.A(-3):=23;  
  (*$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(MEDARB.A); CHECK0(MEDARB.A); 
  IOPEN(POST.A); CHECK0(POST.A); 
  IOPEN(OMVRREGL.A); CHECK0(OMVRREGL.A); 
  MAINTAIN;
  ICLOSE(MEDARB.A);
  ICLOSE(POST.A);
  ICLOSE(OMVRREGL.A);
  (*@@EVT. LUKNING AF ANDRE DATAFILER*)
  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*)
  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.