home *** CD-ROM | disk | FTP | other *** search
/ Simtel MSDOS 1992 June / SIMTEL_0692.cdr / msdos / statstcs / codebook.arc / CODEBOOK.BAS next >
Encoding:
BASIC Source File  |  1989-07-26  |  24.9 KB  |  230 lines
  1. 10 CLEAR:CLOSE:SCREEN 0:WIDTH 80:KEY OFF:COLOR 7,1,1:CLS:DEFINT A-Z:OPTION BASE 1
  2. 20 CHECK.RESULT$="BAD":PRINT "+++ Program CODEBOOK.BAS, version 1.0 by Jim Groeneveld, 26 July 1989. +++"
  3. 25 MAX.N.OF.VARS=0:WHILE MAX.N.OF.VARS=0 ''' or max.n.of.vars<-32767 or max.n.of.vars>32767
  4. 30   PRINT "--- Enter (at least) total number of variables to reserve array space or";"    enter a NEGATIVE starting number for automatic adaptation";"    to the actual number in the codebook file [-100]: ";
  5. 35   INPUT"",MAX.N.OF.VARS '====== in order to reserve array space
  6. 40   IF MAX.N.OF.VARS=0 THEN MAX.N.OF.VARS=-100
  7. 50   IF MAX.N.OF.VARS<-32767 OR MAX.N.OF.VARS>32767 THEN BEEP:PRINT "*** Illegal number of variables entered! ***"
  8. 55   IF MAX.N.OF.VARS<0 THEN MAX.N.OF.VARS=-MAX.N.OF.VARS:EXTRA.VARS=MAX.N.OF.VARS:AUTO.NOV$="YES" ELSE AUTO.NOV$="NO"
  9. 60 WEND
  10. 70 MAX.VARS.PER.FILE=32767:MAX.LINE.INPUT.LENGTH=255:WILDCARD$="NO"
  11. 80 DIM VARIABLE.NAME$(MAX.N.OF.VARS),BEGIN.COLUMN!(MAX.N.OF.VARS),END.COLUMN!(MAX.N.OF.VARS),MISSING.VALUE$(MAX.N.OF.VARS),VAR.TYPE$(MAX.N.OF.VARS)
  12. 99 N.OF.DATA.LINES=1:MAX.COL.SPEC=254
  13. 102 PRINT "--- Do you want to check the codebook for identical variable names? [Y]/N: ";
  14. 104 CHECK.VAR.NAME$="":WHILE CHECK.VAR.NAME$="":WHILE CHECK.VAR.NAME$="":CHECK.VAR.NAME$=INKEY$:WEND:IF INSTR("YyNn"+CHR$(13),CHECK.VAR.NAME$)=0 THEN BEEP:CHECK.VAR.NAME$=""
  15. 106 WEND:IF INSTR("Yy"+CHR$(13),CHECK.VAR.NAME$)>0 THEN CHECK.VAR.NAME$="YES" ELSE CHECK.VAR.NAME$="NO"
  16. 108 PRINT CHECK.VAR.NAME$
  17. 110 WHILE CHECK.RESULT$<>"OK"
  18. 111   WHILE CHECK.RESULT$<>"OK"
  19. 120     PRINT "--- Enter codebook file name: ";:LINE INPUT CODEBOOK.COL$
  20. 130     D.PATH.FILENAME.EXT$=CODEBOOK.COL$:GOSUB 11000 'check file name and split name and extension as CODEBOOK$ and COL$.
  21. 140     IF CHECK.RESULT$<>"OK" THEN BEEP:PRINT CHECK.RESULT$:GOTO 160
  22. 150     CODEBOOK.COL$=D.PATH.FILENAME.EXT$:CODEBOOK$=D.PATH.FILENAME$:COL$=EXT$
  23. 160   WEND
  24. 170   ON ERROR GOTO 11400:OPEN "I",#1,CODEBOOK.COL$:ON ERROR GOTO 0
  25. 180   IF CHECK.RESULT$<>"OK" THEN BEEP:PRINT CHECK.RESULT$
  26. 190 WEND:PRINT "=== Scanning and reading codebook file......please wait and see......"
  27. 200 TOT.N.OF.VARS=0:LINE.COUNT=0:CHECK.FIELD.WIDTH$="OK":WHILE NOT EOF(1)
  28. 202   LINE.COUNT=LINE.COUNT+1:CHECK.RESULT$="OK":ON ERROR GOTO 11400:FIRST.COLUMN$=INPUT$(1,#1)
  29. 204   IF FIRST.COLUMN$=CHR$(13) THEN SECOND.COLUMN$=INPUT$(1,#1):ON ERROR GOTO 0:GOTO 285 '====== (reading LF as the second character) This is an empty line (only CRLF)
  30. 206   IF FIRST.COLUMN$<>" " AND FIRST.COLUMN$<>"'" AND FIRST.COLUMN$<>CHR$(34) THEN LINE INPUT #1,COMMENT.LINE$:J=LEN(COMMENT.LINE$):GOSUB 1050:ON ERROR GOTO 0:GOTO 285 '====== this is a comment line
  31. 208   IF TOT.N.OF.VARS=>MAX.N.OF.VARS AND AUTO.NOV$="NO" THEN BEEP:PRINT "*** Number of variables exceeds maximum of";MAX.N.OF.VARS;", correct and rerun ***";STRING$(80-POS(0),32):CLOSE:STOP
  32. 210   IF TOT.N.OF.VARS=100 THEN PRINT "If running under interpreter BASIC time consuming garbage collection may occur!"
  33. 212   IF TOT.N.OF.VARS=MAX.N.OF.VARS AND AUTO.NOV$="YES" THEN GOSUB 1100 '------ increase arrays VAR.TYPE$, MISSING.VALUE$, BEGIN.COLUMN!, END.COLUMN! and VARIABLE.NAME$ by EXTRA.VARS elements and continue
  34. 214   TOT.N.OF.VARS=TOT.N.OF.VARS+1:VAR.TYPE$(TOT.N.OF.VARS)=FIRST.COLUMN$ ''''':if var.type$(tot.n.of.vars)=" " then var.type$(tot.n.of.vars)="" leads to erroneous copying to another array!!!
  35. 216   INPUT #1,MISSING.VALUE$(TOT.N.OF.VARS),BEGIN.COLUMN!(TOT.N.OF.VARS),END.COLUMN!(TOT.N.OF.VARS),FIELD.WIDTH:LINE INPUT #1,VARIABLE.NAME$(TOT.N.OF.VARS):J=LEN(VARIABLE.NAME$(TOT.N.OF.VARS)):GOSUB 1050:ON ERROR GOTO 0
  36. 218   IF (TOT.N.OF.VARS MOD 10)=0 THEN PRINT "===";TOT.N.OF.VARS;"variables processed from codebook file ";CODEBOOK.COL$;STRING$(80-POS(0),32);:LOCATE ,1
  37. 220   IF CHECK.RESULT$<>"OK" THEN BEEP:PRINT "*** Error";ERROR.NUMBER;"in codebook at line";LINE.COUNT;", variable";TOT.N.OF.VARS;", program abort! ***";STRING$(80-POS(0),32):CLOSE:STOP
  38. 230   WHILE LEFT$(VARIABLE.NAME$(TOT.N.OF.VARS),1)=" ":VARIABLE.NAME$(TOT.N.OF.VARS)=MID$(VARIABLE.NAME$(TOT.N.OF.VARS),2):WEND
  39. 240   I=INSTR(VARIABLE.NAME$(TOT.N.OF.VARS)," "):J=INSTR(VARIABLE.NAME$(TOT.N.OF.VARS),",")
  40. 250   IF J<>0 AND (I>J OR I=0) THEN I=J 'else I remains I
  41. 255   IF I<>0 THEN VARIABLE.NAME$(TOT.N.OF.VARS)=LEFT$(VARIABLE.NAME$(TOT.N.OF.VARS),I-1)
  42. 260   IF VARIABLE.NAME$(TOT.N.OF.VARS)="" THEN VARIABLE.NAME$(TOT.N.OF.VARS)="Var"+MID$(STR$(TOT.N.OF.VARS),2) '====== if no variable name defined, use "Var"&VarNumber
  43. 262   IF CHECK.VAR.NAME$<>"NO" THEN GOSUB 13100 '====== optional check for identical variable names
  44. 265   IF BEGIN.COLUMN!(TOT.N.OF.VARS)<=0 OR END.COLUMN!(TOT.N.OF.VARS)<=0 THEN GOSUB 999:PRINT "*** Illegal fields for variable";TOT.N.OF.VARS;", ";VARIABLE.NAME$(TOT.N.OF.VARS);" at line";LINE.COUNT;" ***";STRING$(80-POS(0),32)
  45. 270   IF BEGIN.COLUMN!(TOT.N.OF.VARS)>END.COLUMN!(TOT.N.OF.VARS) THEN GOSUB 999:PRINT "*** Starting field > ending one for variable";TOT.N.OF.VARS;", ";VARIABLE.NAME$(TOT.N.OF.VARS);" at line";LINE.COUNT;" ***";STRING$(80-POS(0),32)
  46. 272   IF FIELD.WIDTH<0 OR FIELD.WIDTH>255 THEN GOSUB 999:PRINT "*** Illegal field width for variable";TOT.N.OF.VARS;", ";VARIABLE.NAME$(TOT.N.OF.VARS);" at line";LINE.COUNT;" ***";STRING$(80-POS(0),32)
  47. 275   IF FIELD.WIDTH<>END.COLUMN!(TOT.N.OF.VARS)-BEGIN.COLUMN!(TOT.N.OF.VARS)+1 AND FIELD.WIDTH<>0 THEN GOSUB 999:PRINT "*** Non-matching field width for variable";TOT.N.OF.VARS;", ";VARIABLE.NAME$(TOT.N.OF.VARS);" at line";LINE.COUNT;" ***"
  48. 281   IF END.COLUMN!(TOT.N.OF.VARS)>MAX.COL.SPEC! THEN MAX.COL.SPEC!=END.COLUMN!(TOT.N.OF.VARS) ELSE 285
  49. 282   N.OF.DATA.LINES=INT((MAX.COL.SPEC!)/MAX.LINE.INPUT.LENGTH)+1:MAX.COL.SPEC!=N.OF.DATA.LINES*MAX.LINE.INPUT.LENGTH-1
  50. 283 ''if n.of.data.lines>32767 then gosub 999:print "*** Ending field > maximum";32767*max.line.input.length-1;"for variable";tot.n.of.vars;", ";variable.name$(tot.n.of.vars);" at line";line.count;" ***"
  51. 285 WEND:CLOSE 1:PRINT "===";TOT.N.OF.VARS;"variables processed from codebook file ";CODEBOOK.COL$;STRING$(80-POS(0),32)
  52. 290 IF CHECK.FIELD.WIDTH$="BAD" OR CHECK.VAR.NAME$="BAD" THEN BEEP:PRINT "*** Correct errors in codebook file and rerun......program abort ***":STOP
  53. 295 IF TOT.N.OF.VARS=0 THEN 800
  54. 400 CHECK.RESULT$="BAD"
  55. 410 WHILE CHECK.RESULT$<>"OK"
  56. 420   WHILE CHECK.RESULT$<>"OK"
  57. 430     PRINT "--- Enter database file name: ";:LINE INPUT DATABASE.DAT$
  58. 440     D.PATH.FILENAME.EXT$=DATABASE.DAT$:GOSUB 11000 'check file name and split name and extension as DATABASE$ and DAT$
  59. 450     IF CHECK.RESULT$<>"OK" THEN BEEP:PRINT CHECK.RESULT$:GOTO 470
  60. 460     DATABASE.DAT$=D.PATH.FILENAME.EXT$:DATABASE$=D.PATH.FILENAME$:DAT$=EXT$
  61. 470   WEND
  62. 475   GOSUB 12000:IF CHECK.RESULT$<>"OK" THEN BEEP:PRINT "*** File name error: numerical extension not permitted, used for output! ***":PRINT "*** Rename database file to a valid name and rerun......program abort ***":STOP
  63. 480   ON ERROR GOTO 11400:OPEN "I",#1,DATABASE.DAT$:ON ERROR GOTO 0:CLOSE 1
  64. 490   IF CHECK.RESULT$<>"OK" THEN BEEP:PRINT CHECK.RESULT$
  65. 500 WEND:DIM DATA.LINE$(N.OF.DATA.LINES)
  66. 501 PRINT "--- Do you want to check the database for equal record lengths? Y/[N]: ";
  67. 502 CHECK.RECORD.LENGTH$="":WHILE CHECK.RECORD.LENGTH$="":WHILE CHECK.RECORD.LENGTH$="":CHECK.RECORD.LENGTH$=INKEY$:WEND:IF INSTR("YyNn"+CHR$(13),CHECK.RECORD.LENGTH$)=0 THEN BEEP:CHECK.RECORD.LENGTH$=""
  68. 503 WEND:IF INSTR("Yy",CHECK.RECORD.LENGTH$)>0 THEN CHECK.RECORD.LENGTH$="YES" ELSE CHECK.RECORD.LENGTH$="NO"
  69. 504 PRINT CHECK.RECORD.LENGTH$
  70. 505 PRINT "=== Output files wil be called: ";DATABASE$;" with a numerical extension."
  71. 510 PRINT "--- Do you want to overwrite any already existing output file? [Y]/N: ";
  72. 512 OVERWRITE$="":WHILE OVERWRITE$="":WHILE OVERWRITE$="":OVERWRITE$=INKEY$:WEND:IF INSTR("YyNn"+CHR$(13),OVERWRITE$)=0 THEN BEEP:OVERWRITE$=""
  73. 514 WEND:IF INSTR("Yy"+CHR$(13),OVERWRITE$)>0 THEN OVERWRITE$="YES" ELSE OVERWRITE$="NO"
  74. 516 PRINT OVERWRITE$
  75. 520 PRINT "--- Choose type of output data files: BLANK or COMMA delimited or FIXED";"    formatted or Report with 1..9 spaces as delimiters: B/[C]/F/1/../9: ";
  76. 522 DELIMITER$="":WHILE DELIMITER$="":WHILE DELIMITER$="":DELIMITER$=INKEY$:WEND:IF INSTR("BbCcFf"+CHR$(13),DELIMITER$)=0 AND VAL(DELIMITER$)=0 THEN BEEP:DELIMITER$=""
  77. 524 WEND:DEL.SPACES=VAL(DELIMITER$):IF DEL.SPACES>0 GOTO 526
  78. 525 IF INSTR("Bb",DELIMITER$)>0 THEN DELIMITER$="BLANK" ELSE IF INSTR("Ff",DELIMITER$)>0 THEN DELIMITER$="FIXED" ELSE DELIMITER$="COMMA"
  79. 526 PRINT DELIMITER$:IF DEL.SPACES>0 THEN DELIMITER$="" ELSE IF DELIMITER$="BLANK" THEN DELIMITER$=" " ELSE IF DELIMITER$="FIXED" THEN DELIMITER$="" ELSE DELIMITER$=","
  80. 530 PRINT "--- Do you want a header with variable names as the first line of each output":IF DELIMITER$="" AND DEL.SPACES=0 THEN PRINT "    file? Y/[N]: "; ELSE PRINT "    file? [Y]/N: ";
  81. 532 HEADER$="":WHILE HEADER$="":WHILE HEADER$="":HEADER$=INKEY$:WEND:IF INSTR("YyNn"+CHR$(13),HEADER$)=0 THEN BEEP:HEADER$=""
  82. 534 WEND:IF INSTR("Yy",HEADER$)>0 OR (HEADER$=CHR$(13) AND (DELIMITER$<>"" OR DEL.SPACES>0)) THEN HEADER$="YES" ELSE HEADER$="NO"
  83. 536 PRINT HEADER$
  84. 540 MISSING$="":WHILE MISSING$=""
  85. 542   PRINT "--- Enter (missing) value to replace entirely blank fields for variables for";"    which not yet specified in the codebook file [-1]: ";:LINE INPUT MISSING$
  86. 544   IF MISSING$="" THEN MISSING$="-1"
  87. 546 WEND
  88. 550 IF DELIMITER$="" THEN REM.SPACES$="NO":GOTO 560 ELSE PRINT "--- Do you want to remove insignificant spaces from the values? [Y]/N: ";
  89. 552 REM.SPACES$="":WHILE REM.SPACES$="":WHILE REM.SPACES$="":REM.SPACES$=INKEY$:WEND:IF INSTR("YyNn"+CHR$(13),REM.SPACES$)=0 THEN BEEP:REM.SPACES$=""
  90. 554 WEND:IF INSTR("Yy"+CHR$(13),REM.SPACES$)>0 THEN REM.SPACES$="YES" ELSE REM.SPACES$="NO"
  91. 556 PRINT REM.SPACES$
  92. 560 N.VARS.PER.FILE=0:N.OF.OUTPUT.FILES=0:WHILE N.VARS.PER.FILE<=0 OR N.VARS.PER.FILE>MAX.VARS.PER.FILE OR N.OF.OUTPUT.FILES>999
  93. 562   PRINT "--- Enter (max.) number of variables per output file (max.";MAX.VARS.PER.FILE;") [58]: ";:INPUT"",N.VARS.PER.FILE
  94. 564   IF N.VARS.PER.FILE=0 THEN N.VARS.PER.FILE=58
  95. 566   IF N.VARS.PER.FILE<0 OR N.VARS.PER.FILE>MAX.VARS.PER.FILE THEN BEEP:PRINT "*** Illegal number of variables entered! ***"
  96. 568   N.OF.OUTPUT.FILES=INT((TOT.N.OF.VARS-1)/N.VARS.PER.FILE)+1
  97. 570   IF N.OF.OUTPUT.FILES>999 THEN BEEP:PRINT "*** Too few variables per file, needing more than 999 output files, specified,";"    minimum number of variables per output file is";INT((TOT.N.OF.VARS-1)/999)+1;"***"
  98. 572 WEND
  99. 580 LINES.PER.PAGE=0:WHILE LINES.PER.PAGE<=0 AND DEL.SPACES>0
  100. 582   PRINT "--- Enter (max.) number of lines (header/records) per page [60]: ";:INPUT"",LINES.PER.PAGE
  101. 584   IF LINES.PER.PAGE=0 THEN LINES.PER.PAGE=60
  102. 586   IF LINES.PER.PAGE<1-(HEADER$="YES") OR LINES.PER.PAGE>32767 THEN BEEP:PRINT "*** Illegal number of lines per page entered! Minimum:";1-(HEADER$="YES");", maximum: 32767 ***":LINES.PER.PAGE=0
  103. 588 WEND
  104. 590 PRINT "=== Processing database ";DATABASE.DAT$;"......please wait and see......"
  105. 600 FOR OUTPUT.FILE.NUMBER=1 TO N.OF.OUTPUT.FILES
  106. 602   PRINT STRING$(40,"-");" Pass";OUTPUT.FILE.NUMBER;STRING$(5,"-");" Passes to follow:";N.OF.OUTPUT.FILES-OUTPUT.FILE.NUMBER
  107. 605   ON ERROR GOTO 11400:OPEN "I",#2,DATABASE$+"."+MID$(STR$(OUTPUT.FILE.NUMBER),2):ON ERROR GOTO 0:CLOSE 2 '====== check for existence of output file
  108. 607   IF CHECK.RESULT$="*** FILE NOT FOUND ***" THEN CHECK.RESULT$="OK":GOTO 610 ELSE IF CHECK.RESULT$<>"OK" THEN BEEP:PRINT CHECK.RESULT$:PRINT "    This may not occur: program bug! Notify author! Program abort!":STOP
  109. 609     IF OVERWRITE$="NO" THEN PRINT "*** Output file ";DATABASE$+"."+MID$(STR$(OUTPUT.FILE.NUMBER),2);" already exists; skipped this pass ***":GOTO 790 '====== BAD=not existing, OK=existing
  110. 610   OPEN "O",#2,DATABASE$+"."+MID$(STR$(OUTPUT.FILE.NUMBER),2) '====== open DATABASE.nr as output file with freefield data
  111. 615   ON ERROR GOTO 11400:OPEN "I",#1,DATABASE.DAT$:ON ERROR GOTO 0
  112. 620   FIRST=OUTPUT.FILE.NUMBER*N.VARS.PER.FILE-N.VARS.PER.FILE+1:LAST=OUTPUT.FILE.NUMBER*N.VARS.PER.FILE:IF LAST>TOT.N.OF.VARS THEN LAST=TOT.N.OF.VARS
  113. 655   GOSUB 2000 '====== header with variable names if applicable
  114. 660   RECORD.COUNT#=0:MAX.LENGTH#=0:MIN.LENGTH#=-1
  115. 670   WHILE NOT EOF(1) '====== process all records in database file
  116. 675   IF DEL.SPACES>0 AND LINE.COUNT#=LINES.PER.PAGE THEN PRINT #2,CHR$(12);:GOSUB 2000 '====== header with variable names if applicable
  117. 680     READ.PAST.EOL$="":PREVIOUS.RECORD.LENGTH#=RECORD.LENGTH#:RECORD.LENGTH#=0:I=0:RECORD.COUNT#=RECORD.COUNT#+1:WHILE RECORD.LENGTH#=I*MAX.LINE.INPUT.LENGTH
  118. 685       IF I=>N.OF.DATA.LINES THEN J=MAX.LINE.INPUT.LENGTH:GOSUB 1050:RECORD.LENGTH#=RECORD.LENGTH#+ADD.LENGTH#:ADD.LENGTH#=0#:GOTO 700 '====== read record until EOL
  119. 690       I=I+1:LINE INPUT #1,DATA.LINE$(I):RECORD.LENGTH#=RECORD.LENGTH#+LEN(DATA.LINE$(I)) '====== read complete record by multiple LINE INPUT's until CRLF
  120. 700     WEND:IF RECORD.LENGTH#>MAX.LENGTH# THEN MAX.LENGTH#=RECORD.LENGTH#
  121. 701     IF RECORD.LENGTH#<MIN.LENGTH# OR MIN.LENGTH#<0 THEN MIN.LENGTH#=RECORD.LENGTH#
  122. 702     IF CHECK.RECORD.LENGTH$="YES" AND RECORD.COUNT#>1 AND PREVIOUS.RECORD.LENGTH#<>RECORD.LENGTH# THEN PRINT "*** Length";RECORD.LENGTH#;"of record";RECORD.COUNT#;"is unequal to length";PREVIOUS.RECORD.LENGTH#;"of record";RECORD.COUNT#-1;"***"
  123. 705     PRINT "=== Processing";LAST-FIRST+1;"variables";FIRST;"to";LAST;"for record";RECORD.COUNT#;"into file ";DATABASE$+"."+MID$(STR$(OUTPUT.FILE.NUMBER),2);STRING$(80-POS(0),32);:LOCATE ,1
  124. 710     FOR VARIABLE.NUMBER=FIRST TO LAST:VALUE$="":FIELD.WIDTH=END.COLUMN!(VARIABLE.NUMBER)-BEGIN.COLUMN!(VARIABLE.NUMBER)+1 '====== process variables in parts of max. N.VARS.PER.FILE
  125. 720       FOR COLUMN!=BEGIN.COLUMN!(VARIABLE.NUMBER) TO END.COLUMN!(VARIABLE.NUMBER)
  126. 730         IF COLUMN!<=RECORD.LENGTH# THEN VALUE$=VALUE$+MID$(DATA.LINE$(INT((COLUMN!-1)/MAX.LINE.INPUT.LENGTH)+1),((COLUMN!-1) MOD MAX.LINE.INPUT.LENGTH)+1,1)
  127. 731 '====== IF statement to prevent 'Subscript out of range' and to prevent interpreting DATA.LINE$-elements which have not not been read, but contain characters
  128. 733         IF COLUMN!>RECORD.LENGTH# THEN VALUE$=VALUE$+" " '====== add trailing spaces after incomplete fields
  129. 735         IF COLUMN!>RECORD.LENGTH# AND COLUMN!=END.COLUMN!(VARIABLE.NUMBER) AND LEN(READ.PAST.EOL$)<=250 THEN READ.PAST.EOL$=READ.PAST.EOL$+STR$(VARIABLE.NUMBER) '====== remember variable number(s) read past EOL
  130. 740       NEXT COLUMN!:IF VALUE$<>STRING$(LEN(VALUE$)," ") THEN 744
  131. 742       IF MISSING.VALUE$(VARIABLE.NUMBER)<>"" THEN VALUE$=MISSING.VALUE$(VARIABLE.NUMBER) ELSE IF MISSING$<>"" THEN VALUE$=MISSING$ '=== replace entirely blank fields by the value MISSING(.VALUE)$
  132. 743       EXTRA.SPACE$=""
  133. 744       IF DELIMITER$="" THEN IF LEN(VALUE$)<FIELD.WIDTH+DEL.SPACES THEN EXTRA.SPACE$=STRING$(FIELD.WIDTH+DEL.SPACES-LEN(VALUE$),32) ELSE IF LEN(VALUE$)>FIELD.WIDTH+DEL.SPACES THEN VALUE$=RIGHT$(VALUE$,FIELD.WIDTH+DEL.SPACES)
  134. 750       GOSUB 3000:GOSUB 13000:GOSUB 1011:PRINT #2,EXTRA.SPACE$;VALUE$;:GOSUB 1011 '====== remove leading and trailing spaces or enclose value within quotes and double embedded quotes, and write (un)formatted literal value to the output file
  135. 755       IF VARIABLE.NUMBER<LAST THEN PRINT #2,DELIMITER$; '====== DELIMITER$ is empty ("") with FIXED format and Report output
  136. 760     NEXT VARIABLE.NUMBER:LINE.COUNT#=LINE.COUNT#+1#:PRINT #2, '====== eol
  137. 765     IF CHECK.RECORD.LENGTH$="YES" AND READ.PAST.EOL$<>"" THEN PRINT "*** Record";RECORD.COUNT#;"read past end-of-line for variable number(s):";READ.PAST.EOL$;" ***";STRING$(80-POS(0),32)
  138. 770   WEND:CLOSE 2:CLOSE 1
  139. 780   PRINT "===";LAST-FIRST+1;"variables";FIRST;"to";LAST;"for";RECORD.COUNT#;"records processed into file ";DATABASE$+"."+MID$(STR$(OUTPUT.FILE.NUMBER),2);STRING$(80-POS(0),32)
  140. 785   PRINT "=== Minimum record length was";MIN.LENGTH#;" /  Maximum record length was";MAX.LENGTH#
  141. 790 NEXT OUTPUT.FILE.NUMBER
  142. 800 PRINT "=== End of program CODEBOOK === Rerun? [Y]/N: ";:COMMENT$=INPUT$(1):IF INSTR("Yy"+CHR$(13),COMMENT$) THEN RUN ELSE KEY ON:END '====== routines follow
  143. 999 CHECK.FIELD.WIDTH$="BAD":RETURN
  144. 1011 IF VAR.TYPE$(VARIABLE.NUMBER)<>" " AND DELIMITER$<>"" THEN PRINT #2,VAR.TYPE$(VARIABLE.NUMBER);:RETURN
  145. 1050 ADD.LENGTH#=0#:WHILE J=MAX.LINE.INPUT.LENGTH:LINE INPUT #1,COMMENT.LINE$:J=LEN(COMMENT.LINE$):ADD.LENGTH#=ADD.LENGTH#+J:WEND:RETURN '====== read line until length NE 255: CRLF encountered
  146. 1100 REM ====== Adapt maximum number of variables to actual one (from codebook file) by adjusting dimensions of BEGIN.COLUMN!, END.COLUMN! and VARIABLE.NAME$ increasing them by EXTRA.VARS after temporaryly saving their contents to SHADOW! and SHADOW$
  147. 1101 IF EXTRA.VARS=MAX.N.OF.VARS THEN PRINT "!!! If running under interpreter BASIC auto-adaptation may be time consuming!"
  148. 1103 PRINT "=== Automatic adaptation to more than";MAX.N.OF.VARS;"variables in progress......";STRING$(80-POS(0),32);:LOCATE ,1
  149. 1110 IF MAX.N.OF.VARS=32767 THEN BEEP:PRINT "*** Number of variables exceeds maximum of";MAX.N.OF.VARS;", correct and rerun ***";STRING$(80-POS(0),32):CLOSE:STOP
  150. 1115 I!=MAX.N.OF.VARS+EXTRA.VARS:IF I!>32767 THEN I!=32767 '====== define increasing maximum number of variables (compromise between speed and memory space)
  151. 1120 DIM SHADOW!(MAX.N.OF.VARS),SHADOW$(MAX.N.OF.VARS):FOR J=1 TO MAX.N.OF.VARS:SHADOW!(J)=BEGIN.COLUMN!(J):SHADOW$(J)=VAR.TYPE$(J)+VARIABLE.NAME$(J):NEXT J
  152. 1130 ERASE BEGIN.COLUMN!,VARIABLE.NAME$,VAR.TYPE$:DIM BEGIN.COLUMN!(I!),VARIABLE.NAME$(I!),VAR.TYPE$(I!):FOR J=1 TO MAX.N.OF.VARS:BEGIN.COLUMN!(J)=SHADOW!(J):VAR.TYPE$(J)=LEFT$(SHADOW$(J),1):VARIABLE.NAME$(J)=MID$(SHADOW$(J),2):NEXT J
  153. 1150 FOR J=1 TO MAX.N.OF.VARS:SHADOW!(J)=END.COLUMN!(J):SHADOW$(J)=MISSING.VALUE$(J):NEXT J:ERASE END.COLUMN!,MISSING.VALUE$:DIM END.COLUMN!(I!),MISSING.VALUE$(I!)
  154. 1160 FOR J=1 TO MAX.N.OF.VARS:END.COLUMN!(J)=SHADOW!(J):MISSING.VALUE$(J)=SHADOW$(J):NEXT J:ERASE SHADOW!,SHADOW$:MAX.N.OF.VARS=I!:RETURN '===================================
  155. 2000 REM ========== Header with variable names if applicable ==========
  156. 2010 LINE.COUNT#=0#:IF HEADER$="NO" THEN 2060
  157. 2020   FOR VARIABLE.NUMBER=FIRST TO LAST:VAR.NAME$=VARIABLE.NAME$(VARIABLE.NUMBER):FIELD.WIDTH=END.COLUMN!(VARIABLE.NUMBER)-BEGIN.COLUMN!(VARIABLE.NUMBER)+1:EXTRA.SPACE$=""
  158. 2030     IF DELIMITER$="" THEN IF LEN(VAR.NAME$)<FIELD.WIDTH+DEL.SPACES THEN EXTRA.SPACE$=STRING$(FIELD.WIDTH+DEL.SPACES-LEN(VAR.NAME$),32) ELSE IF LEN(VAR.NAME$)>FIELD.WIDTH+DEL.SPACES THEN VAR.NAME$=RIGHT$(VAR.NAME$,FIELD.WIDTH+DEL.SPACES)
  159. 2040     PRINT #2,EXTRA.SPACE$;VAR.NAME$;:IF VARIABLE.NUMBER<LAST THEN PRINT #2,DELIMITER$; '====== write variable names on the same line separated by spaces or commas to the deduced data file for STATGRAPHICS
  160. 2050   NEXT VARIABLE.NUMBER:LINE.COUNT#=LINE.COUNT#+1#:PRINT #2, '====== eol
  161. 2060  RETURN
  162. 3000 REM ========== double embedded single or double quotes within quoted string values ==========
  163. 3010 IF VAR.TYPE$(VARIABLE.NUMBER)=" " OR DELIMITER$="" THEN 3060 'return
  164. 3020 I=INSTR(VALUE$,VAR.TYPE$(VARIABLE.NUMBER)):IF  I=0  THEN 3060 'return
  165. 3030 WHILE I>0 AND I<255:IF LEN(VALUE$)=255 THEN VALUE$=LEFT$(VALUE$,254) '====== if VALUE$ has maximum length delete last character to make room for extra quote
  166. 3040 VALUE$=LEFT$(VALUE$,I)+MID$(VALUE$,I):I=INSTR(I+2,VALUE$,VAR.TYPE$(VARIABLE.NUMBER)):WEND
  167. 3060 RETURN
  168. 9999 '================== routines ==================
  169. 10000 REM ********** Remove leading and trailing spaces from file name *********
  170. 10010 WHILE LEFT$(D.PATH.FILENAME.EXT$,1)=" ":D.PATH.FILENAME.EXT$=MID$(D.PATH.FILENAME.EXT$,2):WEND
  171. 10020 WHILE RIGHT$(D.PATH.FILENAME.EXT$,1)=" ":D.PATH.FILENAME.EXT$=LEFT$(D.PATH.FILENAME.EXT$,LEN(D.PATH.FILENAME.EXT$)-1):WEND
  172. 10030 RETURN
  173. 11000 REM ********** check drv:\path\file names ********** (result in CHECK.RESULT$)
  174. 11010 GOSUB 10000:CHECK.RESULT$="OK"
  175. 11020 U=INSTR(D.PATH.FILENAME.EXT$,":"):IF U=1 OR U>2 THEN CHECK.RESULT$="*** ILLEGALLY PLACED ':' ***":RETURN
  176. 11030 D$="":IF U=2 THEN W=ASC(LEFT$(D.PATH.FILENAME.EXT$,1)):IF W>96 AND W<123 THEN W=W-32:D$=CHR$(W)+":" ELSE IF W>64 AND W<91 THEN D$=CHR$(W)+":" ELSE CHECK.RESULT$="*** ILLEGAL DRIVE NAME ***":RETURN
  177. 11040 PATH$="":PATH.FILENAME.EXT$=MID$(D.PATH.FILENAME.EXT$,U+1):U=INSTR(PATH.FILENAME.EXT$,"\"):IF U=1 THEN PATH$="\":PATH.FILENAME.EXT$=MID$(PATH.FILENAME.EXT$,2)
  178. 11050 U=INSTR(PATH.FILENAME.EXT$,"\"):IF U=0 THEN FILENAME.EXT$=PATH.FILENAME.EXT$:GOSUB 11110:IF CHECK.RESULT$<>"OK" THEN RETURN ELSE D.PATH.FILENAME.EXT$=D$+PATH$+FILENAME.EXT$:D.PATH.FILENAME$=D$+PATH$+FILENAME$:RETURN
  179. 11060 PATHNAME.EXT$=LEFT$(PATH.FILENAME.EXT$,U-1):IF PATHNAME.EXT$<>"." AND PATHNAME.EXT$<>".." THEN FILENAME.EXT$=PATHNAME.EXT$:GOSUB 11110:IF CHECK.RESULT$<>"OK" THEN RETURN ELSE PATHNAME.EXT$=FILENAME.EXT$
  180. 11070 PATH$=PATH$+PATHNAME.EXT$+"\":PATH.FILENAME.EXT$=MID$(PATH.FILENAME.EXT$,U+1):GOTO 11050 '====== repeat check for every subdirectory name
  181. 11110 REM ********** check file names ********** (result in CHECK.RESULT$)
  182. 11120 CHECK.RESULT$="OK":IF LEN(FILENAME.EXT$)>12 OR LEN(FILENAME.EXT$)=0 THEN CHECK.RESULT$="*** ZERO LENGTH OR TOO LONG PATH/FILENAME ***":RETURN
  183. 11130 V=INSTR(FILENAME.EXT$,"."):IF V=0 AND LEN(FILENAME.EXT$)>8 THEN CHECK.RESULT$="*** PATH/FILENAME TOO LONG ***":RETURN
  184. 11133 IF V=0 THEN EXPL.PERIOD$="NO" ELSE EXPL.PERIOD$="YES"
  185. 11140 IF V>0 AND INSTR(V+1,FILENAME.EXT$,".")>0 THEN CHECK.RESULT$="*** TOO MANY PERIODS IN PATH/FILENAME ***":RETURN
  186. 11150 IF V>9 OR V=1 THEN CHECK.RESULT$="*** ILLEGALLY PLACED '.' IN PATH/FILENAME ***":RETURN
  187. 11160 IF V>0 AND (LEN(FILENAME.EXT$)-V)>3 THEN CHECK.RESULT$="*** TOO LONG EXTENSION IN PATH/FILENAME ***":RETURN
  188. 11170 IF INSTR(FILENAME.EXT$,"\")>0 THEN CHECK.RESULT$="*** ILLEGAL '\' IN PATH/FILENAME ***":RETURN
  189. 11180 IF INSTR(FILENAME.EXT$,"+")>0 THEN CHECK.RESULT$="*** ILLEGAL '+' IN PATH/FILENAME ***":RETURN
  190. 11190 IF INSTR(FILENAME.EXT$,"=")>0 THEN CHECK.RESULT$="*** ILLEGAL '=' IN PATH/FILENAME ***":RETURN
  191. 11200 IF INSTR(FILENAME.EXT$,"[")>0 THEN CHECK.RESULT$="*** ILLEGAL '[' IN PATH/FILENAME ***":RETURN
  192. 11210 IF INSTR(FILENAME.EXT$,"]")>0 THEN CHECK.RESULT$="*** ILLEGAL ']' IN PATH/FILENAME ***":RETURN
  193. 11220 IF INSTR(FILENAME.EXT$,":")>0 THEN CHECK.RESULT$="*** ILLEGAL ':' IN PATH/FILENAME ***":RETURN
  194. 11230 IF INSTR(FILENAME.EXT$,";")>0 THEN CHECK.RESULT$="*** ILLEGAL ';' IN PATH/FILENAME ***":RETURN
  195. 11240 IF INSTR(FILENAME.EXT$,CHR$(34))>0 THEN CHECK.RESULT$="*** ILLEGAL '"+CHR$(34)+"' IN PATH/FILENAME ***":RETURN
  196. 11250 IF INSTR(FILENAME.EXT$,"/")>0 THEN CHECK.RESULT$="*** ILLEGAL '/' IN PATH/FILENAME ***":RETURN
  197. 11260 IF INSTR(FILENAME.EXT$,",")>0 THEN CHECK.RESULT$="*** ILLEGAL ',' IN PATH/FILENAME ***":RETURN
  198. 11270 IF INSTR(FILENAME.EXT$,"|")>0 THEN CHECK.RESULT$="*** ILLEGAL '|' IN PATH/FILENAME ***":RETURN
  199. 11280 IF INSTR(FILENAME.EXT$,"<")>0 THEN CHECK.RESULT$="*** ILLEGAL '<' IN PATH/FILENAME ***":RETURN
  200. 11290 IF INSTR(FILENAME.EXT$,">")>0 THEN CHECK.RESULT$="*** ILLEGAL '>' IN PATH/FILENAME ***":RETURN
  201. 11292 IF INSTR(FILENAME.EXT$,"*")>0 AND WILDCARD$="NO" THEN CHECK.RESULT$="*** ILLEGAL '*' IN PATH/FILENAME ***":RETURN
  202. 11294 IF INSTR(FILENAME.EXT$,"?")>0 AND WILDCARD$="NO" THEN CHECK.RESULT$="*** ILLEGAL '?' IN PATH/FILENAME ***":RETURN
  203. 11300 FOR W = 1 TO LEN(FILENAME.EXT$):V = ASC(MID$(FILENAME.EXT$,W,1)):IF V > 96 AND V < 123 THEN V=V-32:MID$(FILENAME.EXT$,W,1)=CHR$(V) '====== change lower case to upper case
  204. 11310 IF V <= 32 OR V>=127 THEN CHECK.RESULT$="*** ILLEGAL SPACE, CONTROL OR EXTENDED ASCII CHARACTER IN PATH/FILENAME ***":W = LEN(FILENAME.EXT$)
  205. 11320 NEXT W:IF CHECK.RESULT$<>"OK" THEN RETURN
  206. 11325 V=INSTR(FILENAME.EXT$,"."):FILENAME$=FILENAME.EXT$:EXT$=""
  207. 11330 IF V>0 THEN FILENAME$=LEFT$(FILENAME.EXT$,V-1):EXT$=MID$(FILENAME.EXT$,V+1)
  208. 11340 RETURN '========================
  209. 11400 ERROR.NUMBER=ERR:CHECK.RESULT$="*** ERROR NUMBER"+STR$(ERROR.NUMBER)+" ***"
  210. 11500 IF ERROR.NUMBER=53 THEN CHECK.RESULT$="*** FILE NOT FOUND ***":GOTO 11800
  211. 11600 IF ERROR.NUMBER=64 THEN CHECK.RESULT$="*** BAD FILE NAME ***":GOTO 11800
  212. 11700 IF ERROR.NUMBER=76 THEN CHECK.RESULT$="*** PATH NOT FOUND ***":GOTO 11800
  213. 11800 RESUME NEXT
  214. 12000 REM ====== check for numerical extension EXT$, if so: CHECK.RESULT$<>"OK" ==========
  215. 12010 IF EXT$="" THEN RETURN '====== OK, no numerical extension, if no extension at all
  216. 12020 FOR J=1 TO 3:FOR I=0 TO 9:IF MID$(EXT$,J,1)=RIGHT$(STR$(I),1) THEN 12040
  217. 12030   NEXT I:RETURN '====== OK if any character of extension is not numerical
  218. 12040   IF LEN(EXT$)=J THEN CHECK.RESULT$="BAD":RETURN '====== BAD if only character(s) of extension is/are numerical
  219. 12050 NEXT J:RETURN '====== this way will never be gone
  220. 13000 REM ====== remove leading and trailing spaces of VALUE$ only if not quoted
  221. 13001 IF VAR.TYPE$(VARIABLE.NUMBER)<>" " OR DELIMITER$="" THEN 13030
  222. 13005 IF REM.SPACES$="NO" THEN 13030 '====== return if no removing of insignificant spaces wanted
  223. 13010 WHILE LEFT$(VALUE$,1)=" ":VALUE$=MID$(VALUE$,2):WEND
  224. 13020 WHILE RIGHT$(VALUE$,1)=" ":VALUE$=LEFT$(VALUE$,LEN(VALUE$)-1):WEND
  225. 13030 RETURN
  226. 13100 REM ====== optional check for (case sensitive) identical variable names ======
  227. 13110 FOR I=1 TO TOT.N.OF.VARS-1
  228. 13120 IF VARIABLE.NAME$(TOT.N.OF.VARS)=VARIABLE.NAME$(I) THEN CHECK.VAR.NAME$="BAD":PRINT "*** Variables";I;"and";TOT.N.OF.VARS;"have identical names '";VARIABLE.NAME$(I);"' ***";STRING$(80-POS(0),32)
  229. 13130 NEXT I:RETURN
  230.