DataMuseum.dk

top - download

    Length: 12640 (0x3160)
    Types: TextFile
    Notes: Mikados_K
    Names: »AKKHVEDL.K«

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

Mikados K File

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