DataMuseum.dk

top - download

    Length: 11150 (0x2b8e)
    Types: SPC/1-COMAL-BIN
    Notes: Mikados_B
    Names: »LØNMODT.B«

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

SPC/1 COMAL-BIN

0010 DIM CPR(10),POST3$(55),POST4$(34),FIL2$(20),POST5$(55),POST6$(55)
0025 DIM NUL$(11),TV$(45,11),FIL1$(20),DAD$(6)
0040 PROC CPRCHECK(NR4,OK4)
0055 OK4=E
0070 FOR I=E TO 10
0085 CPR(I)=ORD(NR4$(I))-48
0100 NEXT I
0115 DATO=CPR(E)*10+CPR(G)
0130 MÅNED=CPR(V)*10+CPR(4)
0145 ÅR=CPR(5)*10+CPR(6)
0160 IF DATO<E OR MÅNED<E OR MÅNED>12 OR DATO>31 THEN OK4=B
0175 IF OK4=B THEN EXIT
0190 CASE MÅNED OF
0205 WHEN 4,6,W,11
0220 IF DATO>30 THEN OK4=B
0235 WHEN G
0250 IF DATO>29 THEN OK4=B
0265 IF DATO=29 AND ÅR MOD 4<>B THEN OK4=B
0280 ENDCASE
0295 IF OK4=B THEN EXIT
0310 MODULC=CPR(E)*4+CPR(G)*V+CPR(V)*G+CPR(4)*7+CPR(5)*6+CPR(6)*5+CPR(7)*4
0325 MODULC=MODULC+CPR(8)*V+CPR(W)*G+CPR(10)
0340 IF MODULC MOD 11<>B THEN OK4=B
0355 ENDPROC
0370 PROC DATOCHECK(NR5,OK5)
0385 OK5=E
0400 ÅR=(ORD(NR5$(E))-48)*10+ORD(NR5$(G))-48
0415 MÅNED=(ORD(NR5$(V))-48)*10+ORD(NR5$(4))-48
0430 DATO=(ORD(NR5$(5))-48)*10+ORD(NR5$(6))-48
0445 IF DATO<E OR MÅNED<E OR MÅNED>12 OR DATO>31 THEN OK5=B
0460 IF OK5=B THEN EXIT
0475 CASE MÅNED OF
0490 WHEN 4,6,W,11
0505 IF DATO>30 THEN OK5=B
0520 WHEN G
0535 IF DATO>29 THEN OK5=B
0550 IF DATO=29 AND ÅR MOD 4<>B THEN OK5=B
0565 ENDCASE
0580 ENDPROC
0581 PROC NULTRANS(N)
0582 J=(N-E)*ATPLM
0583 FOR I=E TO ATPLM
0584 PUT FIL1$,J+I:BL$(E,37)
0585 NEXT I
0586 EXEC FEJL(N,ATPLM,FIL1$)
0587 ENDPROC
0595 PROC NULTÆL(N)
0610 J=W*(N-E)+E
0625 FOR I=J TO J+8
0640 PUT FIL2$,I:POST6$
0655 NEXT I
0670 EXEC FEJL(I,N,FIL2$)
0685 ENDPROC
0700 PROC INDTÆL(N)
0715 J=W*(N-E)
0730 FOR K=6 TO W
0745 GET FIL2$,J+K:POST5$
0760 FOR I=E TO 5
0775 TV$((K-E)*5+I)=POST5$((I-E)*11+E:11)
0790 NEXT I
0805 NEXT K
0820 EXEC FEJL(N,K,FIL2$)
0835 ENDPROC
0850 PROC INLØNMOD(N)
0865 GET FIL$,G*N-E:POST1$
0880 GET FIL$,G*N:POST2$,C1,C2,LT,LF,LR,LA,RPI,K1,K2,FG,FD
0895 EXEC FEJL(E,N,FIL$)
0910 ENDPROC
0925 PROC UDLØNMOD(N)
0940 PUT FIL$,G*N-E:POST1$
0955 PUT FIL$,G*N:POST2$,C1,C2,LT,LF,LR,LA,RPI,K1,K2,FG,FD
0970 EXEC FEJL(G,N,FIL$)
0985 ENDPROC
1000 PROC CONV(NR2,OK22,CIF)
1015 OK2=OK22
1030 NR2$=""
1045 REPEAT
1060 NR2$=CHR((OK2 MOD 10)+48)+NR2$
1075 CIF=CIF-E
1090 OK2=OK2 DIV 10
1105 IF CIF<B AND OK2=B THEN CIF=B
1120 UNTIL CIF=B
1135 ENDPROC
1150 PROC CHECK(NR1,OK1)
1165 OK1=B
1180 RESULT=B
1195 IF LEN(NR1$)>B THEN
1210 IF NR1$(E)="-" THEN
1225 FORTEGN=-E
1240 OK1=E
1255 ELSE
1270 FORTEGN=E
1285 ENDIF
1300 WHILE LEN(NR1$)>OK1
1315 OK1=OK1+E
1330 IF NR1$(OK1)<"0" OR NR1$(OK1)>"9" THEN
1345 FORTEGN=B
1360 OK1=LEN(NR1$)
1375 ENDIF
1390 RESULT=RESULT*10+ORD(NR1$(OK1))-48
1405 ENDWHILE
1420 OK1=OK1*FORTEGN
1435 IF OK1<B THEN OK1=OK1+E
1450 ENDIF
1465 ENDPROC
1480 PROC INOPL(OPL)
1495 EXEC INLINE(OPL)
1510 CASE OPL OF
1525 WHEN E
1540 LMNR=RESULT
1555 WHEN G
1570 POST1$(E,25)=LINE$
1585 WHEN V
1600 POST1$(26,48)=LINE$
1615 WHEN 4
1630 POST1$(49,71)=LINE$
1645 WHEN 5
1660 POST2$(E,4)=LINE$
1675 WHEN 6
1690 POST2$(5,18)=LINE$
1705 WHEN 7
1720 EXEC CPRCHECK(LINE$,C1)
1735 WHILE C1=B
1750 EXEC INLINE(OPL)
1765 EXEC CPRCHECK(LINE$,C1)
1780 ENDWHILE
1795 C1=DATO*10000+MÅNED*100+ÅR
1810 C2=CPR(10)+CPR(W)*10+CPR(8)*100+CPR(7)*1000
1825 WHEN 8
1840 WHILE RESULT<B OR RESULT>99
1855 EXEC INLINE(OPL)
1870 ENDWHILE
1885 LT=RESULT
1900 WHEN W
1915 WHILE RESULT<B OR RESULT>999999
1930 EXEC INLINE(OPL)
1945 ENDWHILE
1960 LF=RESULT
1975 IF LF>B THEN
1990 LR=B
2005 EXEC CONV(LINE$,LR,6)
2020 EXEC OUTLINE(10)
2035 ENDIF
2050 WHEN 10
2065 WHILE RESULT<B OR RESULT>999999
2080 EXEC INLINE(OPL)
2095 ENDWHILE
2110 LR=RESULT
2125 IF LR>B THEN
2140 LF=B
2155 EXEC CONV(LINE$,LF,6)
2170 EXEC OUTLINE(9)
2185 ENDIF
2200 WHEN 11
2215 EXEC DATOCHECK(LINE$,LA)
2230 WHILE LA=B
2245 EXEC INLINE(OPL)
2260 EXEC DATOCHECK(LINE$,LA)
2275 ENDWHILE
2290 LA=RESULT
2305 WHEN 12
2320 POST2$(19,20)=LINE$
2335 WHEN 13
2350 RPI=RESULT
2365 WHEN 14
2380 K1=(ORD(LINE$(E))-48)*10000+(ORD(LINE$(G))-48)*1000
2395 K1=K1+(ORD(LINE$(V))-48)*100+(ORD(LINE$(4))-48)*10+ORD(LINE$(5))-48
2410 K2=(ORD(LINE$(6))-48)*10000+(ORD(LINE$(7))-48)*1000
2425 K2=K2+(ORD(LINE$(8))-48)*100+(ORD(LINE$(W))-48)*10+ORD(LINE$(10))-48
2440 WHEN 15
2455 WHILE RESULT<E OR RESULT>7
2470 EXEC INLINE(OPL)
2485 ENDWHILE
2500 POST2$(21)=LINE$
2515 WHEN 16
2530 WHILE RESULT<E OR RESULT>5
2545 EXEC INLINE(OPL)
2560 ENDWHILE
2575 POST2$(22)=LINE$
2590 WHEN 17
2605 WHILE RESULT<E OR RESULT>4
2620 EXEC INLINE(OPL)
2635 ENDWHILE
2650 POST2$(23)=LINE$
2665 WHEN 18
2680 WHILE RESULT<E
2695 EXEC INLINE(OPL)
2710 ENDWHILE
2725 POST2$(24,25)=LINE$
2740 WHEN 19
2755 FG=RESULT
2770 WHEN 20
2785 WHILE RESULT<B OR RESULT>V
2800 EXEC INLINE(OPL)
2815 ENDWHILE
2830 POST2$(26)=LINE$
2845 WHEN 21
2860 EXEC DATOCHECK(LINE$,FD)
2875 WHILE FD=B AND RESULT<>B
2890 EXEC INLINE(OPL)
2905 EXEC DATOCHECK(LINE$,FD)
2920 ENDWHILE
2935 FD=RESULT
2950 ENDCASE
2965 ENDPROC
2980 PROC SKRIVOPL
2995 IF OUTP=B THEN CLEAR
3000 PRINT "L Ø N M O D T A G E R K A R T O T E K";TAB(60);"Dato ";DAD$
3010 FOR J=E TO A
3025 CASE J OF
3040 WHEN E
3055 EXEC CONV(LINE$,LMNR,0)
3070 WHEN G
3085 LINE$=POST1$(E,25)
3100 WHEN V
3115 LINE$=POST1$(26,48)
3130 WHEN 4
3145 LINE$=POST1$(49,71)
3160 WHEN 5
3175 LINE$=POST2$(E,4)
3190 WHEN 6
3205 LINE$=POST2$(5,18)
3220 WHEN 7
3235 EXEC CONV(LINE$,C1,6)
3250 EXEC CONV(LINE1$,C2,4)
3265 LINE$=LINE$+LINE1$
3280 WHEN 8
3295 EXEC CONV(LINE$,LT,0)
3310 WHEN W
3325 EXEC CONV(LINE$,LF,6)
3340 WHEN 10
3355 EXEC CONV(LINE$,LR,6)
3370 WHEN 11
3385 EXEC CONV(LINE$,LA,6)
3400 WHEN 12
3415 LINE$=POST2$(19,20)
3430 WHEN 13
3445 EXEC CONV(LINE$,RPI,6)
3460 WHEN 14
3475 EXEC CONV(LINE$,K1,5)
3490 EXEC CONV(LINE1$,K2,5)
3505 LINE$=LINE$+LINE1$
3520 WHEN 15
3535 LINE$=POST2$(21)
3550 WHEN 16
3565 LINE$=POST2$(22)
3580 WHEN 17
3595 LINE$=POST2$(23)
3610 WHEN 18
3625 LINE$=POST2$(24,25)
3640 WHEN 19
3655 EXEC CONV(LINE$,FG,5)
3670 WHEN 20
3685 LINE$=POST2$(26)
3700 WHEN 21
3715 EXEC CONV(LINE$,FD,6)
3730 ENDCASE
3745 IF OUTP=B THEN
3760 EXEC OUTLINE(J)
3775 ELSE
3790 EXEC OUTPLINE(J)
3805 ENDIF
3820 NEXT J
3835 ENDPROC
3850 PROC OUTLINE(N)
3865 CURSOR X(N),Y(N)
3880 PRINT USING "### ":N;
3895 PRINT PICT$(N);":";LINE$
3910 ENDPROC
3925 PROC INDVIRK
3940 OPEN FIL$,W
3955 EXEC FEJL(B,B,FIL$)
3970 GET FIL$,E:POST3$
3985 GET FIL$,G:POST4$,SLJNR,MLMNR,ATPLM
3990 GET FIL$,V:DAD$
4000 ENDPROC
4015 PROC FEJL(P1,P2,P3)
4030 IF STATUS(P3$)<>B THEN
4045 OUTPUT T
4060 PRINT "FIL-FEJL ";P3$;STATUS(P3$),P1;P2
4075 STOP
4090 ENDIF
4105 ENDPROC
4120 PROC INLINE(N)
4135 REPEAT
4150 CURSOR X(N)+5+LEN(PICT$(N)),Y(N)
4165 PRINT BL$(E:ABS(TYPE(N))+V)
4180 CURSOR X(N),Y(N)
4195 PRINT USING "### ":N;
4210 PRINT PICT$(N);":";
4225 INPUT "",LINE$
4240 IF TYPE(N)<B THEN
4255 IF LEN(LINE$)<=ABS(TYPE(N)) THEN
4270 OK=E
4285 FOR I=LEN(LINE$)+E TO ABS(TYPE(N))
4300 LINE$(I)=" "
4315 NEXT I
4330 ELSE
4345 OK=B
4360 ENDIF
4375 ELSE
4390 EXEC CHECK(LINE$,OK)
4405 IF TYPE(N)>B AND TYPE(N)<>OK THEN OK=B
4420 ENDIF
4435 UNTIL OK<>B
4450 ENDPROC
4465 PROC SKRIVPICT
4480 CLEAR
4495 FOR I=E TO A
4510 CURSOR X(I),Y(I)
4525 PRINT USING "### ":I;
4540 PRINT PICT$(I);":"
4555 NEXT I
4570 ENDPROC
4585 PROC OUTPLINE(N)
4600 PRINT TAB(X(N));
4615 PRINT USING "### ":N;
4630 PRINT PICT$(N);":";LINE$;
4632 IF N=21 THEN
4634 PRINT
4636 ELSE
4638 IF Y(N)<Y(N+E) THEN PRINT
4640 ENDIF
4645 ENDPROC
4660 A=21
4675 DIM X(A),Y(A),PICT$(A,20),TYPE(A)
4690 DIM POST1$(71),POST2$(27)
4705 DIM BL$(79),LINE$(30),FIL$(20),LINE1$(30)
4720 FOR I=E TO 79
4735 BL$=BL$+" "
4750 NEXT I
4765 FIL$="P641220:VIRKKART"
4780 X(E)=E
4795 X(G)=30
4810 X(V)=E
4825 X(4)=E
4840 X(5)=E
4855 X(6)=30
4870 X(7)=E
4885 X(8)=30
4900 X(W)=E
4915 X(10)=30
4930 X(11)=E
4945 X(12)=30
4960 X(13)=E
4975 X(14)=30
4990 X(15)=E
5005 X(16)=30
5020 X(17)=60
5035 X(18)=E
5050 X(19)=30
5065 X(20)=60
5080 X(21)=E
5095 Y(E)=G
5110 Y(G)=G
5125 Y(V)=4
5140 Y(4)=6
5155 Y(5)=8
5170 Y(6)=8
5185 Y(7)=10
5200 Y(8)=10
5215 Y(W)=12
5230 Y(10)=12
5245 Y(11)=14
5260 Y(12)=14
5275 Y(13)=16
5290 Y(14)=16
5305 Y(15)=18
5320 Y(16)=18
5335 Y(17)=18
5350 Y(18)=20
5365 Y(19)=20
5380 Y(20)=20
5395 Y(21)=22
5410 TYPE(E)=B
5425 TYPE(G)=-25
5440 TYPE(V)=-23
5455 TYPE(4)=-23
5470 TYPE(5)=4
5485 TYPE(6)=-14
5500 TYPE(7)=10
5515 TYPE(8)=B
5530 TYPE(W)=B
5545 TYPE(10)=B
5560 TYPE(11)=6
5575 TYPE(12)=B
5590 TYPE(13)=6
5605 TYPE(14)=10
5620 TYPE(15)=E
5635 TYPE(16)=E
5650 TYPE(17)=E
5665 TYPE(18)=G
5680 TYPE(19)=5
5695 TYPE(20)=E
5710 TYPE(21)=6
5725 PICT$(E)="Lønnr"
5740 PICT$(G)="Navn"
5755 PICT$(V)="Adresse 1"
5770 PICT$(4)="Adresse 2"
5785 PICT$(5)="Postnr"
5800 PICT$(6)="By"
5815 PICT$(7)="CPR-nr"
5830 PICT$(8)="Trækpct"
5845 PICT$(W)="Skattefr 1 md"
5860 PICT$(10)="Rest frikort"
5875 PICT$(11)="Ansættelses dato"
5890 PICT$(12)="Afd-nr"
5905 PICT$(13)="Reg-nr, PI"
5920 PICT$(14)="Kto-nr, PI"
5935 PICT$(15)="Lønperiode"
5950 PICT$(16)="Feriekode"
5965 PICT$(17)="SH-kode"
5980 PICT$(18)="OR-kode"
5995 PICT$(19)="Faggr-kode"
6010 PICT$(20)="Dagp-kode"
6025 PICT$(21)="Fratrædelsesdato"
6040 EXEC INDVIRK
6055 CLOSE FIL$
6070 FIL$="P641220:LØNMODRG"
6085 OPEN FIL$,W
6100 EXEC FEJL(B,B,FIL$)
6115 NUL$="         0+"
6130 OUTP=B
6145 FIL2$="P641220:TÆLLEREG"
6160 OPEN FIL2$,W
6175 EXEC FEJL(B,B,FIL2$)
6190 POST6$=""
6205 FOR J=E TO 5
6220 POST6$=POST6$+NUL$
6235 NEXT J
6236 FIL1$="P641220:TRANSREG"
6237 OPEN FIL1$,W
6238 EXEC FEJL(B,B,FIL1$)
6250 REPEAT
6265 SV=G
6280 CLEAR
6295 CURSOR 10,10
6310 PRINT "L Ø N M O D T A G E R - K A R T O T E K"
6325 PRINT
6340 PRINT TAB(10);"0 Færdig"
6355 PRINT TAB(10);"1 Ændring"
6370 PRINT TAB(10);"2 Udskrift på skærm"
6385 PRINT TAB(10);"3 Udskrift på printer"
6400 PRINT TAB(10);"4 Oprettelse"
6415 PRINT TAB(10);"5 Sletning"
6430 PRINT
6445 REPEAT
6460 CURSOR E,19
6475 EDIT "          ",SV
6490 UNTIL SV=>B AND SV<=5
6505 IF SV>B THEN
6520 REPEAT
6535 EXEC INOPL(1)
6550 UNTIL LMNR=>B AND LMNR<=MLMNR
6551 LISTE=B
6552 IF LMNR=B THEN LISTE=E
6553 REPEAT
6554 IF LISTE=E THEN LMNR=LMNR+E
6565 EXEC INLØNMOD(LMNR)
6580 CASE SV OF
6595 WHEN E
6610 IF LA<>B THEN
6625 EXEC SKRIVOPL
6640 REPEAT
6655 REPEAT
6670 SV1=B
6685 CURSOR E,23
6700 EDIT "Feltnr ",SV1
6715 UNTIL SV1>E AND SV1<22 OR SV1=B
6730 IF SV1>B THEN
6745 EXEC INOPL(SV1)
6760 ENDIF
6775 UNTIL SV1=B
6790 EXEC UDLØNMOD(LMNR)
6805 ELSE
6820 PRINT "Lønmodtager findes ikke"
6835 INPUT "RETURN",LINE$
6850 ENDIF
6865 WHEN G
6880 IF LA<>B THEN
6895 OUTP=B
6910 EXEC SKRIVOPL
6925 INPUT "RETURN",LINE$
6940 ELSE
6955 PRINT "Lønmodtager findes ikke"
6970 INPUT "RETURN",LINE$
6985 ENDIF
7000 WHEN V
7015 IF LA<>B OR LISTE=E THEN
7016 IF LA<>B THEN
7030 OUTPUT P
7045 OUTP=E
7060 EXEC SKRIVOPL
7062 FOR I=13 TO 72
7064 PRINT
7066 NEXT I
7075 OUTP=B
7090 OUTPUT T
7095 ENDIF
7105 ELSE
7120 PRINT "Lønmodtager findes ikke"
7135 INPUT "RETURN",LINE$
7150 ENDIF
7165 WHEN 4
7180 IF LA<>B THEN
7195 PRINT "Lønmodtager findes allerede"
7210 INPUT "RETURN",LINE$
7225 ELSE
7240 EXEC SKRIVPICT
7255 EXEC CONV(LINE$,LMNR,0)
7270 EXEC OUTLINE(1)
7275 FD=B
7285 FOR J=G TO 18
7300 EXEC INOPL(J)
7315 NEXT J
7330 IF RESULT<80 THEN
7345 EXEC INOPL(19)
7360 EXEC INOPL(20)
7375 ELSE
7390 FG=B
7405 POST2$(26)="0"
7420 ENDIF
7435 REPEAT
7450 REPEAT
7465 SV1=B
7480 CURSOR E,23
7495 EDIT "Feltnr ",SV1
7510 UNTIL SV1>E AND SV1<22 OR SV1=B
7525 IF SV1>B THEN
7540 EXEC INOPL(SV1)
7555 ENDIF
7570 UNTIL SV1=B
7585 EXEC NULTÆL(LMNR)
7600 EXEC UDLØNMOD(LMNR)
7615 ENDIF
7630 WHEN 5
7645 IF LA<>B THEN
7660 SV1=G
7675 EXEC INDTÆL(LMNR)
7705 IF TV$(34)<>NUL$ THEN SV1=B
7706 IF TV$(35)<>NUL$ THEN SV1=B
7707 IF TV$(36)<>NUL$ THEN SV1=B
7708 IF TV$(37)<>NUL$ THEN SV1=B
7709 IF TV$(38)<>NUL$ THEN SV1=B
7710 IF TV$(39)<>NUL$ THEN SV1=B
7735 IF SV1=B THEN
7750 CURSOR E,23
7765 INPUT "Sletning ikke tilladt  RETURN ",LINE$
7780 ELSE
7795 EXEC SKRIVOPL
7800 ENDIF
7810 WHILE SV1<>0 AND SV1<>1
7812 SV1=0
7825 CURSOR 1,23
7840 EDIT "Sletning korrekt 1:  ",SV1
7855 ENDWHILE
7870 IF SV1=1 THEN
7885 LA=0
7900 EXEC UDLØNMOD(LMNR)
7910 EXEC NULTRANS(LMNR)
7915 EXEC NULTÆL(LMNR)
7930 ENDIF
7945 ELSE
7960 PRINT "Lønmodtager findes ikke"
7975 INPUT "RETURN",LINE$
7990 ENDIF
8005 ENDCASE
8006 UNTIL LISTE=0 OR LMNR=>MLMNR
8010 ENDIF
8020 UNTIL SV=0
8035 CLOSE FIL$
8050 CLOSE FIL2$
8065 CHAIN "P641210:STARTB"