DataMuseum.dk

top - download

    Length: 7315 (0x1c93)
    Types: SPC/1-COMAL-BCD
    Notes: Mikados_B
    Names: »DEBVEDL.B«

└─⟦ec8c1e0b0⟧ Bits:30007442 8" floppy ( MIKPROG vol. 1-3, MIKREL vol. 1-3, PCSE 4.7.80 vol 1-3, GL.SYS )
    └─⟦this⟧ »DEBVEDL.B« 

SPC/1 COMAL-BCD

0100 DIM K1$(17),K2$(17),DEBNAVN$(25),DSALDO1$(12),DEBKGR$(1),UD2$(14),A$(1)
0110 DIM DSALDO2$(12),DSALDO3$(12),DSALDO4$(12),DEBLK$(1),DEBGADE$(25),N$(6)
0120 DIM T2(9),BLANK$(77),TAL4$(14),TAH$(12),DEBTLF$(9),DEBBY$(20),VTAB2(5)
0130 DIM RES$(14),ÅRKØB$(12),MDNKØB$(12),DSALDI$(12),LK$(3),KG$(3),KTN$(6)
0140 DIM PNR$(6),TY$(1),OP1$(12),OP2$(12),TA$(12),TB$(14),TÅRKØB$(12),DAT$(8)
0150 DIM DEBGADE1$(25),DEBTLF1$(9),BLB2$(12),UBLB2$(14),UD1$(14),STREG$(71)
0160 DIM UD3$(14),UD4$(14),K3$(17),K4$(17),K5$(17),K6$(17),T1(9),LAND$(9,12)
0170 PROC CALC(ART,B1,B2,ES)
0180 OP1$=B1$;OP2$=B2$;RES$=ES$;SI=0;FLAG=0
0190 CALL "P641210:REGN"
0200 ES$=RES$
0210 IF FLAG THEN STOP
0220 ENDPROC
0230 PROC FEJL(NR1,NR2,NR3)
0240 IF STATUS(NR3$)<>0 THEN
0250 PRINT STATUS(NR3$),NR1,NR2,NR3$
0260 STOP
0270 ENDIF
0280 ENDPROC
0290 PROC INDTAB(T,MANTAL,K10)
0300 J=MANTAL DIV 32+1
0310 FOR I=J TO MANTAL DIV 4+J-1
0320 H=(I-J)*4+1;J2=H+1;J3=H+2;J4=H+3
0330 GET K10$,I:T(H,1),T(H,2),T(J2,1),T(J2,2),T(J3,1),T(J3,2),T(J4,1),T(J4,2)
0340 EXEC FEJL(1,1,K10$)
0350 NEXT I
0360 ENDPROC
0370 PROC UDTAB(U,MANTAL1,K9)
0380 J=MANTAL1 DIV 32+1
0390 FOR I=1 TO J-1
0400 H=(I-1)*32+1;J1=H+4;J2=H+8;J3=H+12;J4=H+16;J5=H+20;J6=H+24;J7=H+28
0410 PUT K9$,I:U(H,1),U(J1,1),U(J2,1),U(J3,1),U(J4,1),U(J5,1),U(J6,1),U(J7,1)
0420 EXEC FEJL(2,1,K9$)
0430 NEXT I
0440 FOR I=J TO MANTAL1 DIV 4+J-1
0450 H=(I-J)*4+1;J1=H+1;J2=H+2;J3=H+3
0460 PUT K9$,I:U(H,1),U(H,2),U(J1,1),U(J1,2),U(J2,1),U(J2,2),U(J3,1),U(J3,2)
0470 EXEC FEJL(2,2,K9$)
0480 NEXT I
0490 ENDPROC
0500 PROC FINDPOST(TAB1,MANT1,NØGL1,PIL3)
0510 PIL1=MANT1 DIV 2;PIL3=PIL1;CEKS=1
0520 REPEAT
0530 IF NØGL1=TAB1(PIL3,1) THEN
0540 CEKS=0
0550 ELSE
0560 IF PIL1=1 THEN PIL1=0
0570 PIL1=INT((PIL1+1)/2)
0580 IF NØGL1>TAB1(PIL3,1) THEN
0590 PIL3=PIL3+PIL1
0600 ELSE
0610 PIL3=PIL3-PIL1
0620 ENDIF
0630 IF PIL3<1 THEN PIL3=1
0640 IF PIL3>MANT1 THEN PIL3=MANT1
0650 ENDIF
0660 UNTIL CEKS=0 OR PIL1=0
0670 ENDPROC
0680 PROC SLETDPOST(NØGLE3)
0690 EXEC FINDPOST(DTAB,MDANTAL,NØGLE3,DPIL3)
0700 IF CEKS=1 THEN STOP
0710 DEBNR=0
0720 DEBNAVN$=BLANK$(1:25)
0730 DSALDO1$=BLANK$(1:12)
0740 DSALDO2$=BLANK$(1:12)
0750 DSALDO3$=BLANK$(1:12)
0760 DSALDO4$=BLANK$(1:12)
0770 ÅRKØB$=BLANK$(1:12)
0780 MDNKØB$=BLANK$(1:12)
0790 DEBKGR$="0"
0800 DEBPOSTNR=0
0810 DEBLK$="0"
0820 DEBGADE$=BLANK$(1:25)
0830 DEBTLF$=BLANK$(1:9)
0840 HPOST=0
0850 HKUNDE=0
0860 DEBBY$=BLANK$(1:20)
0870 EXEC GEMDPOST
0880 EXEC SLETPOST(DTAB,ADEB,NØGLE3,DPIL3)
0890 ENDPROC
0900 PROC INDSÆT(TAB2,ANTAL2,NØGL2,PIL4)
0910 IF CEKS=1 THEN
0920 POSTNR=TAB2(ANTAL2+1,2)
0930 IF NØGL2>TAB2(PIL4,1) AND TAB2(PIL4,1)<>1000000 THEN PIL4=PIL4+1
0940 FOR J=ANTAL2+1 TO PIL4+1 STEP -1
0950 TAB2(J,1)=TAB2(J-1,1)
0960 TAB2(J,2)=TAB2(J-1,2)
0970 NEXT J
0980 TAB2(PIL4,1)=NØGL2
0990 TAB2(PIL4,2)=POSTNR
1000 ANTAL2=ANTAL2+1
1010 ENDIF
1020 ENDPROC
1030 PROC SLETPOST(TAB3,ANTAL3,NØGL3,PIL5)
1040 IF CEKS=0 THEN
1050 POSTNR=TAB3(PIL5,2)
1060 FOR I=PIL5 TO ANTAL3
1070 TAB3(I,1)=TAB3(I+1,1)
1080 TAB3(I,2)=TAB3(I+1,2)
1090 NEXT I
1100 TAB3(ANTAL3,1)=1000000
1110 TAB3(ANTAL3,2)=POSTNR
1120 ANTAL3=ANTAL3-1
1130 ENDIF
1140 ENDPROC
1150 PROC HENTDPOST
1160 S=DTAB(DPIL3,2)
1170 GET K3$,S:DEBNR,DEBNAVN$,DSALDO1$,DEBKGR$
1180 EXEC FEJL(8,2,K3$)
1190 IF DEBNR<>DTAB(DPIL3,1) THEN STOP
1200 GET K3$,S+1:DSALDO2$,DSALDO3$,DSALDO4$,DEBPOSTNR,DEBLK$
1210 EXEC FEJL(8,3,K3$)
1220 GET K3$,S+2:DEBGADE$,DEBTLF$,HPOST,HKUNDE
1230 EXEC FEJL(8,4,K3$)
1240 GET K3$,S+3:DEBBY$,ÅRKØB$,MDNKØB$
1250 EXEC FEJL(8,5,K3$)
1260 ENDPROC
1270 PROC GEMDPOST
1280 S=DTAB(DPIL3,2)
1290 PUT K3$,S:DEBNR,DEBNAVN$,DSALDO1$,DEBKGR$
1300 EXEC FEJL(9,3,K3$)
1310 PUT K3$,S+1:DSALDO2$,DSALDO3$,DSALDO4$,DEBPOSTNR,DEBLK$
1320 EXEC FEJL(9,4,K3$)
1330 PUT K3$,S+2:DEBGADE$,DEBTLF$,HPOST,HKUNDE
1340 EXEC FEJL(9,4,K3$)
1350 PUT K3$,S+3:DEBBY$,ÅRKØB$,MDNKØB$
1360 EXEC FEJL(9,5,K3$)
1370 ENDPROC
1380 PROC DINDTAST(DSTYR,CÆND,DEBNR2)
1390 IF CÆND<>1 THEN
1400 CLEAR
1410 CURSOR 21,1
1420 PRINT "Kundeoplysninger"
1430 EXEC OVERSKRIFT
1440 CURSOR 2,3
1450 PRINT "1:Kundenr   :";DEBNR2
1460 ENDIF
1470 REPEAT
1480 CASE DSTYR OF
1490 STOP
1500 WHEN 2
1510 IF CÆND<>1 THEN
1520 CURSOR 2,4
1530 PRINT "2:Navn      :"
1540 DSTYR=3
1550 ENDIF
1560 IF CÆND<>2 THEN
1570 CURSOR 3,23
1580 PRINT "Navn";BLANK$(1:33);"(max 25 tegn)";BLANK$(1:26)
1590 CURSOR 13,23
1600 INPUT DEBNAVN$
1610 ENDIF
1620 CURSOR 16,4
1630 PRINT BLANK$(1:25)
1640 CURSOR 16,4
1650 PRINT DEBNAVN$
1660 WHEN 3
1670 IF CÆND<>1 THEN
1680 CURSOR 2,5
1690 PRINT "3:Gade      :"
1700 DSTYR=4
1710 ENDIF
1720 IF CÆND<>2 THEN
1730 CURSOR 3,23
1740 PRINT "Gade";BLANK$(1:33);"(max 25 tegn)";BLANK$(1:26)
1750 CURSOR 13,23
1760 INPUT DEBGADE$
1770 ENDIF
1780 CURSOR 16,5
1790 PRINT BLANK$(1:25)
1800 CURSOR 16,5
1810 PRINT DEBGADE$
1820 WHEN 4
1830 IF CÆND<>1 THEN
1840 CURSOR 2,6
1850 PRINT "4:Postnr    :"
1860 DSTYR=5
1870 ENDIF
1880 IF CÆND<>2 THEN
1890 REPEAT
1900 CURSOR 3,23
1910 PRINT "Postnr";BLANK$(1:12);"(max 6 tegn)";BLANK$(1:45)
1920 CURSOR 13,23
1930 INPUT PNR$
1940 EXEC NRTEST(PNR$)
1950 UNTIL ((L>3 AND L<7) OR (P=-1 AND CÆND=1)) AND TEST2=0
1960 IF P<>-1 THEN DEBPOSTNR=P
1970 ENDIF
1980 CURSOR 16,6
1990 PRINT BLANK$(1:6)
2000 CURSOR 16,6
2010 PRINT DEBPOSTNR
2020 WHEN 5
2030 IF CÆND<>1 THEN
2040 CURSOR 2,7
2050 PRINT "5:By        :"
2060 DSTYR=6
2070 ENDIF
2080 IF CÆND<>2 THEN
2090 CURSOR 3,23
2100 PRINT "By";BLANK$(1:30);"(max 20 tegn)";BLANK$(1:31)
2110 CURSOR 13,23
2120 INPUT DEBBY$
2130 ENDIF
2140 CURSOR 16,7
2150 PRINT BLANK$(1:20)
2160 CURSOR 16,7
2170 PRINT DEBBY$
2180 WHEN 6
2190 IF CÆND<>1 THEN
2200 CURSOR 2,8
2210 PRINT "6:Landekode :     Land:"
2220 DSTYR=7
2230 ENDIF
2240 IF CÆND<>2 THEN
2250 REPEAT
2260 CURSOR 3,23
2270 PRINT "Landekode";BLANK$(1:9);"0:for Danmark,max 2 cifre)";BLANK$(1:30)
2280 CURSOR 13,23
2290 INPUT LK$
2300 EXEC NRTEST(LK$)
2310 UNTIL (P>-1 AND P<10 AND TEST2=0) OR (P=-1 AND CÆND=1)
2320 ENDIF
2330 CURSOR 16,8
2340 PRINT BLANK$(1:3)
2350 CURSOR 27,8
2360 PRINT BLANK$(1:15)
2370 CURSOR 16,8
2380 IF P<10 AND CÆND<>2 THEN
2390 DEBLK$=CHR(P+48)
2400 ENDIF
2410 P=ORD(DEBLK$)-48
2420 PRINT USING "###":P
2430 CURSOR 27,8
2440 IF P=0 THEN
2450 PRINT "Danmark"
2460 ELSE
2470 PRINT LAND$(P)
2480 ENDIF
2490 WHEN 7
2500 IF CÆND<>1 THEN
2510 CURSOR 2,9
2520 PRINT "7:Telefon   :"
2530 DSTYR=8
2540 ENDIF
2550 IF CÆND<>2 THEN
2560 CURSOR 3,23
2570 PRINT "Telefon";BLANK$(1:14);"(max 9 tegn)";BLANK$(1:44)
2580 CURSOR 13,23
2590 INPUT DEBTLF$
2600 ENDIF
2610 CURSOR 16,9
2620 PRINT BLANK$(1:9)
2630 CURSOR 16,9
2640 PRINT DEBTLF$
2650 WHEN 8
2660 IF CÆND<>1 THEN
2670 CURSOR 2,10
2680 PRINT "8:Kundegr   :"
2690 DSTYR=9
2700 ELSE
2710 IF TYPE=2 THEN
2720 EXEC KSØG(DEBNR2,ORD(DEBKGR$)-48)
2730 EXEC KINDSLET(0)
2740 ENDIF
2750 ENDIF
2760 IF CÆND<>2 THEN
2770 REPEAT
2780 CURSOR 3,23
2790 PRINT "Kundegr        (max 2 cifre)";BLANK$(1:49)
2800 CURSOR 13,23
2810 INPUT KG$
2820 EXEC NRTEST(KG$)
2830 UNTIL (P>0 AND TEST2=0 AND P<=MKGR) OR (P=-1 AND CÆND=1)
2840 ENDIF
2850 CURSOR 16,10
2860 IF P>0 AND CÆND<>