{$M 65520, 0, 655360} Program Report2; {***************************************************************************} {* SUB-PROGRAMS IN ORDER OF APPEARANCE {* {* FUNCTION LookUp {* PROCEDURE DoSplitResponses {* FUNCTION AverageLine {* FUNCTION HDRLine {* PROCEDURE LoadHDROpts {* PROCEDURE ReportHeader {* PROCEDURE GetSaveFiles {* PROCEDURE AnalyzeData {* PROCEDURE StoreLetters {* PROCEDURE StoreData {* PROCEDURE GetDataFile {* PROCEDURE MakeReport {* PROCEDURE MakeHeader {* PROCEDURE SetHeader {* PROCEDURE MakeLetter {* PROCEDURE SetLetter {* PROCEDURE MakeFormat {* PROCEDURE SetFormat {* PROCEDURE Menu {***************************************************************************} {* {* GLOBAL DEFINITIONS {* {* USES UNIT Dos, {* USES UNIT Crt, {* USES UNIT Croft; {* {* GLOBAL CONSTANT MaxNumSurveySheets = 20; {* GLOBAL CONSTANT AToJ: array[1..10] of char = 'ABCDEFGHIJ'; {* GLOBAL CONSTANT KToP: array[1..6] of char = 'KLMNOP'; {* {* GLOBAL TYPE DataStr = array[1..MaxNumSurveySheets] of string; {* GLOBAL TYPE Int10Array = array[1..10] of integer; {* GLOBAL TYPE Char10Array = array[1..10] of char; {* GLOBAL TYPE Str10Array = array[1..10] of string; {* {* GLOBAL VARIABLE InitFormatFile: string; {* GLOBAL VARIABLE InitLetterFile: string; {* GLOBAL VARIABLE InitHeaderFile: string; {* GLOBAL VARIABLE NameLine, {* GLOBAL VARIABLE SexLine, {* GLOBAL VARIABLE EducationLine, {* GLOBAL VARIABLE MonthLine, {* GLOBAL VARIABLE DayLine, {* GLOBAL VARIABLE YearLine, {* GLOBAL VARIABLE IDLine, {* GLOBAL VARIABLE IDNumberSplitLine, {* GLOBAL VARIABLE SpecialCodesSplitLine, {* GLOBAL VARIABLE SpecialCodesLine, {* GLOBAL VARIABLE DataLine: DataStr; {* GLOBAL VARIABLE NumSurveys: integer; {* {***************************************************************************} {* SUB-PROGRAMS with LOCAL DEFINITIONS and other SUB-PROGRAMS CALLED {* {* FUNCTION LookUp {* local variable LU: integer; {* PROCEDURE DoSplitResponses {* local variable alpha, {* local variable bravo: integer; {* local variable NumQuestions: integer; {* local variable NumResponses: array[1..10] of integer; {* local variable ResponsesArray: CroftUnitRealArrayType; {* local variable Mean, {* local variable Median, {* local variable StanDev, {* local variable MinValue, {* local variable MaxValue: real; {* local variable AnswerGiven: boolean; {* calls FUNCTION LookUp {* FUNCTION AverageLine {* local constant SearchChars: string = ', -'; {* local variable LenInStr: integer; {* local variable Position: integer; {* local variable QuesNum1, {* local variable QuesNum2: integer; {* local variable Total: real; {* local variable Done: boolean; {* local variable Count: integer; {* local variable CharFound: char; {* local variable LenDataLine: integer; {* local variable alpha, {* local variable bravo: integer; {* local variable SubTotal: real; {* local variable ValGood: boolean; {* calls FUNCTION LookUp {* FUNCTION HDRLine {* local variable InStr: string; {* local variable TempBool: boolean; {* PROCEDURE LoadHDROpts {* local variable HF: text; {* local variable alpha: integer; {* calls FUNCTION HDRLine {* PROCEDURE ReportHeader {* local variable alpha, {* local variable bravo: integer; {* local variable Name, {* local variable Sex, {* local variable Education, {* local variable Month, {* local variable Day, {* local variable Year, {* local variable IDNumber, {* local variable IDNumberSplit, {* local variable SpecialCodes, {* local variable SpecialCodesSplit, {* local variable Responses: boolean; {* calls PROCEDURE LoadHDROpts {* PROCEDURE GetSaveFiles {* local variable Lead8, {* local variable Ext: string; {* PROCEDURE AnalyzeData {* local variable FF, {* local variable SF: text; {* local variable SaveFile1, {* local variable SaveFile2, {* local variable SaveFile3: string; {* local variable InStr: string; {* local variable alpha, {* local variable bravo: integer; {* local variable AveVal: real; {* local variable ResponsesSplit: boolean; {* local variable FormFeed: char; {* calls PROCEDURE GetSaveFiles {* calls PROCEDURE ReportHeader {* calls FUNCTION AverageLine {* calls PROCEDURE DoSplitResponses {* PROCEDURE StoreLetters {* local variable LF: text; {* local variable alpha: integer; {* local variable InStr: string; {* PROCEDURE StoreData {* local variable SheetNum: integer; {* local variable DF: text; {* PROCEDURE GetDataFile {* PROCEDURE MakeReport {* local variable DataFile: string; {* local variable NameLine, {* local variable IDLine, {* local variable DataLine: DataStr; {* local variable LetterVals: Str10Array; {* calls PROCEDURE GetDataFile {* calls PROCEDURE StoreData {* calls PROCEDURE StoreLetters {* calls PROCEDURE AnalyzeData {* PROCEDURE MakeHeader {* local variable HF: text; {* local variable alpha: integer; {* local variable ID: string; {* PROCEDURE SetHeader {* local variable DirInfo: SearchRec; {* local variable HF: text; {* calls PROCEDURE MakeHeader {* PROCEDURE MakeLetter {* local constant Letter: Char10Array = ('A','B','C','D','E','F','G','H','I','J'); {* local variable LF: text; {* local variable Comments: string; {* local variable LetterVal: Str10Array; {* local variable alpha: integer; {* local variable NulVal: boolean; {* local variable ValStr: string; {* local variable RealVal: real; {* PROCEDURE SetLetter {* local variable DirInfo: SearchRec; {* local variable LF: text; {* calls PROCEDURE MakeLetter {* PROCEDURE MakeFormat {* local variable FF: text; {* local variable Done: boolean; {* local variable InStr: string; {* PROCEDURE SetFormat {* local variable DirInfo: SearchRec; {* local variable FF: text; {* calls PROCEDURE MakeFormat {* PROCEDURE Menu {* local constant NumOptions = 4; {* local variable Option: integer; {* calls PROCEDURE SetFormat {* calls PROCEDURE SetLetter {* calls PROCEDURE SetHeader {* calls PROCEDURE MakeReport {* PROGRAM MAIN {* calls PROCEDURE SetFormat {* calls PROCEDURE SetLetter {* calls PROCEDURE SetHeader {* calls PROCEDURE Menu {***************************************************************************} {* SUB-PROGRAMS IN ALPHABETICAL ORDER {* {* FUNCTION AnalyzeData {* PROCEDURE AverageLine {* FUNCTION DoSplitResponses {* FUNCTION GetDataFile {* PROCEDURE GetSaveFiles {* PROCEDURE HDRLine {* PROCEDURE LoadHDROpts {* PROCEDURE LookUp {* PROCEDURE MakeFormat {* PROCEDURE MakeHeader {* PROCEDURE MakeLetter {* PROCEDURE MakeReport {* PROCEDURE Menu {* PROCEDURE ReportHeader {* PROCEDURE SetFormat {* PROCEDURE SetHeader {* PROCEDURE SetLetter {* PROCEDURE StoreData {* PROCEDURE StoreLetters {***************************************************************************} Uses Dos, Crt, Croft; Const MaxNumSurveySheets = 20; AToJ: array[1..10] of char = 'ABCDEFGHIJ'; KToP: array[1..6] of char = 'KLMNOP'; Type DataStr = array[1..MaxNumSurveySheets] of string; Int10Array = array[1..10] of integer; Char10Array = array[1..10] of char; Str10Array = array[1..10] of string; Var InitFormatFile: string; InitLetterFile: string; InitHeaderFile: string; NameLine, SexLine, EducationLine, MonthLine, DayLine, YearLine, IDLine, IDNumberSplitLine, SpecialCodesSplitLine, SpecialCodesLine, DataLine: DataStr; NumSurveys: integer; Function LookUp(Alpha: char; LetterVals: Str10Array; var ValGood: boolean): real; {***************************************************************************} var LU: integer; begin Alpha := upcase(alpha); case Alpha of ' ': LU := 0; 'A': LU := 1; 'B': LU := 2; 'C': LU := 3; 'D': LU := 4; 'E': LU := 5; 'F': LU := 6; 'G': LU := 7; 'H': LU := 8; 'I': LU := 9; 'J': LU := 10; end; {case} if (LetterVals[LU] = ' N/A') or (LU = 0) then ValGood := false else ValGood := true; if LU <> 0 then LookUp := ValReal(LetterVals[LU]) else LookUp := 0; end; Procedure DoSplitResponses(var SF: text; DataLine: DataStr; LetterVals: Str10Array); {***************************************************************************} var alpha, bravo: integer; NumQuestions: integer; NumResponses: array[1..10] of integer; ResponsesArray: CroftUnitRealArrayType; Mean, Median, StanDev, MinValue, MaxValue: real; AnswerGiven: boolean; begin NumQuestions := length(DataLine[1]); WrLn2T(SF, MultiChar('*',78)); WrLn2T(SF, '### Mean Median StDev Min. Max. A B C D E F G H I J'); for bravo := 1 to NumQuestions do begin for alpha := 1 to 10 do NumResponses[alpha] := 0; AnswerGiven := false; for alpha := 1 to NumSurveys do begin if DataLine[alpha, bravo] in ['A'..'J'] then AnswerGiven := true; case DataLine[alpha,bravo] of 'A': Inc(NumResponses[1]); 'B': Inc(NumResponses[2]); 'C': Inc(NumResponses[3]); 'D': Inc(NumResponses[4]); 'E': Inc(NumResponses[5]); 'F': Inc(NumResponses[6]); 'G': Inc(NumResponses[7]); 'H': Inc(NumResponses[8]); 'I': Inc(NumResponses[9]); 'J': Inc(NumResponses[10]); end; {case} end; if AnswerGiven then begin Wr2T(SF, StrIntLen(bravo, 3)); for alpha := 1 to NumSurveys do ResponsesArray[alpha] := LookUp(DataLine[alpha, bravo], LetterVals, DumBool); Stats(ResponsesArray, NumSurveys, Mean, Median, StanDev, MinValue, MaxValue); Wr2T(SF, ' ' + StrReal(Mean, 6, 2) + ' ' + StrReal(Median, 6, 2) + ' ' + StrReal(StanDev, 6, 2) + ' ' + StrReal(MinValue, 6, 2) + ' ' + StrReal(MaxValue, 6, 2) ); for alpha := 1 to 10 do Wr2T(SF, ' '+StrIntLen(NumResponses[alpha],3)); WrLn2T(SF,''); end; end; end; Function AverageLine(InStr: string; DataLine: DataStr; LetterVals: Str10Array; var AveVal: real): boolean; {***************************************************************************} const SearchChars: string = ', -'; var LenInStr: integer; Position: integer; QuesNum1, QuesNum2: integer; Total: real; Done: boolean; Count: integer; CharFound: char; LenDataLine: integer; alpha, bravo: integer; SubTotal: real; ValGood: boolean; begin LenInStr := length(InStr); LenDataLine := length(DataLine[1]); ; Total := 0; Done := false; Count := 0; ; Position := Pos(':',InStr); if (Position <> 0) and (Position <> LenInStr) then begin repeat ParseInt(InStr, Position, QuesNum1); QuesNum2 := QuesNum1; if Position > LenInStr then Done := true; if (QuesNum1 = 0) and not(Done) then begin writeln(#7); writeln('Format file is bad!'); writeln('A line contains a question of #0 in it!'); PoliteHalt; end else begin if not(Done) then begin PosChars(SearchChars, InStr, Position, CharFound); if (Position > LenInStr) then Done := true; if (CharFound <> ',') or (CharFound = '-') then begin ParseInt(InStr, Position, QuesNum2); if Position > LenInStr then Done := true; if QuesNum2 = 0 then begin writeln(#7); writeln('Format file is bad!'); write('A line contains a question of #0 in it or'); writeln(' number expected after dash not found!'); PoliteHalt; end; end; end; if (QuesNum1 > LenDataLine) or (QuesNum2 > LenDataLine) then begin Writeln(#7); writeln('Format file is bad!'); write('Question number in format file exceeds number of'); writeln(' questions in survey sheet!'); PoliteHalt; end; for alpha := QuesNum1 to QuesNum2 do begin for bravo := 1 to NumSurveys do begin SubTotal := LookUp(DataLine[bravo, alpha], LetterVals, ValGood); if ValGood then begin Total := Total + SubTotal; Inc(Count); end; end; end; end; until Done; if Count = 0 then AverageLine := false else begin AverageLine := true; AveVal := Total/Count; end; end else AverageLine := false; end; Function HDRLine(var HF: text): boolean; {***************************************************************************} var InStr: string; TempBool: boolean; begin readln(HF, InStr); GetQuote(InStr); if InStr = 'YES' then TempBool := true else TempBool := false; HDRLine := TempBool; end; Procedure LoadHDROpts(HeaderFile: string; var Name, Sex, Education, Month, Day, Year, IDNumber, IDNumberSplit, SpecialCodes, SpecialCodesSplit, Responses, ResponsesSplit: boolean); {***************************************************************************} var HF: text; alpha: integer; begin Assign(HF, HeaderFile); Reset(HF); Name := HDRLine(HF); Sex := HDRLine(HF); Education := HDRLine(HF); Month := HDRLine(HF); Day := HDRLine(HF); Year := HDRLine(HF); IDNumber := HDRLine(HF); IDNumberSplit := HDRLine(HF); if IDNumberSplit then for alpha := 1 to 10 do readln(HF, IDNumberSplitLine[alpha]); SpecialCodes := HDRLine(HF); SpecialCodesSplit := HDRLine(HF); if SpecialCodesSplit then for alpha := 1 to 6 do readln(HF, SpecialCodesSplitLine[alpha]); Responses := HDRLine(HF); ResponsesSplit := HDRLine(HF); Close(HF); end; Procedure ReportHeader(var SF: text; SaveFile1, DataFile, HeaderFile, FormatFile, LetterFile: string; var ResponsesSplit: boolean); {***************************************************************************} var alpha, bravo: integer; Name, Sex, Education, Month, Day, Year, IDNumber, IDNumberSplit, SpecialCodes, SpecialCodesSplit, Responses: boolean; begin Clr; LoadHDROpts(HeaderFile, Name, Sex, Education, Month, Day, Year, IDNumber, IDNumberSplit, SpecialCodes, SpecialCodesSplit, Responses, ResponsesSplit); WrLn2T(SF, MultiChar('*',78)); WrLn2T(SF, 'REPORT File "'+SaveFile1+'" made from'); WrLn2T(SF, ' Data File "'+DataFile+'"'); WrLn2T(SF, ' Header File "'+HeaderFile+'"'); WrLn2T(SF, ' Format File "'+FormatFile+'"'); WrLn2T(SF, ' Letter File "'+LetterFile+'"'); WrLn2T(SF, 'using '+StrInt(NumSurveys)+' sheet(s).'); for alpha := 1 to NumSurveys do begin WrLn2T(SF,'SHEET '+StrInt(alpha)); if Name then WrLn2T(SF,' '+NameLine[alpha]); if Sex then WrLn2T(SF,' '+SexLine[alpha]); if Education then WrLn2T(SF,' '+EducationLine[alpha]); if Month then WrLn2T(SF,' '+MonthLine[alpha]); if Day then WrLn2T(SF,' '+DayLine[alpha]); if Year then WrLn2T(SF,' '+YearLine[alpha]); if IDNumber then WrLn2T(SF,' '+IDLine[alpha]); if IDNumberSplit then begin GetQuote(IDLine[alpha]); for bravo := 1 to 10 do WrLn2T(SF,' '+IDNumberSplitLine[bravo]+'= ' +IDLine[alpha,bravo]); end; if SpecialCodes then WrLn2T(SF,' '+SpecialCodesLine[alpha]); if SpecialCodesSplit then begin GetQuote(SpecialCodesLine[alpha]); for bravo := 1 to 6 do WrLn2T(SF,' '+SpecialCodesSplitLine[bravo]+'= ' +SpecialCodesLine[alpha, bravo]); end; if Responses then WrLn2T(SF,' '+DataLine[alpha]); end; WrLn2T(SF, MultiChar('*',78)); end; Procedure GetSaveFiles(var SaveFile1, SaveFile2, SaveFile3: string; DataFile: string); {***************************************************************************} var Lead8, Ext: string; begin Say('The header, format, and individual responses analysis data can be'); Say('written to three separate files instead of one.'); if AskYN('Do you want separate files','N') then begin write('What is the header data file name?: '); readln(SaveFile1); SplitFileName(SaveFile1, Lead8, Ext); SaveFile1 := Lead8 + '.RPT'; BackUpLine; writeln('Header data save file: ', SaveFile1); write('What is the format data file name?: '); readln(SaveFile2); SplitFileName(SaveFile2, Lead8, Ext); SaveFile2 := Lead8 + '.RPT'; BackUpLine; writeln('Format data save file: ', SaveFile2); write('What is the individual responses analysis file name?: '); readln(SaveFile3); SplitFileName(SaveFile3, Lead8, Ext); SaveFile3 := Lead8 + '.RPT'; BackUpLine; writeln('Individual Responses save file: ', SaveFile3); Wait; end else begin SaveFile1 := Copy(DataFile, 1, length(DataFile) - 4) + '.RPT'; SaveFile2 := SaveFile1; SaveFile3 := SaveFile1; end; end; Procedure AnalyzeData(FormatFile, DataFile, LetterFile, HeaderFile: string; LetterVals: Str10Array); {***************************************************************************} var FF, SF: text; SaveFile1, SaveFile2, SaveFile3: string; InStr: string; alpha, bravo: integer; AveVal: real; ResponsesSplit: boolean; FormFeed: char; begin GetSaveFiles(SaveFile1, SaveFile2, SaveFile3, DataFile); if AskYN('Include form feed at the end of section?','N') then FormFeed := #12 else FormFeed := #0; Assign(SF, SaveFile1); Rewrite(SF); ReportHeader(SF, SaveFile1,DataFile,HeaderFile,FormatFile,LetterFile, ResponsesSplit); write(SF, FormFeed); if SaveFile2 <> SaveFile1 then begin close(SF); Assign(SF, SaveFile2); Rewrite(SF); end; Assign(FF, FormatFile); Reset(FF); while not(EOF(FF)) do begin readln(FF, InStr); Wr2T(SF, InStr); if AverageLine(InStr, DataLine, LetterVals, AveVal) then WrLn2T(SF,' = '+StrReal(AveVal,3,2)) else WrLn2T(SF,''); end; {while} write(SF, FormFeed); if ResponsesSplit then begin if SaveFile3 <> SaveFile2 then begin close(SF); Assign(SF, SaveFile3); Rewrite(SF); end; DoSplitResponses(SF, DataLine, LetterVals); write(SF, FormFeed); end; close(SF); close(FF); end; Procedure StoreLetters(LetterFile: string; var LetterVals: Str10Array); {***************************************************************************} var LF: text; alpha: integer; InStr: string; begin assign(LF, LetterFile); reset(LF); repeat readln(LF, InStr); until InStr = 'LETTERS:'; for alpha := 1 to 10 do begin readln(LF, InStr); LetterVals[alpha] := copy(InStr, 4, length(InStr) - 3); end; close(LF); end; Procedure StoreData(var DataFile: string); {***************************************************************************} var SheetNum: integer; DF: text; begin Assign(DF, DataFile); reset(DF); SheetNum := 0; repeat Inc(SheetNum); readln(DF, NameLine[SheetNum]); readln(DF, SexLine[SheetNum]); readln(DF, EducationLine[SheetNum]); readln(DF, MonthLine[SheetNum]); readln(DF, DayLine[SheetNum]); readln(DF, YearLine[SheetNum]); readln(DF, IDLine[SheetNum]); readln(DF, SpecialCodesLine[SheetNum]); readln(DF, DataLine[SheetNum]); GetQuote(DataLine[SheetNum]); readln(DF, DumStr); until EOF(DF); close(DF); NumSurveys := SheetNum; end; Procedure GetDataFile(var DataFile: string); {***************************************************************************} begin Clr; DataFile := GetDirFileOnly('*.DAT'); end; Procedure MakeReport(FormatFile, LetterFile, HeaderFile: string); {***************************************************************************} var DataFile: string; NameLine, IDLine, DataLine: DataStr; LetterVals: Str10Array; begin GetDataFile(DataFile); StoreData(DataFile); StoreLetters(LetterFile, LetterVals); AnalyzeData(FormatFile, DataFile, LetterFile, HeaderFile, LetterVals); end; Procedure MakeHeader(var HeaderFile: string); {***************************************************************************} var HF: text; alpha: integer; ID: string; begin Clr; Assign(HF, HeaderFile); Rewrite(HF); if AskYN('Do you want the NAME line included in the report','Y') then WrLn2T(HF, 'NAME LINE: "YES"') else WrLn2T(HF, 'NAME LINE: "NO"'); DeleteSkip; if AskYN('Do you want the SEX line included in the report','Y') then WrLn2T(HF, 'SEX LINE: "YES"') else WrLn2T(HF, 'SEX LINE: "NO"'); DeleteSkip; if AskYN('Do you want the EDUCATION/GRADE line included in the report', 'Y') then WrLn2T(HF, 'EDUCATION/GRADE: "YES"') else WrLn2T(HF, 'EDUCATION/GRADE: "NO"'); DeleteSkip; if AskYN('Do you want the MONTH line included in the report', 'Y') then WrLn2T(HF, 'MONTH: "YES"') else WrLn2T(HF, 'MONTH: "NO"'); DeleteSkip; if AskYN('Do you want the DAY line included in the report', 'Y') then WrLn2T(HF, 'DAY: "YES"') else WrLn2T(HF, 'DAY: "NO"'); DeleteSkip; if AskYN('Do you want the YEAR line included in the report', 'Y') then WrLn2T(HF, 'YEAR: "YES"') else WrLn2T(HF, 'YEAR: "NO"'); DeleteSkip; if AskYN( 'Do you want the IDENTIFICATION NUMBER line included in the report', 'Y') then WrLn2T(HF, 'IDENTIFICATION NUMBER: "YES"') else WrLn2T(HF, 'IDENTIFICATION NUMBER: "NO"'); DeleteSkip; if AskYN('Do you want the ID NUMBERs listed separately with an identifier' ,'N') then begin BackUpLine; WrLn2T(HF, 'IDENTIFICATION NUMBERS LISTED SEPARATELY: "YES"'); for alpha := 1 to 10 do begin ID := ''; Ask('Identifier for '+AToJ[alpha],ID); BackUpLine; WrLn2T(HF, AToJ[alpha]+': '+ID); end; end else begin BackUpLine; WrLn2T(HF, 'IDENTIFICATION NUMBERS LISTED SEPARATELY: "NO"'); end; if AskYN('Do you want the SPECIAL CODES line included in the report', 'Y') then WrLn2T(HF, 'SPECIAL CODES: "YES"') else WrLn2T(HF, 'SPECIAL CODES: "NO"'); DeleteSkip; if AskYN( 'Do you want the SPECIAL CODES listed separately with an identifier', 'N') then begin BackUpLine; WrLn2T(HF, 'SPECIAL CODES LISTED SEPARATELY: "YES"'); for alpha := 1 to 6 do begin ID := ''; Ask('Identifier for '+KToP[alpha],ID); BackUpLine; WrLn2T(HF, KToP[alpha]+': '+ID); end; end else begin BackUpLine; WrLn2T(HF, 'SPECIAL CODES LISTED SEPARATELY: "NO"'); end; if AskYN('Do you want the RESPONSES line included in the report', 'Y') then WrLn2T(HF, 'RESPONSES: "YES"') else WrLn2T(HF, 'RESPONSES: "NO"'); DeleteSkip; if AskYN('Do you want the RESPONSES listed individually with analysis','N') then WrLn2T(HF, 'INDIVIDUAL RESPONSES ANALYSIS: "YES"') else WrLn2T(HF, 'INDIVIDUAL RESPONSES ANALYSIS: "NO"'); DeleteSkip; Close(HF); end; Procedure SetHeader(var HeaderFile: string); {***************************************************************************} var DirInfo: SearchRec; HF: text; begin if HeaderFile <> 'Pick one.' then begin Clr; HeaderFile := GetDirFile('*.HDR'); FindFirst(HeaderFile, AnyFile, DirInfo); if DosError <> 0 then MakeHeader(HeaderFile); end else begin FindFirst('*.HDR', AnyFile, DirInfo); if DosError <> 0 then begin writeln('No header files available ("*.HDR").'); writeln('Creating "GENERIC.HDR"...'); assign(HF, 'GENERIC.HDR'); rewrite(HF); WriteLn(HF, 'NAME LINE: "YES"'); WriteLn(HF, 'SEX LINE: "YES"'); WriteLn(HF, 'EDUCATION/GRADE: "YES"'); WriteLn(HF, 'MONTH: "YES"'); WriteLn(HF, 'DAY: "YES"'); WriteLn(HF, 'YEAR: "YES"'); WriteLn(HF, 'IDENTIFICATION NUMBER: "YES"'); WriteLn(HF, 'IDENTIFICATION NUMBERS LISTED SEPARATELY: "NO"'); WriteLn(HF, 'SPECIAL CODES: "YES"'); WriteLn(HF, 'SPECIAL CODES LISTED SEPARATELY: "NO"'); WriteLn(HF, 'RESPONSES: "YES"'); WriteLn(HF, 'INDIVIDUAL RESPONSES ANALYSIS: "YES"'); close(HF); writeln('"GENERIC.HDR" created.'); HeaderFile := 'GENERIC.HDR'; Wait; end else repeat HeaderFile := DirInfo.Name; FindNext(DirInfo); until DosError <> 0; end; end; Procedure MakeLetter(var LetterFile: string); {***************************************************************************} const Letter: Char10Array = ('A','B','C','D','E','F','G','H','I','J'); var LF: text; Comments: string; LetterVal: Str10Array; alpha: integer; NulVal: boolean; ValStr: string; RealVal: real; begin Clr; Assign(LF, LetterFile); Rewrite(LF); Say('Letter File: '+LetterFile); BackUpLine; Say('Entering nothing at a letter value prompt will default to "N/A" or'); Say('"Not applicable". This letter will not be averaged in.'); Say('Real values (non-integers) and negatives may be used.'); writeln('Enter your top-of-form comments and notes [max 255 characters].'); writeln('Do not include "LETTERS:" as this designates end of comments.'); Say(MultiChar('*',78)); WrLn2T(LF,'Letter File: '+LetterFile); WrLn2T(LF,'COMMENTS:'); readln(Comments); BackUpLine; WrLn2T(LF, Comments); WrLn2T(LF, 'LETTERS:'); for alpha := 1 to 10 do begin AskRealNul(Letter[alpha], -MaxInt, MaxInt, RealVal, NulVal); ValStr := StrReal(RealVal,0,2); BackUpLine; if NulVal then ValStr := 'N/A'; WrLn2T(LF, Letter[alpha]+' = '+ValStr); end; Close(LF); end; Procedure SetLetter(var LetterFile: string); {***************************************************************************} var DirInfo: SearchRec; LF: text; begin if LetterFile <> 'Pick one.' then begin Clr; LetterFile := GetDirFile('*.LTR'); FindFirst(LetterFile, AnyFile, DirInfo); if DosError <> 0 then MakeLetter(LetterFile); end else begin FindFirst('*.LTR', AnyFile, DirInfo); if DosError <> 0 then begin writeln('No letter files available ("*.LTR").'); writeln('Creating "A-J-1-10.LTR"...'); assign(LF, 'A-J-1-10.LTR'); rewrite(LF); writeln(LF, 'A-J-1-10.LTR'); writeln(LF, 'LETTERS:'); writeln(LF, 'A = 1'); writeln(LF, 'B = 2'); writeln(LF, 'C = 3'); writeln(LF, 'D = 4'); writeln(LF, 'E = 5'); writeln(LF, 'F = 6'); writeln(LF, 'G = 7'); writeln(LF, 'H = 8'); writeln(LF, 'I = 9'); writeln(LF, 'J = 10'); close(LF); writeln('"A-J-1-10.LTR" created.'); LetterFile := 'A-J-1-10.LTR'; Wait; end else repeat LetterFile := DirInfo.Name; FindNext(DirInfo); until DosError <> 0; end; end; Procedure MakeFormat(var FormatFile: string); {***************************************************************************} var FF: text; Done: boolean; InStr: string; begin Done := false; ; Clr; Assign(FF, FormatFile); Rewrite(FF); Say('You make any comment, heading, or sub-heading as long as you'); Say('end the line with a colon (:) and then the questions to be'); Say('averaged. Ex.: "Overall: 1-4, 5, 8 10 12-56". A comma (,) or'); Say('a space delimits a single question to be averaged and dash'); Say('indicates a series. All the series and singles on a line will'); Say('be averaged together. Numbers will be averaged following any'); Say('colon in a line. If there is no colon, nothing will be averaged.'); Say('Enter ".S" or ".s" at the beginning of a line to stop and save.'); Say(MultiChar('*',78)); repeat readln(InStr); if (InStr = '.s') or (InStr = '.S') then Done := true else WriteLn(FF, InStr); until Done; Close(FF); end; Procedure SetFormat(var FormatFile: string); {***************************************************************************} var DirInfo: SearchRec; FF: text; begin if FormatFile <> 'Pick one.' then begin Clr; FormatFile := GetDirFile('*.FRM'); FindFirst(FormatFile, AnyFile, DirInfo); if DosError <> 0 then MakeFormat(FormatFile); end else begin FindFirst('*.FRM', AnyFile, DirInfo); if DosError <> 0 then begin writeln('No format files available ("*.FRM").'); writeln('Creating "GROUP120.FRM"...'); assign(FF, 'GROUP120.FRM'); rewrite(FF); writeln(FF, 'GROUP120.FRM'); writeln(FF,'OVERALL: 1 - 120'); close(FF); writeln('"GROUP120.FRM" created.'); FormatFile := 'GROUP120.FRM'; Wait; end else repeat FormatFile := DirInfo.Name; FindNext(DirInfo); until DosError <> 0; end; end; Procedure Menu(var FormatFile, LetterFile, HeaderFile: string); {***************************************************************************} const NumOptions = 4; var Option: integer; begin Clr; Say('Program REPORT2 by 2Lt David Croft, 31st TES.'); Say(''); Say('Purpose:'); Say(' Creates report files (.RPT) of data files (.DAT) created by'); Say('SCAN.EXE and TRANS.EXE as part of the Questionnaire Analysis System'); Say('(QAS) package.'); Say(''); Say('Notes:'); Say('Max # of responses on a merged answer sheet allowable is 255.'); Say('Max # of answer sheets in a *.DAT file allowable is ' + StrInt(MaxNumSurveySheets) + '.'); Say( 'This program will generate initial .HDR, .LTR, and .FRM files if missing.' ); writeln; Say('0) Quit -- or CONTROL-BREAK'); Say('1) Set up the report format'); Say(' Format currently set to "'+FormatFile+'".'); Say('2) Set the scan sheet letters to numerical values'); Say(' Letters currently set to values in "'+LetterFile+'".'); Say('3) Set up the header format'); Say(' Header currently set to "'+HeaderFile+'".'); Say('4) Generate the report'); writeln; AskNum('Option',NumOptions,Option); case Option of 0: halt; 1: SetFormat(FormatFile); 2: SetLetter(LetterFile); 3: SetHeader(HeaderFile); 4: MakeReport(FormatFile, LetterFile, HeaderFile); end; {case} Wait; end; {***************************************************************************} {***************************************************************************} {***************************************************************************} begin Clr; InitFormatFile := 'Pick one.'; InitLetterFile := 'Pick one.'; InitHeaderFile := 'Pick one.'; SetFormat(InitFormatFile); SetLetter(InitLetterFile); SetHeader(InitHeaderFile); repeat Menu(InitFormatFile, InitLetterFile, InitHeaderFile); until Forever; end.