DataMuseum.dk

top - download

    Length: 6240 (0x1860)
    Types: TextFile
    Notes: Mikados_K
    Names: »DISPLIST.K«

└─⟦eb89399bc⟧ Bits:30008990 SOM ISFORIG, MEN KUN K-FILER
    └─⟦this⟧ »DISPLIST.K« 

Mikados K File

PROGRAM DISPONERINGSLISTE;
(*$IISFHEAD*)
VPOST=RECORD
       A:AR;
       VARENR1,LVRNDØR,OPRLAND,PAKENHED,
       FORVLEVU,DATSBES1,DATSBES2,DATSORD1,DATSORD2,
       DÆKGRASÅ,ANAFTILG:INTEGER;
       NAVN:ARRAY(1..2) OF PACKED ARRAY (1..30) OF CHAR;
       PRIS,KOSTPRIS,TOLDPNR,FYSLAGER,PRIMOLAG,MINLAGER,RESAFLAG,IORDRE,
       RAIORDRE,STASBEST,ASOLGTIÅ,ASOLGTSÅ,OMSIÅR,OMSSÅR,DÆKBIDTD:REAL
END;
 LEVPOST=RECORD
        A:AR;
        NR,
        SBESDAT1,SBESDAT2,
        LAND1,LAND2:INTEGER;
        KOSTPFAK:ARRAY(1..5) OF INTEGER;
        ÅKØB,SÅKØB,SALDO:REAL;
        NAVN1:PACKED ARRAY (1..40) OF CHAR;
        NAVN2,
        ADR1,
        ADR2:PACKED ARRAY (1..30) OF CHAR;
        BETABET,
        LANDSBY1,LANDSBY2: PACKED ARRAY (1..20) OF CHAR;
        POSTNR1,POSTNR2: PACKED ARRAY (1..25) OF CHAR;
        TLF1,TLF2: PACKED ARRAY (1..10) OF CHAR;
END;
 LEVZONE=RECORD
        H:ISFHEAD;
        T:ARRAY(1..382) OF INTEGER
  END;
ZONE= RECORD
       H:ISFHEAD;
       T:ARRAY(1..451) OF INTEGER
 END;
PROCSTAT=RECORD
       NP,NROSTART:INTEGER
END;
NPFILE=FILE OF PROCSTAT;
VAR    FLEV,F:ISF;
       NRPF,CF:NPFILE;
       VZ:ZONE;
       LZ:LEVZONE;
       LEVER:LEVPOST;
       VARTAB:ARRAY (1..2,1..1000) OF INTEGER;
       FILNAVN2:STRING(20);
      L,M,J,K,IER,I,II:INTEGER;
      MAGI:REAL;
       QUQ:^INTEGER;
       VARE:VPOST;
(*$L-*)
(*$R-,IEXCOMCOP*)
(*$IIOPEN*)
(*$IREADPROC*)
(*$IFINDPOST*)
(*$IICLOSE*)
(*$IPUTGET*)
(*$INEXTREC*)
(*$R+*)
(*$L+*)
PROCEDURE STOP;
VAR I:INTEGER;
BEGIN I:=I DIV 0 END;
PROCEDURE ERROR;
BEGIN
  WRITELN('FEJL I REGISTER ',IER);
  ICLOSE(VZ.H,F);
  ICLOSE(LZ.H,FLEV);
  WRITELN('ICLOSE ',IER);
  STOP
END;
PROCEDURE HEAD;
BEGIN
    WRITELN(LIST,'D I S P O N E R I N G S - L I S T E');
    WRITELN(LIST);
    WRITELN(LIST,' ':10,'Disponible;Sidste køb: antal,dato;Magisk tal;');
    WRITELN(LIST,' ':10,'Solgt i år;I ordre    ;Disponible; Kostpris;');
    WRITELN(LIST);
