DataMuseum.dk

top - download

    Length: 10112 (0x2780)
    Types: TextFile
    Notes: Mikados_K
    Names: »PROFILET.K«

└─⟦a3d38fea3⟧ Bits:30008985 PRODUKTION NBT.
    └─⟦this⟧ »PROFILET.K« 

Mikados K File

PROGRAM PROFILETIKETTER;
TYPE
PARMARRAY=PACKED ARRAY (1..39) OF CHAR;
VAR    PARM:^PARMARRAY;
       QUQ:^INTEGER;
       CH:STRING(1);
       FNAVN:STRING(18);
(*$P*)
PROCEDURE REGVEDL;
CONST MSYSZ=243;
      MBESLAGZ=273;
      MFARVEZ=245;
      MOPSPLIZ=385;
      LMARG=1;
(*$IISFHEAD*)
SYSZONE=RECORD
        H:ISFHEAD;
        T:ARRAY(1..MSYSZ) OF INTEGER;
END;
BESLAGZONE=RECORD
           H:ISFHEAD;
           T:ARRAY(1..MBESLAGZ) OF INTEGER;
END;
OPSPLITZONE=RECORD
            H:ISFHEAD;
            T:ARRAY(1..MOPSPLIZ) OF INTEGER;
END;
FARVEZONE=RECORD
         H:ISFHEAD;
         T:ARRAY(1..MFARVEZ) OF INTEGER
END;
ARAR=PACKED ARRAY(-11..-10) OF CHAR;
RAR=ARRAY(0..0) OF REAL;
AR13=ARRAY(1..3) OF INTEGER;
AR14=ARRAY(1..4) OF INTEGER;
AR15=ARRAY(1..5) OF INTEGER;
AR19=ARRAY(1..9) OF INTEGER;
DOBBINT=ARRAY(1..2) OF INTEGER;
TEK=PACKED ARRAY(1..30) OF CHAR;
SYSPOST=RECORD
          AA:ARAR;
          A:AR;
          AAA:RAR;
          NR,
          ORDRENR,
          SDAT1,SDAT2:INTEGER
END;
FARVEPOST=RECORD
         AA:ARAR;
         A:AR;
         AAA:RAR;
         NR,
         KODE:INTEGER;
         TEKST:TEK;
END;
BESLAGPOST=RECORD
           AA:ARAR;
           A:AR;
           AAA:RAR;
           NR:INTEGER;
           VARENR:ARRAY(1..5) OF DOBBINT;
           ANTAL:AR15;
           TEKST:TEK;
END;
OPSPLITPOST=RECORD
            AA:ARAR;
            A:AR;
            AAA:RAR;
            ORDRENR,
            TYP,
            POSITION,
            RAMMENR,
            PLACER,
            ANTAL,
            TYPE1,TYPE2,
            FARVE,
            FTYPE1,FTYPE2,
            FLÆNGDE,
            SLÆNGDE,
            BESLAGNR,
            HÆNGSEL,
            GUMMI11,GUMMI12,
            GUMMI21,GUMMI22,
            STATUS:INTEGER;
END;
VAR OPSF,SYSF,FARF,BESF:ISF;
    SYSZ:SYSZONE;
    OPSZ:OPSPLITZONE;
    FARZ:FARVEZONE;
    BESZ:BESLAGZONE;
    SYSTEM:SYSPOST;
    OPSPLIT:OPSPLITPOST;
    COLOUR:FARVEPOST;
    BESLAG:BESLAGPOST;
    AKTPOS,POSANT,IER,LASTETIK,TANTAL:INTEGER;
    HS:PACKED ARRAY (0..2) OF CHAR;
    HEADING:PACKED ARRAY (1..22) OF CHAR;
    RÆKKE:ARRAY (1..6) OF PACKED ARRAY (1..113) OF CHAR;
(*$P*)
(*$L-*)
(*$R-,IFORWARD*)
(*$IIOPEN*)
(*$IICLOSE*)
(*$R+*)
(*$L+*)
SEGMENT PROCEDURE ERROR(VAR FIL:FILNAVN);
BEGIN
  WRITELN('FEJL I REGISTER ',FIL,' FEJLKODE ',IER);
  ICLOSE(OPSZ.H,OPSF);
  ICLOSE(SYSZ.H,SYSF);
  EXIT(REGVEDL)
END;
SEGMENT PROCEDURE OFEJL(VAR FIL:FILNAVN);
VAR I:INTEGER;
BEGIN
  GOTOXY(1,20);
  WRITELN('REGISTERFEJL ',IER,' I ',FIL,' . SITUATIONEN ER FORSØGT REDDET.');
  WRITELN('TAST 0, HVIS DER SKAL FORTSÆTTES');
  REPEAT GOTOXY(40,21);READLN;READ(I) UNTIL IORESULT=0;
  IF I<>0 THEN ERROR(FIL);
  CLEARSCREEN
