source: cprs/branches/tmg-cprs/CPRS-Chart/fMHTest.pas@ 1156

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

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