DataMuseum.dk

top - download

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

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

Mikados K File

PROGRAM SKRIVJOURNAL;
(*$IISFHEAD*)
 KPOST=RECORD
        A:AR;
        NR:ARRAY (1..23) OF INTEGER;
 (*KNR1,KNR2,ANDBETADR,KÆDENR1,KÆDENR2,RESTORDRE,LAND,BETAKODE,LEVKODE,
   RENTKODE,KREDDAGE,ANTFAKT,SIDFAKD1,SIDFAKD2,EMBALLAGE,BRÆKAGE,RABAT,
   EXPORT,RFSALDO,PERTRENT,NPOSTNR1,NPOSTNR2*)
     (* NAVN,UDVNAVN,LEVADR*)NAVN:ARRAY(1..3) OF PACKED ARRAY (1..30) OF CHAR;
        LANDSBY:PACKED ARRAY (1..20) OF CHAR;
        POSTNR:PACKED ARRAY (1..25) OF CHAR;
        TLF:PACKED ARRAY (1..10) OF CHAR;
        SALDOKØB :ARRAY (1..9) OF REAL;
 (*SALDO1-6,ÅRKØB,MÅNKØB,SIDÅRKØB*)
  END;
JOURPOST=RECORD
       (*KNR1,KNR2,
         FAKTNR1-2*) NR:ARRAY(1..6) OF INTEGER;
       (*IALTMEDMOMS,
         MOMS,
         RABAT,
         BRÆKAGEFORS,
         FRAGT,
         EMBALLAGE,
         VARESALG   *) REEL:ARRAY(1..7) OF REAL
END;
JOURFILE=FILE OF JOURPOST;
SYSPOST=RECORD
HELTAL:ARRAY(1..24) OF INTEGER;
KGB:ARRAY (1..5) OF REAL;
BETADAT:PACKED ARRAY (1..13) OF CHAR;
KODE:ARRAY (1..2) OF PACKED ARRAY (1..10) OF CHAR
END;
SYSFILE=FILE OF SYSPOST;
POSTPOST=RECORD
       A:AR;
      (*KNR1-2,DATO1-2,TEKSTKODE,BILAGSNR1-2*) HELTAL:ARRAY(1..7) OF INTEGER;
      (*BELØB,RESTBELØB*) REEL:ARRAY (1..2) OF REAL
END;
POSTZONE=RECORD
       H:ISFHEAD;
       T:ARRAY (1..508) OF INTEGER
END;
 KZONE=RECORD
        H:ISFHEAD;
        T:ARRAY(1..918) OF INTEGER
  END;
 VAR    FPOST,FKUN : ISF;
        JOURFIL:JOURFILE;
        SYSFIL:SYSFILE;
        KZ:KZONE;
        PZ:POSTZONE;
        PPOST:POSTPOST;
        KUNDE:KPOST;
        FNAVN:STRING(20);
        IER,I,J,K
                        :INTEGER;
        QUQ:^INTEGER;
        RABAT1,BRÆK1,FRAGT1,EMBAL1,VARESAL1,KRENOTA1,KRENOTA,KREMOMS,
        R,R1,R2,MOMS,RABAT,BRÆK,FRAGT,EMBAL,VARESALG:REAL;
(*$L-*)
 (*$R-,IEXCOMCOP*)
 (*$IIOPEN*)
 (*$ISÆTØG*)
 (*$IREADPROC*)
 (*$IFINDPOST*)
 (*$IFORSKYD*)
 (*$IICLOSE*)
 (*$IPUTGET*)
 (*$IINSERT*)
 (*$INEXTREC*)
 (*$R+*)
(*$L+*)
 PROCEDURE ERROR;
 BEGIN
   WRITELN('FEJL I REGISTER ',IER);
   ICLOSE(KZ.H,FKUN);
   ICLOSE(PZ.H,FPOST);
   WRITELN('ICLOSE ',IER);
   I:=I DIV 0
 END;
