DataMuseum.dk

top - download

    Length: 10419 (0x28b3)
    Types: SPC/1-COMAL-BIN
    Notes: Mikados_B
    Names: »ENTVEDL.B«

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

SPC/1 COMAL-BIN

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