END;
(*$P*)
PROCEDURE INIT;
BEGIN
  CLEARSCREEN;
  OPSZ.H.FILENAME:='OPSPLIT ';
  FNAVN:='OPSPLIT:P2:0000:I';
  REWRITE(OPSF,FNAVN);
  IOPEN(OPSZ.H,OPSF,SKRIV);IF IER<>0 THEN OFEJL(OPSZ.H.FILENAME);
  SYSZ.H.FILENAME:='SYSREG  ';
  FNAVN:='SYSREG:P2:0000:I';
  REWRITE(SYSF,FNAVN);
  IOPEN(SYSZ.H,SYSF,SKRIV);IF IER<>0 THEN OFEJL(SYSZ.H.FILENAME);
  FARZ.H.FILENAME:='FARVE   ';
  FNAVN:='FARVE:P2:0000:I';
  REWRITE(FARF,FNAVN);
  IOPEN(FARZ.H,FARF,LÆS);IF IER<>0 THEN OFEJL(FARZ.H.FILENAME);
  BESZ.H.FILENAME:='BESLAGPK';
  FNAVN:='BESLAGPK:P2:0000:I';
  REWRITE(BESF,FNAVN);
  IOPEN(BESZ.H,BESF,LÆS);IF IER<>0 THEN OFEJL(BESZ.H.FILENAME)
END;
(*$L-*)
(*$R-*)
(*$IEXCOMCOP*)
(*$IREADPROC*)
(*$IFINDPOST*)
(*$IPUTGET*)
(*$INEXTREC*)
(*$R+*)
(*$L+*)
(*$P*)
PROCEDURE D23;
BEGIN
  GOTOXY(1,23);WRITELN(' ':79);GOTOXY(1,23)
END;
(*$P*)
PROCEDURE SKRIVRÆKKE;
VAR I:INTEGER;
BEGIN
  IF LASTETIK>0 THEN
  BEGIN
    WRITELN(LIST);
    FOR I:=1 TO 6 DO
    BEGIN
      WRITELN(LIST,' ':LMARG,RÆKKE(I));
      RÆKKE(I):=RÆKKE(2)
    END;
    WRITELN(LIST);
    WRITELN(LIST);
    LASTETIK:=0;
    FOR I:=0 TO 4 DO
    BEGIN
      RÆKKE(3,I*23+9):='/';
      RÆKKE(3,I*23+13):='/'
    END
  END
END;
 
PROCEDURE CHECKETIKET;
VAR I:INTEGER;
BEGIN
  D23;
  WRITE('Monter profiletiketter, RETURN ');READLN;
  FOR I:=1 TO 6 DO
    FILLCHAR(RÆKKE(I),113,' ');
  REPEAT
    FOR I:=1 TO 6 DO
    IF I<>2 THEN FILLCHAR(RÆKKE(I),20,'-');
    LASTETIK:=1;
    SKRIVRÆKKE;
    D23;CH:='J';
    WRITE('Flere testprint J/N ');EDIT(CH)
  UNTIL CH='N'
END;
(*$P*)
PROCEDURE ETIKET;
VAR AKTETIK:INTEGER;
 
PROCEDURE PUTFELT(LINIE,POS,TAL1,TAL2:INTEGER);
VAR CIF:INTEGER;
BEGIN
  POS:=(AKTETIK-1)*23+POS;
  CIF:=0;
  REPEAT
    RÆKKE(LINIE,POS):=CHR(TAL2 MOD 10+48);
    POS:=POS-1;
    TAL2:=TAL2 DIV 10;
    CIF:=CIF+1
  UNTIL TAL2=0;
  IF TAL1>0 THEN
  BEGIN
    WHILE CIF<4 DO
    BEGIN
      RÆKKE(LINIE,POS):='0';
      POS:=POS-1;
      CIF:=CIF+1
    END;
    REPEAT
      RÆKKE(LINIE,POS):=CHR(TAL1 MOD 10+48);
      POS:=POS-1;
      TAL1:=TAL1 DIV 10;
      CIF:=CIF+1
    UNTIL TAL1=0
  END
