home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / BASIC / BASIC00.ZIP / PCMAP.BAS < prev    next >
Encoding:
BASIC Source File  |  1987-01-11  |  10.6 KB  |  237 lines
  1. 1 '*********************************************************************
  2. 2 '*   PC-MAP.  This program recreates a PC-File database into a new   *
  3. 3 '*            Format. Fields may be added or deleted, renamed,       *
  4. 4 '*            rearranged, and lengthened or shortened. Output is a   *
  5. 5 '*            Data file and Header file.  After using PC-File to     *
  6. 6 '*            sort the file (thus creating a new index), the new     *
  7. 7 '*            database is ready to go.                               *
  8. 8 '*            (1982) by F. Neil Lamka.                               *
  9. 9 '*********************************************************************
  10. 10 DEFINT A-Z:COMMON F$,DL,XL,NR
  11. 20 CLS:RC=80
  12. 25 ERCOUNT = 0
  13. 30 FALSE=0:TRUE=1
  14. 40 MC=RC\2:F9=RC\2+2
  15. 50 SCREEN 0,0:COLOR 7,0
  16. 60 WIDTH RC:KEY OFF
  17. 70 DIM OFM$(42),OFL(42) 'set up arrays for field names and lengths
  18. 80 DIM NFM$(42),NFL(42) 'set up arrays for new data base
  19. 90 CLS:LOCATE 10,MC-9:PRINT"PC-MAP Version 1.4";
  20. 95 LOCATE 12,MC-17:PRINT"A PC-FILE Data Base Conversion Aid";
  21. 100 LOCATE 14,MC-11:PRINT"(1982) F. Neil Lamka"
  22. 110 DR$="Which drive (ABCD) contains the origional data base? "
  23. 120 CL = 0
  24. 130 UC=1:GOSUB 20000
  25. 140 IF DR$<"A" OR DR$>"D" GOTO 110
  26. 150 OF$ = DR$+":"   'set file name for old data base
  27. 155 TF$=OF$
  28. 160 DR$="Which drive (ABCD) will contain the new data base? "
  29. 170 CL = -3 'set value for message color (15-3)
  30. 180 UC=1:GOSUB 20000
  31. 190 CL = 0 'reset line color value
  32. 200 IF DR$<"A" OR DR$>"D" GOTO 160
  33. 210 NF$ = DR$+ ":"  'set file name for new data base
  34. 220 ON ERROR GOTO 250
  35. 230 CLS:LOCATE 5,1:PRINT"Choose one of these files to convert:"
  36. 240 FILES OF$+"*.HDR":GOSUB 30000:ON ERROR GOTO 0:GOTO 260
  37. 250 RESUME 260
  38. 260 DR$="Which file:":UC=1:GOSUB 20000
  39. 270 IF DR$="" THEN 260 ELSE OF$ = TF$ + DR$ 'set file name to be used
  40. 280 ON ERROR GOTO 330
  41. 290 VL$=".HDR":FILES OF$+VL$ 'see if the hdr file exists
  42. 300 VL$=".DTA":FILES OF$+VL$ 'see if the data file exists
  43. 310 ON ERROR GOTO 0
  44. 320 CLS:GOTO 360  'go get new file name
  45. 330 RESUME 340
  46. 340 ON ERROR GOTO 0:DR$=OF$+VL$+" does not exist...please respecify: "
  47. 341 CL=-4:UC=1:SOUND 500,9:GOSUB 20000:CL=0
  48. 342 IF DR$="" THEN 260 ELSE OF$=TF$+DR$
  49. 350 GOTO 280
  50. 360 TF$=NF$
  51. 365 DR$="Enter name for new data base: ":CL= -3:UC=1:GOSUB 20000
  52. 370 IF DR$="" THEN 360 ELSE NF$=NF$+DR$ 'set new data base name
  53. 375 IF NF$=OF$ THEN DR$="INVALID NAME - SAME AS THE FIRST ONE - RESPECIFY ":NF$=TF$:UC=1:CL=-4:SOUND 500,4:GOSUB 20000:CL=0:GOTO 370
  54. 380 ON ERROR GOTO 440
  55. 400 VL$=".HDR":FILES NF$+VL$ 'see if a hdr file exists
  56. 410 CLS:DR$=NF$+VL$+" already exists...respecify or hit ENTER to reuse: "
  57. 415 ON ERROR GOTO 0
  58. 420 UC=1:CL=-4:SOUND 500,4:GOSUB 20000:CL=0
  59. 430 IF DR$="" THEN KILL NF$+VL$:GOTO 450 ELSE NF$=TF$+DR$:GOTO 380
  60. 440 RESUME 450 'if we get here then the files did not exist
  61. 450 ON ERROR GOTO 0
  62. 452 ON ERROR GOTO 462:VL$=".DTA":FILES NF$+VL$
  63. 454 CLS:DR$=NF$+VL$+" already exists...respecify or hit ENTER to reuse: "
  64. 456 ON ERROR GOTO 0
  65. 458 UC=1:CL=-3:SOUND 500,9:GOSUB 20000:CL=0
  66. 460 IF DR$="" THEN KILL NF$+VL$:GOTO 464 ELSE NF$=TF$+DR$:GOTO 380
  67. 462 RESUME 464 'files did not exist if we are here
  68. 464 ON ERROR GOTO 0
  69. 500 REM All files have been verified...now start the work
  70. 510 ODL=0:ODF=0 'set record length and number of entries in old db
  71. 520 NDL=0:NDF=0 'set record length and number of entries in new db
  72. 530 CLS
  73. 540 PRINT"Reading origional data base records ";MID$(OF$,3)
  74. 550 OPEN"i",#1,OF$+".HDR"  'open old header file
  75. 560 WHILE NOT EOF(1)       'read old data base header description
  76. 570 INPUT#1,TS$:ODF =ODF + 1:OFM$(ODF) = TS$ 'read label
  77. 580 INPUT#1,OFL(ODF):ODL = ODL + OFL(ODF)
  78. 590 WEND 'end of the loop
  79. 595 CLOSE#1 'done with the old header file
  80. 600 CLS:LOCATE 2,1:PRINT "Origional Data Base Fields";
  81. 602 LOCATE 3,1:PRINT OF$+".HDR";
  82. 605 LC=4:MAXLEN = 0
  83. 610 LOCATE LC,1
  84. 620 FOR I = 1 TO ODF
  85. 630 IF OFL(I) > MAXLEN THEN MAXLEN=OFL(I)
  86. 635 LOCATE LC+I,1:PRINT OFM$(I);:PRINT,USING" ###";OFL(I)
  87. 640 NEXT I
  88. 650 IF MAXLEN+3+2 <= 40 THEN NEXTFIELD=40 ELSE NEXTFIELD=0
  89. 700 LOCATE 1,1:COLOR 12,0:SOUND 800,4:PRINT"Enter values for the new headers";
  90. 703 LOCATE 2,NEXTFIELD:COLOR 15,0:PRINT"New Data Base fields";
  91. 705 LOCATE 3,NEXTFIELD:PRINT NF$+".HDR";
  92. 710 ATLINE = 1:NDF=0:NEWEND = FALSE
  93. 715 CURMAX = 12:COLOR 15,0
  94. 720 WHILE NEWEND = FALSE
  95. 725 IF ATLINE+LC >24 THEN GOSUB 10000:ATLINE = 1
  96. 730 LOCATE ATLINE+LC,NEXTFIELD
  97. 740 LINE INPUT;"";TS$:IF TS$="" THEN NEWEND=TRUE:GOTO 750 ELSE NDF=NDF+1:NFM$(NDF) = TS$
  98. 741 IF LEN(NFM$(NDF)) > 12 THEN NFM$(NDF)=LEFT$(NFM$(NDF),12):LOCATE ATLINE+LC,NEXTFIELD:PRINT NFM$(NDF)+SPACE$(LEN(TS$)-12);
  99. 745 ATLINE = ATLINE + 1
  100. 750 WEND:COLOR 7,0
  101. 752 DR$="Is this HDR information correct (Y or N)? ":UC=1:CL=0:GOSUB 20000
  102. 753 IF DR$="" THEN 752 ELSE IF DR$ = "N" THEN GOSUB 40000:GOTO 710 ELSE IF DR$ <> "Y" THEN 752
  103. 759 NDL=0:LOCATE 1,1:PRINT"                                 "
  104. 760 LOCATE 1,40:COLOR 12,0:PRINT"Enter the width of each field    ";:COLOR 4,0
  105. 765 SOUND 800,5
  106. 770 FOR I = 1 TO NDF
  107. 780 LOCATE LC+I,NEXTFIELD+CURMAX+1
  108. 790 LINE INPUT;"";TS$:NFL(I)=VAL(TS$):NDL=NDL+NFL(I)
  109. 792 IF NFL(I) = 0 THEN LOCATE 25,1:PRINT"Spceified field length is not valid..Please reenter";:SOUND 500,9:GOTO 780
  110. 795 LOCATE LC+I,NEXTFIELD+CURMAX+1:PRINT,USING"###";NFL(I)
  111. 796 LOCATE 25,1:PRINT"                                                    ";
  112. 800 NEXT I
  113. 802 DR$="Is this field width information correct (Y or N)? ":UC=1:CL=0:GOSUB 20000
  114. 803 IF DR$="" THEN 802 ELSE IF DR$ = "N" THEN GOSUB 50000:GOTO 759 ELSE IF DR$ <> "Y" THEN 802
  115. 810 COLOR 7,0
  116. 900 CLS 'now that the data fields have been defined...we need relationships
  117. 910 LOCATE 1,1:PRINT"Define field relationship values";
  118. 920 LOCATE 2,1:PRINT"For each field in the new data base indicate the";
  119. 930 LOCATE 3,1:PRINT"corresponding old data base field number or 0";
  120. 940 LOCATE 4,1
  121. 950 FOR I = 1 TO NDF 'output new data fields
  122. 960 LOCATE 4+I,1:PRINT NFM$(I);
  123. 980 NEXT I
  124. 990 FOR I = 1 TO ODF 'output old data base fields
  125. 1000 LOCATE 4+I,50:PRINT OFM$(I)
  126. 1005 LOCATE 4+I,30:PRINT,USING"###";I;
  127. 1010 NEXT I
  128. 1015 DIM FR(42) 'set the size of the relationship matrix to the # of data flds
  129. 1020 FOR I = 1 TO NDF 'get field relationship value
  130. 1030 LOCATE 4+I,25
  131. 1040 LINE INPUT;"";TS$:IF TS$ = "" THEN 1030
  132. 1050 IF (VAL(TS$) > ODF) OR (VAL(TS$) < 0) THEN LOCATE 25,1:PRINT"Invalid field relationship specified";:SOUND 500,9:GOTO 1030
  133. 1060 LOCATE 25,1:PRINT"                                    ";
  134. 1070 FR(I) = VAL(TS$) 'set the field relationship matrix value
  135. 1080 NEXT I
  136. 1082 DR$="Are these field relationships correct (Y or N)? ":CL=0:UC=1:GOSUB 20000
  137. 1084 IF DR$="" THEN 1082 ELSE IF DR$="N" THEN GOSUB 60000:GOTO 1020 ELSE IF DR$ <> "Y" THEN 1082
  138. 1100 CLS 'now we have all we need to remap the data base
  139. 1110 DIM OFILE$(42),NFILE$(42) 'set up to map the data base
  140. 1120 CLS:PRINT"Writing new HDR file ";:COLOR 12,0
  141. 1130 PRINT NF$+".HDR":COLOR 7,0
  142. 1140 OPEN"o",#1,NF$+".HDR"
  143. 1150 FOR I = 1 TO NDF 'loop until end of header info
  144. 1160 PRINT#1,NFM$(I) 'write out the header name
  145. 1170 PRINT#1,NFL(I)  'write out the field lenght
  146. 1180 NEXT I
  147. 1190 CLOSE#1         'close the new header file
  148. 1200 PRINT"New Header file created"
  149. 1210 REM open the DTA data sets for processing
  150. 1220 OPEN"r",#2,OF$+".DTA",ODL+1
  151. 1230 FIELD#2,ODL AS ODF$          'set up a field for direct read
  152. 1240 OPEN"r",#3,NF$+".DTA",NDL+1
  153. 1250 FIELD#3,NDL AS NDF$          'this will be the outputfield
  154. 1260 X = 1 'set initial record number
  155. 1265 FEND = FALSE
  156. 1270 WHILE FEND = FALSE  'read until \ record found in data base
  157. 1280 GET#2,X  'read record from the old data base
  158. 1290 IF LEFT$(ODF$,1) = "\" THEN FEND=TRUE:DR$="\":GOTO 1400
  159. 1295 'IF LEFT($(ODF$,2)="//" THEN GOTO 1408  check for deleted record
  160. 1300 CPOS = 1 'map old data record to array
  161. 1310 FOR I = 1 TO ODF
  162. 1320 OFILE$(I)=MID$(ODF$,CPOS,OFL(I)):CPOS=CPOS+OFL(I)
  163. 1330 NEXT I
  164. 1340 FOR J = 1 TO NDF
  165. 1350 IF FR(J)=0 THEN NFILE$(J)=SPACE$(NFL(J)):GOTO 1372
  166. 1362 IF NFL(J)<=OFL(FR(J)) THEN NFILE$(J)=LEFT$(OFILE$(FR(J)),NFL(J)):GOTO 1372
  167. 1364 IF NFL(J)>OFL(FR(J)) THEN NFILE$(J)=OFILE$(FR(J))+SPACE$(NFL(J)-OFL(FR(J)))
  168. 1372 NEXT J
  169. 1375 DR$=""
  170. 1376 FOR K=1 TO NDF:DR$=DR$+LEFT$(NFILE$(K),NFL(K)):NEXT K
  171. 1400 LSET NDF$=DR$:PUT#3,X       'write the new record
  172. 1401 CLS:LOCATE 1,1:PRINT"Processing record number(",X,")";
  173. 1402 LOCATE 2,1:PRINT"New File Record";
  174. 1403 LOCATE 2,40:PRINT"Old File Record";
  175. 1406 FOR K = 1 TO NDF:LOCATE 3+K,1:PRINT NFILE$(K);:NEXT K
  176. 1407 FOR K = 1 TO ODF:LOCATE 3+K,40:PRINT OFILE$(K);:NEXT K
  177. 1408 X=X+1
  178. 1410 WEND
  179. 1420 CLOSE#2:CLOSE#3
  180. 1500 CLS 'output final file stats
  181. 1510 LOCATE 8,28:PRINT"File conversion complete";
  182. 1520 LOCATE 9,28:PRINT"Data Base Statistics are";
  183. 1530 LOCATE 11,1 :PRINT"Origional Data Base = ";:LOCATE 11,30:PRINT OF$;
  184. 1550 LOCATE 12,1:PRINT"Origional number of fields = ";:LOCATE 12,30:PRINT ODF;
  185. 1552 LOCATE 13,1:PRINT"Record Length = ";:LOCATE 13,30:PRINT ODL;
  186. 1555 COLOR 15,0
  187. 1560 LOCATE 15,1:PRINT"New Data Base = ";:LOCATE 15,30:PRINT NF$;
  188. 1570 LOCATE 16,1:PRINT"New number of fields = ";:LOCATE 16,30:PRINT NDF;
  189. 1580 LOCATE 17,1:PRINT"New Total Record Length = ";:LOCATE 17,30:PRINT NDL;
  190. 1590 LOCATE 20,1:PRINT"Number of Data Records Read = ",X-1;
  191. 1600 COLOR 7,0
  192. 1610 GOSUB 60990 'go wait for input key to continue
  193. 1615 CLS:PRINT"Your new database is built."
  194. 1620 PRINT:PRINT"You must remember to sort the database"
  195. 1625 PRINT:PRINT"the first time you use it."
  196. 1640 END
  197. 10000 FOR LP = LC+1 TO 24
  198. 10010 LOCATE LP,NEXTFIELD:PRINT SPC(79-NEXTFIELD)
  199. 10020 NEXT LP
  200. 10030 RETURN
  201. 20000 GOSUB 20110
  202. 20010 SOUND 200,9
  203. 20020 LOCATE 25,1:COLOR 15+CL,0
  204. 20030 PRINT DR$;:COLOR 7,0
  205. 20040 LINE INPUT;"";DR$
  206. 20050 IF LEN(DR$)<1 GOTO 20110
  207. 20060 IF UC=0 GOTO 20110
  208. 20070 FOR NN = 1 TO LEN(DR$) 'fold to upper case
  209. 20080 X=ASC(MID$(DR$,NN,1))
  210. 20090 IF X>=97 AND X <= 122 THEN MID$(DR$,NN,1)=CHR$(X-32)
  211. 20100 NEXT:UC = 0
  212. 20110 LOCATE 25,1:PRINT SPACE$(RC-1);:LOCATE 25,1:RETURN
  213. 30000 FOR R = 6 TO 24
  214. 30010 FOR C = 9 TO RC-2 STEP 13
  215. 30020 LOCATE R,C:PRINT"     ";
  216. 30030 NEXT C:NEXT R
  217. 30040 RETURN
  218. 40000 FOR I = 1 TO NDF 'routine called if new field names incorrect
  219. 40010 NFM$(I) = ""
  220. 40020 LOCATE LC+I,NEXTFIELD:PRINT SPC(RC-NEXTFIELD);
  221. 40030 NEXT I
  222. 40040 RETURN
  223. 50000 FOR I = 1 TO NDF 'routine to be called if new field width incorrect
  224. 50020 NFL(I)=0
  225. 50025 LOCATE LC+I,NEXTFIELD+CURMAX+1:PRINT,USING"###";NFL(I);
  226. 50030 NEXT I
  227. 50040 RETURN
  228. 60000 FOR I = 1 TO NDF 'routine to be used if relationship vals incorrect
  229. 60010 LOCATE 4+I,25:PRINT SPC(5)
  230. 60020 FR(I) = 0
  231. 60030 NEXT I
  232. 60040 RETURN
  233. 60990 REM 'Wait for input key subroutine
  234. 60991 LOCATE 25,1:PRINT"Hit any key to continue";
  235. 60992 K$=INKEY$:IF K$="" THEN 60992 ELSE RETURN
  236.  for input key subroutine
  237. 60991 LOCATE 25,1:PRINT"Hit any key t