DataMuseum.dk

top - download

    Length: 10422 (0x28b6)
    Types: SPC/1-COMAL-BIN
    Notes: Mikados_B
    Names: »AKKHVEDL.B«

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

SPC/1 COMAL-BIN

0100 DIM AKK$(49),NR$(606),Å(100),M(30),FIL8$(20),FIL9$(20),AKKNR$(6)
0110 DIM RES$(15),OP1$(12),OP2$(12),RESUL$(12),TAH$(12),B3$(12),DAD$(6)
0120 PROC CALC(AR3,B1,B2,ES)
0130 RES$=ES$;OP1$=B1$;OP2$=B2$;SI=B;FLAG=B;ART=AR3-6*(AR3>5)
0140 CALL "P641210:REGN"
0150 IF AR3<6 THEN
0160 IF FLAG THEN STOP
0170 ENDIF
0180 ES$=RES$
0190 ENDPROC
0191 DIM FIL$(20)
0192 FIL$="P641220:VIRKKART"
0193 OPEN FIL$,R
0194 EXEC FEJL(B,B,FIL$)
0195 GET FIL$,V:DAD$
0196 CLOSE FIL$
0198 B3$="          0+"
0199 TI=10;EL=11
0200 PROC Æ(I1,I2)
0205 I1$=B3$
0210 IF I2<>B THEN
0215 I1$(W,TI)=",0";I0=ABS(I2);K0=INT((I0-INT(I0))*100+0.50001)
0220 IF I2<B THEN I1$(12)="-"
0225 FOR I=EL TO E STEP -E
0230 IF I<>W THEN
0235 I1$(I)=CHR(K0 MOD TI+48)
0240 K0=K0 DIV TI
0245 IF K0=B AND I<TI THEN I=B
0250 ELSE
0255 K0=INT(I0)
0260 ENDIF
0265 NEXT I
0270 ENDIF
0275 ENDPROC
0300 PROC INDAKK
0310 L=E;U=MAX
0320 IF U>B THEN
0330 REPEAT
0340 PEG=(L+U) DIV G
0350 IF AKKNR$>NR$((PEG-E)*6+E:6) THEN
0360 L=PEG+E
0370 ELSE
0380 U=PEG-E
0390 ENDIF
0400 UNTIL L>U OR AKKNR$=NR$((PEG-E)*6+E:6)
0410 ENDIF
0420 L=U+E
0430 IF NR$((L-E)*6+E:6)=AKKNR$ THEN
0440 FOUND=E
0450 PEG=Å(L)
0460 GET FIL8$,PEG:AKK$(E,27),TTIMER,RTIMER
0470 GET FIL8$,PEG+E:AKK$(28,49),M(E),M(G),M(V)
0480 GET FIL8$,PEG+G:M(4),M(5),M(6),M(7),M(8),M(W),M(10),M(11),M(12)
0490 GET FIL8$,PEG+V:M(13),M(14),M(15),M(16),M(17),M(18),M(19),M(20),M(21)
0500 GET FIL8$,PEG+4:M(22),M(23),M(24),M(25),M(26),M(27),M(28),M(29),M(30)
0510 EXEC FEJL(B,PEG,FIL8$)
0520 IF AKK$(E,6)<>AKKNR$ THEN FOUND=-E
0530 ELSE
0540 FOUND=B
0550 ENDIF
0560 ENDPROC
0570 PROC UDAKK
0580 PUT FIL8$,PEG:AKK$(E,27),TTIMER,RTIMER
0590 PUT FIL8$,PEG+E:AKK$(28,49),M(E),M(G),M(V)
0600 PUT FIL8$,PEG+G:M(4),M(5),M(6),M(7),M(8),M(W),M(10),M(11),M(12)
0610 PUT FIL8$,PEG+V:M(13),M(14),M(15),M(16),M(17),M(18),M(19),M(20),M(21)
0620 PUT FIL8$,PEG+4:M(22),M(23),M(24),M(25),M(26),M(27),M(28),M(29),M(30)
0630 EXEC FEJL(E,PEG,FIL8$)
0640 ENDPROC
0650 PROC INDSÆT
0660 FOUND=B
0670 U=MAX+E
0680 IF U<101 THEN
0690 FOUND=E;MAX=U
0700 GN=Å(U)
0710 PEG=U
0720 WHILE PEG>L DO
0730 Å(PEG)=Å(PEG-E)
0740 NR$((PEG-E)*6+E:6)=NR$((PEG-G)*6+E:6)
0750 PEG=PEG-E
0760 ENDWHILE
0770 Å(L)=GN
0780 NR$((L-E)*6+E:6)=AKKNR$
0790 PEG=GN
0800 EXEC UDAKK
0810 ENDIF
0820 ENDPROC
0830 PROC SLET
0840 GN=Å(L)
0850 WHILE L<MAX DO
0860 NR$((L-E)*6+E:6)=NR$(L*6+E:6)
0870 Å(L)=Å(L+E)
0880 L=L+E
0890 ENDWHILE
0900 NR$((L-E)*6+E:6)="      "
0910 Å(L)=GN
0920 MAX=MAX-E
0930 ENDPROC
0940 PROC INDTABEL
0950 FIL9$="P641220:AKKTABEL"
0960 OPEN FIL9$,R
0970 EXEC FEJL(B,B,FIL9$)
0980 FOR I=E TO 10
0990 GET FIL9$:NR$((I-E)*60+E:60)
1000 NEXT I
1010 GET FIL9$:Å(E),Å(G),Å(V),Å(4),Å(5),Å(6),Å(7),Å(8),Å(W),Å(10)
1020 GET FIL9$:Å(11),Å(12),Å(13),Å(14),Å(15),Å(16),Å(17),Å(18),Å(19),Å(20)
1030 GET FIL9$:Å(21),Å(22),Å(23),Å(24),Å(25),Å(26),Å(27),Å(28),Å(29),Å(30)
1040 GET FIL9$:Å(31),Å(32),Å(33),Å(34),Å(35),Å(36),Å(37),Å(38),Å(39),Å(40)
1050 GET FIL9$:Å(41),Å(42),Å(43),Å(44),Å(45),Å(46),Å(47),Å(48),Å(49),Å(50)
1060 GET FIL9$:Å(51),Å(52),Å(53),Å(54),Å(55),Å(56),Å(57),Å(58),Å(59),Å(60)
1070 GET FIL9$:Å(61),Å(62),Å(63),Å(64),Å(65),Å(66),Å(67),Å(68),Å(69),Å(70)
1080 GET FIL9$:Å(71),Å(72),Å(73),Å(74),Å(75),Å(76),Å(77),Å(78),Å(79),Å(80)
1090 GET FIL9$:Å(81),Å(82),Å(83),Å(84),Å(85),Å(86),Å(87),Å(88),Å(89),Å(90)
1100 GET FIL9$:Å(91),Å(92),Å(93),Å(94),Å(95),Å(96),Å(97),Å(98),Å(99),Å(100)
1110 EXEC FEJL(E,B,FIL9$)
1120 FOR I=B TO 99
1130 IF NR$(I*6+E:6)="      " THEN
1140 MAX=I;I=100
1150 ENDIF
1160 NEXT I
1170 CLOSE FIL9$
1180 ENDPROC
1190 PROC UDTABEL
1200 OPEN FIL9$,W
1210 EXEC FEJL(G,B,FIL9$)
1220 FOR I=E TO 10
1230 PUT FIL9$:NR$((I-E)*60+E:60)
1240 NEXT I
1250 PUT FIL9$:Å(E),Å(G),Å(V),Å(4),Å(5),Å(6),Å(7),Å(8),Å(W),Å(10)
1260 PUT FIL9$:Å(11),Å(12),Å(13),Å(14),Å(15),Å(16),Å(17),Å(18),Å(19),Å(20)
1270 PUT FIL9$:Å(21),Å(22),Å(23),Å(24),Å(25),Å(26),Å(27),Å(28),Å(29),Å(30)
1280 PUT FIL9$:Å(31),Å(32),Å(33),Å(34),Å(35),Å(36),Å(37),Å(38),Å(39),Å(40)
1290 PUT FIL9$:Å(41),Å(42),Å(43),Å(44),Å(45),Å(46),Å(47),Å(48),Å(49),Å(50)
1300 PUT FIL9$:Å(51),Å(52),Å(53),Å(54),Å(55),Å(56),Å(57),Å(58),Å(59),Å(60)
1310 PUT FIL9$:Å(61),Å(62),Å(63),Å(64),Å(65),Å(66),Å(67),Å(68),Å(69),Å(70)
1320 PUT FIL9$:Å(71),Å(72),Å(73),Å(74),Å(75),Å(76),Å(77),Å(78),Å(79),Å(80)
1330 PUT FIL9$:Å(81),Å(82),Å(83),Å(84),Å(85),Å(86),Å(87),Å(88),Å(89),Å(90)
1340 PUT FIL9$:Å(91),Å(92),Å(93),Å(94),Å(95),Å(96),Å(97),Å(98),Å(99),Å(100)
1350 ENDPROC
1360 PROC CHECK(NR1,OK1)
1370 OK1=B
1380 RESULT=B
1390 IF LEN(NR1$)>B THEN
1400 IF NR1$(E)="-" THEN
1410 FORTEGN=-E
1420 OK1=E
1430 ELSE
1440 FORTEGN=E
1450 ENDIF
1460 WHILE LEN(NR1$)>OK1
1470 OK1=OK1+E
1480 IF NR1$(OK1)<"0" OR NR1$(OK1)>"9" THEN
1490 FORTEGN=B
1500 OK1=LEN(NR1$)
1510 ENDIF
1520 RESULT=RESULT*10+ORD(NR1$(OK1))-48
1530 ENDWHILE
1540 OK1=OK1*FORTEGN
1550 IF OK1<B THEN OK1=OK1+E
1560 ENDIF
1570 ENDPROC
1580 PROC INOPL(OPL)
1590 EXEC INLINE(OPL)
1600 CASE OPL OF
1610 WHEN E
1620 AKK$(E,6)=LINE$
1630 WHEN G
1640 AKK$(7,27)=LINE$
1650 WHEN V
1660 WHILE RESULT<E
1670 EXEC INLINE(OPL)
1680 ENDWHILE
1690 RTIMER=RESULT
1700 WHEN 4
1710 REPEAT
1720 LINE$=LINE$+"+"
1730 EXEC CALC(6,LINE$,TAH$,RESUL$)
1740 IF FLAG<>B THEN EXEC INLINE(OPL)
1750 UNTIL FLAG=B
1760 AKK$(39,49)=RESUL$(G:11)
1770 ENDCASE
1780 ENDPROC
1790 PROC SKRIVOPL
1800 IF OUTP=B THEN
1810 CLEAR
1820 ELSE
1830 PRINT
1840 PRINT
1850 PRINT
1860 ENDIF
1870 LINES=4
1880 PRINT "A K K O R D - H O V E D E R";TAB(60);"Dato ";DAD$
1890 FOR J=E TO A
1900 CASE J OF
1910 WHEN E
1920 LINE$="     "+AKK$(E,6)
1930 WHEN G
1940 LINE$=AKK$(7,27)
1950 WHEN V
1960 EXEC Æ(LINE$,RTIMER)
1965 IF LINE$(12)="+" THEN LINE$(12)=" "
1970 WHEN 4
1980 LINE$=" "+AKK$(39,49)
1990 IF LINE$(12)="+" THEN LINE$(12)=" "
2000 WHEN 5
2010 EXEC Æ(LINE$,TTIMER)
2015 IF LINE$(12)="+" THEN LINE$(12)=" "
2020 WHEN 6
2030 LINE$=" "+AKK$(28,38)
2040 IF LINE$(12)="+" THEN LINE$(12)=" "
2050 ENDCASE
2060 LINES=LINES+E
2070 IF OUTP=B THEN
2080 EXEC OUTLINE(J)
2090 ELSE
2100 EXEC OUTPLINE(J)
2110 ENDIF
2120 NEXT J
2130 PRINT
2140 PRINT "Medarbejdere på akkorden"
2150 LINES=LINES+V
2160 ANTPR=B
2170 FOR J=E TO 30
2180 IF M(J)<>B THEN
2190 ANTPR=ANTPR+E
2200 IF ANTPR MOD 6=B THEN
2210 PRINT
2220 LINES=LINES+E
2230 ENDIF
2240 PRINT M(J),
2250 ENDIF
2260 NEXT J
2270 PRINT
2280 ENDPROC
2290 PROC OUTLINE(N)
2300 CURSOR X(N),Y(N)
2310 PRINT USING "### ":N;
2320 PRINT PICT$(N);":";TAB(25);LINE$
2330 ENDPROC
2340 PROC FEJL(P1,P2,P3)
2350 IF STATUS(P3$)<>B THEN
2360 OUTPUT T
2370 PRINT "FIL-FEJL ";P3$;STATUS(P3$),P1;P2
2380 STOP
2390 ENDIF
2400 ENDPROC
2410 PROC INLINE(N)
2420 REPEAT
2430 CURSOR 25,Y(N)
2440 PRINT BL$(E:ABS(TYPE(N))+6)
2450 CURSOR X(N),Y(N)
2460 PRINT USING "### ":N;
2470 PRINT PICT$(N);":";
2480 CURSOR 25,Y(N)
2490 INPUT "",LINE$
2500 IF TYPE(N)<B THEN
2510 IF LEN(LINE$)<=ABS(TYPE(N)) THEN
2520 OK=E
2530 FOR I=LEN(LINE$)+E TO ABS(TYPE(N))
2540 LINE$(I)=" "
2550 NEXT I
2560 ELSE
2570 OK=B
2580 ENDIF
2590 ELSE
2600 EXEC CHECK(LINE$,OK)
2610 IF TYPE(N)>B AND TYPE(N)<>OK THEN OK=B
2620 ENDIF
2630 UNTIL OK<>B
2640 ENDPROC
2650 PROC SKRIVPICT
2660 CLEAR
2670 PRINT "A K K O R D - H O V E D E R"
2680 FOR I=E TO A
2690 CURSOR X(I),Y(I)
2700 PRINT "    ";
2710 PRINT PICT$(I);":"
2720 NEXT I
2730 ENDPROC
2740 PROC OUTPLINE(N)
2750 PRINT TAB(X(N));
2760 PRINT USING "### ":N;
2770 PRINT PICT$(N);":";TAB(25);LINE$
2780 ENDPROC
2790 A=6
2800 DIM X(A),Y(A),PICT$(A,20),TYPE(A)
2810 DIM BL$(79),LINE$(30)
2820 TAH$="          0+"
2830 FOR I=E TO 79
2840 BL$=BL$+" "
2850 NEXT I
2860 X(E)=E
2870 X(G)=E
2880 X(V)=E
2890 X(4)=E
2900 X(5)=E
2910 X(6)=E
2920 Y(E)=V
2930 Y(G)=4
2940 Y(V)=5
2950 Y(4)=6
2960 Y(5)=7
2970 Y(6)=8
2980 TYPE(E)=-6
2990 TYPE(G)=-21
3000 TYPE(V)=B
3010 TYPE(4)=-11
3020 PICT$(E)="Akkord-nr"
3030 PICT$(G)="Tekst"
3040 PICT$(V)="Timer til rådighed"
3050 PICT$(4)="Beløb til rådighed"
3060 PICT$(5)="Total timer"
3070 PICT$(6)="Total beløb"
3080 OUTP=B
3090 FIL8$="P641220:AKKHOVED"
3100 OPEN FIL8$,W
3110 EXEC FEJL(B,B,FIL8$)
3120 EXEC INDTABEL
3130 REPEAT
3140 SV=G
3150 CLEAR
3160 CURSOR 10,10
3170 PRINT "A K K O R D - H O V E D E R"
3180 PRINT
3190 PRINT TAB(10);"0 Færdig"
3200 PRINT TAB(10);"1 Ændring"
3210 PRINT TAB(10);"2 Udskrift på skærm"
3220 PRINT TAB(10);"3 Udskrift på printer"
3230 PRINT TAB(10);"4 Oprettelse"
3240 PRINT TAB(10);"5 Sletning"
3250 PRINT
3260 REPEAT
3270 CURSOR E,19
3280 EDIT "          ",SV
3290 UNTIL SV=>B AND SV<=5
3300 IF SV>B THEN
3310 EXEC INOPL(1)
3320 AKKNR$=AKK$(E,6)
3330 EXEC INDAKK
3340 CASE SV OF
3350 WHEN E
3360 IF FOUND=E THEN
3370 EXEC SKRIVOPL
3380 REPEAT
3390 REPEAT
3400 SV1=B
3410 CURSOR E,23
3420 EDIT "Feltnr ",SV1
3430 UNTIL SV1>E AND SV1<5 OR SV1=B
3440 IF SV1>B THEN
3450 EXEC INOPL(SV1)
3460 ENDIF
3470 UNTIL SV1=B
3480 EXEC UDAKK
3490 ELSE
3500 IF FOUND=B THEN
3510 INPUT "Akkord findes ikke, RETURN ",LINE$
3520 ELSE
3530 INPUT "Mystisk fejl, RETURN ",LINE$
3540 ENDIF
3550 ENDIF
3560 WHEN G
3570 IF FOUND=E THEN
3580 OUTP=B
3590 EXEC SKRIVOPL
3600 INPUT "RETURN",LINE$
3610 ELSE
3620 IF FOUND=B THEN
3630 INPUT "Akkord findes ikke, RETURN ",LINE$
3640 ELSE
3650 INPUT "Mystisk fejl, RETURN ",LINE$
3660 ENDIF
3670 ENDIF
3680 WHEN V
3681 IF AKKNR$="0     " THEN
3682 ALL=E
3683 AKKNR$=NR$((ALL-E)*6+E:6)
3684 EXEC INDAKK
3685 ELSE
3686 ALL=MAX
3687 ENDIF
3688 REPEAT
3690 IF FOUND=E THEN
3700 OUTPUT P
3710 OUTP=E
3720 EXEC SKRIVOPL
3730 REPEAT
3740 PRINT
3750 LINES=LINES+E
3760 UNTIL LINES=72
3770 OUTP=B
3780 OUTPUT T
3790 ELSE
3800 IF FOUND=B THEN
3810 INPUT "Akkord findes ikke, RETURN ",LINE$
3820 ELSE
3830 INPUT "Mystisk fejl, RETURN ",LINE$
3840 ENDIF
3850 ENDIF
3851 ALL=ALL+E
3852 IF ALL<=MAX THEN
3853 AKKNR$=NR$((ALL-E)*6+E:6)
3854 EXEC INDAKK
3855 ENDIF
3856 UNTIL ALL>MAX
3860 WHEN 4
3870 IF FOUND=E THEN
3880 INPUT "Akkord findes, RETURN ",LINE$
3890 ELSE
3900 EXEC SKRIVPICT
3910 LINE$=AKKNR$
3920 EXEC OUTLINE(1)
3930 FOR J=G TO 4
3940 EXEC INOPL(J)
3950 NEXT J
3960 AKK$(28,38)="         0+"
3970 TTIMER=B
3980 FOR J=E TO 30
3990 M(J)=B
4000 NEXT J
4010 REPEAT
4020 REPEAT
4030 SV1=B
4040 CURSOR E,23
4050 EDIT "Feltnr ",SV1
4060 UNTIL SV1>E AND SV1<5 OR SV1=B
4070 IF SV1>B THEN
4080 EXEC INOPL(SV1)
4090 ENDIF
4100 UNTIL SV1=B
4110 EXEC INDSÆT
4120 ENDIF
4130 WHEN 5
4140 FOR I=E TO 30
4150 IF M(I)<>B THEN
4160 FOUND=B
4170 I=40
4180 ENDIF
4190 NEXT I
4200 IF FOUND=E THEN
4210 SV1=G
4220 EXEC SKRIVOPL
4230 WHILE SV1<>B AND SV1<>E
4240 SV1=B
4250 CURSOR E,23
4260 EDIT "Sletning korrekt 1:  ",SV1
4270 ENDWHILE
4280 IF SV1=E THEN
4290 EXEC SLET
4300 ENDIF
4310 ELSE
4320 INPUT "Akkord kan ikke slettes, RETURN ",LINE$
4330 ENDIF
4340 ENDCASE
4350 ENDIF
4360 UNTIL SV=B
4370 EXEC UDTABEL
4380 CLOSE
4390 CHAIN "P641210:STARTB"