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

Last change on this file since 1307 was 830, checked in by Kevin Toppenberg, 14 years ago

Upgrading to version 27
File size: 31.0 KB
RevLine 
[456]1unit fMHTest;
2
3interface
4
5uses
6 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
[830]7 StdCtrls, ExtCtrls, ORCtrls, ORFn, uConst, fBase508Form, uDlgComponents,
8 VA508AccessibilityManager, uCore, orNet, TRPCB, StrUtils, rCore, VAUtils;
[456]9
10type
[830]11TShowProc = procedure(Broker: TRPCBroker;
12 InstrumentName,
13 PatientDFN,
14 OrderedBy,
15 OrderedByDUZ,
16 AdministeredBy,
17 AdministeredByDUZ,
18 Location,
19 LocationIEN: string;
20 Required: boolean;
21 var ProgressNote: string); stdcall;
22
23TSaveProc = procedure(Broker: TRPCBroker;
24 InstrumentName,
25 PatientDFN,
26 OrderedByDUZ,
27 AdministeredByDUZ,
28 AdminDate,
29 LocationIEN: string;
30 var Status: string); stdcall;
31
32TRemoveTempFile = procedure(
33 InstrumentName,
34 PatientDFN: string); stdcall;
35
36TCloseProc = procedure;
37
38TUsedMHDll = record
39 Checked: boolean;
40 Display: boolean;
41end;
42
43type
44 TfrmMHTest = class(TfrmBase508Form)
[456]45 sbMain: TScrollBox;
46 pnlBottom: TPanel;
47 btnCancel: TButton;
48 btnOK: TButton;
49 btnClear: TButton;
50 procedure FormDestroy(Sender: TObject);
51 procedure FormCreate(Sender: TObject);
52 procedure FormShow(Sender: TObject);
53 procedure sbMainResize(Sender: TObject);
54 procedure btnOKClick(Sender: TObject);
55 procedure FormKeyDown(Sender: TObject; var Key: Word;
56 Shift: TShiftState);
57 procedure btnClearClick(Sender: TObject);
58 private
59 FIDCount: integer;
60 FAnswers: TStringList;
61 FObjs: TList;
62 FInfoText: string;
[830]63 FInfoLabel: TMentalHealthMemo;
[456]64 FBuilt: boolean;
65 FMaxLines: integer;
66 FBuildingControls: boolean;
67 procedure BuildControls;
68 function Answers: string;
69 procedure GetQText(QText: TStringList);
70 function LoadTest(InitialAnswers, TestName: string): boolean;
71 function CurrentQ: integer;
72 procedure GotoQ(x: integer);
73 public
74 MHTestComp: string;
75 MHA3: boolean;
[830]76 function CallMHDLL(TestName: string; Required: boolean): String;
[456]77 end;
78
[830]79function PerformMHTest(InitialAnswers, TestName: string; QText: TStringList; Required: boolean): string;
80function SaveMHTest(TestName, Date, Loc: string): boolean;
81procedure RemoveMHTest(TestName: string);
82function CheckforMHDll: boolean;
83procedure CloseMHDLL;
[456]84
[830]85var
86 MHDLLHandle: THandle = 0;
87
[456]88implementation
89
[830]90uses fFrame,rReminders, VA508AccessibilityRouter;
[456]91
92{$R *.DFM}
93
94const
95 MaxQ = 100; // Max # of allowed answers for one question
96 LineNumberTag = 1;
97 ComboBoxTag = 2;
98 BevelTag = 3;
99 QuestionLabelTag = 4;
100 CheckBoxTag = 10;
101
102 NumberThreshhold = 5; // min # of questions on test before each has a line number
103 Skipped = 'X';
104 QGap = 4;
105 Gap = 2;
106
[830]107 ShowProc : TShowProc = nil;
108 SaveProc : TSaveProc = nil;
109 RemoveTempFile : TRemoveTempFile = nil;
110 CloseProc : TCloseProc = nil;
111 SHARE_DIR = '\VISTA\Common Files\';
[456]112var
113 frmMHTest: TfrmMHTest;
114 FFirstCtrl: TList;
115 FYPos: TList;
[830]116 UsedMHDll: TUsedMHDll;
117 //DLLForceClose: boolean = false;
[456]118
119type
120 TMHQuestion = class(TObject)
121 private
122 FSeeAnswers: boolean;
123 FAnswerText: string;
124 FText: string;
125 FAllowedAnswers: string;
126 FAnswerIndex: integer;
127 FAnswerCount: integer;
128 FID: integer;
129 FAnswer: string;
130 FObjects: TList;
131 FLine: integer;
132 protected
133 procedure OnChange(Sender: TObject);
134 public
135 constructor Create;
136 destructor Destroy; override;
137 function Question: string;
138 procedure BuildControls(var Y: integer; Wide: integer);
139 property AllowedAnswers: string read FAllowedAnswers;
140 property Answer: string read FAnswer;
141 property AnswerCount: integer read FAnswerCount;
142 property AnswerIndex: integer read FAnswerIndex;
143 property AnswerText: string read FAnswerText;
144 property SeeAnswers: boolean read FSeeAnswers;
145 property ID: integer read FID;
146 property Text: string read FText;
147 end;
148
149procedure ProcessMsg;
150var
151 SaveCursor: TCursor;
152
153begin
154 if(Screen.Cursor = crHourGlass) then
155 begin
156 SaveCursor := Screen.Cursor;
157 Screen.Cursor := crDefault;
158 try
159 Application.ProcessMessages;
160 finally
161 Screen.Cursor := SaveCursor;
162 end;
163 end
164 else
165 Application.ProcessMessages;
166end;
167
[830]168function PerformMHTest(InitialAnswers, TestName: string; QText: TStringList; Required: boolean): string;
169var
170str,scores, tempStr: string;
[456]171begin
172 Result := InitialAnswers;
[830]173 str := frmMHTest.CallMHDLL(testName, Required);
174 if str <> '' then
175 begin
176 if Piece(str,U,1) = 'COMPLETE' then
177 begin
178 Scores := Piece(str, U, 4);
179 if QText <> nil then
180 begin
181 tempStr := Piece(Str, U, 5);
182 if Pos('GAF Score', tempStr) = 0 then tempStr := Copy(tempStr, 2, Length(tempStr));
183 tempStr := AnsiReplaceStr(tempStr,'1156','Response not required due to responses to other questions.');
184 tempStr := AnsiReplaceStr(tempStr,'*','~~');
185 PiecesToList(tempStr,'~',QText);
186 end;
187 Result := 'New MH dll^COMPLETE^'+ Scores;
188 end
189 else if Piece(str,U,1) = 'INCOMPLETE' then
190 begin
191 Result := 'New MH dll^INCOMPLETE^';
192 end
193 else if (Piece(str,U,1) = 'CANCELLED') or (Piece(str, U, 1) = 'NOT STARTED') then
194 begin
195 Result := 'New MH dll^CANCELLED^';
196 end;
197 frmMHTest.Free;
198 exit;
199 end;
[456]200 frmMHTest := TfrmMHTest.Create(Application);
201 try
202 frmMHTest.Caption := TestName;
203 if(frmMHTest.LoadTest(InitialAnswers, TestName)) then
204 begin
205 if(frmMHTest.ShowModal = mrOK) then
206 begin
207 Result := frmMHTest.Answers;
208 if(assigned(QText)) then
209 begin
210 QText.Clear;
211 if(Result <> '') then
212 frmMHTest.GetQText(QText);
213 end;
214 end;
215 end;
216 if frmMHTest.MHTestComp = '' then frmMHTest.MHTestComp := '0';
217 Result := Result + U + frmMHTest.MHTestComp;
218 if Result = U then Result := '';
219 finally
220 frmMHTest.Free;
221 end;
222end;
223
[830]224function SaveMHTest(TestName, date, Loc: string): boolean;
225var
226 MHPath, save: string;
227
228begin
229 MHPath := GetProgramFilesPath + SHARE_DIR + 'YS_MHA';
230 if MHDLLHandle = 0 then
231 MHDLLHandle := LoadLibrary(PChar(MHPath));
232 Result := true;
233 if MHDLLHandle = 0 then
234 begin
235 InfoBox('YS_MHA.DLL not available', 'Error', MB_OK);
236 Exit;
237 end
238 else
239 begin
240 try
241 @SaveProc := GetProcAddress(MHDLLHandle, 'SaveInstrument');
242
243 if @SaveProc = nil then
244 begin
245 // function not found.. misspelled?
246 infoBox('Save Instrument Function not found within YS_MHA.DLL.', 'Error', MB_OK);
247 Exit;
248 end;
249
250 if Assigned(SaveProc) then
251 begin
252// fFrame.frmFrame.DLLActive := True;
253 try
254 SaveProc(RPCBrokerV,
255 UpperCase(TestName), //InstrumentName
256 Patient.DFN, //PatientDFN
257 InttoStr(User.duz), //OrderedByDUZ
258 InttoStr(User.duz), //AdministeredByDUZ
259 date,
260 Loc, //LocationIEN
261 save);
262 finally
263// fFrame.frmFrame.DLLActive := false;
264 if RPCBrokerV.CurrentContext <> 'OR CPRS GUI CHART' then
265 begin
266 if RPCBrokerV.CreateContext('OR CPRS GUI CHART') = false then
267 infoBox('Error switching broker context','Error', MB_OK);
268 end;
269 end; {inner try..finally}
270 end;
271 finally
272 if MHDLLHandle <> 0 then
273 begin
274 FreeLibrary(MHDLLHandle);
275 MHDLLHandle := 0;
276 end;
277 end; {try..finally}
278 end;
279end;
280
281procedure RemoveMHTest(TestName: string);
282var
283 MHPath: string;
284begin
285 MHPath := GetProgramFilesPath + SHARE_DIR + 'YS_MHA';
286 if MHDLLHandle = 0 then
287 MHDLLHandle := LoadLibrary(PChar(MHPath));
288 if MHDLLHandle = 0 then
289 begin
290 InfoBox('YS_MHA.DLL not available', 'Error', MB_OK);
291 Exit;
292 end
293 else
294 begin
295 try
296 @RemoveTempFile := GetProcAddress(MHDLLHandle, 'RemoveTempFile');
297
298 if @RemoveTempFile = nil then
299 begin
300 // function not found.. misspelled?
301 InfoBox('Remove Temp File function not found within YS_MHA.DLL.', 'Error', MB_OK);
302 Exit;
303 end;
304
305 if Assigned(RemoveTempFile) then
306 begin
307// fFrame.frmFrame.DLLActive := True;
308 try
309 RemoveTempFile(UpperCase(TestName), //InstrumentName
310 Patient.DFN);
311 finally
312// fFrame.frmFrame.DLLActive := False;
313 if RPCBrokerV.CurrentContext <> 'OR CPRS GUI CHART' then
314 begin
315 if RPCBrokerV.CreateContext('OR CPRS GUI CHART') = false then
316 infoBox('Error switching broker context','Error', MB_OK);
317 end;
318 end; {inner try..finally}
319 end;
320 finally
321 if MHDLLHandle <> 0 then
322 begin
323 FreeLibrary(MHDLLHandle);
324 MHDLLHandle := 0;
325 end;
326 end; {try..finally}
327 end;
328end;
329
330function CheckforMHDll: boolean;
331var
332 MHPath: string;
333begin
334 Result := True;
335 if (UsedMHDll.Checked = True) and (UsedMHDll.Display = False) then Exit
336 else if UsedMHDll.Checked = false then
337 begin
338 UsedMHDll.Display := UsedMHDllRPC;
339 UsedMHDll.Checked := True;
340 if UsedMHDll.Display = false then
341 begin
342 Result := False;
343 exit;
344 end;
345 end;
346 if MHDLLHandle = 0 then // if not 0 the DLL already loaded - result = true
347 begin
348 MHPath := GetProgramFilesPath + SHARE_DIR + 'YS_MHA';
349 MHDLLHandle := LoadLibrary(PChar(MHPath));
350 if MHDLLHandle = 0 then
351 Result := false
352 else
353 begin
354 FreeLibrary(MHDLLHandle);
355 MHDLLHandle := 0;
356 end;
357 end;
358end;
359
360procedure CloseMHDLL;
361begin
362 if MHDLLHandle = 0 then Exit;
363 try
364 @CloseProc := GetProcAddress(MHDLLHandle, 'CloseDLL');
365 if Assigned(CloseProc) then
366 begin
367 CloseProc;
368 end;
369 finally
370 if MHDLLHandle <> 0 then
371 begin
372 FreeLibrary(MHDLLHandle);
373 MHDLLHandle := 0;
374 end;
375 end; {try..finally}
376end;
377
[456]378{ TfrmMHTest }
379
380function TfrmMHTest.Answers: string;
381var
382 i, XCnt: integer;
383 ans: string;
384
385begin
386 Result := '';
387 XCnt := 0;
388 for i := 0 to FObjs.Count-1 do
389 begin
390 ans := TMHQuestion(FObjs[i]).FAnswer;
391 if(ans = Skipped) then
392 inc(XCnt);
393 Result := Result + ans;
394 end;
395 if(XCnt = FObjs.Count) then
396 Result := '';
397end;
398
399function TfrmMHTest.LoadTest(InitialAnswers, TestName: string): boolean;
400var
401 TstData: TStringList;
402 lNum, i, idx: integer;
403 Line, LastLine, Inp, Code: string;
404 Txt, Spec, p, Spidx, tmp: string;
405 RSpec, First, TCodes: boolean;
406 QObj: TMHQuestion;
407
408 procedure ParseText;
409 var
410 i, tlen: integer;
411
412 begin
413 Code := '';
414 i := 1;
415 tlen := length(Txt);
416 while(i <= tlen) do
417 begin
418 while(i <= tlen) and (Txt[i] = ' ') do inc(i);
419 if(i > tlen) then
420 begin
421 Txt := '';
422 exit;
423 end;
424 if(i > 1) then
425 begin
426 delete(Txt,1,i-1);
427 i := 1;
428 end;
429 if(Spec = 'I') then exit;
430 tlen := length(Txt);
431 if(tlen < 3) then exit;
432 Code := copy(Txt,i,1);
433 if(pos(Code, (UpperCaseLetters + LowerCaseLetters + Digits)) = 0) then
434 begin
435 Code := '';
436 exit;
437 end;
438 inc(i);
439 while(i <= tlen) and (Txt[i] = ' ') do inc(i);
440 if(Txt[i] in ['.','=']) then
441 begin
442 if(pos(Code, QObj.FAllowedAnswers) > 0) then
443 begin
444 inc(i);
445 while(i <= tlen) and (Txt[i] = ' ') do inc(i);
446 if(i <= tlen) then
447 delete(Txt,1,i-1)
448 else
449 Code := '';
450 exit;
451 end
452 else
453 begin
454 Code := '';
455 exit;
456 end;
457 end
458 else
459 begin
460 Code := '';
461 exit;
462 end;
463 end;
464 end;
465
466 procedure AddTxt2Str(var X: string);
467 begin
468 if(Txt <> '') then
469 begin
470 if(X <> '') then
471 begin
472 X := X + ' ';
473 if(copy(Txt, length(Txt), 1) = '.') then
474 X := X + ' ';
475 end;
476 X := X + Txt;
477 end;
478 end;
479
480begin
481 Result := TRUE;
482 TstData := TStringList.Create;
483 try
[830]484 FastAssign(LoadMentalHealthTest(TestName), TstData);
[456]485 if TstData.Strings[0] = '1' then MHA3 := True
486 else MHA3 := False;
487 Screen.Cursor := crHourGlass;
488 try
489 TstData.Add('99999;X;0');
490 idx := 1;
491 FMaxLines := 0;
492 FInfoText := '';
493 LastLine := U;
494 First := TRUE;
495 RSpec := FALSE;
496 TCodes := FALSE;
497 QObj := nil;
498 while (idx < TstData.Count) do
499 begin
500 Inp := TstData[idx];
501 if(pos('[ERROR]', Inp) > 0) then
502 begin
503 Result := FALSE;
504 break;
505 end;
506 p := Piece(Inp, U, 1);
507 Line := Piece(p, ';', 1);
508 Spec := Piece(p, ';', 2);
509 SpIdx := Piece(p, ';', 3);
510 if(LastLine <> Line) then
511 begin
512 LastLine := Line;
513 if(First) then
514 First := FALSE
515 else
516 begin
517 if(not RSpec) then
518 begin
519 Result := FALSE;
520 break;
521 end;
522 end;
523 if(Spec = 'X') then break;
524 lNum := StrToIntDef(Line, 0);
525 if(lNum <= 0) then
526 begin
527 Result := FALSE;
528 break;
529 end;
530 RSpec := FALSE;
531 TCodes := FALSE;
532 QObj := TMHQuestion(FObjs[FObjs.Add(TMHQuestion.Create)]);
533 QObj.FLine := lNum;
534 if(FMaxLines < lNum) then
535 FMaxLines := lNum;
536 end;
537 Txt := Piece(Inp, U, 2);
538 ParseText;
539 if(Txt <> '') then
540 begin
541 if(Spec = 'I') then
542 begin
543 if MHA3 = True then AddTxt2Str(QObj.FText)
544 else
545 AddTxt2Str(FInfoText);;
546 end
547 else
548 if(Spec = 'R') then
549 begin
550 RSpec := TRUE;
551 if(spIdx = '0') then
552 QObj.FAllowedAnswers := Txt
553 else
554 if(Code = '') then
555 QObj.FAnswerText := Txt
556 else
557 begin
558 QObj.FSeeAnswers := FALSE;
559 FAnswers.Add(Code + U + Txt);
560 inc(QObj.FAnswerCount);
561 end;
562 end
563 else
564 if(Spec = 'T') then
565 begin
566 if(Code = '') then
567 begin
568 if(TCodes) then
569 begin
570 tmp := FAnswers[FAnswers.Count-1];
571 AddTxt2Str(tmp);
572 FAnswers[FAnswers.Count-1] := tmp;
573 end
574 else
575 AddTxt2Str(QObj.FText);
576 end
577 else
578 begin
579 TCodes := TRUE;
580 FAnswers.Add(Code + U + Txt);
581 inc(QObj.FAnswerCount);
582 end;
583 end;
584 end;
585 inc(idx);
586 end;
587 finally
588 Screen.Cursor := crDefault;
589 end;
590 finally
591 TstData.Free;
592 end;
593 if(not Result) then
[830]594 InfoBox('Error encountered loading ' + TestName, 'Error', MB_OK)
[456]595 else
596 begin
597 for i := 0 to FObjs.Count-1 do
598 begin
599 with TMHQuestion(FObjs[i]) do
600 begin
601 tmp := copy(InitialAnswers,i+1,1);
602 if(tmp <> '') then
603 FAnswer := tmp;
604 end;
605 end;
606 end;
607end;
608
609procedure TfrmMHTest.FormCreate(Sender: TObject);
610begin
611 ResizeAnchoredFormToFont(self);
612 FAnswers := TStringList.Create;
613 FObjs := TList.Create;
614 FFirstCtrl := TList.Create;
615 FYPos := TList.Create;
616end;
617
618procedure TfrmMHTest.FormDestroy(Sender: TObject);
619begin
620 KillObj(@FFirstCtrl);
621 KillObj(@FYPos);
622 KillObj(@FObjs, TRUE);
623 KillObj(@FAnswers);
624end;
625
626procedure TfrmMHTest.BuildControls;
627var
628 i, Wide, Y: integer;
629 BoundsRect: TRect;
630begin
631 if(not FBuildingControls) then
632 begin
633 FBuildingControls := TRUE;
634 try
635 Wide := sbMain.Width - (Gap * 2) - ScrollBarWidth - 4;
636 Y := gap - sbMain.VertScrollBar.Position;
637 if MHA3 = False then
638 begin
639 if(not assigned(FInfoLabel)) then
640 begin
[830]641 FInfoLabel := TMentalHealthMemo.Create(Self);
[456]642 FInfoLabel.Color := clBtnFace;
643 FInfoLabel.BorderStyle := bsNone;
644 FInfoLabel.ReadOnly := TRUE;
[830]645 FInfoLabel.TabStop := ScreenReaderSystemActive;
[456]646 FInfoLabel.Parent := sbMain;
647 FInfoLabel.WordWrap := TRUE;
648 FInfoLabel.Text := FInfoText;
649 FInfoLabel.Left := Gap;
[830]650 UpdateColorsFor508Compliance(FInfoLabel);
[456]651 end;
652 BoundsRect := FInfoLabel.BoundsRect;
653 //Wide := sbMain.Width - (Gap * 2) - ScrollBarWidth - 4;
654 //Y := gap - sbMain.VertScrollBar.Position;
655 BoundsRect.Top := Y;
656 BoundsRect.Right := BoundsRect.Left + Wide;
657 WrappedTextHeightByFont(Canvas, FInfoLabel.Font, FInfoLabel.Text, BoundsRect);
658 BoundsRect.Right := BoundsRect.Left + Wide;
659 FInfoLabel.BoundsRect := BoundsRect;
660 ProcessMsg;
661 inc(Y, FInfoLabel.Height + QGap);
662 for i := 0 to FObjs.Count-1 do
663 TMHQuestion(FObjs[i]).BuildControls(Y, Wide);
664 end
665 else
666 begin
667 inc(Y, 1);
668 for i := 0 to FObjs.Count-1 do TMHQuestion(FObjs[i]).BuildControls(Y, Wide);
669 end;
670 finally
671 FBuildingControls := FALSE;
672 end;
673 end;
[830]674 amgrMain.RefreshComponents;
[456]675end;
676
677procedure TfrmMHTest.GetQText(QText: TStringList);
678var
679 i, lx: integer;
680
681begin
682 if(FObjs.Count > 99) then
683 lx := 5
684 else
685 if(FObjs.Count > 9) then
686 lx := 4
687 else
688 lx := 3;
689 for i := 0 to FObjs.Count-1 do
690 QText.Add(copy(IntToStr(i+1) + '. ', 1, lx) + TMHQuestion(FObjs[i]).Question);
691end;
692
[830]693function TfrmMHTest.CallMHDLL(TestName: string; Required: boolean): String;
694var
695// dllHandle : THandle;
696 ProgressNote, MHPath : string;
697begin
698 ProgressNote := '';
699 if (UsedMHDll.Checked = True) and (UsedMHDll.Display = False) then Exit
700 else if UsedMHDll.Checked = false then
701 begin
702 UsedMHDll.Display := UsedMHDllRPC;
703 UsedMHDll.Checked := True;
704 if UsedMHDll.Display = false then exit;
705 end;
706 MHPath := GetProgramFilesPath + SHARE_DIR + 'YS_MHA';
707 if MHDLLHandle = 0 then
708 MHDLLHandle := LoadLibrary(PChar(MHPath));
709 Result := '';
710 if MHDLLHandle = 0 then
711 begin
712 InfoBox('YS_MHA.dll not available.' + CRLF + 'CPRS will continue processing the MH test using the previous format.' +
713 CRLF + CRLF + 'Contact IRM to install the YS_MHA.dll file on this machine.', 'Warning', MB_OK);
714 Exit;
715 end
716 else
717 begin
718 try
719 @ShowProc := GetProcAddress(MHDLLHandle, 'ShowInstrument');
720
721 if @ShowProc = nil then
722 begin
723 // function not found.. misspelled?
724 InfoBox('Function ShowInstrument not found within YS_MHA.DLL not available', 'Error', MB_OK);
725 Exit;
726 end;
727
728 if Assigned(ShowProc) then
729 begin
730// MHDLLHandle := dllHandle;
731 Result := '';
732// fFrame.frmFrame.DLLActive := True;
733 try
734 ShowProc(RPCBrokerV,
735 UpperCase(TestName), //InstrumentName
736 Patient.DFN, //PatientDFN
737 '', //OrderedByName
738 InttoStr(User.duz), //OrderedByDUZ
739 User.Name, //AdministeredByName
740 InttoStr(User.duz), //AdministeredByDUZ
741 Encounter.LocationName, //Location
742 InttoStr(Encounter.Location), //LocationIEN
743 Required,
744 ProgressNote);
745 Result := ProgressNote;
746 finally
747// MHDllHandle := 0;
748// fFrame.frmFrame.DLLActive := false;
749 if RPCBrokerV.CurrentContext <> 'OR CPRS GUI CHART' then
750 begin
751 if RPCBrokerV.CreateContext('OR CPRS GUI CHART') = false then
752 infoBox('Error switching broker context','Error', MB_OK);
753 end;
754 end; {inner try ..finally}
755 end;
756 finally
757 if MHDLLHandle <> 0 then
758 begin
759 FreeLibrary(MHDLLHandle);
760 MHDllHandle := 0;
761 end;
762 end; {try..finally}
763 //Result := ProgressNote;
764 end;
765end;
766
[456]767function TfrmMHTest.CurrentQ: integer;
768var
769 i, j: integer;
770 ctrl: TWinControl;
771 MHQ: TMHQuestion;
772
773begin
774 Result := 0;
775 ctrl := ActiveControl;
776 if(not assigned(Ctrl)) then
777 exit;
778 for i := 0 to FObjs.Count-1 do
779 begin
780 MHQ := TMHQuestion(FObjs[i]);
781 for j := 0 to MHQ.FObjects.Count-1 do
782 begin
783 if(Ctrl = MHQ.FObjects[j]) then
784 begin
785 Result := i;
786 exit;
787 end;
788 end;
789 end;
790end;
791
792procedure TfrmMHTest.GotoQ(x: integer);
793begin
794 if(ModalResult <> mrNone) then exit;
795 if(x < 0) then x := 0;
796 if(x >= FYPos.Count) then
797 begin
798 btnOK.Default := TRUE;
799 btnOK.SetFocus;
800 end
801 else
802 begin
803 btnOK.Default := FALSE;
804 sbMain.VertScrollBar.Position := Integer(FYPos[x]) - 2;
805 TWinControl(FFirstCtrl[x]).SetFocus;
806 end;
807end;
808
809procedure TfrmMHTest.FormKeyDown(Sender: TObject; var Key: Word;
810 Shift: TShiftState);
811begin
[830]812 inherited;
[456]813 if Key = VK_PRIOR then
814 begin
815 GotoQ(CurrentQ - 1);
816 Key := 0;
817 end
818 else
819 if (Key = VK_NEXT) or (Key = VK_RETURN) then
820 begin
821 GotoQ(CurrentQ + 1);
822 Key := 0;
823 end;
824end;
825
826{ TMHQuestion }
827
828procedure TMHQuestion.BuildControls(var Y: integer; Wide: integer);
829var
830 RCombo: TComboBox;
[830]831 LNLbl, RLbl: TMentalHealthMemo;
[456]832 Bvl: TBevel;
833 cb: TORCheckBox;
834 ans, idx, DX, MaxDX, MaxDY: integer;
835 Offset: integer;
836 txt: string;
837 QNum: integer;
838
839 function GetCtrl(SubTag: integer): TControl;
840 var
841 i: integer;
842
843 begin
844 Result := nil;
845 for i := 0 to FObjects.Count-1 do
846 begin
847 if(TControl(FObjects[i]).Tag = (FID + SubTag)) then
848 begin
849 Result := TControl(FObjects[i]);
850 break;
851 end;
852 end;
853 end;
854
855 procedure AdjDY(Ht: integer);
856 begin
857 if(MaxDY < Ht) then
858 MaxDY := Ht;
859 end;
860
861 procedure GetRLbl;
862 var
863 BoundsRect: TRect;
864 begin
865 if(FText <> '') then
866 begin
[830]867 RLbl := TMentalHealthMemo(GetCtrl(QuestionLabelTag));
[456]868 if(not assigned(RLbl)) then
869 begin
[830]870 RLbl := TMentalHealthMemo.Create(frmMHTest);
[456]871 RLbl.Color := clBtnFace;
872 RLbl.BorderStyle := bsNone;
873 RLbl.ReadOnly := TRUE;
[830]874 RLbl.TabStop := ScreenReaderSystemActive;
[456]875 RLbl.Parent := frmMHTest.sbMain;
876 RLbl.Tag := FID + QuestionLabelTag;
877 RLbl.WordWrap := TRUE;
878 RLbl.Text := FText;
879 FObjects.Add(RLbl);
[830]880 UpdateColorsFor508Compliance(RLbl);
[456]881 end;
882 BoundsRect.Top := Y;
883 BoundsRect.Left := Offset;
884 BoundsRect.Right := Wide;
885 WrappedTextHeightByFont(frmMHTest.Canvas, RLbl.Font, RLbl.Text, BoundsRect);
886 BoundsRect.Right := Wide;
887 RLbl.BoundsRect := BoundsRect;
888 ProcessMsg;
889 end
890 else
891 RLbl := nil;
892 end;
893
894begin
895 QNum := (FID div MaxQ)-1;
896 while(FFirstCtrl.Count <= QNum) do
897 FFirstCtrl.Add(nil);
898 while(FYPos.Count <= QNum) do
899 FYPos.Add(nil);
900 FYPos[QNum] := Pointer(Y);
901 ans := pos(FAnswer, FAllowedAnswers) - 1;
902 Offset := Gap;
903 if(not assigned(FObjects)) then
904 FObjects := TList.Create;
905 MaxDY := 0;
906 if(frmMHTest.FObjs.Count >= NumberThreshhold) then
907 begin
[830]908 LNLbl := TMentalHealthMemo(GetCtrl(LineNumberTag));
[456]909 if(not assigned(LNLbl)) then
910 begin
[830]911 LNLbl := TMentalHealthMemo.Create(frmMHTest);
[456]912 LNLbl.Color := clBtnFace;
913 LNLbl.BorderStyle := bsNone;
914 LNLbl.ReadOnly := TRUE;
[830]915 LNLbl.TabStop := ScreenReaderSystemActive;
[456]916 LNLbl.Parent := frmMHTest.sbMain;
917 LNLbl.Tag := FID + LineNumberTag;
918 LNLbl.Text := IntToStr(QNum+1) + '.';
[830]919 if ScreenReaderSystemActive then
920 frmMHTest.amgrMain.AccessText[LNLbl] := 'Question';
[456]921 LNLbl.Width := TextWidthByFont(LNLbl.Font.Handle, LNLbl.Text);
922 LNLbl.Height := TextHeightByFont(LNLbl.Font.Handle, LNLbl.Text);
923 FObjects.Add(LNLbl);
[830]924 UpdateColorsFor508Compliance(LNLbl);
[456]925 end;
926 LNLbl.Top := Y;
927 LNLbl.Left := Offset;
928 inc(Offset, MainFontSize * 4);
929 AdjDY(LNLbl.Height);
930 end;
931
932 Bvl := TBevel(GetCtrl(BevelTag));
933 if(not assigned(Bvl)) then
934 begin
935 Bvl := TBevel.Create(frmMHTest);
936 Bvl.Parent := frmMHTest.sbMain;
937 Bvl.Tag := FID + BevelTag;
938 Bvl.Shape := bsFrame;
939 FObjects.Add(Bvl);
[830]940 UpdateColorsFor508Compliance(Bvl);
[456]941 end;
942 Bvl.Top := Y;
943 Bvl.Left := Offset;
944 Bvl.Width := Wide - Offset;
945 inc(Offset, Gap * 2);
946 inc(Y, Gap * 2);
947 dec(Wide, Offset + (Gap * 2));
948
949 GetRLbl;
950 if(assigned(RLbl)) then
951 begin
952 MaxDY := RLbl.Height;
953 inc(Y, MaxDY + Gap * 2);
954 end;
955
956 if(FSeeAnswers) then
957 begin
958 for idx := 0 to FAnswerCount-1 do
959 begin
960 cb := TORCheckBox(GetCtrl(CheckBoxTag + idx));
961 if(not assigned(cb)) then
962 begin
963 cb := TORCheckBox.Create(frmMHTest);
964 if(idx = 0) then
965 FFirstCtrl[QNum] := cb;
966 cb.Parent := frmMHTest.sbMain;
967 cb.Tag := FID + CheckBoxTag + idx;
968 cb.GroupIndex := FID;
969 cb.WordWrap := TRUE;
970 cb.AutoSize := TRUE;
971 if(idx = ans) then
972 cb.Checked := TRUE;
973 cb.OnClick := OnChange;
974 cb.Caption := Piece(frmMHTest.FAnswers[FAnswerIndex + idx], U, 2);
975 FObjects.Add(cb);
[830]976 UpdateColorsFor508Compliance(cb);
[456]977 end;
978 cb.Top := Y;
979 cb.Left := Offset;
980 cb.WordWrap := TRUE;
981 cb.Width := Wide;
982 cb.AutoAdjustSize;
983 cb.WordWrap := (not cb.SingleLine);
984 inc(Y, cb.Height + Gap);
985 end;
986 end
987 else
988 begin
989 RCombo := TComboBox(GetCtrl(ComboBoxTag));
990 if(not assigned(RCombo)) then
991 begin
992 RCombo := TComboBox.Create(frmMHTest);
993 FFirstCtrl[QNum] := RCombo;
994 RCombo.Parent := frmMHTest.sbMain;
995 RCombo.Tag := FID + ComboBoxTag;
996 FObjects.Add(RCombo);
997 MaxDX := 0;
998 for idx := 0 to FAnswerCount-1 do
999 begin
1000 txt := Piece(frmMHTest.FAnswers[FAnswerIndex + idx], U, 2);
1001 RCombo.Items.Add(txt);
1002 DX := TextWidthByFont(frmMHTest.sbMain.Font.Handle, txt);
1003 if(MaxDX < DX) then
1004 MaxDX := DX;
1005 end;
1006 RCombo.ItemIndex := ans;
1007 RCombo.Width := MaxDX + 24;
1008 RCombo.OnChange := OnChange;
[830]1009 UpdateColorsFor508Compliance(RCombo);
[456]1010 end;
1011 RCombo.Top := Y;
1012 RCombo.Left := Offset;
1013 inc(Y, RCombo.Height + (Gap * 2));
1014 end;
1015 Bvl.Height := Y - Bvl.Top;
1016 inc(Y, QGap);
1017end;
1018
1019constructor TMHQuestion.Create;
1020begin
1021 inherited;
1022 FSeeAnswers := TRUE;
1023 FAnswerText := '';
1024 FText := '';
1025 FAllowedAnswers := '';
1026 FAnswerIndex := frmMHTest.FAnswers.Count;
1027 FAnswerCount := 0;
1028 inc(frmMHTest.FIDCount, MaxQ);
1029 FID := frmMHTest.FIDCount;
1030 FAnswer := Skipped;
1031end;
1032
1033destructor TMHQuestion.Destroy;
1034begin
1035 KillObj(@FObjects, TRUE);
1036 inherited;
1037end;
1038
1039procedure TMHQuestion.OnChange(Sender: TObject);
1040var
1041 idx: integer;
1042 cb: TCheckBox;
1043 cbo: TComboBox;
1044
1045begin
1046 if(Sender is TCheckBox) then
1047 begin
1048 cb := TCheckBox(Sender);
1049 if(cb.Checked) then
1050 begin
1051 idx := cb.Tag - CheckBoxTag + 1;
1052 idx := idx mod MaxQ;
1053 FAnswer := copy(FAllowedAnswers, idx, 1);
1054 end
1055 else
1056 FAnswer := Skipped;
1057 end
1058 else
1059 if(Sender is TComboBox) then
1060 begin
1061 cbo := TComboBox(Sender);
1062 idx := cbo.ItemIndex + 1;
1063 if(idx = 0) or (cbo.Text = '') then
1064 FAnswer := Skipped
1065 else
1066 FAnswer := copy(FAllowedAnswers, idx, 1);
1067 end;
1068end;
1069
1070procedure TfrmMHTest.FormShow(Sender: TObject);
1071begin
1072 if(not FBuilt) then
1073 begin
1074 Screen.Cursor := crHourGlass;
1075 try
1076 BuildControls;
1077 FBuilt := TRUE;
1078 finally
1079 Screen.Cursor := crDefault;
1080 end;
1081 end;
1082end;
1083
1084procedure TfrmMHTest.sbMainResize(Sender: TObject);
1085begin
1086 if(FBuilt) then
1087 BuildControls;
1088end;
1089
1090function TMHQuestion.Question: string;
1091var
1092 idx: integer;
1093 echar: string;
1094
1095begin
1096 Result := trim(FText);
1097 echar := copy(Result, length(Result), 1);
1098 if(echar <> ':') and (echar <> '?') then
1099 begin
1100 if(echar = '.') then
1101 delete(Result, length(result), 1);
1102 Result := Result + ':';
1103 end;
1104 if(FAnswer = Skipped) then
1105 Result := Result + ' Not rated'
1106 else
1107 begin
1108 idx := pos(FAnswer, FAllowedAnswers) + FAnswerIndex - 1;
1109 if(idx >= 0) and (idx < frmMHTest.FAnswers.Count) then
1110 Result := Result + ' ' + Piece(frmMHTest.FAnswers[idx],U,2);
1111 end;
1112end;
1113
1114procedure TfrmMHTest.btnOKClick(Sender: TObject);
1115var
1116 i, XCnt, First: integer;
1117 msg, ans, TestStatus: string;
1118
1119begin
1120 msg := '';
1121 ans := '';
1122 XCnt := 0;
1123 First := -1;
1124 TestStatus := '2';
1125 MHTestComp := '2';
1126 for i := 0 to FObjs.Count-1 do
1127 begin
1128 ans := ans + TMHQuestion(Fobjs[i]).FAnswer;
1129 if(TMHQuestion(FObjs[i]).FAnswer = Skipped) then
1130 begin
1131 if(First < 0) then First := i;
1132 inc(XCnt);
1133 if(msg <> '') then
1134 msg := msg + ', ';
1135 msg := msg + IntToStr(i+1);
1136 end;
1137 end;
1138 if(XCnt = FObjs.Count) then ModalResult := mrOK;
1139 TestStatus := VerifyMentalHealthTestComplete(Self.Caption, ans);
1140 if Piece(TestStatus,U,1) <> '2' then
1141 begin
1142 if Piece(TestStatus,U,1)='1' then
1143 begin
1144 ModalResult := mrOK;
1145 MHTestComp := '1';
1146 EXIT;
1147 end;
1148 if Piece(TestStatus,U,1)='0' then
1149 begin
1150 MHTestComp := '0';
1151 msg := Piece(TestStatus,u,2);
1152 msg := 'The following questions have not been answered:' + CRLF + CRLF + ' ' + msg;
1153 if(InfoBox(msg + CRLF + CRLF + 'Answer skipped questions?', 'Skipped Questions',
1154 MB_YESNO or MB_ICONQUESTION) = IDYES) then GotoQ(First)
1155 else
1156 ModalResult := mrOK;
1157 EXIT;
1158 end;
1159 end;
1160 if(XCnt = 0) then
1161 ModalResult := mrOK
1162 else
1163 begin
1164 if(XCnt = FObjs.Count) then
1165 ModalResult := mrOK
1166 else
1167 begin
1168 msg := 'The following questions have not been answered:' + CRLF + CRLF + ' ' + msg;
1169 if(InfoBox(msg + CRLF + CRLF + 'Answer skipped questions?', 'Skipped Questions',
1170 MB_YESNO or MB_ICONQUESTION) = IDYES) then
1171 GotoQ(First)
1172 else
1173 ModalResult := mrOK;
1174 end;
1175 end;
1176end;
1177
1178procedure TfrmMHTest.btnClearClick(Sender: TObject);
1179var
1180 i: integer;
1181
1182begin
1183 for i := 0 to sbMain.ControlCount-1 do
1184 begin
1185 if(sbMain.Controls[i] is TCheckBox) then
1186 TCheckBox(sbMain.Controls[i]).Checked := FALSE
1187 else
1188 if(sbMain.Controls[i] is TComboBox) then
1189 begin
1190 with TComboBox(sbMain.Controls[i]) do
1191 begin
1192 ItemIndex := -1;
1193 OnChange(sbMain.Controls[i]);
1194 end;
1195 end;
1196 end;
1197end;
1198
1199end.
Note: See TracBrowser for help on using the repository browser.