DataMuseum.dk

top - download

    Length: 9670 (0x25c6)
    Types: SPC/1-COMAL-BIN
    Notes: Mikados_B
    Names: »DEBLIST.B«

└─⟦385f097a1⟧ Bits:30008988 SPC/1 COMAL programmer til bogføring
    └─⟦this⟧ »DEBLIST.B« 
└─⟦ff7f7aeee⟧ Bits:30009007 NBT	15/3-84
    └─⟦this⟧ »DEBLIST.B« 

SPC/1 COMAL-BIN

0090 REM DEBLIST
0100 DIM K1$(17),N$(6),K2$(17),K3$(17),DEBNAVN$(25),DSALDO1$(12),DEBKGR$(2)
0110 DIM DSALDO2$(12),DSALDO3$(12),DSALDO4$(12),DEBLK$(2),DEBGADE$(25)
0120 DIM BLANK$(77),A$(1),TAL4$(14),TAH$(12),T1(9),DEBTLF$(9),DEBBY$(20)
0130 DIM RES$(14),ÅRKØB$(12),MDNKØB$(12),DSALDI$(12),LK$(3),KG$(3),KTN$(6)
0140 DIM PNR$(6),TY$(1),OP1$(12),OP2$(12),TA$(12),TB$(14),TÅRKØB$(12),DV$(10)
0150 DIM SUM$(12),SUM1$(12),SUM2$(12),SUM3$(12),SUM4$(12),SUM5$(12),SUM6$(12)
0160 DIM TAL1$(14),TAL2$(14),TAL3$(14),KS$(5),DAT$(8),STREG$(78),K4$(17)
0170 DIM K5$(17),LAND$(9,12)
0175 TALLET=0
0180 PROC CALC(ART,B1,B2,ES)
0190 OP1$=B1$
0200 OP2$=B2$
0210 RES$=ES$
0220 SI=0
0230 FLAG=0
0240 CALL "P641210:REGN"
0250 ES$=RES$
0260 IF FLAG THEN STOP
0270 ENDPROC
0280 PROC FEJL(NR1,NR2,NR3)
0290 IF STATUS(NR3$)<>0 THEN
0300 PRINT STATUS(NR3$),NR1,NR2,NR3$
0310 STOP
0320 ENDIF
0330 ENDPROC
0340 PROC INDTAB(T,MANTAL,L10)
0350 J=MANTAL DIV 32+1
0360 FOR I=J TO MANTAL DIV 4+J-1
0370 H=(I-J)*4+1;H1=H+1;H2=H+2;H3=H+3
0380 GET L10$,I:T(H,1),T(H,2),T(H1,1),T(H1,2),T(H2,1),T(H2,2),T(H3,1),T(H3,2)
0390 EXEC FEJL(1,1,L10$)
0400 NEXT I
0410 ENDPROC
0420 PROC HENTDPOST
0430 S=DTAB(DPIL3,2)
0440 GET K3$,S:DEBNR,DEBNAVN$,DSALDO1$,DEBKGR$
0450 EXEC FEJL(8,2,K3$)
0460 GET K3$,S+1:DSALDO2$,DSALDO3$,DSALDO4$,DPOSTNR,DEBLK$
0470 EXEC FEJL(8,3,K3$)
0480 GET K3$,S+2:DEBGADE$,DEBTLF$,HPOST,HKUNDE
0490 EXEC FEJL(8,4,K3$)
0500 GET K3$,S+3:DEBBY$,ÅRKØB$,MDNKØB$
0510 EXEC FEJL(8,5,K3$)
0520 ENDPROC
0530 PROC TUD(BLB,UBLB,TEGN,STØR)
0540 EXEC CALC(5,BLB$,TAH$,UBLB$)
0550 IF TEGN=0 THEN
0560 UBLB$=UBLB$(1:13)
0570 ELSE
0580 IF TEGN=1 AND UBLB$(LEN(UBLB$))="+" THEN
0590 UBLB$(LEN(UBLB$))=" "
0600 ENDIF
0610 ENDIF
0620 IF STØR=1 THEN UBLB$=UBLB$(4:LEN(UBLB$)-3)
0630 ENDPROC
0640 PROC HOVED(GR)
0650 LINIE=LINIE+1
0660 IF LINIE MOD (13*(1+2*(TYPE=2)))=1 THEN
0670 IF LINIE<>1 THEN PRINT CHR(10);CHR(10)
0680 IF LINIE<>1 AND TYPE=2 THEN PRINT " "
0690 SIDENR=SIDENR+1
0700 PRINT TAB(64);DV$;" "
0710 PRINT CHR(14);"    Debitor"+KS$+"liste";CHR(15);TAB(25);
0720 IF GR>0 THEN
0730 PRINT USING "Gruppe:###":GR;
0740 ENDIF
0750 PRINT TAB(37);"Dato: ";DAT$;
0760 PRINT USING " Side:###":SIDENR
0770 PRINT " "
0780 IF TYPE=2 THEN
0790 PRINT " KONTO  NAVN";TAB(37);"POSTNR  BY";TAB(67);"TLF"
0800 PRINT STREG$
0810 ELSE
0820 PRINT " KONTO   TLF";TAB(28);"SALDO IALT";TAB(44);"0-30 DAGE";
0830 PRINT TAB(56);"60-90 DAGE MÅNEDENS KØB"
0840 PRINT " NAVN";TAB(43);"30-60 DAGE    ÆLDRE      ÅRETS KØB"
0850 PRINT STREG$
0860 ENDIF
0870 ENDIF
0880 ENDPROC
0890 PROC BUND
0900 FOR LINIE=LINIE+1 TO 13*(1+2*(TYPE=2))*SIDENR
0910 IF TYPE=1 THEN
0920 PRINT CHR(10);CHR(10)
0930 ELSE
0940 PRINT " "
0950 ENDIF
0960 NEXT LINIE
0970 IF TYPE=1 THEN
0980 EXEC TUD(SUM$,TAL1$,1,0)
0990 EXEC TUD(SUM1$,TAL2$,1,0)
1000 EXEC TUD(SUM3$,TAL3$,1,0)
1010 EXEC TUD(SUM5$,TAL4$,1,0)
1020 PRINT TAB(10);CHR(14);"Total";CHR(15);TAB(21);TAL1$,TAB(35);TAL2$;
1030 PRINT TAB(49);TAL3$;TAB(63);TAL4$
1040 EXEC TUD(SUM2$,TAL1$,1,0)
1050 EXEC TUD(SUM4$,TAL2$,1,0)
1060 EXEC TUD(SUM6$,TAL3$,1,0)
1070 PRINT TAB(38);TAL1$;TAB(52);TAL2$;TAB(66);TAL3$
1090 ELSE
1100 PRINT CHR(10);CHR(10);CHR(10)
1120 ENDIF
1130 ENDPROC
1140 PROC UDSKRIV
1150 CASE TYPE OF
1160 WHEN 1
1170 EXEC CALC(0,DSALDO1$,DSALDO2$,DSALDI$)
1180 EXEC CALC(0,DSALDI$,DSALDO3$,DSALDI$)
1190 EXEC CALC(0,DSALDI$,DSALDO4$,DSALDI$)
1200 EXEC CALC(0,SUM$,DSALDI$,SUM$)
1210 EXEC CALC(0,SUM1$,DSALDO1$,SUM1$)
1220 EXEC CALC(0,SUM2$,DSALDO2$,SUM2$)
1230 EXEC CALC(0,SUM3$,DSALDO3$,SUM3$)
1240 EXEC CALC(0,SUM4$,DSALDO4$,SUM4$)
1250 EXEC CALC(0,SUM5$,MDNKØB$,SUM5$)
1260 TÅRKØB$=ÅRKØB$
1270 EXEC CALC(0,SUM6$,TÅRKØB$,SUM6$)
1280 EXEC TUD(DSALDI$,TAL1$,1,0)
1290 EXEC TUD(DSALDO1$,TAL2$,1,0)
1300 EXEC TUD(DSALDO3$,TAL3$,1,0)
1310 EXEC TUD(MDNKØB$,TAL4$,1,0)
1320 PRINT USING "######   ":DEBNR;
1330 PRINT DEBTLF$;
1340 PRINT TAB(24);TAL1$;TAB(38);TAL2$;TAB(52);TAL3$;TAB(65);TAL4$
1350 EXEC TUD(DSALDO2$,TAL1$,1,0)
1360 EXEC TUD(DSALDO4$,TAL2$,1,0)
1370 EXEC TUD(TÅRKØB$,TAL3$,1,0)
1380 PRINT " ";DEBNAVN$;TAB(38);TAL1$;TAB(52);TAL2$;TAB(65);TAL3$
1390 PRINT " "
1400 WHEN 2
1410 PRINT USING "######  ":DEBNR;
1420 PRINT DEBNAVN$;TAB(34);
1430 PRINT USING "#######    ":DPOSTNR;
1440 PRINT DEBBY$;TAB(67);DEBTLF$
1450 WHEN 3
1451 J=0
1452 REPEAT
1460 FOR I=1 TO 4
1470 PRINT " "
1480 NEXT I
1490 PRINT USING "######   ":DEBNR;
1500 PRINT DEBNAVN$;" "
1510 PRINT " "
1520 PRINT TAB(10);DEBGADE$;" "
1530 PRINT " "
1540 PRINT TAB(7);
1550 PRINT USING "########  ":DPOSTNR;
1560 PRINT DEBBY$;" "
1570 IF DEBLK$>"0" AND DEBLK$<="9" THEN
1580 PRINT " "
1590 PRINT TAB(9);LAND$(ORD(DEBLK$)-48)
1600 ELSE
1610 PRINT CHR(10);CHR(10)
1620 ENDIF
1630 PRINT CHR(10);CHR(10);CHR(10);CHR(10);CHR(10)
1635 J=J+1
1636 UNTIL J=TALLET
1640 ENDCASE
1650 ENDPROC
1660 PROC FINDPOST(TAB1,MANT1,NØGL1,PIL3)
1670 PIL1=MANT1 DIV 2;PIL3=PIL1;CEKS=1
1680 REPEAT
1690 IF NØGL1=TAB1(PIL3,1) OR PIL1=1 THEN EXIT
1700 PIL1=(PIL1+1) DIV 2;PIL3=PIL3+PIL1*(1-2*(NØGL1<TAB1(PIL3,1)))
1710 IF PIL3<1 THEN PIL3=1
1720 IF PIL3>MANT1 THEN PIL3=MANT1
1730 UNTIL PIL1=0
1740 IF NØGL1=TAB1(PIL3,1) THEN CEKS=0
1750 ENDPROC
1760 PROC NRTEST(NUM)
1770 P=0;TEST2=0;KTAL=0;L=LEN(NUM$)
1780 CASE L OF
1790 FOR J=1 TO L
1800 P1=INT(ORD(NUM$(J))-48)
1810 IF P1=>0 AND P1<=9 THEN
1820 P=P*10+P1
1830 ELSE
1840 TEST2=1
1850 ENDIF
1860 NEXT J
1870 KTAL=P DIV 10000
1880 WHEN 0
1890 P=-1
1900 WHEN 1
1910 CASE NUM$ OF
1920 P=INT(ORD(NUM$)-48)
1930 WHEN "j","J"
1940 P=-7
1950 WHEN "n","N"
1960 P=-8
1970 ENDCASE
1980 ENDCASE
1990 ENDPROC
2000 K1$="P641220:SYSTEM1"
2010 OPEN K1$,R
2020 EXEC FEJL(9,1,K1$)
2030 GET K1$,1:MFANTAL,MDANTAL
2040 EXEC FEJL(9,2,K1$)
2050 GET K1$,4:MKPOST,MFAK,MVGR,MKGR
2060 EXEC FEJL(9,3,K1$)
2070 GET K1$,8:DIVNR,DIVDNR,DIFNR,DTAL
2080 EXEC FEJL(9,4,K1$)
2090 GET K1$,10:N$
2100 EXEC FEJL(9,5,K1$)
2110 GET K1$,12:K2$
2120 EXEC FEJL(9,6,K1$)
2130 GET K1$,16:K3$
2140 EXEC FEJL(9,7,K1$)
2150 GET K1$,35:K4$
2160 EXEC FEJL(9,8,K1$)
2170 GET K1$,36:K5$
2180 EXEC FEJL(9,9,K1$)
2190 CLOSE K1$
2200 EXEC FEJL(9,10,K1$)
2210 K2$=N$+K2$;K3$=N$+K3$;K4$=N$+K4$;K5$=N$+K5$
2220 OPEN K5$,R
2230 EXEC FEJL(9,11,K5$)
2240 GET K5$,2:T1(1),T1(2),T1(3),T1(4),T1(5),T1(6),T1(7),T1(8),T1(9)
2250 EXEC FEJL(9,12,K5$)
2260 FOR I=1 TO 3
2270 H=(I-1)*3+1
2280 GET K5$,I+2:LAND$(H),LAND$(H+1),LAND$(H+2)
2290 EXEC FEJL(9,13,K5$)
2300 NEXT I
2310 GET K5$,14:AFIN,ADEB
2320 EXEC FEJL(9,14,K5$)
2330 GET K5$,20:DV$
2340 EXEC FEJL(9,21,K5$)
2350 CLOSE K5$
2360 EXEC FEJL(9,22,K5$)
2370 DIM DTAB(MDANTAL,2),KARRAY(MKGR)
2380 OPEN K4$,R
2390 EXEC FEJL(9,15,K4$)
2400 FOR I=1 TO MKGR DIV 5
2410 J=(I-1)*5+1
2420 GET K4$,I:KARRAY(J),KARRAY(J+1),KARRAY(J+2),KARRAY(J+3),KARRAY(J+4)
2430 EXEC FEJL(9,16,K4$)
2440 NEXT I
2450 CLOSE K4$
2460 EXEC FEJL(9,12,K4$)
2470 OPEN K2$,R
2480 EXEC FEJL(9,18,K2$)
2490 OPEN K3$,R
2500 EXEC FEJL(9,19,K3$)
2510 EXEC INDTAB(DTAB,MDANTAL,K2$)
2520 DA=T1(7)
2530 DAT$="        "
2540 FOR J=8 TO 1 STEP -1
2550 IF J MOD 3=0 THEN
2560 DAT$(J)="."
2570 ELSE
2580 DAT$(J)=CHR(DA MOD 10+48)
2590 DA=DA DIV 10
2600 ENDIF
2610 NEXT J
2620 STREG$="---------------------------------------";STREG$=STREG$+STREG$
2630 REPEAT
2640 SUM$="0+";SUM1$="0+";SUM2$="0+";SUM3$="0+";SUM4$="0+";SUM5$="0+"
2650 SUM6$="0+";LINIE=0;SIDENR=0
2660 OUTPUT T
2670 CLEAR
2680 CURSOR 20,1
2690 PRINT "Debitorudskrifter"
2700 CURSOR 11,6
2710 PRINT "0: Færdig"
2720 CURSOR 11,8
2730 PRINT "1: Saldoliste"
2740 CURSOR 11,10
2750 PRINT "2: Kontoliste"
2760 CURSOR 11,12
2770 PRINT "3: Labels"
2780 REPEAT
2790 CURSOR 13,14
2800 INPUT "Vælg type :",A$
2810 EXEC NRTEST(A$)
2820 UNTIL P>-1 AND P<4
2830 TYPE=P
2840 IF TYPE=0 THEN EXIT
2850 REPEAT
2860 CURSOR 13,17
2870 PRINT "Ordnet efter :      (1: Gruppe , 2: Nr)"
2880 CURSOR 26,17
2890 INPUT A$
2900 EXEC NRTEST(A$)
2910 UNTIL P=1 OR P=2
2920 ORDEN=P
2930 REPEAT
2940 REPEAT
2950 CURSOR 13,19
2960 IF ORDEN=1 THEN
2970 PRINT "Fra gruppenr :      (0: Alle)"
2980 ELSE
2990 PRINT "Fra kontonr  :      (0: Alle)"
3000 ENDIF
3010 CURSOR 26,19
3020 INPUT KTN$
3030 EXEC NRTEST(KTN$)
3040 UNTIL P=0 OR (P>0 AND P<=MKGR AND ORDEN=1) OR (KTAL=DTAL AND ORDEN=2)
3050 IF ORDEN=1 THEN
3060 IF P=0 THEN
3070 FRA=1;TIL=MKGR
3080 ELSE
3090 FRA=P
3100 ENDIF
3110 ELSE
3120 IF P=0 THEN
3130 FRA=1;TIL=ADEB
3140 ELSE
3150 IF DTAB(ADEB,1)<P THEN
3160 FRA=0
3170 ELSE
3180 EXEC FINDPOST(DTAB,MDANTAL,P,DPIL3)
3190 IF CEKS=0 THEN
3200 FRA=DPIL3
3210 ELSE
3220 FRA=DPIL3+1
3230 ENDIF
3240 ENDIF
3250 ENDIF
3260 ENDIF
3270 UNTIL FRA<>0
3280 IF P>0 THEN
3290 REPEAT
3300 REPEAT
3310 CURSOR 13,21
3320 IF ORDEN=1 THEN
3330 INPUT "Til gruppenr :",KTN$
3340 ELSE
3350 INPUT "Til kontonr  :",KTN$
3360 ENDIF
3370 EXEC NRTEST(KTN$)
3380 UNTIL (P>0 AND P<=MKGR AND ORDEN=1) OR (KTAL=DTAL AND ORDEN=2)
3390 IF ORDEN=1 THEN
3400 TIL=P
3410 ELSE
3420 IF DTAB(ADEB,1)<P THEN
3430 TIL=ADEB
3440 ELSE
3450 EXEC FINDPOST(DTAB,MDANTAL,P,DPIL3)
3460 TIL=DPIL3
3470 ENDIF
3480 ENDIF
3490 UNTIL FRA<=TIL
3500 ENDIF
3501 IF TYPE=3 THEN
3502 CURSOR 13,23
3503 INPUT "Hvor mange labels ønskes af hver, (1-99) ",TALLET
3504 ENDIF
3510 CLEAR
3520 REPEAT
3530 CURSOR 18,13
3540 INPUT "Monter lister til udskrift og tast RETURN",A$
3550 UNTIL ORD(A$)=255
3560 IF TYPE=1 THEN KS$="saldo"
3570 IF TYPE=2 THEN KS$="konto"
3580 OUTPUT P
3590 IF ORDEN=1 THEN
3600 FOR H=FRA TO TIL
3610 SUM1$="0+";SUM2$="0+";SUM3$="0+";SUM4$="0+";SUM5$="0+";SUM6$="0+"
3620 SUM$="0+";LINIE=0;SIDENR=0
3630 HKUNDE=KARRAY(H)
3640 REPEAT
3650 IF HKUNDE=0 THEN EXIT
3660 IF TYPE<>3 THEN
3670 EXEC HOVED(H)
3680 ENDIF
3690 EXEC FINDPOST(DTAB,MDANTAL,HKUNDE,DPIL3)
3700 EXEC HENTDPOST
3710 EXEC UDSKRIV
3720 UNTIL HKUNDE=0
3730 IF TYPE<>3 AND KARRAY(H)<>0 THEN
3740 EXEC BUND
3750 ENDIF
3760 NEXT H
3770 ELSE
3780 FOR DPIL3=FRA TO TIL
3790 IF TYPE<>3 THEN
3800 EXEC HOVED(0)
3810 ENDIF
3820 EXEC HENTDPOST
3830 EXEC UDSKRIV
3840 NEXT DPIL3
3850 IF TYPE<>3 THEN
3860 EXEC BUND
3870 ENDIF
3880 ENDIF
3890 UNTIL TYPE=0
3900 CHAIN "P641210:OPSTART"