END;
(*$P*)
BEGIN
  WITH OPSPLIT DO
  BEGIN
    IF PLACER>4 THEN AKTETIK:=5 ELSE AKTETIK:=PLACER;
    IF LASTETIK>=AKTETIK THEN SKRIVRÆKKE;
    LASTETIK:=AKTETIK;
    IF RAMMENR=0 THEN
      IF PLACER<5 THEN MOVELEFT(HEADING(1),RÆKKE(1,(AKTETIK-1)*23+1),4)
      ELSE MOVELEFT(HEADING(1),RÆKKE(1,(AKTETIK-1)*23+1),8)
    ELSE
      IF PLACER<5 THEN MOVELEFT(HEADING(9),RÆKKE(1,(AKTETIK-1)*23+1),5)
      ELSE MOVELEFT(HEADING(14),RÆKKE(1,(AKTETIK-1)*23+1),9);
    PUTFELT(3,4,0,ORDRENR);
    PUTFELT(3,8,0,POSITION);
    PUTFELT(3,12,0,TANTAL);
    PUTFELT(3,15,0,RAMMENR);
    RÆKKE(3,(AKTETIK-1)*23+18):=HS(HÆNGSEL);
    PUTFELT(4,5,TYPE1,TYPE2);
    IF PLACER<20 THEN PUTFELT(4,12,FTYPE1,FTYPE2);
    COLOUR.NR:=FARVE;
    GETREC(FARZ.H,FARF,COLOUR.A);
    IF (IER<>0) AND (IER<>-6) THEN ERROR(FARZ.H.FILENAME);
    IF IER=0 THEN MOVELEFT(COLOUR.TEKST,RÆKKE(6,(AKTETIK-1)*23+17),4);
    PUTFELT(5,12,0,FLÆNGDE);
    PUTFELT(5,5,0,SLÆNGDE);
    IF BESLAGNR>0 THEN
    BEGIN
      BESLAG.NR:=BESLAGNR;
      GETREC(BESZ.H,BESF,BESLAG.A);
      IF (IER<>0) AND (IER<>-6) THEN ERROR(BESZ.H.FILENAME);
      IF IER=0 THEN MOVELEFT(BESLAG.TEKST(1),RÆKKE(6,(AKTETIK-1)*23+1),15)
    END;
    IF (GUMMI11<>0) OR (GUMMI12<>0) THEN PUTFELT(4,19,GUMMI11,GUMMI12);
    IF (GUMMI21<>0) OR (GUMMI22<>0) THEN PUTFELT(5,19,GUMMI21,GUMMI22)
  END
END;
(*$P*)
BEGIN
  INIT;
  HS:=' HV';
  HEADING:='KARMPOSTRAMMEGLASLISTE';
  SYSTEM.NR:=2;
  GETREC(SYSZ.H,SYSF,SYSTEM.A);
  IF IER<>0 THEN ERROR(SYSZ.H.FILENAME);
  SYSTEM.SDAT2:=SYSTEM.SDAT2+1;
  PUTREC(SYSZ.H,SYSF,SYSTEM.A);
  IF IER<>0 THEN ERROR(SYSZ.H.FILENAME);
  CHECKETIKET;
  OPSPLIT.ORDRENR:=SYSTEM.ORDRENR;
  OPSPLIT.TYP:=0;
  OPSPLIT.POSITION:=0;
  OPSPLIT.RAMMENR:=0;
  OPSPLIT.PLACER:=0;
  NEXTREC(OPSZ.H,OPSF,OPSPLIT.A);
  IF -IER IN (.1,2,9.) THEN IER:=0 ELSE ERROR(OPSZ.H.FILENAME);
  WHILE (IER=0) AND (OPSPLIT.ORDRENR=SYSTEM.ORDRENR) AND (OPSPLIT.TYP=1) DO
  BEGIN
    AKTPOS:=OPSPLIT.POSITION;
    POSANT:=OPSPLIT.ANTAL;
    TANTAL:=1;
    REPEAT
      ETIKET;
      IF (SYSTEM.SDAT1=3) AND (TANTAL=1) THEN
      BEGIN
        OPSPLIT.STATUS:=3;
        PUTREC(OPSZ.H,OPSF,OPSPLIT.A);
        IF IER<>0 THEN ERROR(OPSZ.H.FILENAME)
      END;
      NEXTREC(OPSZ.H,OPSF,OPSPLIT.A);
      IF (IER=-2) OR (OPSPLIT.POSITION<>AKTPOS) OR (OPSPLIT.TYP<>1) OR
                     (OPSPLIT.ORDRENR<>SYSTEM.ORDRENR) THEN
      BEGIN
        IF TANTAL<POSANT THEN
        BEGIN
          OPSPLIT.ORDRENR:=SYSTEM.ORDRENR;
          OPSPLIT.TYP:=1;
          OPSPLIT.POSITION:=AKTPOS;
          OPSPLIT.RAMMENR:=0;
          OPSPLIT.PLACER:=0;
          SKRIVRÆKKE;
          NEXTREC(OPSZ.H,OPSF,OPSPLIT.A);
          IF IER<>-1 THEN ERROR(OPSZ.H.FILENAME) ELSE IER:=0
        END;
        TANTAL:=TANTAL+1
      END
    UNTIL TANTAL>POSANT;
    SKRIVRÆKKE
  END;
  ICLOSE(OPSZ.H,OPSF);
  ICLOSE(SYSZ.H,SYSF);
  WRITELN('ICLOSE ',IER)
END;
(*$P*)
BEGIN
  REGVEDL;
  FNAVN:=' ';
  FNAVN(1):=PARM^(1);
  CHAIN('L       *1',CONCAT('INTRE,GLASETIK:P2,',FNAVN),QUQ);
  IF IORESULT<>0 THEN WRITELN('IORESULT ',IORESULT)
END.