home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / cpm / database / dims103.ark / DCHESHIR.ASC < prev    next >
Encoding:
Text File  |  1986-12-07  |  8.6 KB  |  351 lines
  1. 10 ' ********************************
  2. 20 ' *            NOTICE            *
  3. 30 ' * COPYRIGHT (c) 1983 DAN DUGAN *
  4. 40 ' ********************************
  5. 50 '
  6.  
  7.  
  8.                 STANDALONE ENTRY
  9.  
  10.  
  11. 60 PRINT:PRINT "CHESHIR 1.03 November 2, 1983
  12. 70 PRINT:PRINT "This program prints 4-up Cheshire labels from a sequential data file.
  13. 80 PRINT 
  14. 90 DEFINT A-Z
  15. 100 WIDTH LPRINT 255
  16. 105 I=0
  17. 110 '
  18.  
  19.  
  20.                 OPEN SOURCE FILE
  21.  
  22.  
  23. 120 PRINT:INPUT"Name of source file";X$
  24. 130 IF X$="" THEN STOP
  25. 140 GOSUB 2430:F2$=Y$        'ucv
  26. 150 IF MID$(F2$,2,1)=":" THEN 170
  27. 160 F2$=DD$(5)+F2$
  28. 170 '
  29.  
  30.  
  31.         TEST FOR EXISTENCE
  32.  
  33.  
  34. 180 ON ERROR GOTO 210
  35. 190    OPEN"I",3,F2$
  36. 200    ON ERROR GOTO 0:GOTO 260    'ok
  37. 210 '        LOCAL ERROR TRAP
  38. 220 CLOSE 3
  39. 230 IF ERR=53 THEN CLOSE 3:PRINT"File not found":RESUME 110
  40. 240 IF ERR=64 THEN PRINT"Bad file name, try again.":RESUME 110
  41. 250 ON ERROR GOTO 0
  42. 260 '        SHOW AND ASK
  43. 270 PRINT:PRINT"Here's the first line of "F2$".
  44. 280 LINE INPUT#3,T$
  45. 290 PRINT:PRINT T$
  46. 300 CLOSE 3:OPEN"I",3,F2$
  47. 310 PRINT:
  48.  
  49.     INPUT"Please enter the total number of fields in the source file:  ",NC
  50. 320 IF NC=0 THEN CLOSE:STOP
  51. 330 DIM B$(NC),L$(4,NC)
  52. 340 DIMS=0                'switch for sequential file
  53. 350 GOTO 1090
  54. 1000 '
  55.  
  56.  
  57.                 DIMS ENTRY
  58.  
  59.  
  60. 1010 GOSUB 2130 'cs
  61. 1020 PRINT:PRINT TAB(16);"CHESHIRE 1.03 October 26, 1983
  62. 1030 PRINT"Prints Cheshire labels 4-up
  63. 1040 ' by Dan Dugan -- public domain
  64. 1050 PRINT
  65. 1060 DEFINT A-Z
  66. 1070 COMMON I,J,K,X,Y,T$,R$,S$,T1$,SKIPPARSE,FT,SEARCH,
  67.  
  68.     C,N,NC,P6,P7,P8,P9,PI,S,T,T1,T2,C(),B$(),N$(),
  69.  
  70.     SEARCHWORD$(),SEARCHFIELD(),SKIPWORD$(),LOOKFIELD(),DD$(),F$,FT$
  71. 1080 DIMS=1            'switch for dims data file
  72. 1090 '
  73.  
  74.  
  75.                 INITIALIZATION FOR BOTH MODES
  76.  
  77.  
  78. 1100 DIM COLPOS(4)
  79. 1110 '        COLUMN PRINT POSITIONS
  80. 1120 COLPOS(1)=2:COLPOS(2)=43:COLPOS(3)=84:COLPOS(4)=124
  81. 1130 '        MAXIMUM FIELD LENGTH
  82. 1140 MAXLEN=34
  83. 1145 DONE=0            'EOF flag
  84. 1150 '
  85.  
  86.  
  87.                 SET-UP LABELS
  88.  
  89.  
  90. 1160 PRINT:PRINT"Please indicate the form that this list is in:
  91. 1170 PRINT:PRINT"     1.  Short form, (NAME, N2, ADDR, C-ST, ZIP)
  92. 1180 PRINT"     2.  Medium form, (LNAM, FNAM, N2, ADDR, C-ST, ZIP)
  93. 1190 PRINT"     3.  Long form, (LNAM, FNAM, TITL, ORG, ADDR etc.)
  94. 1200 PRINT:PRINT"Enter 1, 2 or 3:  ";
  95. 1210 A$=INPUT$(1): IF A$=CHR$(13) THEN A$="1"
  96. 1220 PRINT A$: A=VAL(A$): IF A=0 THEN 1950
  97. 1230 IF A<1 OR A>3 THEN 1200
  98. 1240 FORM=A-1
  99. 1242 PRINT:PRINT"Set up printer:"
  100. 1244 PRINT"Print head on perforation.
  101. 1245 PRINT"Hit return when ready to print":A$=INPUT$(1)
  102. 1250 '
  103.  
  104.  
  105.  
  106.  
  107.                 RECORD WORK LOOP
  108.  
  109.  
  110. 1260 LC=0 ' count
  111. 1270 COL=0 ' print column
  112. 1280 '
  113. 1290 IF DIMS THEN FOR I=T1 TO T2 '        <==== FOR
  114. 1300 COL=COL+1:IF COL>4 THEN COL=1
  115. 1302 IF COL=1 THEN 1304 ELSE 1310
  116. 1304 FOR J=1 TO 4
  117. 1305    FOR K=1 TO 4
  118. 1306        L$(J,K)=""
  119. 1307    NEXT
  120. 1308 NEXT
  121. 1310 IF DIMS THEN GOSUB 2280 ELSE GOSUB 2520 ' get rec
  122. 1320 IF DIMS=0 THEN 1670
  123. 1330 IF ASC(T$)=0 THEN PRINT"0";:GOTO 1920
  124. 1340 PRINT"+";
  125. 1350 T1$=T$ ' save it
  126. 1360 IF SKIPPARSE=1 THEN 1380
  127. 1370 GOSUB 1990 ' parse record string
  128. 1380 IF SEARCH=0 THEN 1670
  129. 1390 '
  130.  
  131.  
  132.  
  133.                 SEARCH
  134.  
  135.  
  136. 1400 IF SEARCH<>2 THEN 1450
  137. 1410 '
  138.  
  139.  
  140.         FIND
  141.  
  142.  
  143. 1420 IF INSTR(T$,SEARCHWORD$(0))=0 THEN 1920
  144. 1430 GOSUB 1990 ' parse
  145. 1440 GOTO 1670
  146. 1450 '
  147.  
  148.  
  149.         FIELD SEARCH
  150.  
  151.  
  152. 1460 J=0 '            check for skips first
  153. 1470 IF SKIPWORD$(J)="" THEN 1550 ' try search then
  154. 1480 IF LOOKFIELD(J)<>0 THEN 1520 ' look in field
  155. 1490 IF INSTR(T1$,SKIPWORD$(J))<>0 THEN 1920 ' whole rec search - skip it
  156. 1500 J=J+1
  157. 1510 GOTO 1470
  158. 1520 IF INSTR(B$(LOOKFIELD(J)),SKIPWORD$(J))<>0 THEN 1920 ' field compare - skip
  159. 1530 J=J+1
  160. 1540 GOTO 1470
  161. 1550 IF SEARCHWORD$(0)="" THEN 1650 ' don't care so print it
  162. 1560 J=0: GOTO 1580 '        now search
  163. 1570 IF SEARCHWORD$(J)="" THEN 1920 ' hesitate no longer
  164. 1580 IF SEARCHFIELD(J)<>0 THEN 1620 ' field
  165. 1590 IF INSTR(T1$,SEARCHWORD$(J))<>0 THEN 1650 ' found it
  166. 1600 J=J+1
  167. 1610 GOTO 1570
  168. 1620 IF INSTR(B$(SEARCHFIELD(J)),SEARCHWORD$(J))<>0 THEN 1650
  169. 1630 J=J+1
  170. 1640 GOTO 1570
  171. 1650 '
  172.  
  173.  
  174.         GET READY TO DO IT
  175.  
  176.  
  177. 1660 IF SKIPPARSE=1 THEN GOSUB 1990 ' parse
  178. 1670 '
  179.  
  180.  
  181.  
  182.                 PAUSE CONTROLS (TERM DEP IF UPPERCASE ONLY)
  183.  
  184.  
  185. 1680 GOSUB 2080:IF DIMS=0 THEN 1770    ' exit returns A
  186. 1690 IF A=122 THEN 1770        ' z means go on
  187. 1700 PRINT I;B$(1);TAB(14);"Ready (SPACE/z/r/n/ESC) >";
  188. 1710 A$=INPUT$(1):A=ASC(A$):
  189.  
  190.     IF A=27 THEN IF DIMS THEN CLOSE 3:GOTO 1950 ELSE GOTO 50
  191. 1720 PRINT A$:IF A=13 OR A=32 OR A=122 THEN 1770
  192. 1730 IF A=114 THEN I=IPREV:GOTO 1310 ' r
  193. 1740 IF A=110 THEN 1750 ELSE 1670 ' n or loop
  194. 1750 INPUT"Enter number of desired record:  ";I:GOTO 1310
  195. 1760 GOSUB 2080            ' exit
  196. 1770 '
  197.  
  198.  
  199.  
  200.                 STORE LABEL IN 4-UP ARRAY
  201.  
  202.  
  203. 1780 IF DIMS THEN IPREV=I ELSE I=I+1
  204. 1790 IF FORM=1 THEN GOSUB 2360    ' reformat medium to short form
  205. 1800 IF FORM=2 THEN GOSUB 2160    ' reformat long to short form
  206. 1810 PRINT "("I")"
  207. 1820 LIN=1
  208. 1830 FOR J=1 TO 3
  209. 1840    IF B$(J)="" THEN 1880
  210. 1850    IF LEN(B$(J))>MAXLEN THEN B$(J)=LEFT$(B$(J),MAXLEN)
  211. 1860    L$(COL,LIN)=B$(J)
  212. 1870    LIN=LIN+1
  213. 1880 NEXT J
  214. 1890 X=LEN(B$(5))+1
  215. 1900 IF LEN(B$(4))>MAXLEN-X THEN B$(4)=LEFT$(B$(4),MAXLEN-X)
  216. 1910 L$(COL,LIN)=B$(4)+" "+B$(5)
  217. 1920    GOSUB 2080 ' check exit
  218. 1930 IF COL=4 THEN GOSUB 2900:
  219.  
  220.     IF DONE THEN IF DIMS GOTO 1950 ELSE STOP 'print labels
  221. 1940 IF DIMS THEN NEXT I ELSE GOTO 1300 '    END OF RECORD WORK LOOP
  222. 1942 FOR J=COL+1 TO 4
  223. 1944    FOR K=1 TO 4
  224. 1945        L$(J,K)=""
  225. 1946    NEXT
  226. 1947 NEXT
  227. 1948 GOSUB 2900
  228. 1950 '
  229.  
  230.  
  231.                 GO HOME TO DIMS
  232.  
  233.  
  234. 1970 PRINT:PRINT:PRINT TAB(17)"Re-loading DEDIT.
  235. 1980 CHAIN DD$(1)+"DEDIT",1000
  236. 1990 '
  237.  
  238.  
  239.  
  240.  
  241.                 (SUB) PARSE STRING
  242.  
  243.  
  244. 2000 K=0
  245. 2010 M=INSTR(T$,CHR$(126)) ' delimiter
  246. 2020 IF M=0 THEN RETURN
  247. 2030 K=K+1
  248. 2040 B$(K)=""
  249. 2050 B$(K)=MID$(T$,1,M-1)
  250. 2060 T$=MID$(T$,M+1)
  251. 2070 GOTO 2010
  252. 2080 '
  253.  
  254.  
  255.  
  256.                 (SUB) EXIT TEST (TERM DEP)
  257.  
  258.  
  259. 2090 X$=INKEY$            'use ESC to escape printing
  260. 2100 IF X$<>"" THEN A=ASC(X$)
  261. 2110 IF A=27 THEN CLOSE 3:IF DIMS GOTO 1970 ELSE GOTO 110 
  262. 2120 RETURN
  263. 2130 '
  264.  
  265.  
  266.  
  267.                 (SUB) CLEAR SCREEN (TERM DEP)
  268.  
  269.  
  270. 2140 PRINT CHR$(26);
  271. 2150 RETURN
  272. 2160 '
  273.  
  274.  
  275.                 (SUB) LONG FORM LABEL RE-FORMAT
  276.  
  277.  
  278. 2170 IF B$(1)="" AND B$(2)="" OR B$(3)="" THEN 2260
  279. 2180 IF B$(2)="" THEN B$(1)=B$(1)+", "+B$(3): GOTO 2200
  280. 2190 B$(1)=B$(2)+" "+B$(1)+", "+B$(3)
  281. 2200    IF LEN(B$(1))>39 THEN B$(1)=LEFT$(B$(1),39)
  282. 2210 B$(2)=B$(4)
  283. 2220 B$(3)=B$(5)
  284. 2230 B$(4)=B$(6)
  285. 2240 B$(5)=B$(7)
  286. 2250 RETURN
  287. 2260 IF B$(2)+B$(1)="" THEN B$(1)=B$(3) ELSE
  288.  
  289.     IF B$(2)="" THEN B$(1)=B$(1) ELSE
  290.  
  291.     B$(1)=B$(2)+" "+B$(1)
  292. 2270 GOTO 2200
  293. 2280 '
  294.  
  295.  
  296.  
  297.                 (SUB) GET DIMS RECORD "I" IN T$
  298.  
  299.  
  300. 2290 T$="" ' necessary!
  301. 2300 ON FT GOTO 2330,2310
  302. 2310    GET#1,FT*I+2 ' latter half
  303. 2320    T$=LEFT$(R$,127)
  304. 2330    GET#1,FT*I+1 ' whole or first half
  305. 2340    T$=R$+T$
  306. 2350 RETURN
  307. 2360 '
  308.  
  309.  
  310.                 (SUB) MEDIUM FORM RE-FORMAT
  311.  
  312.  
  313. 2370 IF B$(2)="" THEN 2380
  314.  
  315.     ELSE B$(1)=B$(2)+" "+B$(1)
  316. 2380 B$(2)=B$(3)
  317. 2390 B$(3)=B$(4)
  318. 2400 B$(4)=B$(5)
  319. 2410 B$(5)=B$(6)
  320. 2420 RETURN
  321. 2430 '
  322.  
  323.  
  324.                 (SUB) UCV
  325.  
  326.  
  327. 2440 Y$=""
  328. 2450 FOR K=1 TO LEN(X$)
  329. 2460    Y$=Y$+CHR$(32)
  330. 2470    X=ASC(MID$(X$,K,1))
  331. 2480    IF 96<X AND X<123 THEN MID$(Y$,K,1)=CHR$(X-32):GOTO 2500
  332. 2490    MID$(Y$,K,1)=MID$(X$,K,1)
  333. 2500 NEXT
  334. 2510 RETURN
  335. 2520 '
  336.  
  337.  
  338.                 (SUB) GET NEXT SEQUENTIAL RECORD
  339.  
  340.  
  341. 2530 GOSUB 2080            'exit
  342. 2540 IF EOF(3) THEN DONE=1
  343. 2550 FOR K=1 TO NC:B$(K)="":NEXT
  344. 2555 IF DONE THEN RETURN
  345. 2560 LINE INPUT #3,T$
  346. 2570 GOSUB 2680         'parse into B$ array j=fields found
  347. 2580 IF J<>NC THEN 2600 ELSE 2610
  348. 2600 PRINT"Input file line"INREC"defective."CHR$(7)
  349. 2610 FOR K=1 TO J        'recover quotes encoded by DPUT.BAS
  350. 2630    QUOTE=INSTR(B$(K),CHR$(126))
  351. 2640    IF QUOTE THEN MID$(B$(K),QUOTE,1)=CHR$(34):GOTO 2630
  352. 2660 NEXT
  353. 2670 RETURN
  354. 2680 '
  355.  
  356.  
  357.             (SUB) PARSE COMMA-DELIM. RECORD T$ -> B$ ARRAY
  358.  
  359.  
  360. 2690 '                returns J = number of fields found
  361. 2700 FOR J=1 TO NC:B$(J)="":NEXT
  362. 2710 J=0
  363. 2720 ' process loop
  364. 2730    J=J+1:IF J=NC THEN 2830
  365. 2740    X=INSTR(T$,CHR$(44))     'comma
  366. 2750    IF X=0 THEN 2830    'must be last field
  367. 2760    Y=INSTR(T$,CHR$(34))     'quote
  368. 2770    IF Y=0 OR ( Y<>0 AND X<Y ) THEN 2800 ELSE 2780 'comma before quote
  369. 2780    Z=INSTR(Y+1,T$,CHR$(34))
  370. 2790    X=INSTR(Z+1,T$,CHR$(44))'loc of next comma after close quote
  371. 2800    B$(J)=MID$(T$,1,X-1):GOSUB 2860
  372. 2810 '        TRIM OFF USED PART
  373. 2820    T$=MID$(T$,X+1):GOTO 2720
  374. 2830 '        LAST FIELD
  375. 2840    B$(J)=T$:GOSUB 2860
  376. 2850 RETURN
  377. 2860 '
  378.  
  379.  
  380.                 (SUB) TRIM QUOTES OFF STRING
  381.  
  382.  
  383. 2870 IF LEFT$(B$(J),1)=CHR$(34) THEN B$(J)=RIGHT$(B$(J),LEN(B$(J))-1)
  384. 2880 IF RIGHT$(B$(J),1)=CHR$(34) THEN B$(J)=LEFT$(B$(J),LEN(B$(J))-1)
  385. 2890 RETURN
  386. 2900 '
  387.  
  388.  
  389.                 (SUB) PRINT LABELS
  390.  
  391.  
  392. 2910 LPRINT
  393. 2920 FOR LIN=1 TO 4
  394. 2930    FOR COL=1 TO 4
  395. 2940        X=COLPOS(COL):GOSUB 3000 'diablo tab
  396. 2950        LPRINT L$(COL,LIN);
  397. 2960    NEXT COL
  398. 2970    LPRINT
  399. 2980 NEXT LIN
  400. 2990 LPRINT
  401. 2995 RETURN
  402. 3000 '
  403.  
  404.  
  405.                 (SUB) TAB LPRINT (DIABLO)
  406.  
  407.  
  408. 3010 IF X>126 THEN LPRINT TAB(X);:GOTO 3030 ' Diablo abs. tab limit
  409. 3020 LPRINT CHR$(27);CHR$(137);CHR$(X+128);
  410. 3030 RETURN
  411. 3010 IF X>126 THEN LPRINT TAB(X);:GOTO 3030 ' D