END;
PROCEDURE DOIT;
BEGIN
  WITH VARE DO
  BEGIN
    VARENR1:=0;
    I:=1;
    NEXTREC(VZ.H,F,A);
    REPEAT
       VARTAB(1,I):=VARENR1;
       VARTAB(2,I):=LVRNDØR;
       I:=I+1;
       NEXTREC(VZ.H,F,A)
    UNTIL IER<>0;
    IF IER<>-2 THEN ERROR;
    I:=I-1;
    FOR J:=1 TO I DO
    BEGIN
      M:=J;
      FOR K:=J+1 TO I DO
      BEGIN
        IF (VARTAB(2,K)<VARTAB(2,M)) OR
          ((VARTAB(2,K)=VARTAB(2,M)) AND (VARTAB(1,K)<VARTAB(1,M))) THEN M:=K
      END;
      IF M>J THEN
      BEGIN
        L:=VARTAB(1,M);VARTAB(1,M):=VARTAB(1,J);VARTAB(1,J):=L;
        L:=VARTAB(2,M);VARTAB(2,M):=VARTAB(2,J);VARTAB(2,J):=L
      END
    END;
    II:=I;
    REPEAT
    CLEARSCREEN;
    I:=II;
    GOTOXY(1,1);
    WRITELN('Leverandørnr, 0 for alle, -1 for STOP');
    REPEAT
       GOTOXY(39,1);READLN;READ(K)
    UNTIL (IORESULT=0);
    IF K>=0 THEN
    BEGIN
    IF K=0 THEN
      J:=1
    ELSE
    BEGIN
      J:=0;
      M:=1;
      WHILE M<=I DO
      BEGIN
        IF J=0 THEN BEGIN IF VARTAB(2,M)=K THEN J:=M END
        ELSE IF VARTAB(2,M)<>K THEN I:=M-1;
        M:=M+1
      END
    END;
    HEAD;
    VARTAB(2,I+1):=VARTAB(2,I)+1;
    IF J>0 THEN
    WITH LEVER DO
    REPEAT
      NR:=VARTAB(2,J);
      GETREC(LZ.H,FLEV,LEVER.A);
      WRITE(LIST,NR:8);
      IF IER<>0 THEN
        IF IER<>-6 THEN ERROR ELSE
        BEGIN
        WRITELN(LIST,'  FINDES IKKE');
        WRITELN(LIST);
        WHILE NR=VARTAB(2,J) DO J:=J+1;
        END
      ELSE
      BEGIN
        WRITELN(LIST,'  ',NAVN1);
        WRITELN(LIST,' ':10,ADR1,' ':10,LANDSBY1);
        WRITELN(LIST,' ':10,POSTNR1);
        WRITELN(LIST);
        WRITELN(LIST,' ':10,KOSTPFAK(1):10,KOSTPFAK(2):10,KOSTPFAK(3):10,
                            KOSTPFAK(4):10,KOSTPFAK(5):10);
        WRITELN(LIST);
        WHILE NR=VARTAB(2,J) DO
        BEGIN
          VARENR1:=VARTAB(1,J);
          GETREC(VZ.H,F,VARE.A);
          IF (PRIMOLAG+FYSLAGER)*OMSIÅR<>0 THEN MAGI:=ASOLGTIÅ*200*DÆKBIDTD/
                                ((PRIMOLAG+FYSLAGER)*OMSIÅR) ELSE MAGI:=0;
          WRITELN(LIST,' ':10,VARENR1:4,' ':5,NAVN(2));
          WRITELN(LIST,' ':10,FYSLAGER-RESAFLAG:10:-2,STASBEST:10:-2,
                              DATSBES1*10000.0+DATSBES2:10:-2,MAGI:12:-2);
          WRITELN(LIST,' ':10,ASOLGTIÅ:10:-2,
                              IORDRE:10:-2,IORDRE-RAIORDRE:10:-2,
                              KOSTPRIS/100:12:2);
          WRITELN(LIST);
          J:=J+1
        END;
        WRITELN(LIST);
      END;
    UNTIL J>I;
    END
    UNTIL K<0
  END;
END;
BEGIN
  FILNAVN2:='PROCSTAT:P2:0:I';
(*$C-*)
  REPEAT
    REWRITE(NRPF,FILNAVN2);
    SEEK(NRPF,1)
  UNTIL IORESULT=0;
(*$C+*)
  GET(NRPF);
  NRPF^.NP:=1;
  SEEK(NRPF,1);
  PUT(NRPF);
  REPEAT
    GOTOXY(1,20);
    WRITELN('Sæt plade 1 i drev 1 og tryk RETURN');
    READLN;
(*$C-*)
    REWRITE(CF,'C1:P1:0:J');
    SEEK(CF,1)
(*$C+*)
  UNTIL IORESULT=0;
  CLOSE(CF);
  CLOSE(NRPF);
  FILNAVN2:='REGVARE:P1:1137:I';
  RESET(F,FILNAVN2);
  IOPEN(VZ.H,F,LÆS);
 
  FILNAVN2:='LEVERRG:P2:0000:I';
  RESET(FLEV,FILNAVN2);
  IOPEN(LZ.H,FLEV,LÆS);
  IF IER<>0 THEN ERROR;
 
  DOIT;
  ICLOSE(VZ.H,F);
  ICLOSE(LZ.H,FLEV);
  CHAIN('INTRE   *1','HOVSA:P1',QUQ)
END.