PROCEDURE OFEJL;
BEGIN
  GOTOXY(1,20);
  WRITELN('REGISTERFEJL ',IER,' . 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;
  CLEARSCREEN
END;
PROCEDURE NEDTÆLÆLDSTE;
BEGIN
  WITH KUNDE,PPOST DO
  BEGIN
    HELTAL(1):=KUNDE.NR(1);
    HELTAL(2):=KUNDE.NR(2);
    FOR I:=3 TO 7 DO HELTAL(I):=0;
    NEXTREC(PZ.H,FPOST,A);
    IF (IER<>-1) AND (IER<>-2) THEN ERROR;IER:=0;
    WHILE (HELTAL(1)=NR(1)) AND (HELTAL(2)=NR(2)) AND (R1<0.0) DO
    BEGIN
      IF ((HELTAL(5)=1) OR (HELTAL(5)=4) OR (HELTAL(5)=9)) AND (REEL(2)>0.0)
      THEN
      BEGIN
        REEL(2):=REEL(2)+R1;
        IF REEL(2)<=0.0 THEN
        BEGIN
          R1:=REEL(2);
          REEL(2):=0;
          IF HELTAL(5)=1 THEN
          BEGIN
            NR(12):=NR(12)+1;
            NR(11):=NR(11)+TRUNC(
                  JOURFIL^.NR(5)*360.0+JOURFIL^.NR(6) DIV 100*30.0
                  +JOURFIL^.NR(6) MOD 100 -
                  HELTAL(3)*360.0-HELTAL(4) DIV 100*30.0-HELTAL(4) MOD 100);
          END
        END
        ELSE R1:=0.0;
        PUTREC(PZ.H,FPOST,A)
      END
      ELSE IF HELTAL(5)=10 THEN
      BEGIN
        REEL(2):=REEL(2)+JOURFIL^.REEL(1);
        IF REEL(2)<0 THEN REEL(2):=0
      END;
      NEXTREC(PZ.H,FPOST,A)
    END
  END
END;
PROCEDURE PRUT;
BEGIN
 WRITELN(LIST,'TOTAL',' ':49,R/100:12:2);
  WRITELN(LIST);
  WRITELN(LIST);
  WRITELN(LIST,' ':20,'MOMSPLIGTIGT',' ':10,'IKKE MOMSPLIGTIGT');
  WRITELN(LIST,'VARESALG',' ':12,VARESALG/100:12:2,' ':10,VARESAL1/100:12:2);
  WRITELN(LIST,'EMBALLAGE',' ':11,EMBAL/100:12:2,' ':10,EMBAL1/100:12:2);
  WRITELN(LIST,'BRÆKAGEFORS',' ':9,BRÆK/100:12:2,' ':10,BRÆK1/100:12:2);
END;
PROCEDURE DOIT;
BEGIN
  FOR K:=2 TO SYSFIL^.HELTAL(13)-1 DO
  BEGIN
    GET(JOURFIL);
    WITH JOURFIL^ DO
    BEGIN
    KUNDE.NR(1):=NR(1);
    KUNDE.NR(2):=NR(2);
    GETREC(KZ.H,FKUN,KUNDE.A);
    IF IER<>0 THEN ERROR;
    WITH KUNDE DO
    BEGIN
      R1:=REEL(1);
      IF REEL(1)>0 THEN
      BEGIN
      NR(13):=SYSFIL^.HELTAL(1);
      NR(14):=SYSFIL^.HELTAL(2);
      SALDOKØB(1):=SALDOKØB(1)+REEL(1);
      SALDOKØB(7):=SALDOKØB(7)+REEL(7)-REEL(3);
      SALDOKØB(8):=SALDOKØB(8)+REEL(7)-REEL(3)
      END
      ELSE
      BEGIN
        SALDOKØB(6):=SALDOKØB(6)+REEL(1);
        I:=5;
        WHILE (SALDOKØB(I+1)<0.0) AND (I>0) DO
        BEGIN
          SALDOKØB(I):=SALDOKØB(I)+SALDOKØB(I+1);
          SALDOKØB(I+1):=0.0;
          I:=I-1
        END;
        NEDTÆLÆLDSTE
      END
    END;
    PUTREC(KZ.H,FKUN,KUNDE.A);
    IF IER<>0 THEN ERROR;
    WITH PPOST DO
    BEGIN
      HELTAL(1):=NR(1);
      HELTAL(2):=NR(2);
      HELTAL(3):=NR(5);
      HELTAL(4):=NR(6);
      IF JOURFIL^.REEL(1)<0 THEN HELTAL(5):=2 ELSE
      HELTAL(5):=1;(*FAKTURA*)
      HELTAL(6):=NR(3);
      HELTAL(7):=NR(4);
      REEL(1):=JOURFIL^.REEL(1);
      REEL(2):=R1;
      INSERT(PZ.H,FPOST,A);
      IF IER<>0 THEN ERROR
    END;
    R:=R+REEL(1);
    IF REEL(2)<>0 THEN
    BEGIN
    IF REEL(2)<0 THEN KREMOMS:=KREMOMS+REEL(2) ELSE
    MOMS:=MOMS+REEL(2);
    RABAT:=RABAT+REEL(3);
    BRÆK:=BRÆK+REEL(4);
    FRAGT:=FRAGT+REEL(5);
    EMBAL:=EMBAL+REEL(6);
    IF REEL(7)<0 THEN KRENOTA:=KRENOTA+REEL(7) ELSE
    VARESALG:=VARESALG+REEL(7);
    END
    ELSE
    BEGIN
       RABAT1:=RABAT1+REEL(3);
       BRÆK1:=BRÆK1+REEL(4);
       FRAGT1:=FRAGT1+REEL(5);
       EMBAL1:=EMBAL1+REEL(6);
       IF REEL(7)<0 THEN KRENOTA1:=KRENOTA1+REEL(7) ELSE
       VARESAL1:=VARESAL1+REEL(7);
    END;
    WRITE(LIST,NR(1)*10000.0+NR(2):7:-2,KUNDE.NAVN(1):35,
                 NR(3)*10000.0+NR(4):10:-2,REEL(1)/100:14:2);
    IF REEL(1)<0 THEN WRITELN(LIST,'  ***') ELSE WRITELN(LIST);
    END;
  END;
 PRUT;
END;
BEGIN
 
 
  FNAVN:='KUNDERG:P2:0000:I';
  REWRITE(FKUN,FNAVN);
  IOPEN(KZ.H,FKUN,SKRIV);IF IER<>0 THEN OFEJL;
 
  FNAVN:='POSTREG:P2:0000:I';
  REWRITE(FPOST,FNAVN);
  IOPEN(PZ.H,FPOST,SKRIV);
  IF IER<>0 THEN OFEJL;
  FNAVN:='SYSREG:P2:1:I';
  REWRITE(SYSFIL,FNAVN);
  SEEK(SYSFIL,1);
  GET(SYSFIL);
  FNAVN:='JOURNAL:P2:30:I';
  REWRITE(JOURFIL,FNAVN);
 
  IF (SYSFIL^.HELTAL(13)-2>PZ.H.NREC-PZ.H.RECINUSE) THEN
     WRITELN('Der er ikke plads til flere posteringer')
  ELSE
  BEGIN
    SEEK(JOURFIL,2);
  R:=0;
  MOMS:=0;RABAT:=0;BRÆK:=0;FRAGT:=0;EMBAL:=0;VARESALG:=0;
  RABAT1:=0;BRÆK1:=0;FRAGT1:=0;EMBAL1:=0;VARESAL1:=0;
  KREMOMS:=0;KRENOTA:=0;KRENOTA1:=0;
   WRITELN(LIST,'FAKTURERINGS-JOURNAL',' ':20,SYSFIL^.HELTAL(1)*10000.0+
                 SYSFIL^.HELTAL(2):8:-2,'    Side ',SYSFIL^.HELTAL(18):4);
   SYSFIL^.HELTAL(18):=SYSFIL^.HELTAL(18)+1;
  WRITELN(LIST);
  DOIT;
  WRITELN(LIST,'FRAGT',' ':15,FRAGT/100:12:2,' ':10,FRAGT1/100:12:2);
  WRITELN(LIST,'MOMS',' ':16,MOMS/100:12:2);
  WRITELN(LIST,'KREDITNOTA-MOMS',' ':5,KREMOMS/100:12:2);
  WRITELN(LIST,'RABAT',' ':13,'- ',RABAT/100:12:2,'-':10,RABAT1/100:12:2);
 WRITELN(LIST,'KREDITNOTA',' ':10,KRENOTA/100:12:2,' ':10,KRENOTA1/100:12:2);
  R1:=VARESALG+EMBAL+FRAGT+BRÆK+MOMS-RABAT+KRENOTA+KREMOMS;
  R2:=VARESAL1+EMBAL1+FRAGT1+BRÆK1-RABAT1+KRENOTA1;
  WRITELN(LIST,'TOTAL',' ':15,R1/100:12:2,' ':10,R2/100:12:2,
                              (R1+R2)/100:12:2);
  WRITELN(LIST,'DIFFERENCE',' ':44,(R1+R2-R)/100:12:2);
  ICLOSE(KZ.H,FKUN);
  ICLOSE(PZ.H,FPOST);
  SYSFIL^.HELTAL(13):=2;
  SEEK(SYSFIL,1);
  PUT(SYSFIL);
  SEEK(JOURFIL,1);
  GET(JOURFIL);
  WITH JOURFIL^ DO
  BEGIN
    FOR I:=1 TO 4 DO NR(I):=0;
    REEL(1):=REEL(1)+R;
    REEL(2):=REEL(2)+MOMS+KREMOMS;
    REEL(3):=REEL(3)+RABAT+RABAT1;
    REEL(4):=REEL(4)+BRÆK+BRÆK1;
    REEL(5):=REEL(5)+FRAGT+FRAGT1;
    REEL(6):=REEL(6)+EMBAL+EMBAL1;
    REEL(7):=REEL(7)+VARESALG+VARESAL1+KRENOTA+KRENOTA1;
  END;
  SEEK(JOURFIL,1);
  PUT(JOURFIL);
  END;
  CLOSE(JOURFIL);
  CLOSE(SYSFIL);
  CHAIN('INTRE   *1','HOVSA:P1',QUQ)
END.