DataMuseum.dk

top - download

    Length: 4044 (0xfcc)
    Types: SPC/1-COMAL-BIN
    Notes: Mikados_B
    Names: »VIRK.B«

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

SPC/1 COMAL-BIN

0010 PROC DATOCHECK(NR5,OK5)
0015 OK5=E
0020 ÅR=(ORD(NR5$(E))-48)*10+ORD(NR5$(G))-48
0025 MÅNED=(ORD(NR5$(V))-48)*10+ORD(NR5$(4))-48
0030 DATO=(ORD(NR5$(5))-48)*10+ORD(NR5$(6))-48
0035 IF DATO<E OR MÅNED<E OR MÅNED>12 OR DATO>31 THEN OK5=B
0040 IF OK5=B THEN EXIT
0045 CASE MÅNED OF
0050 WHEN 4,6,W,11
0055 IF DATO>30 THEN OK5=B
0060 WHEN G
0065 IF DATO>29 THEN OK5=B
0070 IF DATO=29 AND ÅR MOD 4<>B THEN OK5=B
0075 ENDCASE
0080 ENDPROC
0100 PROC CHECK(NR1,OK1)
0110 OK1=B
0115 RESULT=B
0120 IF LEN(NR1$)>B THEN
0130 IF NR1$(E)="-" THEN
0140 FORTEGN=-E
0150 OK1=E
0160 ELSE
0170 FORTEGN=E
0180 ENDIF
0190 WHILE LEN(NR1$)>OK1
0200 OK1=OK1+E
0210 IF NR1$(OK1)<"0" OR NR1$(OK1)>"9" THEN
0220 FORTEGN=B
0230 OK1=LEN(NR1$)
0240 ENDIF
0245 RESULT=RESULT*10+ORD(NR1$(OK1))-48
0250 ENDWHILE
0260 OK1=OK1*FORTEGN
0270 IF OK1<B THEN OK1=OK1+E
0280 ENDIF
0290 ENDPROC
0300 PROC INOPL(OPL)
0305 EXEC INLINE(OPL)
0310 CASE OPL OF
0315 WHEN E
0320 POST1$(E,7)=LINE$
0325 WHEN G
0330 POST1$(8,32)=LINE$
0335 WHEN V
0340 POST1$(33,55)=LINE$
0345 WHEN 4
0350 POST2$(E,4)=LINE$
0355 WHEN 5
0360 POST2$(5,18)=LINE$
0365 WHEN 6
0370 POST2$(19,24)=LINE$
0375 WHEN 7
0380 POST2$(25,34)=LINE$
0381 WHEN 8
0382 REPEAT
0383 EXEC DATOCHECK(LINE$,J)
0384 IF J=B THEN EXEC INLINE(OPL)
0385 UNTIL J>B
0386 DAD$=LINE$
0387 ENDCASE
0390 ENDPROC
0395 PROC SKRIVOPL
0400 IF OUTP=B THEN CLEAR
0405 FOR J=E TO A
0410 CASE J OF
0415 WHEN E
0420 LINE$=POST1$(E,7)
0425 WHEN G
0430 LINE$=POST1$(8,32)
0435 WHEN V
0440 LINE$=POST1$(33,55)
0445 WHEN 4
0450 LINE$=POST2$(E,4)
0455 WHEN 5
0460 LINE$=POST2$(5,18)
0465 WHEN 6
0470 LINE$=POST2$(19,24)
0475 WHEN 7
0480 LINE$=POST2$(25,34)
0481 WHEN 8
0482 LINE$=DAD$
0485 ENDCASE
0487 IF OUTP=B THEN
0490 EXEC OUTLINE(J)
0491 ELSE
0492 EXEC OUTPLINE(J)
0493 ENDIF
0495 NEXT J
0500 ENDPROC
0505 PROC OUTLINE(N)
0510 CURSOR X(N),Y(N)
0515 PRINT USING "### ":N;
0520 PRINT PICT$(N);
0525 CURSOR X(N)+25,Y(N)
0530 PRINT LINE$
0535 ENDPROC
0540 PROC INDVIRK
0545 OPEN FIL$,W
0550 EXEC FEJL(B,B,FIL$)
0555 GET FIL$,E:POST1$
0560 GET FIL$,G:POST2$,SLJNR,MLMNR,ATPLM
0563 GET FIL$,V:DAD$
0565 ENDPROC
0570 PROC UDVIRK
0575 PUT FIL$,E:POST1$
0580 PUT FIL$,G:POST2$,SLJNR,MLMNR,ATPLM
0583 PUT FIL$,V:DAD$
0585 CLOSE FIL$
0590 EXEC FEJL(E,B,FIL$)
0595 ENDPROC
0600 PROC FEJL(P1,P2,P3)
0605 IF STATUS(P3$)<>B THEN
0610 OUTPUT T
0615 PRINT "FIL-FEJL ";P3$;STATUS(P3$),P1;P2
0620 STOP
0625 ENDIF
0630 ENDPROC
0680 PROC INLINE(N)
0690 REPEAT
0700 CURSOR X(N),Y(N)
0705 PRINT USING "###":N;
0710 PRINT BL$(X(N)+V,79)
0720 CURSOR X(N)+4,Y(N)
0730 PRINT PICT$(N)
0740 CURSOR X(N)+25,Y(N)
0750 INPUT "",LINE$
0760 IF TYPE(N)<B THEN
0770 IF LEN(LINE$)<=ABS(TYPE(N)) THEN
0780 OK=E
0790 FOR I=LEN(LINE$)+E TO ABS(TYPE(N))
0800 LINE$(I)=" "
0810 NEXT I
0820 ELSE
0830 OK=B
0840 ENDIF
0850 ELSE
0860 EXEC CHECK(LINE$,OK)
0870 IF TYPE(N)>B AND TYPE(N)<>OK THEN OK=B
0880 ENDIF
0890 UNTIL OK<>B
0900 ENDPROC
0910 PROC SKRIVPICT
0920 CLEAR
0930 FOR I=E TO A
0940 CURSOR X(I),Y(I)
0945 PRINT USING "### ":I;
0950 PRINT PICT$(I)
0960 NEXT I
0970 ENDPROC
0975 PROC OUTPLINE(N)
0977 PRINT TAB(X(N));
0979 PRINT USING "### ":N;
0981 PRINT PICT$(N);TAB(X(N)+25);LINE$
0983 ENDPROC
9000 A=8
9010 DIM X(A),Y(A),PICT$(A,20),TYPE(A)
9011 DIM POST1$(55),POST2$(34),DAD$(6)
9020 DIM BL$(79),LINE$(30),FIL$(20)
9025 OUTP=B
9030 FOR I=E TO 79
9031 BL$=BL$+" "
9032 NEXT I
9040 FIL$="P641220:VIRKKART"
9200 FOR I=E TO A
9210 X(I)=E
9220 Y(I)=E+G*I
9230 NEXT I
9240 PICT$(E)="CIR-nr"
9250 TYPE(E)=7
9260 PICT$(G)="Navn"
9270 TYPE(G)=-25
9280 PICT$(V)="Adresse"
9290 TYPE(V)=-23
9300 PICT$(4)="Postnr"
9310 TYPE(4)=4
9320 PICT$(5)="By"
9330 TYPE(5)=-14
9340 PICT$(6)="Aftalenr i PI"
9350 TYPE(6)=6
9360 PICT$(7)="Kontonr i PI"
9370 TYPE(7)=10
9372 PICT$(8)="System-dato"
9374 TYPE(8)=6
9380 Æ=B
9390 EXEC INDVIRK
9400 REPEAT
9405 SV=G
9410 CLEAR
9420 CURSOR 10,10
9430 PRINT "V I R K S O M H E D S - K A R T O T E K"
9440 PRINT
9450 PRINT TAB(10);"0 Færdig"
9460 PRINT TAB(10);"1 Ændring"
9470 PRINT TAB(10);"2 Udskrift på skærm"
9480 PRINT TAB(10);"3 Udskrift på printer"
9490 PRINT
9500 REPEAT
9510 CURSOR E,17
9520 EDIT "          ",SV
9530 UNTIL SV=>B AND SV<=V
9540 CASE SV OF
9550 WHEN E
9560 EXEC SKRIVOPL
9570 REPEAT
9580 REPEAT
9585 SV1=B
9590 CURSOR E,23
9600 EDIT "Feltnr ",SV1
9610 UNTIL SV1=>B AND SV1<W
9620 IF SV1>B THEN
9630 EXEC INOPL(SV1)
9640 Æ=E
9650 ENDIF
9660 UNTIL SV1=B
9670 WHEN G
9675 OUTP=B
9680 EXEC SKRIVOPL
9685 INPUT "RETURN",LINE$
9690 WHEN V
9700 OUTPUT P
9705 OUTP=E
9710 EXEC SKRIVOPL
9711 FOR I=W TO 72
9712 PRINT
9713 NEXT I
9715 OUTP=B
9720 OUTPUT T
9730 ENDCASE
9740 UNTIL SV=B
9750 IF Æ=E THEN
9760 EXEC UDVIRK
9790 ENDIF
9800 CLOSE
9810 CHAIN "P641210:STARTB"