DataMuseum.dk

top - download

    Length: 9326 (0x246e)
    Types: SPC/1-COMAL-BIN
    Notes: Mikados_B
    Names: »UNKVEDL.B«

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

SPC/1 COMAL-BIN

0100 DIM RES$(15),OP1$(12),OP2$(12)
0110 DIM FNAVN$(25),FUKODE$(E),DAT$(8),STREG$(71)
0120 DIM N$(6),BLANK$(77),A$(E),TAL4$(14),TAH$(12),DV$(10)
0130 DIM KTN$(7),BLB2$(12),UBLB2$(14),UD1$(14),UD2$(14),UD3$(14)
0140 DIM UD4$(14),K4$(17),K5$(17),T1(W),T2(W),K3$(17),K1$(17),K2$(17)
0150 PROC CALC(AT,B1,B2,ES)
0160 RES$=ES$;OP1$=B1$;OP2$=B2$;SI=B;FLAG=B;ART=AT
0170 CALL "P641210:REGN"
0180 ES$=RES$
0190 IF FLAG THEN STOP
0200 ENDPROC
0210 PROC FEJL(NR1,NR2,NR3)
0220 IF STATUS(NR3$)<>B THEN
0230 PRINT STATUS(NR3$),NR1,NR2,NR3$
0240 STOP
0250 ENDIF
0260 ENDPROC
0270 PROC DKRTEST
0280 FOR EPIL3=E TO AENT
0290 IF ETAB(EPIL3,E)<1000000 THEN
0300 EXEC HENTEPOST
0320 EXEC CALC(4,MBEV$(UPIL2),TAH$,TAH$)
0330 IF SI<>B THEN EXIT
0340 EXEC CALC(4,YBEV$(UPIL2),TAH$,TAH$)
0350 IF SI<>B THEN EXIT
0360 ENDIF
0370 NEXT EPIL3
0380 IF EPIL3<AENT+E THEN TEST=E
0390 ENDPROC
0400 PROC INDTAB1(T)
0410 J=MEANTAL DIV 32+E
0420 FOR I=J TO MEANTAL DIV 4+J-E
0430 H=(I-J)*4+E;J2=H+E;J3=H+G;J4=H+V
0440 GET K5$,I:T(H,E),T(H,G),T(J2,E),T(J2,G),T(J3,E),T(J3,G),T(J4,E),T(J4,G)
0450 EXEC FEJL(E,E,K5$)
0460 NEXT I
0470 ENDPROC
0480 PROC INDTAB
0490 FOR I=E TO MUNKANT+METOT
0500 GET K2$,I:UNR(I),UKODE$(I),UNAVN$(I)
0510 EXEC FEJL(E,E,K2$)
0520 NEXT I
0530 ENDPROC
0540 PROC UDTAB
0550 FOR I=E TO MUNKANT+METOT
0560 PUT K2$,I:UNR(I),UKODE$(I),UNAVN$(I)
0570 EXEC FEJL(G,E,K2$)
0580 NEXT I
0590 ENDPROC
0600 PROC FINDPOST
0610 UPIL3=MUNKANT+METOT;CEKS=E;UPIL2=AUNK;CEKS1=E
0620 WHILE FNR<UNR(UPIL3) AND UPIL3>E DO
0630 IF UKODE$(UPIL3)="0" THEN UPIL2=UPIL2-E
0640 UPIL3=UPIL3-E
0650 ENDWHILE
0660 IF FNR=UNR(UPIL3) THEN CEKS=B
0670 IF UKODE$(UPIL3)="0" THEN CEKS1=B
0680 IF FNR>UNR(UPIL3) THEN
0681 UPIL2=UPIL2+E*(UPIL2<MUNKANT)
0682 UPIL3=UPIL3+E*(UPIL3<MUNKANT+METOT)
0683 ENDIF
0690 ENDPROC
0700 PROC INDSÆT
0710 IF CEKS=E THEN
0720 FOR I=AUNK+ETOT+E TO UPIL3+E STEP -E
0730 UNR(I)=UNR(I-E);UKODE$(I)=UKODE$(I-E);UNAVN$(I)=UNAVN$(I-E)
0740 NEXT I
0750 IF FUKODE$="0" THEN
0760 FOR EPIL3=E TO AENT
0770 IF ETAB(EPIL3,E)<1000000 THEN
0780 EXEC HENTEPOST
0790 FOR I=AUNK+E TO UPIL2+E STEP -E
0800 UKNR(I)=UKNR(I-E);MBEV$(I)=MBEV$(I-E);YBEV$(I)=YBEV$(I-E)
0810 NEXT I
0820 UKNR(UPIL2)=FNR;MBEV$(UPIL2)="0+";YBEV$(UPIL2)="0+"
0830 EXEC GEMEPOST
0840 ENDIF
0850 NEXT EPIL3
0860 AUNK=AUNK+E
0870 ELSE
0880 ETOT=ETOT+E
0890 ENDIF
0900 ENDIF
0910 ENDPROC
0920 PROC SLETPOST
0930 IF CEKS=B THEN
0940 FOR I=UPIL3 TO AUNK+ETOT-E
0950 UNR(I)=UNR(I+E);UKODE$(I)=UKODE$(I+E);UNAVN$(I)=UNAVN$(I+E)
0960 NEXT I
0970 UNR(I)=1000000;UKODE$(I)="E";UNAVN$(I)=BLANK$
0980 IF FUKODE$="0" THEN
0990 FOR EPIL3=E TO AENT
1000 IF ETAB(EPIL3,E)<1000000 THEN
1010 EXEC HENTEPOST
1020 IF UKNR(UPIL2)<>FNR THEN STOP
1030 FOR I=UPIL2 TO AUNK-E
1040 UKNR(I)=UKNR(I+E);MBEV$(I)=MBEV$(I+E);YBEV$(I)=YBEV$(I+E)
1050 NEXT I
1060 UKNR(I)=1000000;MBEV$(I)="0+";YBEV$(I)="0+"
1070 EXEC GEMEPOST
1080 ENDIF
1090 NEXT EPIL3
1100 AUNK=AUNK-E
1110 ELSE
1120 ETOT=ETOT-E
1130 ENDIF
1140 ENDIF
1150 ENDPROC
1160 PROC HENTEPOST
1170 S=ETAB(EPIL3,G)+E
1180 FOR X=E TO MUNKANT
1190 GET K3$,X+S:UKNR(X),MBEV$(X),YBEV$(X)
1200 EXEC FEJL(V,E,K3$)
1210 NEXT X
1220 ENDPROC
1230 PROC GEMEPOST
1240 S=ETAB(EPIL3,G)+E
1250 FOR X=E TO MUNKANT
1260 PUT K3$,X+S:UKNR(X),MBEV$(X),YBEV$(X)
1270 EXEC FEJL(V,G,K3$)
1280 NEXT X
1290 ENDPROC
1300 PROC HENTPOST
1310 FNR=UNR(UPIL3);FUKODE$=UKODE$(UPIL3);FNAVN$=UNAVN$(UPIL3)
1320 ENDPROC
1330 PROC GEMUPOST
1340 UNR(UPIL3)=FNR;UKODE$(UPIL3)=FUKODE$;UNAVN$(UPIL3)=FNAVN$
1350 ENDPROC
1360 PROC FINDTAST(FSTYR,FÆND,FNR2)
1370 IF FÆND<>E THEN
1380 CLEAR
1390 CURSOR 21,E
1400 PRINT "Kontooplysninger"
1410 EXEC VERSKRIFT
1420 CURSOR G,V
1430 PRINT USING "1:Kontonr      : ######":FNR2
1440 ENDIF
1450 REPEAT
1460 CASE FSTYR OF
1470 STOP
1480 WHEN G
1490 IF FÆND<>E THEN
1500 CURSOR G,5
1510 PRINT "2:Kontonavn    :"
1520 FSTYR=V
1530 ENDIF
1540 IF FÆND<>G THEN
1550 CURSOR V,23
1560 PRINT "Kontonavn";BLANK$(E:29);"(max 25 tegn)";BLANK$(E:25)
1570 CURSOR 13,23
1580 INPUT FNAVN$
1590 ENDIF
1600 CURSOR 19,5
1610 PRINT BLANK$(E:25)
1620 CURSOR 19,5
1630 PRINT FNAVN$
1640 WHEN V
1650 IF FÆND<>E THEN
1660 CURSOR G,7
1670 PRINT "3:Udskriftskode:"
1680 ENDIF
1690 IF FÆND<>G THEN
1700 REPEAT
1710 CURSOR V,23
1720 PRINT "Udskriftskode     (0:normal,1:undergr,.2:hovedgr.,3:subto";
1730 PRINT "tal,4:Overgr.)      "
1740 CURSOR 17,23
1750 INPUT A$
1760 UNTIL ORD(A$)>47 AND ORD(A$)<53
1770 IF TYPE=E THEN
1780 FUKODE$=A$
1790 ELSE
1800 IF FUKODE$<>"0" THEN IF A$<>"0" THEN FUKODE$=A$
1810 ENDIF
1820 ENDIF
1830 CURSOR 19,7
1840 PRINT " "
1850 CURSOR 19,7
1860 PRINT FUKODE$
1870 FSTYR=4
1880 ENDCASE
1890 IF FÆND=E THEN FSTYR=4
1900 UNTIL FSTYR=4
1910 ENDPROC
1920 PROC TUD(BLB1,UBLB1,TEGN,STØR)
1930 BLB2$=BLB1$;UBLB2$=UBLB1$
1940 EXEC CALC(5,BLB2$,TAH$,UBLB2$)
1950 UBLB1$=UBLB2$
1960 IF TEGN=B THEN
1970 UBLB1$=UBLB1$(E:13)
1980 ELSE
1990 IF TEGN=E AND UBLB1$(LEN(UBLB1$))="+" THEN
2000 UBLB1$(LEN(UBLB1$))=" "
2010 ENDIF
2020 IF STØR=E THEN
2030 UBLB1$=UBLB1$(4:LEN(UBLB1$)-V)
2040 ENDIF
2050 ENDIF
2060 PRINT UBLB1$
2070 ENDPROC
2080 PROC NRTEST(NUM1)
2090 P=B;TEST2=B;KTAL=B;L=LEN(NUM1$)
2100 CASE L OF
2110 FOR I=E TO L
2120 P1=INT(ORD(NUM1$(I))-48)
2130 IF P1=>B AND P1<=W THEN
2140 P=P*10+P1
2150 ELSE
2160 TEST2=E
2170 ENDIF
2180 NEXT I
2190 KTAL=P DIV 10000;KTAL9=P DIV 1000
2200 IF KTAL9=KRTAL THEN KTAL=KRTAL
2210 WHEN B
2220 P=-E
2230 WHEN E
2240 CASE NUM1$ OF
2250 P=INT(ORD(NUM1$)-48)
2260 WHEN "j","J"
2270 P=-7
2280 WHEN "n","N"
2290 P=-8
2300 ENDCASE
2310 ENDCASE
2320 ENDPROC
2330 PROC VERSKRIFT
2340 CURSOR 45,E
2350 CASE TYPE OF
2360 WHEN E
2370 PRINT "Oprettelse"
2380 WHEN G
2390 PRINT "Ændring"
2400 WHEN V
2410 PRINT "Sletning"
2420 WHEN 4
2430 PRINT "Udskrift"
2440 WHEN 5
2450 PRINT "Underkontoliste"
2460 ENDCASE
2470 ENDPROC
2480 K1$="P641220:SYSTEM1"
2490 OPEN K1$,R
2500 EXEC FEJL(W,E,K1$)
2510 GET K1$,W:KRTAL,VTAL,MEANTAL,MUNKANT
2520 EXEC FEJL(W,6,K1$)
2530 GET K1$,10:N$
2540 EXEC FEJL(W,7,K1$)
2550 GET K1$,36:K4$
2560 EXEC FEJL(W,10,K1$)
2570 GET K1$,37:K3$
2580 EXEC FEJL(W,G,K1$)
2590 GET K1$,38:K5$
2600 EXEC FEJL(W,V,K1$)
2610 GET K1$,39:K2$
2620 EXEC FEJL(W,10,K1$)
2630 GET K1$,43:METOT
2640 EXEC FEJL(W,11,K1$)
2650 CLOSE K1$
2660 EXEC FEJL(W,11,K1$)
2670 DIM UNR(MUNKANT+METOT),UKODE$(MUNKANT+METOT),UNAVN$(MUNKANT+METOT,25)
2680 DIM UKNR(MUNKANT),MBEV$(MUNKANT,12),YBEV$(MUNKANT,12),ETAB(MEANTAL,G)
2690 K4$=N$+K4$
2700 OPEN K4$,W
2710 EXEC FEJL(W,12,K4$)
2720 GET K4$,G:T1(E),T1(G),T1(V),T1(4),T1(5),T1(6),DATO
2730 EXEC FEJL(W,13,K4$)
2740 GET K4$,20:DV$
2750 EXEC FEJL(W,22,K4$)
2760 GET K4$,21:AENT,AUNK,ETOT,EMID,EPOST
2770 EXEC FEJL(W,12,K4$)
2780 CLOSE K4$
2790 EXEC FEJL(W,17,K4$)
2800 K2$=N$+K2$;K3$=N$+K3$;K5$=N$+K5$
2810 OPEN K2$,W
2820 EXEC FEJL(W,18,K2$)
2830 OPEN K5$,R
2840 EXEC FEJL(W,19,K5$)
2850 OPEN K3$,W
2860 EXEC FEJL(W,20,K3$)
2870 EXEC INDTAB1(ETAB)
2880 EXEC INDTAB
2890 BLANK$="                                      ";BLANK$=BLANK$+BLANK$+" "
2900 TAH$="0+";TAL4$="0+"
2910 STREG$="-----------------------------------";STREG$=STREG$+STREG$
2920 REPEAT
2930 CLEAR
2940 CURSOR 15,E
2950 PRINT "Underkontovedligeholdelse"
2960 CURSOR 21,5
2970 PRINT "0:Færdig"
2980 CURSOR 21,7
2990 PRINT "1:Oprettelse"
3000 CURSOR 21,W
3010 PRINT "2:Ændring"
3020 CURSOR 21,11
3030 PRINT "3:Sletning"
3040 CURSOR 21,13
3050 PRINT "4:Udskrift"
3060 CURSOR 21,15
3070 PRINT "5:Underkontoliste"
3080 REPEAT
3090 CURSOR 23,17
3100 PRINT "Vælg type     (0-5)"
3110 CURSOR 33,17
3120 INPUT A$
3130 EXEC NRTEST(A$)
3140 UNTIL P>-E AND P<6
3150 TYPE=P
3160 IF TYPE=B THEN EXIT
3170 REPEAT
3180 EXEC VERSKRIFT
3190 TEST=B;FNR=E;UPIL3=E
3200 IF TYPE<5 THEN
3210 REPEAT
3220 REPEAT
3230 CURSOR V,23
3240 PRINT "Indtast nyt kontonr        (0:for færdig)";BLANK$(E:35)
3250 CURSOR 22,23
3260 INPUT KTN$
3270 EXEC NRTEST(KTN$)
3280 UNTIL P>W AND P<100 OR P=B
3290 FNR=P
3300 IF FNR=B THEN EXIT
3310 EXEC FINDPOST
3320 REPEAT
3330 CURSOR 44,23
3340 FT=B
3350 IF AUNK<MUNKANT AND ETOT<METOT THEN FT=E
3360 IF (CEKS=B AND TYPE<>E) OR (CEKS=E AND TYPE=E AND FT=E) THEN
3370 PRINT BLANK$(E:35)
3380 P=-E
3390 ELSE
3400 IF CEKS=E AND TYPE=E AND ETOT=>METOT AND AUNK=>MUNKANT THEN
3410 CURSOR V,23
3420 INPUT "Ikke plads til flere konti , tast RETURN                 ",A$
3430 ELSE
3440 IF CEKS=B THEN
3450 INPUT "Konto eksisterer ,tast RETURN      ",A$
3460 ELSE
3470 INPUT "Konto eksisterer ikke , tast RETURN",A$
3480 ENDIF
3490 ENDIF
3500 EXEC NRTEST(A$)
3510 ENDIF
3520 UNTIL P=-E
3530 UNTIL (CEKS=B AND TYPE<>E) OR (CEKS=E AND TYPE=E AND FT=E)
3540 IF FNR=B THEN EXIT
3550 IF TYPE<>E THEN
3560 TEST=B
3570 EXEC HENTPOST
3580 IF TYPE=V AND CEKS1=B THEN EXEC DKRTEST
3590 EXEC FINDTAST(2,2,FNR)
3600 ELSE
3610 FNAVN$=BLANK$(E:25);FUKODE$="0"
3620 EXEC FINDTAST(2,0,FNR)
3630 ENDIF
3640 ENDIF
3650 IF FNR=B THEN EXIT
3660 IF TEST=B THEN
3670 CASE TYPE OF
3680 STOP
3690 WHEN E,G
3700 REPEAT
3710 REPEAT
3720 CURSOR V,23
3730 PRINT "Hvilket felt ønskes ændret      (Indtast feltnr 2-3, ";
3740 PRINT "0:for færdig)          "
3750 CURSOR 32,23
3760 INPUT A$
3770 EXEC NRTEST(A$)
3780 UNTIL P=B OR (P>E AND P<4)
3790 STYR1=P
3800 IF STYR1=B THEN EXIT
3810 EXEC FINDTAST(STYR1,1,FNR)
3820 UNTIL STYR1=B
3830 EXEC FINDPOST
3840 EXEC INDSÆT
3850 EXEC GEMUPOST
3860 WHEN V
3870 REPEAT
3880 CURSOR V,23
3890 PRINT "Er det rigtigt at denne konto skal slettes";
3900 PRINT "      (J/N)";BLANK$(E:23)
3910 CURSOR 48,23
3920 INPUT A$
3930 EXEC NRTEST(A$)
3940 UNTIL P=-7 OR P=-8
3950 IF P=-7 THEN
3960 EXEC SLETPOST
3970 ENDIF
3980 WHEN 4
3990 WHEN 5
4000 CLEAR
4010 REPEAT
4020 CURSOR 8,13
4030 INPUT "Monter papir til udskrift af underkontoliste og tast RETURN",A$
4040 UNTIL ORD(A$)=255
4050 OUTPUT P
4060 SIDE=E
4070 DA1=DATO
4080 DAT$="        "
4090 FOR J=8 TO E STEP -E
4100 IF J MOD V=B THEN
4110 DAT$(J)="."
4120 ELSE
4130 DAT$(J)=CHR(DA1 MOD 10+48)
4140 DA1=DA1 DIV 10
4150 ENDIF
4160 NEXT J
4170 FOR I=E TO AUNK+ETOT
4180 PRINT TAB(67);DV$;" "
4190 PRINT TAB(10);CHR(14);"Underkontoliste";CHR(15);TAB(36);"Dato : ";DAT$;
4200 PRINT USING "   Side :####":SIDE
4210 PRINT " "
4220 PRINT TAB(7);"Nr     Betegnelse";TAB(44);"Udskriftskode"
4230 PRINT TAB(6);STREG$
4240 SIDE=SIDE+E
4250 FOR UPIL3=I TO I+39
4260 IF UNR(UPIL3)<>1000000 THEN
4270 PRINT USING "     ######  ":UNR(UPIL3);
4280 PRINT UNAVN$(UPIL3);TAB(49);UKODE$(UPIL3)
4290 ENDIF
4300 IF UPIL3=AUNK+ETOT THEN EXIT
4310 NEXT UPIL3
4320 IF UPIL3=AUNK+ETOT AND UPIL3<I+40 THEN EXIT
4330 NEXT I
4340 FOR J=UPIL3+E TO I+42
4350 PRINT " "
4360 NEXT J
4370 OUTPUT T
4380 FNR=B
4390 ENDCASE
4400 ELSE
4410 REPEAT
4420 CURSOR V,23
4430 FNR=ETAB(EPIL3,E)
4440 PRINT "Kontoen kan ikke slettes, saldo på entreprise ";FNR;" ,tast ";
4450 PRINT "RETURN        ";
4460 INPUT A$
4470 EXEC NRTEST(A$)
4480 UNTIL P=-E
4490 ENDIF
4500 UNTIL FNR=B
4510 UNTIL TYPE=B
4520 EXEC UDTAB
4530 CLOSE K2$
4540 EXEC FEJL(W,30,K2$)
4550 CLOSE K3$
4560 EXEC FEJL(W,31,K3$)
4570 CLOSE K5$
4580 EXEC FEJL(W,32,K5$)
4590 OPEN K4$,W
4600 EXEC FEJL(W,32,K4$)
4610 PUT K4$,21:AENT,AUNK,ETOT,EMID,EPOST
4620 EXEC FEJL(W,34,K4$)
4630 CLOSE K4$
4640 EXEC FEJL(W,35,K4$)
4650 CHAIN "P641210:OPSTART"