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