DataMuseum.dk

top - download

    Length: 7455 (0x1d1f)
    Types: SPC/1-COMAL-BIN
    Notes: Mikados_B
    Names: »FSORT.B«

└─⟦385f097a1⟧ Bits:30008988 SPC/1 COMAL programmer til bogføring
    └─⟦this⟧ »FSORT.B« 

SPC/1 COMAL-BIN

0100 REM FSORT
0110 DIM K1$(17),K2$(17),K3$(17),K4$(17),K5$(17),K6$(17),K7$(17),T11(W)
0120 DIM K9$(17),T12(W),N1$(6),A$(E),BLANK$(25),TKO$(E),BEO$(12),TEO$(25)
0130 DIM T21(W),T22(W),K8$(17),K10$(17),K19$(17),K23$(17),T13(W),T23(W)
0140 DIM K20$(17),K21$(17),K22$(17),K40$(17),K41$(17),K42$(17),K43$(17)
0150 BLANK$="                         "
0160 CLEAR
0170 REPEAT
0180 CURSOR 30,13
0190 INPUT "Sæt plade nr 21 i ,tast RETURN",A$
0200 UNTIL ORD(A$)=255
0210 K1$="P641220:SYSTEM1"
0220 OPEN K1$,R
0230 EXEC FEJL(E,E,K1$)
0240 GET K1$,G:MKASPOST,MPPOST,MBHPOST,MFMID
0250 EXEC FEJL(E,G,K1$)
0260 GET K1$,V:MDMID,MKMID,MFPOST,MDPOST
0270 EXEC FEJL(E,V,K1$)
0280 GET K1$,4:MKPOST
0290 EXEC FEJL(E,4,K1$)
0300 GET K1$,10:N1$
0310 EXEC FEJL(E,6,K1$)
0320 GET K1$,22:K3$
0330 EXEC FEJL(V,E,K1$)
0340 GET K1$,23:K4$
0350 EXEC FEJL(V,G,K1$)
0360 GET K1$,24:K5$
0370 EXEC FEJL(V,V,K1$)
0380 GET K1$,25:K6$
0390 EXEC FEJL(V,4,K1$)
0400 GET K1$,26:K7$
0410 EXEC FEJL(V,5,K1$)
0420 GET K1$,27:K8$
0430 EXEC FEJL(V,6,K1$)
0440 GET K1$,32:K9$
0450 EXEC FEJL(V,7,K1$)
0460 GET K1$,33:K10$
0470 EXEC FEJL(V,8,K1$)
0480 GET K1$,34:K19$
0490 EXEC FEJL(V,W,K1$)
0500 GET K1$,40:K40$
0510 EXEC FEJL(20,20,K1$)
0520 GET K1$,41:K41$
0530 EXEC FEJL(20,21,K1$)
0540 GET K1$,42:K42$
0550 EXEC FEJL(20,22,K1$)
0560 GET K1$,43:METOT,MEMID,MEPOST
0570 EXEC FEJL(20,23,K1$)
0580 CLOSE K1$
0590 EXEC FEJL(E,5,K1$)
0591 IMD=MDPOST
0592 IF IMD<MFPOST THEN IMD=MFPOST
0593 IF IMD<MKPOST THEN IMD=MKPOST
0594 IF IMD<MEPOST THEN IMD=MEPOST
0600 DIM HDTAB(IMD DIV 40,G),UDTAB(4,G)
0620 K20$=K7$+"1";K20$(G)="1";K21$=K6$+"1";K21$(G)="1";K22$=K8$+"1"
0630 K22$(G)="1";K3$=N1$+K3$;K4$=N1$+K4$;K5$=N1$+K5$;K6$=N1$+K6$;K7$=N1$+K7$
0640 K8$=N1$+K8$;K9$=N1$+K9$;K10$=N1$+K10$;K19$=N1$+K19$;K20$=N1$+K20$
0650 K21$=N1$+K21$;K22$=N1$+K22$;K43$=K41$+"1";K43$(G)="1";K40$=N1$+K40$
0660 K41$=N1$+K41$;K42$=N1$+K42$;K43$=N1$+K43$;IMD=MFMID
0670 IF IMD<MDMID THEN IMD=MDMID
0680 IF IMD<MKMID THEN IMD=MKMID
0690 IF IMD<MEMID THEN IMD=MEMID
0700 DIM N(IMD),D(IMD),BI(IMD),TK$(IMD,E),BE$(IMD,12),TE$(IMD,25),PEG(IMD)
0710 DIM ENT(IMD)
0720 K1$=N1$+"20:SYSTEM2"
0730 EXEC FSYSIN(K1$,T11,T12,T13)
0740 K2$=N1$+"21:SYSTEM21"
0750 EXEC FSYSIN(K2$,T21,T22,T23)
0760 EXEC FSORT(K4$,T11(3))
0770 EXEC FFLET(K20$,K7$,T11(3),T21(6),T11(6))
0780 CLEAR
0790 CURSOR 10,11
0795 T35=T11(6)
0800 PRINT USING "Antal debitorposteringer   :###### Max:######":T35,MDPOST
0810 EXEC FSYSUD(K1$,T11,T12,T13)
0820 EXEC TABINIT(K7$,K10$,MDPOST,HDTAB,UDTAB)
0830 EXEC FSORT(K3$,T11(2))
0840 EXEC FFLET(K21$,K6$,T11(2),T21(5),T11(5))
0850 CURSOR 10,13
0855 T40=T11(5)
0860 PRINT USING "Antal finansposteringer    :###### Max:######":T40,MFPOST
0870 EXEC FSYSUD(K1$,T11,T12,T13)
0880 EXEC TABINIT(K6$,K9$,MFPOST,HDTAB,UDTAB)
0890 EXEC FSORT(K5$,T11(4))
0900 EXEC FFLET(K22$,K8$,T11(4),T21(7),T11(7))
0910 CURSOR 10,15
0915 T45=T11(7)
0920 PRINT USING "Antal kreditorposteringer  :###### Max:######":T45,MKPOST
0930 EXEC FSYSUD(K1$,T11,T12,T13)
0940 EXEC TABINIT(K8$,K19$,MKPOST,HDTAB,UDTAB)
0950 EXEC FSORT(K40$,T13(4))
0960 EXEC FFLET(K43$,K41$,T13(4),T23(5),T13(5))
0970 CURSOR 10,17
0975 T30=T13(5)
0980 PRINT USING "Antal entrepriseposteringer:###### Max:######":T30,MEPOST
0990 EXEC FSYSUD(K1$,T11,T12,T13)
1000 EXEC TABINIT(K41$,K42$,MEPOST,HDTAB,UDTAB)
1010 T11(V)=B;T11(4)=B;T11(G)=B;T12(E)=B;T12(G)=V;T13(4)=B
1020 EXEC FSYSUD(K1$,T11,T12,T13)
1030 CLEAR
1080 CHAIN "P641210:ÅKOPI"
1090 END
1100 PROC FEJL(NR1,NR2,NR3)
1110 IF STATUS(NR3$)<>B THEN
1120 PRINT NR1,NR2,NR3$,STATUS(NR3$)
1130 STOP
1140 ENDIF
1150 ENDPROC
1160 PROC FSORT(K,MID)
1170 OPEN K$,R
1180 EXEC FEJL(G,E,K$)
1190 J=E
1200 FOR I=E TO MID
1210 EXEC FGET2(K$,I,N(J),D(J),BI(J),TK$(J),BE$(J),TE$(J),ENT(J))
1220 J=J+E
1230 NEXT I
1240 FOR I=E TO J-E
1250 PEG(I)=I
1260 NEXT I
1270 FOR I=E TO J-E
1280 MIN=I
1290 FOR H=I+E TO J-E
1300 IF N(PEG(H))<N(PEG(MIN)) THEN
1310 MIN=H
1320 ELSE
1330 IF N(PEG(H))=N(PEG(MIN)) THEN
1340 IF D(PEG(H))<D(PEG(MIN)) THEN MIN=H
1350 ENDIF
1360 ENDIF
1370 NEXT H
1380 MP=PEG(I)
1390 PEG(I)=PEG(MIN)
1400 PEG(MIN)=MP
1410 NEXT I
1420 CLOSE K$
1430 EXEC FEJL(G,4,K$)
1440 ENDPROC
1450 PROC FSYSIN(K11,T1,T2,T5)
1460 OPEN K11$,R
1470 EXEC FEJL(5,E,K11$)
1480 GET K11$,13:T1(E),T1(G),T1(V),T1(4),T1(5),T1(6),T1(7),T1(8),T1(W)
1490 EXEC FEJL(5,G,K11$)
1500 GET K11$,17:T2(E),T2(G),T2(V),T2(4),T2(5),T2(6),T2(7),T2(8),T2(W)
1510 EXEC FEJL(5,V,K11$)
1512 GET K11$,21:T5(E),T5(G),T5(V),T5(4),T5(5),T5(6),T5(7),T5(8),T5(W)
1514 EXEC FEJL(20,30,K11$)
1520 CLOSE K11$
1530 EXEC FEJL(5,4,K11$)
1540 ENDPROC
1550 PROC FSYSUD(K12,T3,T4,T6)
1560 OPEN K12$,W
1570 EXEC FEJL(6,E,K12$)
1580 PUT K12$,13:T3(E),T3(G),T3(V),T3(4),T3(5),T3(6),T3(7),T3(8),T3(W)
1590 EXEC FEJL(6,G,K12$)
1600 PUT K12$,17:T4(E),T4(G),T4(V),T4(4),T4(5),T4(6),T4(7),T4(8),T4(W)
1610 EXEC FEJL(6,V,K12$)
1612 PUT K12$,21:T6(E),T6(G),T6(V),T6(4),T6(5),T6(6),T6(7),T6(8),T6(W)
1614 EXEC FEJL(20,31,K12$)
1620 CLOSE K12$
1630 EXEC FEJL(6,4,K12$)
1640 ENDPROC
1650 PROC FGET2(K15,I3,N3,D3,BI3,TK3,BE3,TE3,ENT3)
1660 GET K15$,I3:N3,D3,BI3,TK3$,BE3$,ENT3
1670 EXEC FEJL(W,E,K15$)
1680 IF ORD(TK3$)-48>W AND ORD(TK3$)-48<20 THEN
1690 I3=I3+E
1700 GET K15$,I3:N3,TE3$
1710 EXEC FEJL(W,G,K15$)
1720 ELSE
1730 TE3$=BLANK$
1740 ENDIF
1750 ENDPROC
1760 PROC FPUT2(K16,I4,N4,D4,BI4,TK4,BE4,TE4,ENT4)
1770 PUT K16$,I4:N4,D4,BI4,TK4$,BE4$,ENT4
1780 EXEC FEJL(10,E,K16$)
1790 IF ORD(TK4$)-48>W AND ORD(TK4$)-48<20 THEN
1800 I4=I4+E
1810 PUT K16$,I4:N4,TE4$
1820 EXEC FEJL(10,G,K16$)
1830 ENDIF
1840 ENDPROC
1850 PROC FFLET(K17,K18,DPM2,DPO2,DPO3)
1860 OPEN K17$,R
1870 EXEC FEJL(11,E,K17$)
1880 OPEN K18$,W
1890 EXEC FEJL(11,G,K18$)
1900 L=E
1910 M=E
1920 P=E
1930 TEST=B
1940 IF DPM2<>B AND DPO2<>B THEN
1950 REPEAT
1960 IF TEST=B THEN
1970 EXEC FGET2(K17$,L,NO,DO,BIO,TKO$,BEO$,TEO$,ENTO)
1980 L=L+E
1990 TEST=E
2000 ENDIF
2010 IF M<J THEN
2020 Q=PEG(M)
2030 ELSE
2040 N(Q)=100000
2050 ENDIF
2060 IF N(Q)<NO THEN
2070 EXEC FPUT2(K18$,P,N(Q),D(Q),BI(Q),TK$(Q),BE$(Q),TE$(Q),ENT(Q))
2080 M=M+E
2090 ELSE
2100 IF N(Q)=NO AND D(Q)<DO THEN
2110 EXEC FPUT2(K18$,P,N(Q),D(Q),BI(Q),TK$(Q),BE$(Q),TE$(Q),ENT(Q))
2120 M=M+E
2130 ELSE
2140 EXEC FPUT2(K18$,P,NO,DO,BIO,TKO$,BEO$,TEO$,ENTO)
2150 TEST=B
2160 ENDIF
2170 ENDIF
2180 P=P+E
2190 UNTIL (DPO2=L-E OR M=J) AND TEST=B
2200 IF DPO2=L-E THEN
2210 STYR=E
2220 ELSE
2230 STYR=B
2240 ENDIF
2250 ELSE
2260 IF DPM2=B THEN
2270 STYR=B
2280 ELSE
2290 STYR=E
2300 ENDIF
2310 ENDIF
2320 IF STYR=E THEN
2330 FOR I=M TO J-E
2340 Q=PEG(I)
2350 EXEC FPUT2(K18$,P,N(Q),D(Q),BI(Q),TK$(Q),BE$(Q),TE$(Q),ENT(Q))
2360 P=P+E
2370 NEXT I
2380 ELSE
2390 FOR I=L TO DPO2
2400 EXEC FGET2(K17$,I,NO,DO,BIO,TKO$,BEO$,TEO$,ENTO)
2410 EXEC FPUT2(K18$,P,NO,DO,BIO,TKO$,BEO$,TEO$,ENTO)
2420 P=P+E
2430 NEXT I
2440 ENDIF
2450 DPO3=P-E
2460 CLOSE K17$
2470 EXEC FEJL(11,V,K17$)
2480 CLOSE K18$
2490 EXEC FEJL(11,4,K18$)
2500 ENDPROC
2510 PROC TABINIT(K31,K32,MPOSTANTAL3,HTAB2,UTAB2)
2520 OPEN K31$,R
2530 EXEC FEJL(15,E,K31$)
2540 OPEN K32$,W
2550 EXEC FEJL(15,G,K32$)
2560 H=E
2570 FOR I=E TO MPOSTANTAL3 DIV 40
2580 GET K31$,H:KONR
2590 EXEC FEJL(15,V,K31$)
2600 HTAB2(I,E)=KONR
2610 FOR J=E TO 4
2620 GET K31$,H:KONR
2630 EXEC FEJL(15,4,K31$)
2640 UTAB2(J,E)=KONR
2650 H=H+W
2660 GET K31$,H:KONR
2670 EXEC FEJL(15,5,K31$)
2680 UTAB2(J,G)=KONR
2690 H=H+E
2700 NEXT J
2710 HTAB2(I,G)=KONR
2720 EXEC UNDUD(K32$,I,UTAB2,MPOSTANTAL3)
2730 NEXT I
2740 EXEC HOVUD(K32$,MPOSTANTAL3,HTAB2)
2750 CLOSE K31$
2760 EXEC FEJL(15,6,K31$)
2770 CLOSE K32$
2780 EXEC FEJL(15,7,K32$)
2790 ENDPROC ;TABINIT
2800 PROC UNDUD(V3,U2,T,MPOSTANT)
2810 U3=U2+MPOSTANT DIV 160
2820 PUT V3$,U3:T(E,E),T(E,G),T(G,E),T(G,G),T(V,E),T(V,G),T(4,E),T(4,G)
2830 EXEC FEJL(16,E,V3$)
2840 ENDPROC ;UNDUD
2850 PROC HOVUD(V4,MPOSTANTAL4,S)
2860 FOR I=E TO MPOSTANTAL4 DIV 160
2870 J=(I-E)*4+E;J1=J+E;J2=J+G;J3=J+V
2880 PUT V4$,I:S(J,E),S(J,G),S(J1,E),S(J1,G),S(J2,E),S(J2,G),S(J3,E),S(J3,G)
2890 EXEC FEJL(17,G,V4$)
2900 NEXT I
2910 ENDPROC