source: cprs/trunk/CPRS-Chart/fMHTest.pas@ 468

Last change on this file since 468 was 456, checked in by Kevin Toppenberg, 16 years ago

Initial Upload of Official WV CPRS 1.0.26.76
File size: 21.2 KB
RevLine 
[456]1unit fMHTest;
2
3interface
4
5uses
6 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
7 StdCtrls, ExtCtrls, ORCtrls, ORFn, uConst;
8
9type
10 TfrmMHTest = class(TForm)
11 sbMain: TScrollBox;
12 pnlBottom: TPanel;
13 btnCancel: TButton;
14 btnOK: TButton;
15 btnClear: TButton;
16 procedure FormDestroy(Sender: TObject);
17 procedure FormCreate(Sender: TObject);
18 procedure FormShow(Sender: TObject);
19 procedure sbMainResize(Sender: TObject);
20 procedure btnOKClick(Sender: TObject);
21 procedure FormKeyDown(Sender: TObject; var Key: Word;
22 Shift: TShiftState);
23 procedure btnClearClick(Sender: TObject);
24 private
25 FIDCount: integer;
26 FAnswers: TStringList;
27 FObjs: TList;
28 FInfoText: string;
29 FInfoLabel: TMemo;
30 FBuilt: boolean;
31 FMaxLines: integer;
32 FBuildingControls: boolean;
33 procedure BuildControls;
34 function Answers: string;
35 procedure GetQText(QText: TStringList);
36 function LoadTest(InitialAnswers, TestName: string): boolean;
37 function CurrentQ: integer;
38 procedure GotoQ(x: integer);
39 public
40 MHTestComp: string;
41 MHA3: boolean;
42 end;
43
44function PerformMHTest(InitialAnswers, TestName: string; QText: TStringList): string;
45
46implementation
47
48uses rReminders;
49
50{$R *.DFM}
51
52const
53 MaxQ = 100; // Max # of allowed answers for one question
54 LineNumberTag = 1;
55 ComboBoxTag = 2;
56 BevelTag = 3;
57 QuestionLabelTag = 4;
58 CheckBoxTag = 10;
59
60 NumberThreshhold = 5; // min # of questions on test before each has a line number
61 Skipped = 'X';
62 QGap = 4;
63 Gap = 2;
64
65var
66 frmMHTest: TfrmMHTest;
67 FFirstCtrl: TList;
68 FYPos: TList;
69
70type
71 TMHQuestion = class(TObject)
72 private
73 FSeeAnswers: boolean;
74 FAnswerText: string;
75 FText: string;
76 FAllowedAnswers: string;
77 FAnswerIndex: integer;
78 FAnswerCount: integer;
79 FID: integer;
80 FAnswer: string;
81 FObjects: TList;
82 FLine: integer;
83 protected
84 procedure OnChange(Sender: TObject);
85 public
86 constructor Create;
87 destructor Destroy; override;
88 function Question: string;
89 procedure BuildControls(var Y: integer; Wide: integer);
90 property AllowedAnswers: string read FAllowedAnswers;
91 property Answer: string read FAnswer;
92 property AnswerCount: integer read FAnswerCount;
93 property AnswerIndex: integer read FAnswerIndex;
94 property AnswerText: string read FAnswerText;
95 property SeeAnswers: boolean read FSeeAnswers;
96 property ID: integer read FID;
97 property Text: string read FText;
98 end;
99
100procedure ProcessMsg;
101var
102 SaveCursor: TCursor;
103
104begin
105 if(Screen.Cursor = crHourGlass) then
106 begin
107 SaveCursor := Screen.Cursor;
108 Screen.Cursor := crDefault;
109 try
110 Application.ProcessMessages;
111 finally
112 Screen.Cursor := SaveCursor;
113 end;
114 end
115 else
116 Application.ProcessMessages;
117end;
118
119function PerformMHTest(InitialAnswers, TestName: string; QText: TStringList): string;
120begin
121 Result := InitialAnswers;
122 frmMHTest := TfrmMHTest.Create(Application);
123 try
124 frmMHTest.Caption := TestName;
125 if(frmMHTest.LoadTest(InitialAnswers, TestName)) then
126 begin
127 if(frmMHTest.ShowModal = mrOK) then
128 begin
129 Result := frmMHTest.Answers;
130 if(assigned(QText)) then
131 begin
132 QText.Clear;
133 if(Result <> '') then
134 frmMHTest.GetQText(QText);
135 end;
136 end;
137 end;
138 if frmMHTest.MHTestComp = '' then frmMHTest.MHTestComp := '0';
139 Result := Result + U + frmMHTest.MHTestComp;
140 if Result = U then Result := '';
141 finally
142 frmMHTest.Free;
143 end;
144end;
145
146{ TfrmMHTest }
147
148function TfrmMHTest.Answers: string;
149var
150 i, XCnt: integer;
151 ans: string;
152
153begin
154 Result := '';
155 XCnt := 0;
156 for i := 0 to FObjs.Count-1 do
157 begin
158 ans := TMHQuestion(FObjs[i]).FAnswer;
159 if(ans = Skipped) then
160 inc(XCnt);
161 Result := Result + ans;
162 end;
163 if(XCnt = FObjs.Count) then
164 Result := '';
165end;
166
167function TfrmMHTest.LoadTest(InitialAnswers, TestName: string): boolean;
168var
169 TstData: TStringList;
170 lNum, i, idx: integer;
171 Line, LastLine, Inp, Code: string;
172 Txt, Spec, p, Spidx, tmp: string;
173 RSpec, First, TCodes: boolean;
174 QObj: TMHQuestion;
175
176 procedure ParseText;
177 var
178 i, tlen: integer;
179
180 begin
181 Code := '';
182 i := 1;
183 tlen := length(Txt);
184 while(i <= tlen) do
185 begin
186 while(i <= tlen) and (Txt[i] = ' ') do inc(i);
187 if(i > tlen) then
188 begin
189 Txt := '';
190 exit;
191 end;
192 if(i > 1) then
193 begin
194 delete(Txt,1,i-1);
195 i := 1;
196 end;
197 if(Spec = 'I') then exit;
198 tlen := length(Txt);
199 if(tlen < 3) then exit;
200 Code := copy(Txt,i,1);
201 if(pos(Code, (UpperCaseLetters + LowerCaseLetters + Digits)) = 0) then
202 begin
203 Code := '';
204 exit;
205 end;
206 inc(i);
207 while(i <= tlen) and (Txt[i] = ' ') do inc(i);
208 if(Txt[i] in ['.','=']) then
209 begin
210 if(pos(Code, QObj.FAllowedAnswers) > 0) then
211 begin
212 inc(i);
213 while(i <= tlen) and (Txt[i] = ' ') do inc(i);
214 if(i <= tlen) then
215 delete(Txt,1,i-1)
216 else
217 Code := '';
218 exit;
219 end
220 else
221 begin
222 Code := '';
223 exit;
224 end;
225 end
226 else
227 begin
228 Code := '';
229 exit;
230 end;
231 end;
232 end;
233
234 procedure AddTxt2Str(var X: string);
235 begin
236 if(Txt <> '') then
237 begin
238 if(X <> '') then
239 begin
240 X := X + ' ';
241 if(copy(Txt, length(Txt), 1) = '.') then
242 X := X + ' ';
243 end;
244 X := X + Txt;
245 end;
246 end;
247
248begin
249 Result := TRUE;
250 TstData := TStringList.Create;
251 try
252 TstData.Assign(LoadMentalHealthTest(TestName));
253 if TstData.Strings[0] = '1' then MHA3 := True
254 else MHA3 := False;
255 Screen.Cursor := crHourGlass;
256 try
257 TstData.Add('99999;X;0');
258 idx := 1;
259 FMaxLines := 0;
260 FInfoText := '';
261 LastLine := U;
262 First := TRUE;
263 RSpec := FALSE;
264 TCodes := FALSE;
265 QObj := nil;
266 while (idx < TstData.Count) do
267 begin
268 Inp := TstData[idx];
269 if(pos('[ERROR]', Inp) > 0) then
270 begin
271 Result := FALSE;
272 break;
273 end;
274 p := Piece(Inp, U, 1);
275 Line := Piece(p, ';', 1);
276 Spec := Piece(p, ';', 2);
277 SpIdx := Piece(p, ';', 3);
278 if(LastLine <> Line) then
279 begin
280 LastLine := Line;
281 if(First) then
282 First := FALSE
283 else
284 begin
285 if(not RSpec) then
286 begin
287 Result := FALSE;
288 break;
289 end;
290 end;
291 if(Spec = 'X') then break;
292 lNum := StrToIntDef(Line, 0);
293 if(lNum <= 0) then
294 begin
295 Result := FALSE;
296 break;
297 end;
298 RSpec := FALSE;
299 TCodes := FALSE;
300 QObj := TMHQuestion(FObjs[FObjs.Add(TMHQuestion.Create)]);
301 QObj.FLine := lNum;
302 if(FMaxLines < lNum) then
303 FMaxLines := lNum;
304 end;
305 Txt := Piece(Inp, U, 2);
306 ParseText;
307 if(Txt <> '') then
308 begin
309 if(Spec = 'I') then
310 begin
311 if MHA3 = True then AddTxt2Str(QObj.FText)
312 else
313 AddTxt2Str(FInfoText);;
314 end
315 else
316 if(Spec = 'R') then
317 begin
318 RSpec := TRUE;
319 if(spIdx = '0') then
320 QObj.FAllowedAnswers := Txt
321 else
322 if(Code = '') then
323 QObj.FAnswerText := Txt
324 else
325 begin
326 QObj.FSeeAnswers := FALSE;
327 FAnswers.Add(Code + U + Txt);
328 inc(QObj.FAnswerCount);
329 end;
330 end
331 else
332 if(Spec = 'T') then
333 begin
334 if(Code = '') then
335 begin
336 if(TCodes) then
337 begin
338 tmp := FAnswers[FAnswers.Count-1];
339 AddTxt2Str(tmp);
340 FAnswers[FAnswers.Count-1] := tmp;
341 end
342 else
343 AddTxt2Str(QObj.FText);
344 end
345 else
346 begin
347 TCodes := TRUE;
348 FAnswers.Add(Code + U + Txt);
349 inc(QObj.FAnswerCount);
350 end;
351 end;
352 end;
353 inc(idx);
354 end;
355 finally
356 Screen.Cursor := crDefault;
357 end;
358 finally
359 TstData.Free;
360 end;
361 if(not Result) then
362 ShowMessage('Error encountered loading ' + TestName)
363 else
364 begin
365 for i := 0 to FObjs.Count-1 do
366 begin
367 with TMHQuestion(FObjs[i]) do
368 begin
369 tmp := copy(InitialAnswers,i+1,1);
370 if(tmp <> '') then
371 FAnswer := tmp;
372 end;
373 end;
374 end;
375end;
376
377procedure TfrmMHTest.FormCreate(Sender: TObject);
378begin
379 ResizeAnchoredFormToFont(self);
380 FAnswers := TStringList.Create;
381 FObjs := TList.Create;
382 FFirstCtrl := TList.Create;
383 FYPos := TList.Create;
384end;
385
386procedure TfrmMHTest.FormDestroy(Sender: TObject);
387begin
388 KillObj(@FFirstCtrl);
389 KillObj(@FYPos);
390 KillObj(@FObjs, TRUE);
391 KillObj(@FAnswers);
392end;
393
394procedure TfrmMHTest.BuildControls;
395var
396 i, Wide, Y: integer;
397 BoundsRect: TRect;
398begin
399 if(not FBuildingControls) then
400 begin
401 FBuildingControls := TRUE;
402 try
403 Wide := sbMain.Width - (Gap * 2) - ScrollBarWidth - 4;
404 Y := gap - sbMain.VertScrollBar.Position;
405 if MHA3 = False then
406 begin
407 if(not assigned(FInfoLabel)) then
408 begin
409 FInfoLabel := TMemo.Create(Self);
410 FInfoLabel.Color := clBtnFace;
411 FInfoLabel.BorderStyle := bsNone;
412 FInfoLabel.ReadOnly := TRUE;
413 FInfoLabel.TabStop := FALSE;
414 FInfoLabel.Parent := sbMain;
415 FInfoLabel.WordWrap := TRUE;
416 FInfoLabel.Text := FInfoText;
417 FInfoLabel.Left := Gap;
418 end;
419 BoundsRect := FInfoLabel.BoundsRect;
420 //Wide := sbMain.Width - (Gap * 2) - ScrollBarWidth - 4;
421 //Y := gap - sbMain.VertScrollBar.Position;
422 BoundsRect.Top := Y;
423 BoundsRect.Right := BoundsRect.Left + Wide;
424 WrappedTextHeightByFont(Canvas, FInfoLabel.Font, FInfoLabel.Text, BoundsRect);
425 BoundsRect.Right := BoundsRect.Left + Wide;
426 FInfoLabel.BoundsRect := BoundsRect;
427 ProcessMsg;
428 inc(Y, FInfoLabel.Height + QGap);
429 for i := 0 to FObjs.Count-1 do
430 TMHQuestion(FObjs[i]).BuildControls(Y, Wide);
431 end
432 else
433 begin
434 inc(Y, 1);
435 for i := 0 to FObjs.Count-1 do TMHQuestion(FObjs[i]).BuildControls(Y, Wide);
436 end;
437 finally
438 FBuildingControls := FALSE;
439 end;
440 end;
441end;
442
443procedure TfrmMHTest.GetQText(QText: TStringList);
444var
445 i, lx: integer;
446
447begin
448 if(FObjs.Count > 99) then
449 lx := 5
450 else
451 if(FObjs.Count > 9) then
452 lx := 4
453 else
454 lx := 3;
455 for i := 0 to FObjs.Count-1 do
456 QText.Add(copy(IntToStr(i+1) + '. ', 1, lx) + TMHQuestion(FObjs[i]).Question);
457end;
458
459function TfrmMHTest.CurrentQ: integer;
460var
461 i, j: integer;
462 ctrl: TWinControl;
463 MHQ: TMHQuestion;
464
465begin
466 Result := 0;
467 ctrl := ActiveControl;
468 if(not assigned(Ctrl)) then
469 exit;
470 for i := 0 to FObjs.Count-1 do
471 begin
472 MHQ := TMHQuestion(FObjs[i]);
473 for j := 0 to MHQ.FObjects.Count-1 do
474 begin
475 if(Ctrl = MHQ.FObjects[j]) then
476 begin
477 Result := i;
478 exit;
479 end;
480 end;
481 end;
482end;
483
484procedure TfrmMHTest.GotoQ(x: integer);
485begin
486 if(ModalResult <> mrNone) then exit;
487 if(x < 0) then x := 0;
488 if(x >= FYPos.Count) then
489 begin
490 btnOK.Default := TRUE;
491 btnOK.SetFocus;
492 end
493 else
494 begin
495 btnOK.Default := FALSE;
496 sbMain.VertScrollBar.Position := Integer(FYPos[x]) - 2;
497 TWinControl(FFirstCtrl[x]).SetFocus;
498 end;
499end;
500
501procedure TfrmMHTest.FormKeyDown(Sender: TObject; var Key: Word;
502 Shift: TShiftState);
503begin
504 if Key = VK_PRIOR then
505 begin
506 GotoQ(CurrentQ - 1);
507 Key := 0;
508 end
509 else
510 if (Key = VK_NEXT) or (Key = VK_RETURN) then
511 begin
512 GotoQ(CurrentQ + 1);
513 Key := 0;
514 end;
515end;
516
517{ TMHQuestion }
518
519procedure TMHQuestion.BuildControls(var Y: integer; Wide: integer);
520var
521 RCombo: TComboBox;
522 LNLbl, RLbl: TMemo;
523 Bvl: TBevel;
524 cb: TORCheckBox;
525 ans, idx, DX, MaxDX, MaxDY: integer;
526 Offset: integer;
527 txt: string;
528 QNum: integer;
529
530 function GetCtrl(SubTag: integer): TControl;
531 var
532 i: integer;
533
534 begin
535 Result := nil;
536 for i := 0 to FObjects.Count-1 do
537 begin
538 if(TControl(FObjects[i]).Tag = (FID + SubTag)) then
539 begin
540 Result := TControl(FObjects[i]);
541 break;
542 end;
543 end;
544 end;
545
546 procedure AdjDY(Ht: integer);
547 begin
548 if(MaxDY < Ht) then
549 MaxDY := Ht;
550 end;
551
552 procedure GetRLbl;
553 var
554 BoundsRect: TRect;
555 begin
556 if(FText <> '') then
557 begin
558 RLbl := TMemo(GetCtrl(QuestionLabelTag));
559 if(not assigned(RLbl)) then
560 begin
561 RLbl := TMemo.Create(frmMHTest);
562 RLbl.Color := clBtnFace;
563 RLbl.BorderStyle := bsNone;
564 RLbl.ReadOnly := TRUE;
565 RLbl.TabStop := FALSE;
566 RLbl.Parent := frmMHTest.sbMain;
567 RLbl.Tag := FID + QuestionLabelTag;
568 RLbl.WordWrap := TRUE;
569 RLbl.Text := FText;
570 FObjects.Add(RLbl);
571 end;
572 BoundsRect.Top := Y;
573 BoundsRect.Left := Offset;
574 BoundsRect.Right := Wide;
575 WrappedTextHeightByFont(frmMHTest.Canvas, RLbl.Font, RLbl.Text, BoundsRect);
576 BoundsRect.Right := Wide;
577 RLbl.BoundsRect := BoundsRect;
578 ProcessMsg;
579 end
580 else
581 RLbl := nil;
582 end;
583
584begin
585 QNum := (FID div MaxQ)-1;
586 while(FFirstCtrl.Count <= QNum) do
587 FFirstCtrl.Add(nil);
588 while(FYPos.Count <= QNum) do
589 FYPos.Add(nil);
590 FYPos[QNum] := Pointer(Y);
591 ans := pos(FAnswer, FAllowedAnswers) - 1;
592 Offset := Gap;
593 if(not assigned(FObjects)) then
594 FObjects := TList.Create;
595 MaxDY := 0;
596 if(frmMHTest.FObjs.Count >= NumberThreshhold) then
597 begin
598 LNLbl := TMemo(GetCtrl(LineNumberTag));
599 if(not assigned(LNLbl)) then
600 begin
601 LNLbl := TMemo.Create(frmMHTest);
602 LNLbl.Color := clBtnFace;
603 LNLbl.BorderStyle := bsNone;
604 LNLbl.ReadOnly := TRUE;
605 LNLbl.TabStop := FALSE;
606 LNLbl.Parent := frmMHTest.sbMain;
607 LNLbl.Tag := FID + LineNumberTag;
608 LNLbl.Text := IntToStr(QNum+1) + '.';
609 LNLbl.Width := TextWidthByFont(LNLbl.Font.Handle, LNLbl.Text);
610 LNLbl.Height := TextHeightByFont(LNLbl.Font.Handle, LNLbl.Text);
611 FObjects.Add(LNLbl);
612 end;
613 LNLbl.Top := Y;
614 LNLbl.Left := Offset;
615 inc(Offset, MainFontSize * 4);
616 AdjDY(LNLbl.Height);
617 end;
618
619 Bvl := TBevel(GetCtrl(BevelTag));
620 if(not assigned(Bvl)) then
621 begin
622 Bvl := TBevel.Create(frmMHTest);
623 Bvl.Parent := frmMHTest.sbMain;
624 Bvl.Tag := FID + BevelTag;
625 Bvl.Shape := bsFrame;
626 FObjects.Add(Bvl);
627 end;
628 Bvl.Top := Y;
629 Bvl.Left := Offset;
630 Bvl.Width := Wide - Offset;
631 inc(Offset, Gap * 2);
632 inc(Y, Gap * 2);
633 dec(Wide, Offset + (Gap * 2));
634
635 GetRLbl;
636 if(assigned(RLbl)) then
637 begin
638 MaxDY := RLbl.Height;
639 inc(Y, MaxDY + Gap * 2);
640 end;
641
642 if(FSeeAnswers) then
643 begin
644 for idx := 0 to FAnswerCount-1 do
645 begin
646 cb := TORCheckBox(GetCtrl(CheckBoxTag + idx));
647 if(not assigned(cb)) then
648 begin
649 cb := TORCheckBox.Create(frmMHTest);
650 if(idx = 0) then
651 FFirstCtrl[QNum] := cb;
652 cb.Parent := frmMHTest.sbMain;
653 cb.Tag := FID + CheckBoxTag + idx;
654 cb.GroupIndex := FID;
655 cb.WordWrap := TRUE;
656 cb.AutoSize := TRUE;
657 if(idx = ans) then
658 cb.Checked := TRUE;
659 cb.OnClick := OnChange;
660 cb.Caption := Piece(frmMHTest.FAnswers[FAnswerIndex + idx], U, 2);
661 FObjects.Add(cb);
662 end;
663 cb.Top := Y;
664 cb.Left := Offset;
665 cb.WordWrap := TRUE;
666 cb.Width := Wide;
667 cb.AutoAdjustSize;
668 cb.WordWrap := (not cb.SingleLine);
669 inc(Y, cb.Height + Gap);
670 end;
671 end
672 else
673 begin
674 RCombo := TComboBox(GetCtrl(ComboBoxTag));
675 if(not assigned(RCombo)) then
676 begin
677 RCombo := TComboBox.Create(frmMHTest);
678 FFirstCtrl[QNum] := RCombo;
679 RCombo.Parent := frmMHTest.sbMain;
680 RCombo.Tag := FID + ComboBoxTag;
681 FObjects.Add(RCombo);
682 MaxDX := 0;
683 for idx := 0 to FAnswerCount-1 do
684 begin
685 txt := Piece(frmMHTest.FAnswers[FAnswerIndex + idx], U, 2);
686 RCombo.Items.Add(txt);
687 DX := TextWidthByFont(frmMHTest.sbMain.Font.Handle, txt);
688 if(MaxDX < DX) then
689 MaxDX := DX;
690 end;
691 RCombo.ItemIndex := ans;
692 RCombo.Width := MaxDX + 24;
693 RCombo.OnChange := OnChange;
694 end;
695 RCombo.Top := Y;
696 RCombo.Left := Offset;
697 inc(Y, RCombo.Height + (Gap * 2));
698 end;
699 Bvl.Height := Y - Bvl.Top;
700 inc(Y, QGap);
701end;
702
703constructor TMHQuestion.Create;
704begin
705 inherited;
706 FSeeAnswers := TRUE;
707 FAnswerText := '';
708 FText := '';
709 FAllowedAnswers := '';
710 FAnswerIndex := frmMHTest.FAnswers.Count;
711 FAnswerCount := 0;
712 inc(frmMHTest.FIDCount, MaxQ);
713 FID := frmMHTest.FIDCount;
714 FAnswer := Skipped;
715end;
716
717destructor TMHQuestion.Destroy;
718begin
719 KillObj(@FObjects, TRUE);
720 inherited;
721end;
722
723procedure TMHQuestion.OnChange(Sender: TObject);
724var
725 idx: integer;
726 cb: TCheckBox;
727 cbo: TComboBox;
728
729begin
730 if(Sender is TCheckBox) then
731 begin
732 cb := TCheckBox(Sender);
733 if(cb.Checked) then
734 begin
735 idx := cb.Tag - CheckBoxTag + 1;
736 idx := idx mod MaxQ;
737 FAnswer := copy(FAllowedAnswers, idx, 1);
738 end
739 else
740 FAnswer := Skipped;
741 end
742 else
743 if(Sender is TComboBox) then
744 begin
745 cbo := TComboBox(Sender);
746 idx := cbo.ItemIndex + 1;
747 if(idx = 0) or (cbo.Text = '') then
748 FAnswer := Skipped
749 else
750 FAnswer := copy(FAllowedAnswers, idx, 1);
751 end;
752end;
753
754procedure TfrmMHTest.FormShow(Sender: TObject);
755begin
756 if(not FBuilt) then
757 begin
758 Screen.Cursor := crHourGlass;
759 try
760 BuildControls;
761 FBuilt := TRUE;
762 finally
763 Screen.Cursor := crDefault;
764 end;
765 end;
766end;
767
768procedure TfrmMHTest.sbMainResize(Sender: TObject);
769begin
770 if(FBuilt) then
771 BuildControls;
772end;
773
774function TMHQuestion.Question: string;
775var
776 idx: integer;
777 echar: string;
778
779begin
780 Result := trim(FText);
781 echar := copy(Result, length(Result), 1);
782 if(echar <> ':') and (echar <> '?') then
783 begin
784 if(echar = '.') then
785 delete(Result, length(result), 1);
786 Result := Result + ':';
787 end;
788 if(FAnswer = Skipped) then
789 Result := Result + ' Not rated'
790 else
791 begin
792 idx := pos(FAnswer, FAllowedAnswers) + FAnswerIndex - 1;
793 if(idx >= 0) and (idx < frmMHTest.FAnswers.Count) then
794 Result := Result + ' ' + Piece(frmMHTest.FAnswers[idx],U,2);
795 end;
796end;
797
798procedure TfrmMHTest.btnOKClick(Sender: TObject);
799var
800 i, XCnt, First: integer;
801 msg, ans, TestStatus: string;
802
803begin
804 msg := '';
805 ans := '';
806 XCnt := 0;
807 First := -1;
808 TestStatus := '2';
809 MHTestComp := '2';
810 for i := 0 to FObjs.Count-1 do
811 begin
812 ans := ans + TMHQuestion(Fobjs[i]).FAnswer;
813 if(TMHQuestion(FObjs[i]).FAnswer = Skipped) then
814 begin
815 if(First < 0) then First := i;
816 inc(XCnt);
817 if(msg <> '') then
818 msg := msg + ', ';
819 msg := msg + IntToStr(i+1);
820 end;
821 end;
822 if(XCnt = FObjs.Count) then ModalResult := mrOK;
823 TestStatus := VerifyMentalHealthTestComplete(Self.Caption, ans);
824 if Piece(TestStatus,U,1) <> '2' then
825 begin
826 if Piece(TestStatus,U,1)='1' then
827 begin
828 ModalResult := mrOK;
829 MHTestComp := '1';
830 EXIT;
831 end;
832 if Piece(TestStatus,U,1)='0' then
833 begin
834 MHTestComp := '0';
835 msg := Piece(TestStatus,u,2);
836 msg := 'The following questions have not been answered:' + CRLF + CRLF + ' ' + msg;
837 if(InfoBox(msg + CRLF + CRLF + 'Answer skipped questions?', 'Skipped Questions',
838 MB_YESNO or MB_ICONQUESTION) = IDYES) then GotoQ(First)
839 else
840 ModalResult := mrOK;
841 EXIT;
842 end;
843 end;
844 if(XCnt = 0) then
845 ModalResult := mrOK
846 else
847 begin
848 if(XCnt = FObjs.Count) then
849 ModalResult := mrOK
850 else
851 begin
852 msg := 'The following questions have not been answered:' + CRLF + CRLF + ' ' + msg;
853 if(InfoBox(msg + CRLF + CRLF + 'Answer skipped questions?', 'Skipped Questions',
854 MB_YESNO or MB_ICONQUESTION) = IDYES) then
855 GotoQ(First)
856 else
857 ModalResult := mrOK;
858 end;
859 end;
860end;
861
862procedure TfrmMHTest.btnClearClick(Sender: TObject);
863var
864 i: integer;
865
866begin
867 for i := 0 to sbMain.ControlCount-1 do
868 begin
869 if(sbMain.Controls[i] is TCheckBox) then
870 TCheckBox(sbMain.Controls[i]).Checked := FALSE
871 else
872 if(sbMain.Controls[i] is TComboBox) then
873 begin
874 with TComboBox(sbMain.Controls[i]) do
875 begin
876 ItemIndex := -1;
877 OnChange(sbMain.Controls[i]);
878 end;
879 end;
880 end;
881end;
882
883end.
Note: See TracBrowser for help on using the repository browser.