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 / DUNFLAG.ASC < prev    next >
Text File  |  1986-12-07  |  4KB  |  186 lines
  1. 10 PRINT"This program must be entered from DEDIT.":STOP
  2. 1000 GOSUB 2060 'cs
  3. 1010 PRINT:PRINT TAB(29);"DUNFLAG March 11, 1984
  4. 1015 ' by Dan Dugan -- public domain
  5. 1020 PRINT
  6. 1030 DEFINT A-Z
  7. 1040 COMMON I,J,K,X,Y,T$,R$,S$,T1$,SKIPPARSE,FT,SEARCH,
  8.     C,N,NC,P6,P7,P8,P9,PI,S,T,T1,T2,C(),B$(),N$(),
  9.     SEARCHWORD$(),SEARCHFIELD(),SKIPWORD$(),LOOKFIELD(),DD$(),F$,FT$
  10. 1060 '                SET UP
  11. 1065 PRINT"Here are the fields in "F$":"
  12. 1070 GOSUB 2290        'show fields
  13. 1075 PRINT
  14. 1080 INPUT"Number of field to unflag? ",F
  15. 1085 IF F=0 THEN 1740    'quit
  16. 1090 PRINT:INPUT"String to find and remove";FLAG$
  17. 1100 L=LEN(FLAG$)
  18. 1150 '
  19.  
  20.  
  21.  
  22.                 RECORD WORK LOOP
  23.  
  24. 1160 C2=0 ' first time
  25. 1170 LC=0 ' count
  26. 1180 '
  27. 1190 FOR I=T1 TO T2 '        <==== FOR
  28. 1200 GOSUB 2210 ' get rec
  29. 1205 IF ASC(T$)=0 THEN PRINT"0";:GOTO 1720
  30. 1210 PRINT"+";
  31. 1220 T1$=T$ ' save it
  32. 1230 IF SKIPPARSE=1 THEN 1250
  33. 1240 GOSUB 1780 ' parse record string
  34. 1250 IF SEARCH=0 THEN 1540
  35. 1260 '
  36.  
  37.  
  38.                 SEARCH
  39.  
  40. 1270 IF SEARCH<>2 THEN 1320
  41. 1275 '
  42.  
  43.         FIND
  44.  
  45. 1280 IF INSTR(T$,SEARCHWORD$(0))=0 THEN 1720
  46. 1300 GOSUB 1780 ' parse
  47. 1310 GOTO 1540
  48. 1320 '
  49.  
  50.         FIELD SEARCH
  51.  
  52. 1330 J=0 '            check for skips first
  53. 1340 IF SKIPWORD$(J)="" THEN 1420 ' try search then
  54. 1350 IF LOOKFIELD(J)<>0 THEN 1390 ' look in field
  55. 1360 IF INSTR(T1$,SKIPWORD$(J))<>0 THEN 1720 ' whole rec search - skip it
  56. 1370 J=J+1
  57. 1380 GOTO 1340
  58. 1390 IF INSTR(B$(LOOKFIELD(J)),SKIPWORD$(J))<>0 THEN 1720 ' field compare - skip
  59. 1400 J=J+1
  60. 1410 GOTO 1340
  61. 1420 IF SEARCHWORD$(0)="" THEN 1520 ' don't care so print it
  62. 1430 J=0: GOTO 1450 '        now search
  63. 1440 IF SEARCHWORD$(J)="" THEN 1720 ' hesitate no longer
  64. 1450 IF SEARCHFIELD(J)<>0 THEN 1490 ' field
  65. 1460 IF INSTR(T1$,SEARCHWORD$(J))<>0 THEN 1520 ' found it
  66. 1470 J=J+1
  67. 1480 GOTO 1440
  68. 1490 IF INSTR(B$(SEARCHFIELD(J)),SEARCHWORD$(J))<>0 THEN 1520
  69. 1500 J=J+1
  70. 1510 GOTO 1440
  71. 1520 '
  72.  
  73.         GET READY TO DO IT
  74.  
  75. 1530 IF SKIPPARSE=1 THEN GOSUB 1780 ' parse
  76. 1540 '
  77.  
  78.  
  79.                 PAUSE CONTROLS (TERM DEP IF UPPERCASE ONLY)
  80.  
  81. 1541 GOSUB 2030            ' exit returns A
  82. 1542 IF A=122 THEN 1560        ' z means go on
  83. 1543 PRINT I;B$(1);TAB(14);"Ready (SPACE/z/r/n/ESC) >";
  84. 1544 A$=INPUT$(1):A=ASC(A$):IF A=27 THEN CLOSE 3:GOTO 1740
  85. 1545 PRINT A$:IF A=13 OR A=32 OR A=122 THEN 1560
  86. 1546 IF A=114 THEN I=IPREV:GOTO 1200 ' r
  87. 1547 IF A=110 THEN 1548 ELSE 1540 ' n or loop
  88. 1548 INPUT"Enter number of desired record:  ";I:GOTO 1200
  89. 1550 GOSUB 2030            ' exit
  90. 1560 '
  91.  
  92.  
  93.                 DO IT
  94.  
  95. 1570 TEST=INSTR(B$(F),FLAG$)
  96. 1580 IF TEST THEN 1590 ELSE 1720
  97. 1590 B$(F)=LEFT$(B$(F),TEST-1)+MID$(B$(F),TEST+L)
  98. 1600 '                ASSEM CHANGED REC STR & PUT TO DISK
  99. 1610 T$=""
  100. 1620 FOR J=1 TO NC
  101. 1630    T$=T$+B$(J)+CHR$(126)
  102. 1640 NEXT
  103. 1650 GOSUB 2350:PRINT"*";:GOSUB 2420:PRINT"!"
  104. 1720    GOSUB 2030 ' check exit
  105. 1730 NEXT I '            END OF RECORD WORK LOOP
  106. 1740 '
  107.  
  108.                 FINISH
  109.  
  110. 1760 PRINT:PRINT:PRINT TAB(32)"Re-loading DEDIT.
  111. 1770 CHAIN DD$(1)+"DEDIT",1000
  112. 1780 '
  113.  
  114.  
  115.  
  116.                 (SUB) PARSE STRING
  117.  
  118. 1790 K=0
  119. 1800 M=INSTR(T$,CHR$(126)) ' delimiter
  120. 1810 IF M=0 THEN RETURN
  121. 1820 K=K+1
  122. 1830 B$(K)=""
  123. 1840 B$(K)=MID$(T$,1,M-1)
  124. 1850 T$=MID$(T$,M+1)
  125. 1860 GOTO 1800
  126. 2030 '
  127.  
  128.  
  129.                 (SUB) EXIT TEST (TERM DEP)
  130.  
  131. 2040 X$=INKEY$
  132. 2042 IF X$<>"" THEN A=ASC(X$)
  133. 2045 IF A=27 THEN CLOSE 3:GOTO 1740    'use ESC to escape listing
  134. 2050 RETURN
  135. 2060 '
  136.  
  137.  
  138.                 (SUB) CLEAR SCREEN (TERM DEP)
  139.  
  140. 2070 PRINT CHR$(12);
  141. 2080 RETURN
  142. 2210 '
  143.  
  144.  
  145.                 (SUB) GET RECORD "I" IN T$
  146.  
  147. 2220 T$="" ' necessary!
  148. 2230 ON FT GOTO 2260,2240
  149. 2240    GET#1,FT*I+2 ' latter half
  150. 2250    T$=LEFT$(R$,127)
  151. 2260    GET#1,FT*I+1 ' whole or first half
  152. 2270    T$=R$+T$
  153. 2280 RETURN
  154. 2290 '
  155.  
  156.                 SHOW FIELDS (SUB)
  157.  
  158. 2300 FOR K=1 TO NC
  159. 2310    PRINT TAB(29);
  160. 2320    PRINT USING"##";K;:PRINT".  "LEFT$(N$(K),4)"  "RIGHT$(N$(K),1)
  161. 2330 NEXT
  162. 2340 RETURN
  163. 2350 '
  164.  
  165.                 PUT T$ AS RECORD I (SUB)
  166.  
  167. 2360 ON FT GOTO 2390,2370
  168. 2370 LSET R$=MID$(T$,129)    'latter half
  169. 2380 PUT #1,FT*I+2
  170. 2390 LSET R$=LEFT$(T$,128)
  171. 2400 PUT #1,FT*I+1
  172. 2410 RETURN
  173. 2420 '
  174.  
  175.                 PUT T$ AS DUPE REC I (SUB)
  176.  
  177. 2430 ON FT GOTO 2460,2440
  178. 2440 LSET S$=MID$(T$,129)
  179. 2450 PUT #2,FT*I+2
  180. 2460 LSET S$=LEFT$(T$,128)
  181. 2470 PUT #2,FT*I+1
  182. 2480 RETURN
  183. FT GOTO 2460,2440
  184. 2440 LSET S$=MID$(T$,129)
  185. 2450 PUT #2,FT*I+2
  186. 2460 LSET S$=LEFT$(T$,128)