DataMuseum.dk

top - download

    Length: 10112 (0x2780)
    Types: TextFile
    Notes: Mikados_K
    Names: »LØNARTVD.K«

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

Mikados K File

0009DIM POST6$(29),FIL5$(20),TVN(45) 
0011TVN(E)=E 
0012TVN(G)=G 
0013TVN(V)=V 
0014TVN(4)=4 
0015TVN(5)=5 
0016TVN(6)=7 
0017TVN(7)=8 
0018TVN(8)=W 
0019TVN(W)=10 
0020TVN(10)=11 
0021TVN(11)=12 
0022TVN(12)=13 
0023TVN(13)=14 
0024TVN(14)=15 
0025TVN(15)=16 
0026TVN(16)=112 
0027TVN(17)=113 
0028TVN(18)=313 
0029TVN(19)=413 
0030TVN(20)=115 
0031TVN(21)=315 
0032TVN(22)=415 
0033TVN(23)=116 
0034TVN(24)=316 
0035TVN(25)=416 
0036TVN(26)=117 
0037TVN(27)=317 
0038TVN(28)=417 
0039TVN(29)=123 
0040TVN(30)=206 
0041TVN(31)=212 
0042TVN(32)=214 
0043TVN(33)=218 
0044TVN(34)=219 
0045TVN(35)=319 
0046TVN(36)=419 
0047TVN(37)=220 
0048TVN(38)=320 
0049TVN(39)=420 
0050TVN(40)=221 
0051TVN(41)=321 
0052TVN(42)=421 
0053TVN(43)=222 
0054TVN(44)=223 
0055TVN(45)=224 
0199DIM FIL$(20),DAD$(6) 
0200PROC INDVIRK 
0205FIL$="P641220:VIRKKART" 
0210OPEN FIL$,R 
0220EXEC FEJL(B,B,FIL$) 
0245GET FIL$,V:DAD$ 
0247CLOSE FIL$ 
0250ENDPROC  
1000PROC CONV(NR2,OK22,CIF) 
1015OK2=OK22 
1030NR2$="" 
1045REPEAT  
1060NR2$=CHR((OK2 MOD 10)+48)+NR2$ 
1075CIF=CIF-E 
1090OK2=OK2 DIV 10 
1105IF CIF<B AND OK2=B THEN CIF=B 
1120UNTIL CIF=B 
1135ENDPROC  
1150PROC CHECK(NR1,OK1) 
1165OK1=B 
1180RESULT=B 
1195IF LEN(NR1$)>B THEN  
1210IF NR1$(E)="-" THEN  
1225FORTEGN=-E 
1240OK1=E 
1255ELSE  
1270FORTEGN=E 
1285ENDIF  
1300WHILE LEN(NR1$)>OK1 
1315OK1=OK1+E 
1330IF NR1$(OK1)<"0" OR NR1$(OK1)>"9" THEN  
1345FORTEGN=B 
1360OK1=LEN(NR1$) 
1375ENDIF  
1390RESULT=RESULT*10+ORD(NR1$(OK1))-48 
1405ENDWHILE  
1420OK1=OK1*FORTEGN 
1435IF OK1<B THEN OK1=OK1+E 
1450ENDIF  
1465ENDPROC  
1480PROC INOPL(OPL) 
1495EXEC INLINE(OPL) 
1510CASE OPL OF  
1525WHEN E 
1540LANR=RESULT 
1555WHEN G 
1556WHILE LINE$(E)=" " 
1557EXEC INLINE(OPL) 
1558ENDWHILE  
1559POST6$(E)="1" 
1570POST6$(G,21)=LINE$ 
1585WHEN V 
1600WHILE RESULT<E OR RESULT=6 OR RESULT>11 
1601EXEC INLINE(OPL) 
1602ENDWHILE  
1610KT=RESULT-(RESULT>6) 
1620ÅT=B 
2950ENDCASE  
2965ENDPROC  
2980PROC SKRIVOPL 
2995IF OUTP=B THEN CLEAR  
2998PRINT "L Ø N A R T S - K A R T O T E K";TAB(60);"Dato ";DAD$ 
3010FOR J=E TO A 
3025CASE J OF  
3040WHEN E 
3055EXEC CONV(LINE$,LANR,2) 
3056LINE$=POST6$(29)+LINE$ 
3070WHEN G 
3085LINE$=POST6$(G,21) 
3100WHEN V 
3101IF KT=B THEN  
3102TV=B 
3103ELSE  
3104TV=TVN(KT) 
3105ENDIF  
3115EXEC CONV(LINE$,TV,3) 
3130WHEN 4 
3131IF FSHT=B THEN  
3132TV=B 
3133ELSE  
3134TV=TVN(FSHT) 
3135ENDIF  
3145EXEC CONV(LINE$,TV,3) 
3160WHEN 5 
3161IF ÅT=B THEN  
3162TV=B 
3163ELSE  
3164TV=TVN(ÅT) 
3165ENDIF  
3175EXEC CONV(LINE$,TV,3) 
3190WHEN 6,7,8,W,10,11,12 
3205IF POST6$(16+J)="0" THEN  
3220LINE$="NEJ" 
3235ELSE  
3250LINE$=" JA" 
3265ENDIF  
3730ENDCASE  
3745IF OUTP=B THEN  
3760EXEC OUTLINE(J) 
3775ELSE  
3790EXEC OUTPLINE(J) 
3805ENDIF  
3820NEXT J 
3835ENDPROC  
3850PROC OUTLINE(N) 
3865CURSOR X(N),Y(N) 
3880IF N<4 THEN  
3881PRINT USING "### ":N; 
3882ELSE  
3883IF N>5 THEN PRINT "    "; 
3884ENDIF  
3890IF N>V AND N<6 THEN  
3895PRINT PICT$(N);":";LINE$ 
3896ELSE  
3897PRINT PICT$(N);":";TAB(25);LINE$ 
3898ENDIF  
3910ENDPROC  
3925PROC INDART(N) 
3927GET FIL5$,N:POST6$,KT,FSHT,ÅT 
3929EXEC FEJL(G,N,FIL5$) 
3931ENDPROC  
3933PROC UDART(N) 
3935PUT FIL5$,N:POST6$,KT,FSHT,ÅT 
3937EXEC FEJL(E,N,FIL5$) 
3939ENDPROC  
3941PROC CH(N) 
3943OKAY=B 
3945IF N<40 THEN OKAY=E 
3947IF N>42 AND N<49 THEN OKAY=E 
3949IF N>50 AND N<57 THEN OKAY=E 
3951IF N>57 AND N<60 THEN OKAY=E 
3953IF N>60 AND N<65 THEN OKAY=E 
3955IF N<40 THEN  
3957SF=V 
3959ELSE  
3961SF=G 
3963ENDIF  
3965ENDPROC  
4015PROC FEJL(P1,P2,P3) 
4030IF STATUS(P3$)<>B THEN  
4045OUTPUT T 
4060PRINT "FIL-FEJL ";P3$;STATUS(P3$),P1;P2 
4075STOP  
4090ENDIF  
4105ENDPROC  
4120PROC INLINE(N) 
4135REPEAT  
4150CURSOR 25,Y(N) 
4165PRINT BL$(E:ABS(TYPE(N))+6) 
4180CURSOR X(N),Y(N) 
4195PRINT USING "### ":N; 
4214PRINT PICT$(N);":"; 
4215CURSOR 25,Y(N) 
4225INPUT "",LINE$ 
4240IF TYPE(N)<B THEN  
4255IF LEN(LINE$)<=ABS(TYPE(N)) THEN  
4270OK=E 
4285FOR I=LEN(LINE$)+E TO ABS(TYPE(N)) 
4300LINE$(I)=" " 
4315NEXT I 
4330ELSE  
4345OK=B 
4360ENDIF  
4375ELSE  
4390EXEC CHECK(LINE$,OK) 
4405IF TYPE(N)>B AND TYPE(N)<>OK THEN OK=B 
4420ENDIF  
4435UNTIL OK<>B 
4450ENDPROC  
4465PROC SKRIVPICT 
4480CLEAR  
4490PRINT "L Ø N A R T S - K A R T O T E K" 
4495FOR I=E TO A 
4510CURSOR X(I),Y(I) 
4520IF I<4 THEN  
4525PRINT USING "### ":I; 
4526ELSE  
4527IF I>5 THEN PRINT "    "; 
4528ENDIF  
4540PRINT PICT$(I);":" 
4555NEXT I 
4570ENDPROC  
4585PROC OUTPLINE(N) 
4600PRINT TAB(X(N)); 
4610IF N<4 THEN  
4615PRINT USING "### ":N; 
4616ELSE  
4617IF N>5 THEN PRINT "    "; 
4618ENDIF  
4620IF N>V AND N<6 THEN  
4630PRINT PICT$(N);":";LINE$; 
4632ELSE  
4634PRINT PICT$(N);":";TAB(25);LINE$; 
4635ENDIF  
4636IF N<V OR N>4 THEN PRINT  
4645ENDPROC  
4660A=12 
4675DIM X(A),Y(A),PICT$(A,20),TYPE(A) 
4705DIM BL$(79),LINE$(30) 
4720FOR I=E TO 79 
4735BL$=BL$+" " 
4750NEXT I 
4780X(E)=E 
4795X(G)=E 
4810X(V)=E 
4825X(4)=35 
4840X(5)=45 
4855X(6)=E 
4870X(7)=E 
4885X(8)=E 
4900X(W)=E 
4915X(10)=E 
4930X(11)=E 
4945X(12)=E 
5095Y(E)=V 
5110Y(G)=5 
5125Y(V)=7 
5140Y(4)=7 
5155Y(5)=7 
5170Y(6)=W 
5185Y(7)=11 
5200Y(8)=13 
5215Y(W)=15 
5230Y(10)=17 
5245Y(11)=19 
5260Y(12)=21 
5410TYPE(E)=B 
5425TYPE(G)=-20 
5440TYPE(V)=B 
5725PICT$(E)="LA-nr" 
5740PICT$(G)="Tekst" 
5755PICT$(V)="Tælleværk nr" 
5770PICT$(4)="" 
5785PICT$(5)="" 
5800PICT$(6)="Ferieberett løn" 
5815PICT$(7)="Trækpligtig A-indk" 
5830PICT$(8)="Trækfri A-indk" 
5845PICT$(W)="Nettoløndel" 
5860PICT$(10)="Fradrag M saldo" 
5875PICT$(11)="Fradrag U saldo" 
5890PICT$(12)="Udbetaling" 
6000EXEC INDVIRK 
6130OUTP=B 
6145FIL5$="P641220:LØNARTRG" 
6160OPEN FIL5$,W 
6175EXEC FEJL(B,B,FIL5$) 
6250REPEAT  
6265SV=G 
6280CLEAR  
6295CURSOR 10,10 
6310PRINT "L Ø N A R T S - K A R T O T E K" 
6325PRINT  
6340PRINT TAB(10);"0 Færdig" 
6355PRINT TAB(10);"1 Ændring" 
6370PRINT TAB(10);"2 Udskrift på skærm" 
6385PRINT TAB(10);"3 Udskrift på printer" 
6400PRINT TAB(10);"4 Oprettelse" 
6415PRINT TAB(10);"5 Sletning" 
6430PRINT  
6445REPEAT  
6460CURSOR E,19 
6475EDIT "          ",SV 
6490UNTIL SV=>B AND SV<=5 
6505IF SV>B THEN  
6520REPEAT  
6535EXEC INOPL(1) 
6550UNTIL LANR=>B AND LANR<=99 
6551LISTE=B 
6552IF LANR=B THEN LISTE=E 
6553REPEAT  
6554IF LISTE=E THEN LANR=LANR+E 
6565EXEC INDART(LANR) 
6580CASE SV OF  
6595WHEN E 
6600EXEC CH(LANR) 
6610IF POST6$(E)="1" AND OKAY=E THEN  
6625EXEC SKRIVOPL 
6640REPEAT  
6655REPEAT  
6670SV1=B 
6685CURSOR E,23 
6700EDIT "Feltnr ",SV1 
6715UNTIL SV1>E AND SV1<=SF OR SV1=B 
6730IF SV1>B THEN  
6745EXEC INOPL(SV1) 
6760ENDIF  
6775UNTIL SV1=B 
6790EXEC UDART(LANR) 
6805ELSE  
6820PRINT "Lønart kan ikke ændres" 
6835INPUT "RETURN",LINE$ 
6850ENDIF  
6865WHEN G 
6880IF POST6$(E)="1" THEN  
6895OUTP=B 
6910EXEC SKRIVOPL 
6925INPUT "RETURN",LINE$ 
6940ELSE  
6955PRINT "Lønart findes ikke" 
6970INPUT "RETURN",LINE$ 
6985ENDIF  
7000WHEN V 
7015IF POST6$(E)="1" OR LISTE=E THEN  
7016IF POST6$(E)="1" THEN  
7030OUTPUT P 
7045OUTP=E 
7060EXEC SKRIVOPL 
7061FOR I=12 TO 72 
7062PRINT  
7063NEXT I 
7075OUTP=B 
7090OUTPUT T 
7095ENDIF  
7105ELSE  
7120PRINT "Lønart findes ikke" 
7135INPUT "RETURN",LINE$ 
7150ENDIF  
7165WHEN 4 
7170EXEC CH(LANR) 
7180IF POST6$(E)="1" OR OKAY=B THEN  
7195PRINT "Lønart må ikke oprettes" 
7210INPUT "RETURN",LINE$ 
7225ELSE  
7240EXEC SKRIVOPL 
7255EXEC CONV(LINE$,LANR,2) 
7260LINE$=" "+LINE$ 
7270EXEC OUTLINE(1) 
7285FOR J=G TO SF 
7300EXEC INOPL(J) 
7315NEXT J 
7435REPEAT  
7450REPEAT  
7465SV1=B 
7480CURSOR E,23 
7495EDIT "Feltnr ",SV1 
7510UNTIL SV1>E AND SV1<=SF OR SV1=B 
7525IF SV1>B THEN  
7540EXEC INOPL(SV1) 
7555ENDIF  
7570UNTIL SV1=B 
7600EXEC UDART(LANR) 
7615ENDIF  
7630WHEN 5 
7640EXEC CH(LANR) 
7645IF POST6$(E)="1" AND OKAY=E THEN  
7660SV1=G 
7795EXEC SKRIVOPL 
7810WHILE SV1<>B AND SV1<>E 
7812SV1=B 
7825CURSOR E,23 
7840EDIT "Sletning korrekt 1:  ",SV1 
7855ENDWHILE  
7870IF SV1=E THEN  
7885POST6$(E,21)="0                    " 
7900EXEC UDART(LANR) 
7930ENDIF  
7945ELSE  
7960PRINT "Lønart kan ikke slettes" 
7975INPUT "RETURN",LINE$ 
7990ENDIF  
8005ENDCASE  
8006UNTIL LISTE=B OR LANR=>99 
8010ENDIF  
8020UNTIL SV=B 
8050CLOSE FIL5$ 
8065CHAIN "P641210:STARTB"