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

Last change on this file since 1708 was 1679, checked in by healthsevak, 10 years ago

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