//kt -- Modified with SourceScanner on 7/19/2007 unit fMHTest; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls, ORCtrls, ORFn, uConst, DKLang; type TfrmMHTest = class(TForm) sbMain: TScrollBox; pnlBottom: TPanel; btnCancel: TButton; btnOK: TButton; btnClear: TButton; DKLanguageController1: TDKLanguageController; procedure FormDestroy(Sender: TObject); procedure FormCreate(Sender: TObject); procedure FormShow(Sender: TObject); procedure sbMainResize(Sender: TObject); procedure btnOKClick(Sender: TObject); procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); procedure btnClearClick(Sender: TObject); private FIDCount: integer; FAnswers: TStringList; FObjs: TList; FInfoText: string; FInfoLabel: TMemo; FBuilt: boolean; FMaxLines: integer; FBuildingControls: boolean; procedure BuildControls; function Answers: string; procedure GetQText(QText: TStringList); function LoadTest(InitialAnswers, TestName: string): boolean; function CurrentQ: integer; procedure GotoQ(x: integer); public MHTestComp: string; MHA3: boolean; end; function PerformMHTest(InitialAnswers, TestName: string; QText: TStringList): string; implementation uses rReminders; {$R *.DFM} const MaxQ = 100; // Max # of allowed answers for one question LineNumberTag = 1; ComboBoxTag = 2; BevelTag = 3; QuestionLabelTag = 4; CheckBoxTag = 10; NumberThreshhold = 5; // min # of questions on test before each has a line number Skipped = 'X'; QGap = 4; Gap = 2; var frmMHTest: TfrmMHTest; FFirstCtrl: TList; FYPos: TList; type TMHQuestion = class(TObject) private FSeeAnswers: boolean; FAnswerText: string; FText: string; FAllowedAnswers: string; FAnswerIndex: integer; FAnswerCount: integer; FID: integer; FAnswer: string; FObjects: TList; FLine: integer; protected procedure OnChange(Sender: TObject); public constructor Create; destructor Destroy; override; function Question: string; procedure BuildControls(var Y: integer; Wide: integer); property AllowedAnswers: string read FAllowedAnswers; property Answer: string read FAnswer; property AnswerCount: integer read FAnswerCount; property AnswerIndex: integer read FAnswerIndex; property AnswerText: string read FAnswerText; property SeeAnswers: boolean read FSeeAnswers; property ID: integer read FID; property Text: string read FText; end; procedure ProcessMsg; var SaveCursor: TCursor; begin if(Screen.Cursor = crHourGlass) then begin SaveCursor := Screen.Cursor; Screen.Cursor := crDefault; try Application.ProcessMessages; finally Screen.Cursor := SaveCursor; end; end else Application.ProcessMessages; end; function PerformMHTest(InitialAnswers, TestName: string; QText: TStringList): string; begin Result := InitialAnswers; frmMHTest := TfrmMHTest.Create(Application); try frmMHTest.Caption := TestName; if(frmMHTest.LoadTest(InitialAnswers, TestName)) then begin if(frmMHTest.ShowModal = mrOK) then begin Result := frmMHTest.Answers; if(assigned(QText)) then begin QText.Clear; if(Result <> '') then frmMHTest.GetQText(QText); end; end; end; if frmMHTest.MHTestComp = '' then frmMHTest.MHTestComp := '0'; Result := Result + U + frmMHTest.MHTestComp; if Result = U then Result := ''; finally frmMHTest.Free; end; end; { TfrmMHTest } function TfrmMHTest.Answers: string; var i, XCnt: integer; ans: string; begin Result := ''; XCnt := 0; for i := 0 to FObjs.Count-1 do begin ans := TMHQuestion(FObjs[i]).FAnswer; if(ans = Skipped) then inc(XCnt); Result := Result + ans; end; if(XCnt = FObjs.Count) then Result := ''; end; function TfrmMHTest.LoadTest(InitialAnswers, TestName: string): boolean; var TstData: TStringList; lNum, i, idx: integer; Line, LastLine, Inp, Code: string; Txt, Spec, p, Spidx, tmp: string; RSpec, First, TCodes: boolean; QObj: TMHQuestion; procedure ParseText; var i, tlen: integer; begin Code := ''; i := 1; tlen := length(Txt); while(i <= tlen) do begin while(i <= tlen) and (Txt[i] = ' ') do inc(i); if(i > tlen) then begin Txt := ''; exit; end; if(i > 1) then begin delete(Txt,1,i-1); i := 1; end; if(Spec = 'I') then exit; tlen := length(Txt); if(tlen < 3) then exit; Code := copy(Txt,i,1); if(pos(Code, (UpperCaseLetters + LowerCaseLetters + Digits)) = 0) then begin Code := ''; exit; end; inc(i); while(i <= tlen) and (Txt[i] = ' ') do inc(i); if(Txt[i] in ['.','=']) then begin if(pos(Code, QObj.FAllowedAnswers) > 0) then begin inc(i); while(i <= tlen) and (Txt[i] = ' ') do inc(i); if(i <= tlen) then delete(Txt,1,i-1) else Code := ''; exit; end else begin Code := ''; exit; end; end else begin Code := ''; exit; end; end; end; procedure AddTxt2Str(var X: string); begin if(Txt <> '') then begin if(X <> '') then begin X := X + ' '; if(copy(Txt, length(Txt), 1) = '.') then X := X + ' '; end; X := X + Txt; end; end; begin Result := TRUE; TstData := TStringList.Create; try TstData.Assign(LoadMentalHealthTest(TestName)); if TstData.Strings[0] = '1' then MHA3 := True else MHA3 := False; Screen.Cursor := crHourGlass; try TstData.Add('99999;X;0'); idx := 1; FMaxLines := 0; FInfoText := ''; LastLine := U; First := TRUE; RSpec := FALSE; TCodes := FALSE; QObj := nil; while (idx < TstData.Count) do begin Inp := TstData[idx]; if(pos('[ERROR]', Inp) > 0) then begin Result := FALSE; break; end; p := Piece(Inp, U, 1); Line := Piece(p, ';', 1); Spec := Piece(p, ';', 2); SpIdx := Piece(p, ';', 3); if(LastLine <> Line) then begin LastLine := Line; if(First) then First := FALSE else begin if(not RSpec) then begin Result := FALSE; break; end; end; if(Spec = 'X') then break; lNum := StrToIntDef(Line, 0); if(lNum <= 0) then begin Result := FALSE; break; end; RSpec := FALSE; TCodes := FALSE; QObj := TMHQuestion(FObjs[FObjs.Add(TMHQuestion.Create)]); QObj.FLine := lNum; if(FMaxLines < lNum) then FMaxLines := lNum; end; Txt := Piece(Inp, U, 2); ParseText; if(Txt <> '') then begin if(Spec = 'I') then begin if MHA3 = True then AddTxt2Str(QObj.FText) else AddTxt2Str(FInfoText);; end else if(Spec = 'R') then begin RSpec := TRUE; if(spIdx = '0') then QObj.FAllowedAnswers := Txt else if(Code = '') then QObj.FAnswerText := Txt else begin QObj.FSeeAnswers := FALSE; FAnswers.Add(Code + U + Txt); inc(QObj.FAnswerCount); end; end else if(Spec = 'T') then begin if(Code = '') then begin if(TCodes) then begin tmp := FAnswers[FAnswers.Count-1]; AddTxt2Str(tmp); FAnswers[FAnswers.Count-1] := tmp; end else AddTxt2Str(QObj.FText); end else begin TCodes := TRUE; FAnswers.Add(Code + U + Txt); inc(QObj.FAnswerCount); end; end; end; inc(idx); end; finally Screen.Cursor := crDefault; end; finally TstData.Free; end; if(not Result) then // ShowMessage('Error encountered loading ' + TestName) <-- original line. //kt 7/19/2007 ShowMessage(DKLangConstW('fMHTest_Error_encountered_loading') + TestName) //kt added 7/19/2007 else begin for i := 0 to FObjs.Count-1 do begin with TMHQuestion(FObjs[i]) do begin tmp := copy(InitialAnswers,i+1,1); if(tmp <> '') then FAnswer := tmp; end; end; end; end; procedure TfrmMHTest.FormCreate(Sender: TObject); begin ResizeAnchoredFormToFont(self); FAnswers := TStringList.Create; FObjs := TList.Create; FFirstCtrl := TList.Create; FYPos := TList.Create; end; procedure TfrmMHTest.FormDestroy(Sender: TObject); begin KillObj(@FFirstCtrl); KillObj(@FYPos); KillObj(@FObjs, TRUE); KillObj(@FAnswers); end; procedure TfrmMHTest.BuildControls; var i, Wide, Y: integer; BoundsRect: TRect; begin if(not FBuildingControls) then begin FBuildingControls := TRUE; try Wide := sbMain.Width - (Gap * 2) - ScrollBarWidth - 4; Y := gap - sbMain.VertScrollBar.Position; if MHA3 = False then begin if(not assigned(FInfoLabel)) then begin FInfoLabel := TMemo.Create(Self); FInfoLabel.Color := clBtnFace; FInfoLabel.BorderStyle := bsNone; FInfoLabel.ReadOnly := TRUE; FInfoLabel.TabStop := FALSE; FInfoLabel.Parent := sbMain; FInfoLabel.WordWrap := TRUE; FInfoLabel.Text := FInfoText; FInfoLabel.Left := Gap; end; BoundsRect := FInfoLabel.BoundsRect; //Wide := sbMain.Width - (Gap * 2) - ScrollBarWidth - 4; //Y := gap - sbMain.VertScrollBar.Position; BoundsRect.Top := Y; BoundsRect.Right := BoundsRect.Left + Wide; WrappedTextHeightByFont(Canvas, FInfoLabel.Font, FInfoLabel.Text, BoundsRect); BoundsRect.Right := BoundsRect.Left + Wide; FInfoLabel.BoundsRect := BoundsRect; ProcessMsg; inc(Y, FInfoLabel.Height + QGap); for i := 0 to FObjs.Count-1 do TMHQuestion(FObjs[i]).BuildControls(Y, Wide); end else begin inc(Y, 1); for i := 0 to FObjs.Count-1 do TMHQuestion(FObjs[i]).BuildControls(Y, Wide); end; finally FBuildingControls := FALSE; end; end; end; procedure TfrmMHTest.GetQText(QText: TStringList); var i, lx: integer; begin if(FObjs.Count > 99) then lx := 5 else if(FObjs.Count > 9) then lx := 4 else lx := 3; for i := 0 to FObjs.Count-1 do QText.Add(copy(IntToStr(i+1) + '. ', 1, lx) + TMHQuestion(FObjs[i]).Question); end; function TfrmMHTest.CurrentQ: integer; var i, j: integer; ctrl: TWinControl; MHQ: TMHQuestion; begin Result := 0; ctrl := ActiveControl; if(not assigned(Ctrl)) then exit; for i := 0 to FObjs.Count-1 do begin MHQ := TMHQuestion(FObjs[i]); for j := 0 to MHQ.FObjects.Count-1 do begin if(Ctrl = MHQ.FObjects[j]) then begin Result := i; exit; end; end; end; end; procedure TfrmMHTest.GotoQ(x: integer); begin if(ModalResult <> mrNone) then exit; if(x < 0) then x := 0; if(x >= FYPos.Count) then begin btnOK.Default := TRUE; btnOK.SetFocus; end else begin btnOK.Default := FALSE; sbMain.VertScrollBar.Position := Integer(FYPos[x]) - 2; TWinControl(FFirstCtrl[x]).SetFocus; end; end; procedure TfrmMHTest.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); begin if Key = VK_PRIOR then begin GotoQ(CurrentQ - 1); Key := 0; end else if (Key = VK_NEXT) or (Key = VK_RETURN) then begin GotoQ(CurrentQ + 1); Key := 0; end; end; { TMHQuestion } procedure TMHQuestion.BuildControls(var Y: integer; Wide: integer); var RCombo: TComboBox; LNLbl, RLbl: TMemo; Bvl: TBevel; cb: TORCheckBox; ans, idx, DX, MaxDX, MaxDY: integer; Offset: integer; txt: string; QNum: integer; function GetCtrl(SubTag: integer): TControl; var i: integer; begin Result := nil; for i := 0 to FObjects.Count-1 do begin if(TControl(FObjects[i]).Tag = (FID + SubTag)) then begin Result := TControl(FObjects[i]); break; end; end; end; procedure AdjDY(Ht: integer); begin if(MaxDY < Ht) then MaxDY := Ht; end; procedure GetRLbl; var BoundsRect: TRect; begin if(FText <> '') then begin RLbl := TMemo(GetCtrl(QuestionLabelTag)); if(not assigned(RLbl)) then begin RLbl := TMemo.Create(frmMHTest); RLbl.Color := clBtnFace; RLbl.BorderStyle := bsNone; RLbl.ReadOnly := TRUE; RLbl.TabStop := FALSE; RLbl.Parent := frmMHTest.sbMain; RLbl.Tag := FID + QuestionLabelTag; RLbl.WordWrap := TRUE; RLbl.Text := FText; FObjects.Add(RLbl); end; BoundsRect.Top := Y; BoundsRect.Left := Offset; BoundsRect.Right := Wide; WrappedTextHeightByFont(frmMHTest.Canvas, RLbl.Font, RLbl.Text, BoundsRect); BoundsRect.Right := Wide; RLbl.BoundsRect := BoundsRect; ProcessMsg; end else RLbl := nil; end; begin QNum := (FID div MaxQ)-1; while(FFirstCtrl.Count <= QNum) do FFirstCtrl.Add(nil); while(FYPos.Count <= QNum) do FYPos.Add(nil); FYPos[QNum] := Pointer(Y); ans := pos(FAnswer, FAllowedAnswers) - 1; Offset := Gap; if(not assigned(FObjects)) then FObjects := TList.Create; MaxDY := 0; if(frmMHTest.FObjs.Count >= NumberThreshhold) then begin LNLbl := TMemo(GetCtrl(LineNumberTag)); if(not assigned(LNLbl)) then begin LNLbl := TMemo.Create(frmMHTest); LNLbl.Color := clBtnFace; LNLbl.BorderStyle := bsNone; LNLbl.ReadOnly := TRUE; LNLbl.TabStop := FALSE; LNLbl.Parent := frmMHTest.sbMain; LNLbl.Tag := FID + LineNumberTag; LNLbl.Text := IntToStr(QNum+1) + '.'; LNLbl.Width := TextWidthByFont(LNLbl.Font.Handle, LNLbl.Text); LNLbl.Height := TextHeightByFont(LNLbl.Font.Handle, LNLbl.Text); FObjects.Add(LNLbl); end; LNLbl.Top := Y; LNLbl.Left := Offset; inc(Offset, MainFontSize * 4); AdjDY(LNLbl.Height); end; Bvl := TBevel(GetCtrl(BevelTag)); if(not assigned(Bvl)) then begin Bvl := TBevel.Create(frmMHTest); Bvl.Parent := frmMHTest.sbMain; Bvl.Tag := FID + BevelTag; Bvl.Shape := bsFrame; FObjects.Add(Bvl); end; Bvl.Top := Y; Bvl.Left := Offset; Bvl.Width := Wide - Offset; inc(Offset, Gap * 2); inc(Y, Gap * 2); dec(Wide, Offset + (Gap * 2)); GetRLbl; if(assigned(RLbl)) then begin MaxDY := RLbl.Height; inc(Y, MaxDY + Gap * 2); end; if(FSeeAnswers) then begin for idx := 0 to FAnswerCount-1 do begin cb := TORCheckBox(GetCtrl(CheckBoxTag + idx)); if(not assigned(cb)) then begin cb := TORCheckBox.Create(frmMHTest); if(idx = 0) then FFirstCtrl[QNum] := cb; cb.Parent := frmMHTest.sbMain; cb.Tag := FID + CheckBoxTag + idx; cb.GroupIndex := FID; cb.WordWrap := TRUE; cb.AutoSize := TRUE; if(idx = ans) then cb.Checked := TRUE; cb.OnClick := OnChange; cb.Caption := Piece(frmMHTest.FAnswers[FAnswerIndex + idx], U, 2); FObjects.Add(cb); end; cb.Top := Y; cb.Left := Offset; cb.WordWrap := TRUE; cb.Width := Wide; cb.AutoAdjustSize; cb.WordWrap := (not cb.SingleLine); inc(Y, cb.Height + Gap); end; end else begin RCombo := TComboBox(GetCtrl(ComboBoxTag)); if(not assigned(RCombo)) then begin RCombo := TComboBox.Create(frmMHTest); FFirstCtrl[QNum] := RCombo; RCombo.Parent := frmMHTest.sbMain; RCombo.Tag := FID + ComboBoxTag; FObjects.Add(RCombo); MaxDX := 0; for idx := 0 to FAnswerCount-1 do begin txt := Piece(frmMHTest.FAnswers[FAnswerIndex + idx], U, 2); RCombo.Items.Add(txt); DX := TextWidthByFont(frmMHTest.sbMain.Font.Handle, txt); if(MaxDX < DX) then MaxDX := DX; end; RCombo.ItemIndex := ans; RCombo.Width := MaxDX + 24; RCombo.OnChange := OnChange; end; RCombo.Top := Y; RCombo.Left := Offset; inc(Y, RCombo.Height + (Gap * 2)); end; Bvl.Height := Y - Bvl.Top; inc(Y, QGap); end; constructor TMHQuestion.Create; begin inherited; FSeeAnswers := TRUE; FAnswerText := ''; FText := ''; FAllowedAnswers := ''; FAnswerIndex := frmMHTest.FAnswers.Count; FAnswerCount := 0; inc(frmMHTest.FIDCount, MaxQ); FID := frmMHTest.FIDCount; FAnswer := Skipped; end; destructor TMHQuestion.Destroy; begin KillObj(@FObjects, TRUE); inherited; end; procedure TMHQuestion.OnChange(Sender: TObject); var idx: integer; cb: TCheckBox; cbo: TComboBox; begin if(Sender is TCheckBox) then begin cb := TCheckBox(Sender); if(cb.Checked) then begin idx := cb.Tag - CheckBoxTag + 1; idx := idx mod MaxQ; FAnswer := copy(FAllowedAnswers, idx, 1); end else FAnswer := Skipped; end else if(Sender is TComboBox) then begin cbo := TComboBox(Sender); idx := cbo.ItemIndex + 1; if(idx = 0) or (cbo.Text = '') then FAnswer := Skipped else FAnswer := copy(FAllowedAnswers, idx, 1); end; end; procedure TfrmMHTest.FormShow(Sender: TObject); begin if(not FBuilt) then begin Screen.Cursor := crHourGlass; try BuildControls; FBuilt := TRUE; finally Screen.Cursor := crDefault; end; end; end; procedure TfrmMHTest.sbMainResize(Sender: TObject); begin if(FBuilt) then BuildControls; end; function TMHQuestion.Question: string; var idx: integer; echar: string; begin Result := trim(FText); echar := copy(Result, length(Result), 1); if(echar <> ':') and (echar <> '?') then begin if(echar = '.') then delete(Result, length(result), 1); Result := Result + ':'; end; if(FAnswer = Skipped) then // Result := Result + ' Not rated' <-- original line. //kt 7/19/2007 Result := Result + DKLangConstW('fMHTest_Not_rated') //kt added 7/19/2007 else begin idx := pos(FAnswer, FAllowedAnswers) + FAnswerIndex - 1; if(idx >= 0) and (idx < frmMHTest.FAnswers.Count) then Result := Result + ' ' + Piece(frmMHTest.FAnswers[idx],U,2); end; end; procedure TfrmMHTest.btnOKClick(Sender: TObject); var i, XCnt, First: integer; msg, ans, TestStatus: string; begin msg := ''; ans := ''; XCnt := 0; First := -1; TestStatus := '2'; MHTestComp := '2'; for i := 0 to FObjs.Count-1 do begin ans := ans + TMHQuestion(Fobjs[i]).FAnswer; if(TMHQuestion(FObjs[i]).FAnswer = Skipped) then begin if(First < 0) then First := i; inc(XCnt); if(msg <> '') then msg := msg + ', '; msg := msg + IntToStr(i+1); end; end; if(XCnt = FObjs.Count) then ModalResult := mrOK; TestStatus := VerifyMentalHealthTestComplete(Self.Caption, ans); if Piece(TestStatus,U,1) <> '2' then begin if Piece(TestStatus,U,1)='1' then begin ModalResult := mrOK; MHTestComp := '1'; EXIT; end; if Piece(TestStatus,U,1)='0' then begin MHTestComp := '0'; msg := Piece(TestStatus,u,2); // msg := 'The following questions have not been answered:' + CRLF + CRLF + ' ' + msg; <-- original line. //kt 7/19/2007 msg := DKLangConstW('fMHTest_The_following_questions_have_not_been_answeredx') + CRLF + CRLF + ' ' + msg; //kt added 7/19/2007 // if(InfoBox(msg + CRLF + CRLF + 'Answer skipped questions?', 'Skipped Questions', <-- original line. //kt 7/19/2007 if(InfoBox(msg + CRLF + CRLF + DKLangConstW('fMHTest_Answer_skipped_questionsx'), DKLangConstW('fMHTest_Skipped_Questions'), //kt added 7/19/2007 MB_YESNO or MB_ICONQUESTION) = IDYES) then GotoQ(First) else ModalResult := mrOK; EXIT; end; end; if(XCnt = 0) then ModalResult := mrOK else begin if(XCnt = FObjs.Count) then ModalResult := mrOK else begin // msg := 'The following questions have not been answered:' + CRLF + CRLF + ' ' + msg; <-- original line. //kt 7/19/2007 msg := DKLangConstW('fMHTest_The_following_questions_have_not_been_answeredx') + CRLF + CRLF + ' ' + msg; //kt added 7/19/2007 // if(InfoBox(msg + CRLF + CRLF + 'Answer skipped questions?', 'Skipped Questions', <-- original line. //kt 7/19/2007 if(InfoBox(msg + CRLF + CRLF + DKLangConstW('fMHTest_Answer_skipped_questionsx'), DKLangConstW('fMHTest_Skipped_Questions'), //kt added 7/19/2007 MB_YESNO or MB_ICONQUESTION) = IDYES) then GotoQ(First) else ModalResult := mrOK; end; end; end; procedure TfrmMHTest.btnClearClick(Sender: TObject); var i: integer; begin for i := 0 to sbMain.ControlCount-1 do begin if(sbMain.Controls[i] is TCheckBox) then TCheckBox(sbMain.Controls[i]).Checked := FALSE else if(sbMain.Controls[i] is TComboBox) then begin with TComboBox(sbMain.Controls[i]) do begin ItemIndex := -1; OnChange(sbMain.Controls[i]); end; end; end; end; end.