Shareware Overload/ShartewareOverload.cdr/database/steel14.zip/FORM.BAS

BASIC Source File | 1983-03-10 | 14KB | 489 lines

3 DEFDBL X
4 DEFINT A-W,Y-Z
5 DIM F$(15),FLDN$(15,30),FTY(15,30),FL(15,30)
10 DIM X$(30),Y$(30)
13 DIM L(15),NREC(15),Z$(30)
14 DIM X(30),CK$(30),SN$(30),SFN(30),DTOPT(10)
16 DIM KY(15,30),KEYLIST(15,30),L$(10,100),LEND(30),CL(30)
18 DIM SU%(40),S!(30),FORM$(30)
19 DIM EN(80),CE(80,10),TE(80,10),Q$(80,10)
20 DIM XL(40)
21 DIM TX(6,20)
25 DIM S#(30)
35 DIM K$(80)
40 DIM EFN(10,80),MAXK(30)
61 CH = 29: PRINT FRE(0)
70 NE = 0
75 GOSUB 50000
80 GOSUB 10000
90 GOTO 30000
2300 REM **************  DISK  SELECTION  ***************
2302 IF HDISK = 2 THEN GOSUB 13000
2303 IF HDISK = 2 THEN GOTO 2360
2304 PRINT ""
2305 PRINT "************  WHICH DISK DRIVE IS THE FILE ON  **************"
2310 PRINT ""
2315 PRINT "                 1 - DISK DRIVE A"
2320 PRINT "                 2 - DISK DRIVE B"
2325 PRINT "                 3 - DISK DRIVE C"
2330 PRINT "                 4 - DISK DRIVE D"
2335 PRINT ""
2340 PRINT "***********  ENTER THE NUMBER THEN PRESS RETURN  ************"
2345 GOSUB 14000
2347 IF DT# < 0 OR DT#>4 GOTO 2345
2350 T = DT#
2355 ON T GOTO 2360,2370,2380,2390
2360 T$ = F$(A)
2365 GOTO 2490
2370 T$ = "B:"+F$(A)
2375 GOTO 2490
2380 T$ = "C:"+F$(A)
2385 GOTO 2490
2390 T$ = "D:"+F$(A)
2490 RETURN
2500 REM *******  OPEN FILE SUBROUTINE  *******
2503 CLOSE #1
2505 OPEN "R",#1,T$,L(A)
2507 D = 0
2510 FOR T = 1 TO NREC(A)
2520 FIELD #1,D AS DY$,FL(A,T) AS X$(T)
2530 D = D + FL(A,T)
2540 NEXT T
2543 GOSUB 7800
2545 RETURN
2550 REM *******   OPEN SECOND FILE  *******
2553 CLOSE #2
2555 OPEN "R",#2,T$,L(B)
2557 D = 0
2560 FOR T = 1 TO NREC(B)
2565 FIELD #2,D AS DY$,FL(B,T) AS Y$(T)
2570 D = D + FL(B,T)
2575 NEXT T
2578 RETURN
2580 REM *******   OPEN THIRD FILE  *******
2582 PRINT C,F$(C),L(C)
2584 OPEN "R",#2,F$(C),L(C)
2586 D = 0
2588 FOR T = 1 TO NREC(C)
2590 FIELD #2,D AS DY$,FL(C,T) AS Z$(T)
2592 D = D + FL(C,T)
2594 NEXT T
2596 RETURN
7800 MRN = LOF(1)/ L(A)
7805 REM MRN = INT(MRN)
7810 RETURN
7900 REM ***** LOF
7910 MRN2 = LOF(3)/82
7920 RETURN
7950 REM ******* LOF
7960 MRNS = LOF(B)/L(B)
7970 RETURN
10000 REM *************  READ SUBROUTINE  *************
10004 GOSUB 10900
10010 OPEN "I",#1,"FFILE"
10020 INPUT #1,MAXF
10030 FOR A = 1 TO MAXF
10040 INPUT #1,A,F$(A),NREC(A),L(A)
10050 FOR N = 1 TO NREC(A)
10060 INPUT #1,FLDN$(A,N),FTY(A,N),FL(A,N)
10070 IF FTY(A,N) = 2 THEN INPUT #1,KY(A,N),KEYLIST(A,N)
10080 NEXT N
10090 NEXT A
10100 CLOSE #1
10110 RETURN
10900 REM  *************  PUT DISK IN DRIVE SUB
10905 IF HDISK = 2 THEN RETURN
10910 GOSUB 13000
10920 PRINT "    ********  PUT PROGRAM DATA DISK IN THE DEFAULT DISK DRIVE  *********"
10930 PRINT ""
10940 PRINT "                     THEN PRESS ANY KEY TO CONTINUE "
10950 PRINT ""
10960 PRINT "    If the program data disk is already in the default disk drive then"
10965 PRINT "                   just press any key to continue."
10970 PRINT ""
10990 IF INKEY$ = "" GOTO 10990
10995 RETURN
11000 REM  ********  LOAD KEYLIST  *********
11010 GOSUB 13000
11100 A = 10
11105 PRINT "FILE : KEYLIST "
11110 GOSUB 2300
11120 GOSUB 2500
11130 FOR T = 1 TO 10000
11140 IF T > MRN GOTO 11900
11150 GET #1,T
11160 T1 = CVI(X$(1))
11170 T2 = CVI(X$(2))
11180 L$(T1,T2) = X$(3)
11185 IF T2 > MAXK(T1) THEN MAXK(T1) = T2
11190 NEXT T
11900 KD = 5
11935 CLOSE #1
11940 RETURN
13000 REM *********  CLEAR SCREEN
13010 CLS
13020 RETURN
13100 REM *********  LOCATE
13110 LOCATE LI,1
13120 RETURN
13200 FOR T% = 1 TO 80
13210 PRINT CHR$(8);
13220 NEXT T%
13222 FOR T% = 1 TO 24
13223 PRINT CHR$(11);
13224 NEXT T%
13225 LI = LI - 1
13230 FOR T% = 1 TO LI
13240 PRINT CHR$(0)
13250 NEXT T%
13590 RETURN
13600 REM ****** CHECK FOR ASC0
13610 S4$ = INKEY$
13620 C2 =  ASC(S4$)
13630 IF C2 = 83 THEN C = 1
13640 IF C2 = 82 THEN C = 6
13650 IF C2 = 75 THEN C = 19
13660 IF C2 = 77 THEN C = 4
13670 RETURN
14000 REM *******  INTEGER LESS THEN 100 CHECK  ********
14010 MAX = 2
14020 ACT$ = "1234567890=<>^"
14023 IF NE = 0 THEN ACT$ = "1234567890"
14025 PRINT ">__<";
14030 GOTO 14500
14100 REM *******  INTEGER *******
14110 MAX = 8
14120 ACT$ = "1234567890-+,=<>^"
14123 IF NE = 0 THEN ACT$ = "1234567890-+,"
14125 PRINT ">________<";
14130 GOTO 14500
14200 REM *******  SINGLE PRECISION  *******
14210 MAX = 10
14220 ACT$ = "1234567890-+,.%$=<>^"
14223 IF NE = 0 THEN ACT$ = "1234567890+-,.%$"
14225 PRINT ">__________<";
14230 GOTO 14500
14300 REM *******  DOUBLE PRECISION  *******
14310 MAX = 20
14320 ACT$ = "1234567890-+,.%$=<>^"
14323 IF NE = 0 THEN ACT$ = "1234567890+-,.%$"
14325 PRINT ">____________________<";
14330 GOTO 14500
14500 REM ********** NUMBER CHECK **********
14505 A$ = ""
14510 K$(20) = " "
14515 KTMAX = 0
14520 FOR T9 = 1 TO MAX
14525 K$(T9) = " "
14530 NEXT T9
14535 DIG$ = "1234567890."
14540 DOTFLG = 0
14541 T2 = MAX + 1
14542 FOR T6 = 1 TO T2
14544 PRINT CHR$(CH);
14546 NEXT T6
14550 IF INKEY$ = "" GOTO 14560 ELSE GOTO 14550
14560 KT = 0
14565 REM ***********  CHECK ALFANUMERIC INPUT FOR LENGTH  ***********
14570 KT = KT + 1
14575 REM
14580 W$ = INKEY$
14585 IF W$ = "" GOTO 14580
14590 C = ASC(W$)
14593 IF C = 0 THEN GOSUB 13600
14595 IF C = 13 GOTO 14660
14600 IF C = 17 OR C = 8 GOTO 14860
14605 IF C = 19 GOTO 14690
14610 IF C = 4 GOTO 14710
14615 IF C = 6 GOTO 14730
14620 IF C = 1 GOTO 14790
14625 IF KT > MAX GOTO 14575
14630 IF INSTR(ACT$,W$) = 0 GOTO 14890
14635 K$(KT) = W$
14645 PRINT K$(KT);
14650 IF KT > KTMAX THEN KTMAX = KT
14655 GOTO 14570
14660 REM **********  RETURN  **********
14670 FOR T9 = 1 TO KTMAX
14675 A$ = A$ + K$(T9)
14680 NEXT T9
14681 IF KTMAX = 0 THEN PRINT "1"
14682 IF KTMAX = 0 THEN DT# = 1
14683 IF KTMAX = 0 THEN RETURN
14684 PRINT ""
14685 GOTO 14905
14690 REM ********* MOVE CURSE BACK ********
14695 IF KT = 1 GOTO 14575
14700 KT = KT - 1
14703 PRINT CHR$(CH);
14705 GOTO 14575
14710 REM ********* MOVE CURSER FORWARD *********
14715 IF KT >= MAX GOTO 14575
14716 IF KT > (KTMAX + 1) GOTO 14575
14718 PRINT K$(KT);
14720 KT = KT + 1
14725 GOTO 14575
14730 REM ********** INSERT ***********
14733 IF KT > KTMAX GOTO 14575
14735 X9 = MAX
14740 WHILE X9 > KT
14745 X9 = X9 - 1
14750 K$(X9 + 1) = K$(X9)
14755 WEND
14760 K$(KT) = " "
14767 KTMAX = KTMAX + 1
14769 IF KTMAX > MAX THEN KTMAX = MAX
14770 FOR T9 = KT TO KTMAX
14775 PRINT K$(T9);
14780 NEXT T9
14781 T6 = (KTMAX - KT) + 1
14782 FOR T7 = 1 TO T6
14783 PRINT CHR$(CH);
14784 NEXT T7
14785 GOTO 14575
14790 REM ********** DELETE ***********
14793 IF KT > KTMAX GOTO 14575
14794 IF KTMAX = 1 GOTO 14575
14795 K$(MAX + 1) = ""
14800 X9 = KT
14805 WHILE X9 <= MAX
14810 K$(X9) = K$(X9 + 1)
14815 X9 = X9 + 1
14820 WEND
14830 KTMAX = KTMAX - 1
14835 FOR T9 = KT TO KTMAX
14840 PRINT K$(T9);
14845 NEXT T9
14850 PRINT "_";
14851 T7 = (KTMAX - KT) + 2
14852 FOR T8 = 1 TO T7
14853 PRINT CHR$(CH);
14854 NEXT T8
14855 GOTO 14575
14860 REM ********* BACKSPACE ********
14865 IF KT = 1 GOTO 14575
14870 KT = KT - 1
14875 PRINT CHR$(CH);
14877 K$(KT) = " "
14880 PRINT "_";
14883 PRINT CHR$(CH);
14885 GOTO 14575
14890 REM *******  INPUT NOT ACCEPTABLE  ********
14895 PRINT CHR$(7);
14900 GOTO 14580
14905 REM ********* CLEAR STRINGS ********
14910 MAX = LEN(A$)
14915 D2$ = ""
14920 D1$ = ""
14925 DFLG = 0
14930 FOR Q93 = 1 TO MAX
14935 R$ = MID$(A$,Q93,1)
14940 IF INSTR(DIG$,R$) = 0 GOTO 14975
14945 IF R$ = "." OR DFLG = 1 GOTO 14965
14950 IF DFLG = 1 GOTO 14965
14955 D2$ = D2$ + R$
14960 GOTO 14975
14965 D1$ = D1$ + R$
14970 DFLG = 1
14975 NEXT Q93
14980 DA# = VAL(D2$)
14985 D1# = VAL(D1$)
14990 DT# = DA# + D1#
14995 IF K$(1) = "-" THEN DT# =  -DT#
14997 RETURN
16010 PRINT "***********  MAKE SURE YOUR PRINTER IS ON  **************"
16020 PRINT ""
16030 PRINT "********************  WITH PAPER  ***********************"
16040 PRINT ""
16050 PRINT "**********  PRESS ANY KEY TO START PRINTING  ************"
16055 PRINT ""
16057 PRINT "     *******  PRESS THE LETTER A TO ABORT  *******"
16070 T$ = INKEY$
16073 IF T$ = "" GOTO 16070
16075 PRINT T$
16085 IF T$ = "A" THEN GOTO 30000
16090 RETURN
16200 REM *********  PRINT OUT FIELDS
16205 T2 = 1
16210 FOR T = 1 TO NREC(A)
16220 PRINT TAB(T2) T;"-";FLDN$(A,T);
16230 IF T MOD 3 = 0 THEN PRINT ""
16235 IF T MOD 3 = 0 THEN T2 = -25
16237 T2 = T2 + 26
16340 NEXT T
16350 RETURN
26100 EFLG = 1
26200 PRINT "**********  END OF FILE  ***********"
26202 PRINT "**** PRESS ANY KEY TO CONTINUE ****"
26204 IF INKEY$ = "" GOTO 26204
26500 REM *********  ON ERROR SUBROUTINE ***********
26600 PRINT "**********  END OF FILE  ***********"
26610 PRINT "**** PRESS ANY KEY TO CONTINUE ****"
26620 IF INKEY$ = "" GOTO 26620
26635 EFLG = 1
26640 RETURN
26800 REM **********  ON ERROR GOTO  **************
26900 PRINT "************  RECORD NOT FOUND  *************"
30000 REM **********  FORM OUTPUT ***********
30003 CLOSE
30005 IF KD <> 5 THEN GOSUB 11000
30010 GOSUB 30300
30100 GOSUB 13000
30110 PRINT "************  PRINT A CUSTOM FORM  *************"
30120 PRINT ""
30130 PRINT "******   ENTER ZERO TO EXIT THE PROGRAM  *******"
30140 GOSUB 30380
30150 PRINT "*******  WHAT FORM DO YOU WANT TO PRINT ? ******"
30155 GOSUB 14000
30156 IF DT# <0 OR DT# >MAXFORM  GOTO 30155
30160 T = DT#
30165 IF DT# = 0 GOTO 51000
30170 N$ = FORM$(T)
30175 CLOSE
30180 GOTO 30900
30300 REM *********  INPUT LIST OF FORMS FROM DISK  *********
30305 GOSUB 10900
30310 OPEN "I",#1,"FORMLIST"
30320 INPUT #1,MAXFORM
30330 FOR T = 1 TO MAXFORM
30340 INPUT #1,FORM$(T)
30350 NEXT T
30360 CLOSE #1
30370 RETURN
30380 REM ******* PRINT FORM LIST *******
30390 FOR T = 1 TO MAXFORM
30400 PRINT T;"-";FORM$(T)
30410 NEXT T
30420 RETURN
30900 REM *****
31000 REM ********** READ DATA ON FILE ***********
31005 OPEN "I",#1,N$
31010 INPUT #1,LN,MF,SFO
31015 IF SFO = 1 THEN INPUT #1,TMF,TSF,SF
31020 FOR T1 = 1 TO LN
31025  INPUT #1,EN(T1)
31030  FOR T2 = 1 TO EN(T1)
31035   INPUT #1,CE(T1,T2),TE(T1,T2)
31040   ON TE(T1,T2) GOTO 31045,31055,31065,31075,31075
31045    INPUT #1,Q$(T1,T2)
31050    GOTO 31075
31055    INPUT #1,EFN(T1,T2)
31060    GOTO 31075
31065    INPUT #1,EFN(T1,T2)
31070    GOTO 31075
31075  NEXT T2
31080 NEXT T1
31085 CLOSE
31160 GOSUB 13000
31161 A = MF
31162 PRINT "MAIN FILE = ";F$(A)
31164 GOSUB 2300
31166 GOSUB 2500
31170 GOSUB 13000
31171 GOTO 31300
31300 REM ****** END ON ERROR ROUTINE  ******
31310 GOSUB 13000
31320 PRINT " CUSTOM FORM    ";N$
31330 PRINT " MAIN FILE      ";F$(MF)
31350 PRINT ""
31360 PRINT "*****  WHAT RECORD DO YOU WANT TO START AT  *****"
31362 GOSUB 14100
31364 RNS = DT#
31365 A = MF
31366 GOSUB 7800
31367 IF DT# <1 OR DT# >10000 GOTO 31362
31368 PRINT "THE HIGHEST RECORD NUMBER IS ";MRN
31370 PRINT "******  WHAT RECORD DO YOU WANT TO STOP AT  ******"
31372 GOSUB 14100
31373 IF DT# <RNS OR DT# >MRN GOTO 31372
31374 RNF = DT#
31380 IF RNF > MRN GOTO 31370
31400 REM ********  START FORM LOOP  ********
31410 FOR T = RNS TO RNF
31415 GET #1,T
31420 GOSUB 32000
31430 IF INKEY$ = "" GOTO 31450
31440 GOSUB 31500
31450 NEXT T
31460 GOTO 30100
31500 REM  **********  PAUSE ROUTINE  ************
31510 PRINT "*************  PAUSE ROUTINE  **************"
31520 PRINT "      1 - CONTINUE PRINTING FORMS "
31530 PRINT "      2 - DONE BACK TO INITIAL MENU "
31540 PRINT "***  ENTER THE NUMBER THEN PRESS RETURN  ***"
31550 GOSUB 14000
31552 IF DT# <1 OR DT# >2  GOTO 31550
31560 IF DT# = 1 THEN RETURN
31570 CLOSE
31580 GOTO 30000
32000 REM  ***********  PRINT FORM  *********************
32100 FOR L = 1 TO LN
32110  GOSUB 32200
32115 LPRINT ""
32120 NEXT L
32130 RETURN
32200 FOR E = 1 TO EN(L)
32210  GOSUB 32300
32220 Z$ = INKEY$
32225 IF Z$ = "" GOTO 32230
32227 GOSUB 31500
32230 NEXT E
32240 RETURN
32300 REM ********
32310  C = CE(L,E)
32320 ON TE(L,E) GOTO 32400,32600,32800,33500,33200
32400 REM  ******  STRING CONSTANT ******
32410  LPRINT TAB(C) Q$(L,E);
32420 GOTO 33500
32600 REM  ******  GET FROM MAIN FILE  ******
32610 F = EFN(L,E)
32620 ON FTY(MF,F) GOTO 32630,32660,32700,32750,32790
32630 REM *****  String  *****
32635 LPRINT TAB(C) X$(F);
32640 GOTO 33500
32660 REM *****  INTEGER  ******
32665 I% = CVI(X$(F))
32670 LPRINT TAB(C) I%;
32675 GOTO 33500
32700 REM ***** SINGLE PRECISION *****
32710 I! = CVS(X$(F))
32720 LPRINT TAB(C) I!;
32730 GOTO 33500
32750 REM *****  DOUBLE PRECISION  ******
32760 I# = CVD(X$(F))
32770 LPRINT TAB(C) I#;
32780 GOTO 33500
32790 REM *****  DOLLARS AND CENTS  ******
32792 I# = CVD(X$(F))
32793 LPRINT TAB(C) ;
32794 LPRINT USING "**$########,.##";I#;
32796 GOTO 33500
32800 REM  ******  GET FROM SECONDARY FILE  ******
32810 F = EFN(L,E)
32830 I% = CVI(X$(F))
32832 T1 = KEYLIST(MF,F)
32835 W$ = L$(T1,I%)
32840 LPRINT TAB(C) W$;
33200 REM  ******  BLANK LINE ******
33500 RETURN
50000 REM **********  INTRO
50010 GOSUB 13000
50100 PRINT "           P R I N T   F O R M    P R O G R A M    3.0   "
50105 PRINT ""
50110 PRINT "       Copyright 1984 by Potomac Pacific Engineering Inc."
50120 PRINT ""
50130 PRINT "This program is licensed FREE to all users with some restrictions "
50165 PRINT "        See the manual for more information on the license."
50167 PRINT ""
50950 PRINT "******************  PRESS ANY KEY TO CONTINUE  ******************";
50960 IF INKEY$ = "" GOTO 50960
50970 RETURN
51000 REM ******** EXIT
51100 GOSUB 13000
51200 PRINT "BYE - Have a nice day "
51300 END
Y$ = "" GOTO 50960
50970 RETURN
51000 REM ******** EXIT
51100 GOSUB 13000
512