source: cprs/trunk/CPRS-Chart/fProbs.pas@ 1243

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

Upgrading to version 27
File size: 70.6 KB
Line 
1unit fProbs;
2{$O-}
3interface
4
5uses
6 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
7 fHSplit, StdCtrls, ExtCtrls, Menus, ORCtrls, Buttons, uProbs,
8 Grids, Vawrgrid, ORfn, uCore, fProbEdt, uConst, ComCtrls,
9 VA508AccessibilityManager, fBase508Form;
10
11type
12 TfrmProblems = class(TfrmHSplit)
13 mnuProbs: TMainMenu;
14 mnuView: TMenuItem;
15 mnuViewChart: TMenuItem;
16 mnuChartCover: TMenuItem;
17 mnuChartProbs: TMenuItem;
18 mnuChartMeds: TMenuItem;
19 mnuChartOrders: TMenuItem;
20 mnuChartNotes: TMenuItem;
21 mnuChartCslts: TMenuItem;
22 mnuChartDCSumm: TMenuItem;
23 mnuChartLabs: TMenuItem;
24 mnuChartReports: TMenuItem;
25 mnuAct: TMenuItem;
26 mnuActNew: TMenuItem;
27 Z3: TMenuItem;
28 mnuActChange: TMenuItem;
29 mnuActInactivate: TMenuItem;
30 mnuActRemove: TMenuItem;
31 mnuActVerify: TMenuItem;
32 Z4: TMenuItem;
33 mnuActAnnotate: TMenuItem;
34 Z1: TMenuItem;
35 mnuViewActive: TMenuItem;
36 mnuViewBoth: TMenuItem;
37 popProb: TPopupMenu;
38 popChange: TMenuItem;
39 popInactivate: TMenuItem;
40 popRestore: TMenuItem;
41 popRemove: TMenuItem;
42 popVerify: TMenuItem;
43 N36: TMenuItem;
44 popAnnotate: TMenuItem;
45 N37: TMenuItem;
46 pnlProbList: TORAutoPanel;
47 pnlProbCats: TPanel;
48 lblProbCats: TLabel;
49 lstCatPick: TORListBox;
50 pnlProbEnt: TPanel;
51 pnlProbDlg: TPanel;
52 wgProbData: TCaptionListBox;
53 mnuViewInactive: TMenuItem;
54 mnuViewRemoved: TMenuItem;
55 N1: TMenuItem;
56 mnuActRestore: TMenuItem;
57 mnuViewFilters: TMenuItem;
58 N2: TMenuItem;
59 lblProbList: TOROffsetLabel;
60 pnlView: TPanel;
61 N3: TMenuItem;
62 popViewDetails: TMenuItem;
63 lstView: TORListBox;
64 lblView: TOROffsetLabel;
65 N4: TMenuItem;
66 mnuActDetails: TMenuItem;
67 bbNewProb: TORAlignButton;
68 lblProbEnt: TLabel;
69 mnuViewSave: TMenuItem;
70 mnuViewRestoreDefault: TMenuItem;
71 mnuViewComments: TMenuItem;
72 sptProbPanel: TSplitter;
73 pnlButtons: TPanel;
74 bbOtherProb: TORAlignButton;
75 bbCancel: TORAlignButton;
76 pnlProbs: TPanel;
77 lblProblems: TLabel;
78 lstProbPick: TORListBox;
79 edProbEnt: TCaptionEdit;
80 mnuChartSurgery: TMenuItem;
81 HeaderControl: THeaderControl;
82 mnuViewInformation: TMenuItem;
83 mnuViewDemo: TMenuItem;
84 mnuViewVisits: TMenuItem;
85 mnuViewPrimaryCare: TMenuItem;
86 mnuViewMyHealtheVet: TMenuItem;
87 mnuInsurance: TMenuItem;
88 mnuViewFlags: TMenuItem;
89 mnuViewReminders: TMenuItem;
90 mnuViewRemoteData: TMenuItem;
91 mnuViewPostings: TMenuItem;
92 mnuOptimizeFields: TMenuItem;
93 procedure mnuChartTabClick(Sender: TObject);
94 procedure lstProbPickClick(Sender: TObject);
95 procedure lstProbPickDblClick(Sender: TObject);
96 procedure lstCatPickClick(Sender: TObject);
97 procedure lstProbActsClick(Sender: TObject);
98 procedure pnlRightResize(Sender:TObject);
99 procedure pnlProbEntResize(Sender: TObject);
100 procedure wgProbDataClick(Sender: TObject);
101 procedure wgProbDataDblClick(Sender: TObject);
102 procedure edProbEntKeyPress(Sender: TObject; var Key: Char);
103 procedure bbOtherProbClick(Sender: TObject);
104 procedure FormCreate(Sender: TObject);
105 procedure bbCancelClick(Sender: TObject);
106 procedure lstViewClick(Sender: TObject);
107 procedure FormDestroy(Sender: TObject);
108 procedure mnuViewSaveClick(Sender: TObject);
109 procedure mnuViewRestoreDefaultClick(Sender: TObject);
110 procedure mnuViewCommentsClick(Sender: TObject);
111 procedure wgProbDataMeasureItem(Control: TWinControl; Index: Integer;
112 var Height: Integer);
113 procedure wgProbDataDrawItem(Control: TWinControl; Index: Integer;
114 Rect: TRect; State: TOwnerDrawState);
115 procedure HeaderControlSectionResize(HeaderControl: THeaderControl;
116 Section: THeaderSection);
117 procedure lstViewExit(Sender: TObject);
118 procedure FormShow(Sender: TObject);
119 procedure FormHide(Sender: TObject);
120 procedure pnlRightExit(Sender: TObject);
121 procedure bbNewProbExit(Sender: TObject);
122 procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
123 Y: Integer);
124 procedure ViewInfo(Sender: TObject);
125 procedure mnuViewInformationClick(Sender: TObject);
126 procedure mnuOptimizeFieldsClick(Sender: TObject);
127 procedure HeaderControlSectionClick(HeaderControl: THeaderControl;
128 Section: THeaderSection);
129 procedure HeaderControlMouseUp(Sender: TObject; Button: TMouseButton;
130 Shift: TShiftState; X, Y: Integer);
131 procedure HeaderControlMouseDown(Sender: TObject; Button: TMouseButton;
132 Shift: TShiftState; X, Y: Integer);
133 function getTotalSectionsWidth : integer;
134 procedure setSectionWidths;
135 procedure sptHorzMoved(Sender: TObject);
136 private
137 FContextString: string;
138 FFilterString: string;
139 FAllProblems: TStringList; //Unfiltered list of problems
140 FProblemsVisible: TStringList; //Parallels FAllProblems. "Y" for visible
141 FItemData: TStringList; //Parallels Grid. String representation of integer indexes into FAllProblems
142 // FProblemsVisible[FItemData[i]] = 'Y'
143 FWarningShown: boolean;
144 FOldFramePnlPatientExit: TNotifyEvent;
145 FMousing: TDateTime;
146 FSilent: boolean;
147 procedure frmFramePnlPatientExit(Sender: TObject);
148 procedure UMCloseProblem(var Message:TMessage); message UM_CLOSEPROBLEM; {pdr}
149 procedure ApplyViewFilters;
150// procedure UMPLFilter(var Message:TMessage); message UM_PLFILTER; {pdr}
151 procedure UMPLLexicon(var Message:TMessage); message UM_PLLEX; {pdr}
152 procedure GetRowCount;
153 procedure RefreshList;
154 procedure SetGridPieces(Pieces: string);
155 procedure ShowPnlView();
156 function PlainText( MString: string): string;
157 function MString( index: integer): string;
158 public
159 function AllowContextChange(var WhyNot: string): Boolean; override;
160 procedure LoadProblems;
161 procedure LoadUserCats(AList:Tstringlist);
162 procedure LoadUserProbs(AList:TstringList);
163 procedure AddProblem;
164 procedure EditProblem(const why:char);
165 procedure LoadPatientParams(AList:TstringList);
166 procedure LoadUserParams(Alist:TstringList);
167 procedure UpdateProblem(const why:char;Line: string;AllProblemsIndex:integer);
168 procedure RestoreProblem;
169 procedure LoadPatientProblems(AList:TstringList;const status:char;init:boolean);
170 procedure ClearPtData; override;
171 procedure DisplayPage; override;
172 procedure NoRowSelected;
173 procedure RowSelected;
174 procedure ClearGrid;
175 procedure RequestPrint; override;
176 procedure SetFontSize( NewFontSize: integer); override;
177 function HighlightDuplicate( NewProb: string; const Msg: string;
178 DlgType: TMsgDlgType; Action: string): boolean;
179 property Silent: Boolean read FSilent write FSilent;
180 end;
181
182 function EncounterPresent: Boolean;
183
184const
185 TX_PROV_LOC = 'A provider and location must be selected before' + #13#10 +
186 'entering or making any change to a problem.';
187 TC_PROV_LOC = 'Incomplete Information';
188 TX_INVALID_PATIENT = 'Problem list is unavailable: Patient DFN is undefined.';
189 TC_NO_PATIENT = 'No patient is selected';
190 TX_INACTIVE_CODE_V = 'references an inactive ICD code, and must be updated' + #13#10 +
191 'using the ''Change'' option before it can be verified.';
192 TC_INACTIVE_CODE = 'Inactive Code';
193 TX_INACTIVE_CODE = 'This problem references an inactive ICD code,' + #13#10 +
194 'and must be updated using the ''Change'' option.';
195 TX_ADD_REMOVED = 'Cannot add to the "Removed Problem List"';
196 TC_ADD_REMOVED = 'Unable to add';
197
198 RPT_PROBLIST = 21;
199 CT_PROBLEMS = 2;
200
201 // GridColWidths[i] = 0 for columns that are always hidden
202 // GridColWidths[i] = -1 for one (and only one) adjustable column
203 GridColWidths: Array[0..15] of integer =(0, 5, -1, 9, 9, 0, 12, 12, 12, 0, 0, 0, 0, 0, 0, 0);
204
205 type
206 arOrigSecWidths = array[0..15] of integer;
207
208var
209 frmProblems: TfrmProblems;
210 dlgProbs:TfrmdlgProb;
211 gFontHeight: Integer;
212 gFontWidth: Integer;
213 gFixedWidth: Integer;
214 origWidths: arOrigSecWidths;
215
216implementation
217
218uses fFrame, fProbFlt, fProbLex, rProbs, rcover, fCover, fRptBox,
219 fProbCmt, fEncnt, fReportsPrint, fReports, rPCE, DateUtils, VA2006Utils,
220 VA508AccessibilityRouter;
221
222{$R *.DFM}
223
224function TfrmProblems.AllowContextChange(var WhyNot: string): Boolean;
225begin
226 Result := inherited AllowContextChange(WhyNot); // sets result = true
227 //if dlgProbs <> nil then Result := dlgProbs.OkToQuit;
228 //if dlgProbs <> nil then dlgProbs.bbQuitClick(Self);
229 //need to check here and set to false if quit was cancelled or true if accepted
230
231 if dlgProbs <> nil then
232 case BOOLCHAR[frmFrame.CCOWContextChanging] of
233 '1': begin
234 WhyNot := 'Changes to current problem will be discarded.';
235 Result := False;
236 end;
237 '0': begin
238 if WhyNot = 'COMMIT' then
239 begin
240 FSilent := True;
241 dlgProbs.Silent := True;
242 dlgProbs.bbQuitClick(Self);
243 end
244 else
245 begin
246 dlgProbs.bbQuitClick(Self);
247 Result := dlgProbs.CanQuit;
248 end;
249 end;
250 end;
251
252end;
253
254procedure TfrmProblems.ClearPtData;
255begin
256 inherited ClearPtData;
257 ClearGrid;
258 lblProbList.Caption := '';
259 wgProbData.Caption := lblProbList.Caption;
260 FWarningShown := False;
261end;
262
263procedure TfrmProblems.DisplayPage;
264begin
265 inherited DisplayPage;
266 frmFrame.ShowHideChartTabMenus(mnuViewChart);
267 frmFrame.mnuFilePrint.Tag := CT_PROBLEMS;
268 frmFrame.mnuFilePrint.Enabled := True;
269 frmFrame.mnuFilePrintSetup.Enabled := True;
270 if InitPatient then
271 begin
272 FWarningShown := False;
273 if PLUser <> nil then
274 begin
275 PLUser.Destroy;
276 PLUser := nil;
277 end;
278 //ClearPtData;
279 ShowPnlView;
280 pnlButtons.SendToBack;
281 pnlButtons.Hide;
282 LoadProblems ;
283 end;
284end;
285
286procedure TfrmProblems.mnuChartTabClick(Sender: TObject);
287begin
288 inherited;
289 frmFrame.mnuChartTabClick(Sender);
290end;
291
292{------------------------ pdr - Problem list gadget event methods ------------}
293procedure TfrmProblems.lstCatPickClick(Sender: TObject);
294var
295 AList:TStringList;
296begin
297 AList:=TStringList.create;
298 try
299 LoadUserProbs(AList);
300 finally
301 AList.free;
302 end;
303end;
304
305procedure TfrmProblems.lstProbActsClick(Sender: TObject);
306var
307 act, i, j: integer;
308 Alist: TstringList;
309 cmt, ProblemIFN, ut, x, line, comments: string ;
310 ProbRec: TProbRec ;
311 ContextString, FilterString: string;
312 FilterChanged: boolean;
313 AllProblemsIndex: integer;
314begin
315 if PLPt = nil then
316 begin
317 InfoBox(TX_INVALID_PATIENT, TC_NO_PATIENT, MB_OK or MB_ICONWARNING);
318 Exit;
319 end;
320 act := TComponent(Sender).tag ;
321 if act = 0 then exit;
322 // make sure a visit (time & location) is available before creating the problem
323 case act of
324 100: {add new problem}
325 begin
326 if PlUser.usViewAct = 'R' then
327 begin
328 InfoBox(TX_ADD_REMOVED, TC_ADD_REMOVED, MB_ICONINFORMATION or MB_OK);
329 exit;
330 end;
331 if not EncounterPresent then exit;
332 PLProblem := '';
333 AList := TStringList.Create;
334 pProviderID := Encounter.Provider;
335 pProviderName := Encounter.ProviderName ;
336 try
337 if pnlView.Visible then
338 begin
339 pnlView.SendToBack;
340 pnlProbCats.Show;
341 pnlProbCats.BringToFront;
342 pnlButtons.Visible := True;
343 if PLUser.usUseLexicon then
344 begin
345 lblProbCats.Visible := True;
346 lstCatPick.Visible := True;
347 lblProblems.Visible := True;
348 lstProbPick.Visible := True;
349 lstCatPick.Clear ;
350 LoadUserCats(AList);
351 bbOtherProb.Visible := True;
352 pnlProbList.Visible := True;
353 lstCatPick.TabStop := True;
354 lstProbPick.TabStop := True;
355 lstView.TabStop := False;
356 bbNewProb.TabStop := False;
357 pnlProbList.BringToFront ;
358 pnlProbCats.ClientHeight := (pnlProbList.ClientHeight - pnlButtons.ClientHeight) div 2;
359 pnlProbEnt.Visible := False;
360 pnlProbEnt.SendToBack;
361 if (lstCatPick.Items.Count = 1) then
362 if Piece(lstCatPick.Items[0], U, 1) = '-1' then
363 bbOtherProbClick(Self);
364 end
365 else
366 begin
367 bbOtherProb.Visible := False;
368 edProbEnt.Visible := True;
369 lblProbEnt.Visible := True;
370 pnlProbEnt.Visible := True;
371 pnlProbEnt.BringToFront;
372 pnlProbList.Visible := False;
373 lstCatPick.TabStop := False;
374 lstProbPick.TabStop := False;
375 lstView.TabStop := True;
376 bbNewProb.TabStop := True;
377 pnlProbList.SendToBack ;
378 edProbEnt.text := '';
379 if pnlProbEnt.Visible then edProbEnt.SetFocus;
380 end;
381 end
382 else
383 begin
384 if (lstProbPick.itemindex < 0) and (edProbEnt.text = '') then
385 InfoBox('Select a Problem to add from lists' + #13#10 + ' on left or enter a new one ',
386 'Information', MB_OK or MB_ICONINFORMATION)
387 else
388 begin
389 AddProblem;
390 lstProbPick.itemindex := -1;
391 end;
392 end ;
393 finally
394 AList.Free;
395 end;
396 end;
397 200: {Inactivate}
398 begin
399 if PlUser.usViewAct = 'R' then
400 begin
401 InfoBox('Cannot inactivate a problem on the "Removed Problem List"',
402 'Information', MB_OK or MB_ICONINFORMATION);
403 exit;
404 end;
405 if (wgProbData.ItemIndex < 0) or (Piece(MString(wgProbData.itemindex), U, 3) = '') then
406 InfoBox('Select a patient problem from the grid on right',
407 'Information', MB_OK or MB_ICONINFORMATION)
408 else
409 begin
410 if not EncounterPresent then exit;
411 pProviderID := Encounter.Provider;
412 pProviderName := Encounter.ProviderName ;
413 AllProblemsIndex := 0;
414 repeat
415 begin
416 if wgProbData.Selected[AllProblemsIndex] then
417 begin
418 Line := FAllProblems[AllProblemsIndex];
419 if CharAt(Piece(Line, U, 2), 1) = 'A' then
420 UpdateProblem('I',Line,AllProblemsIndex)
421 else
422 InfoBox('Problem "' + Trim(UpperCase(Piece(Piece(Line, U, 3), #13, 1))) + '" is already inactive.',
423 'Problem not updated', MB_ICONINFORMATION or MB_OK);
424 end;
425 inc(AllProblemsIndex);
426 end;
427 until AllProblemsIndex >= wgProbData.Count;
428 RefreshList;
429 end;
430 if (PlUser.usViewAct='A') then
431 begin
432 AList := TStringList.Create ;
433 LoadPatientProblems(Alist,'A',False) ;
434 NoRowSelected ;
435 end;
436 RefreshList;
437 end;
438 250: {Verify}
439 begin
440 if not PLuser.usVerifyTranscribed then exit ;
441 if PlUser.usViewAct = 'R' then
442 begin
443 InfoBox('Cannot verify a problem on the "Removed Problem List"',
444 'Information', MB_OK or MB_ICONINFORMATION);
445 exit;
446 end;
447 if (wgProbData.ItemIndex < 0) or (Piece(MString(wgProbData.ItemIndex), U, 3) = '') then
448 InfoBox('Select a patient problem from the grid on right',
449 'Information', MB_OK or MB_ICONINFORMATION)
450 else
451 begin
452 if not EncounterPresent then exit;
453 pProviderID := Encounter.Provider;
454 pProviderName := Encounter.ProviderName ;
455 AllProblemsIndex := 0;
456 repeat
457 begin
458 if wgProbData.Selected[AllProblemsIndex] then
459 begin
460 Line := FAllProblems[AllProblemsIndex];
461 if Pos('#',Piece(Line, U, 2)) > 0 then
462 InfoBox('Problem "' + Trim(UpperCase(Piece(Piece(Line, U, 3), #13, 1))) + '" ' + #13#10 +
463 TX_INACTIVE_CODE_V, TC_INACTIVE_CODE, MB_ICONWARNING or MB_OK)
464 else if Pos('(u)',Piece(Line, U, 2)) = 0 then
465 InfoBox('Problem "' + Trim(UpperCase(Piece(Piece(Line, U, 3), #13, 1))) + '" is already verified.',
466 'Problem not updated', MB_ICONINFORMATION or MB_OK)
467 else
468 UpdateProblem('V',Line,AllProblemsIndex);
469 end;
470 inc(AllProblemsIndex);
471 end;
472 until AllProblemsIndex >= wgProbData.Count;
473 RefreshList;
474 mnuActVerify.Enabled := False;
475 popVerify.Enabled := False;
476 end;
477 end;
478 300: {detail}
479 with wgProbData do
480 begin
481 if ItemIndex < 0 then
482 InfoBox('Select a problem from the grid for Detail Display',
483 'Information', MB_OK or MB_ICONINFORMATION)
484 else if StrToIntDef(Piece(MString(ItemIndex), U, 1),0)>0 then
485 ReportBox(DetailProblem(StrToInt(Piece(MString(ItemIndex), U, 1))),
486 Piece(Piece(MString(ItemIndex), U, 3), #13, 1), True);
487 end;
488 400: {edit}
489 begin
490 if PlUser.usViewAct = 'R' then
491 begin
492 InfoBox('Cannot select a problem to edit from the "Removed Problem List"',
493 'Information', MB_OK or MB_ICONINFORMATION);
494 exit;
495 end;
496 if wgProbData.ItemIndex < 0 then
497 InfoBox('Select a problem from the grid to Edit', 'Information', MB_OK or MB_ICONINFORMATION)
498 else
499 begin
500 if not EncounterPresent then exit;
501 pProviderID := Encounter.Provider;
502 pProviderName := Encounter.ProviderName ;
503 EditProblem('E');
504 end
505 end;
506 500: {Remove}
507 begin
508 if not PlUser.usPrimeUser then exit ;
509 if PlUser.usViewAct = 'R' then
510 begin
511 InfoBox('Cannot remove from the "Removed Problem List"' +#13#10 + 'Use "Restore Problem"',
512 'Information', MB_OK or MB_ICONINFORMATION);
513 exit;
514 end;
515 if wgProbData.ItemIndex < 0 then
516 InfoBox('Select a problem from the grid to remove', 'Information', MB_OK or MB_ICONINFORMATION)
517 else
518 begin
519 if not EncounterPresent then exit;
520 pProviderID := Encounter.Provider;
521 pProviderName := Encounter.ProviderName ;
522 EditProblem('R');
523 end;
524 end;
525 550: {Restore}
526 begin
527 if not PlUser.usPrimeUser then exit ;
528 if PlUser.usViewAct <> 'R' then
529 begin
530 InfoBox('View the Removed Problems Display, and select a record to restore.',
531 'Information', MB_OK or MB_ICONINFORMATION);
532 exit;
533 end;
534 if wgProbData.ItemIndex < 0 then
535 InfoBox('Select a problem to restore from the grid on right', 'Information', MB_OK or MB_ICONINFORMATION)
536 else
537 begin
538 if not EncounterPresent then exit;
539 pProviderID := Encounter.Provider;
540 pProviderName := Encounter.ProviderName ;
541 RestoreProblem;
542 end;
543 end;
544 600: {Add Comment}
545 begin
546 if PlUser.usViewAct = 'R' then
547 begin
548 InfoBox('Cannot add a comment to a removed problem', 'Information', MB_OK or MB_ICONINFORMATION);
549 exit;
550 end;
551 if wgProbData.ItemIndex < 0 then
552 InfoBox('Select a problem to annotate from the grid on right', 'Information', MB_OK or MB_ICONINFORMATION)
553 else
554 begin
555 if not EncounterPresent then exit;
556 pProviderID := Encounter.Provider;
557 pProviderName := Encounter.ProviderName ;
558 AList := TStringList.Create;
559 ProblemIFN := Piece(MString(wgProbData.ItemIndex), U, 1);
560 FastAssign(EditLoad(ProblemIFN, pProviderID, PLPt.ptVAMC), AList) ;
561 if Alist.count = 0 then
562 begin
563 InfoBox('No Data on Host for problem ' + ProblemIFN, 'Information', MB_OK or MB_ICONINFORMATION);
564 close;
565 exit;
566 end;
567 ProbRec:=TProbRec.Create(Alist); {create a problem object}
568 try
569 ProbRec.PIFN := ProblemIFN;
570 if not IsActiveICDCode(ProbRec.Diagnosis.extern) then
571 begin
572 InfoBox(TX_INACTIVE_CODE, TC_INACTIVE_CODE, MB_ICONWARNING or MB_OK);
573 exit;
574 end ;
575 if ProbRec.CmtIsXHTML then
576 begin
577 InfoBox(ProbRec.CmtNoEditReason, 'Unable to add new comment', MB_ICONWARNING or MB_OK);
578 exit;
579 end ;
580 cmt := NewComment ;
581 if (StrToInt(Piece(cmt, U, 1)) > 0) and (Piece(cmt, U, 3) <> '') then
582 begin
583 ProbRec.AddNewComment(Piece(cmt, U, 3));
584 ut := '';
585 If PLUser.usPrimeUser then ut := '1';
586 FastAssign(EditSave(ProblemIFN,pProviderID,PLPt.ptVAMC,ut,ProbRec.FilerObject), AList) ;
587 LoadPatientProblems(AList,PlUser.usViewAct[1],true);
588 end ;
589 finally
590 Alist.Free ;
591 ProbRec.Free ;
592 end ;
593 end ;
594 end;
595 700: {Active only}
596 begin
597 Alist := TstringList.create;
598 try
599 PlUser.usViewAct := 'A';
600 LoadPatientProblems(Alist,'A',false);
601 SetPiece(FContextString, ';', 3, 'A');
602 GetRowCount;
603 finally
604 Alist.free;
605 end;
606 end;
607 800: {inactive Only}
608 begin
609 Alist := TstringList.create;
610 try
611 PlUser.usViewAct := 'I';
612 LoadPatientProblems(Alist,'I',false);
613 SetPiece(FContextString, ';', 3, 'I');
614 GetRowCount;
615 finally
616 Alist.free;
617 end;
618 end;
619 900: {all problems display}
620 begin
621 Alist := TstringList.create;
622 try
623 PlUser.usViewAct := 'B';
624 LoadPatientProblems(Alist,'B',false);
625 SetPiece(FContextString, ';', 3, 'B');
626 GetRowCount;
627 finally
628 Alist.free;
629 end;
630 end;
631 950: {Removed Problems Display}
632 begin
633 Alist := TstringList.create;
634 try
635 PlUser.usViewAct := 'R';
636 LoadPatientProblems(Alist,'R',false);
637 SetPiece(FContextString, ';', 3, 'R');
638 GetRowCount;
639 finally
640 Alist.free;
641 end;
642 end;
643 975: {Select viewing filters}
644 begin
645 lstView.ItemIndex := -1;
646 ContextString := '^;;' + PLUser.usViewAct[1] + ';' + PLUser.usViewComments;
647 GetViewFilters(Font.Size, PLFilters, ContextString, FilterString, FilterChanged);
648 if not FilterChanged then exit;
649 FContextString := ContextString;
650 FFilterString := FilterString;
651 if (Piece(ContextString, ';', 3) <> PLUser.usViewAct[1]) then
652 begin
653 AList := TStringList.Create;
654 try
655 PLUser.usViewAct := Piece(ContextString, ';', 3);
656 LoadPatientProblems(Alist, PLUser.usViewAct[1], False);
657 finally
658 AList.Free;
659 end;
660 end;
661 if (Piece(ContextString, ';', 4) <> PLUser.usViewComments) then with FAllProblems do
662 begin
663 for i := 0 to Count - 1 do
664 begin
665 if Objects[i] = nil then continue;
666 x := Piece(Piece(Strings[i], U, 3), #13, 1);
667 if Piece(ContextString, ';', 4) = '1' then
668 begin
669 comments := '';
670 for j := 0 to TStringList(Objects[i]).Count - 1 do
671 comments := comments + ' ' + TStringList(Objects[i]).Strings[j] + #13#10;
672 //comments := comments + ' CMT: ' + TStringList(Items.Objects[i]).Strings[j] + #13#10;
673 line := Strings[i];
674 SetPiece(line, U, 3, x + #13#10 + comments);
675 Strings[i] := line;
676 mnuViewComments.Checked := True;
677 end
678 else
679 begin
680 line := Strings[i];
681 SetPiece(line, U, 3, x);
682 Strings[i] := line;
683 mnuViewComments.Checked := False;
684 end;
685 end;
686 RefreshList;
687 PLUser.usViewComments := Piece(ContextString, ';', 4);
688 end;
689 pnlRightResize(Self);
690 end ;
691 end;
692end;
693
694procedure TfrmProblems.lstProbPickClick(Sender: TObject);
695begin
696 if PlUser.usViewAct = 'R' then exit;
697 pProviderID := Encounter.Provider ;
698 AddProblem;
699 TListBox(sender).itemindex := -1;
700end;
701
702procedure TfrmProblems.pnlProbEntResize(Sender: TObject);
703(*var
704 i:integer;*)
705begin
706(* for i := 0 to pred(twincontrol(sender).controlcount) do
707 begin
708 twincontrol(sender).controls[i].width := twincontrol(sender).width - 4;
709 twincontrol(sender).controls[i].left := 2;
710 end;*)
711end;
712
713procedure TfrmProblems.wgProbDataClick(Sender: TObject);
714var
715 S: string;
716begin
717 pnlRight.font.color := self.font.color;
718 S := MString(wgProbData.ItemIndex);
719 pnlRight.caption := Piece(Piece(S, U , 3), #13, 1);
720 if (Piece(S, U, 1) = '') or
721 (Pos('No data available', Piece(S, U, 2)) > 0) or
722 (Pos('No problems found.', Piece(S, U, 2)) > 0)
723 then NoRowSelected else RowSelected ;
724end;
725
726procedure TfrmProblems.wgProbDataDblClick(Sender: TObject);
727begin
728 lstProbActsClick(mnuActDetails);
729end;
730
731procedure TfrmProblems.lstProbPickDblClick(Sender: TObject);
732begin
733 if PlUser.usViewAct = 'R' then exit;
734 pProviderID := Encounter.Provider ;
735 AddProblem;
736 TListBox(sender).itemindex := -1;
737end;
738
739procedure TfrmProblems.edProbEntKeyPress(Sender: TObject; var Key: Char);
740begin
741 if key=#13 then lstProbPickDblClick(sender);
742end;
743
744procedure TfrmProblems.bbOtherProbClick(Sender: TObject);
745var
746 frmPLLex: TfrmPLLex;
747begin
748 if not PLUser.usUseLexicon then exit; {don't allow lookup}
749 frmPLLex := TFrmPLLex.create(Application);
750 try
751 frmPLLex.showmodal;
752 finally
753 frmPLLex.Free;
754 end;
755end;
756
757procedure TfrmProblems.UMCloseProblem(var Message:TMessage);
758begin
759 pnlView.BringToFront ;
760 ShowPnlView;
761 bbCancel.Enabled := True ;
762 bbOtherProb.enabled := true; {restore lexicon access}
763 pnlButtons.Visible := False;
764 pnlButtons.SendToBack;
765 pnlProbEnt.Visible := (not PLUser.usUseLexicon) ;
766 if PLuser.usViewAct = 'A' then
767 pnlRight.caption := ACTIVE_LIST_CAP
768 else if PLuser.usViewAct = 'I' then
769 pnlRight.caption := INACTIVE_LIST_CAP
770 else if PLuser.usViewAct = 'B' then
771 pnlRight.caption := BOTH_LIST_CAP
772 else if PLuser.usViewAct = 'R' then
773 pnlRight.caption := REMOVED_LIST_CAP
774 else
775 begin
776 PlUser.usViewAct := 'A';
777 pnlRight.caption := ACTIVE_LIST_CAP;
778 end;
779 if dlgProbs <> nil then dlgProbs:=nil;
780end;
781
782//procedure TfrmProblems.UMPLFilter(var Message:TMessage);
783procedure TfrmProblems.ApplyViewFilters;
784var
785 i: integer;
786 wantnulls: boolean;
787begin
788 {the following escape is necessitated by change in default row height which
789 corrupts display of hidden rows in wgProbData. Since the default rowheight
790 is changed with each change in screen size, this gets called once before
791 PLFilters is created}
792 if PLFilters = nil then exit; {not initialized}
793 {show all rows}
794 wantnulls := (PLFilters.ProviderList.indexof('-1') > -1);
795 for i := 0 to pred(FProblemsVisible.count) do FProblemsVisible[i] := 'Y';
796
797 {filter for provider}
798 if PLFilters.ProviderList.Count > 0 then
799 if PLFilters.ProviderList[0] <> '0' then { 0 signifies all }
800 for i := 0 to pred(FAllProblems.count) do
801 if Piece(FAllProblems[i], U, 1) <> '' then {don't want to disappear empty rows}
802 if (PLFilters.ProviderList.indexof(Piece(FAllProblems[i], U, 10)) < 0) or
803 ((Piece(FAllProblems[i], U, 10) = '') and (not wantnulls)) then
804 FProblemsVisible[i] := 'N';
805
806 if PLUser.usCurrentView = PL_UF_VIEW then exit; {Bail out - no filtering by Loc}
807
808 {conditionally filter for clinic(s) - may be multiple selected}
809 if PLUser.usCurrentView = PL_OP_VIEW then
810 begin
811 wantnulls := (PLFilters.ClinicList.indexof('-1') > -1);
812 if PLFilters.ClinicList.Count = 0 then exit;
813 if PLFilters.ClinicList[0] <> '0' then { 0 signifies all }
814 for i := 0 to pred(FAllProblems.count) do
815 if (Piece(FAllProblems[i], U, 1) <> '') and {don't want to disappear empty rows}
816 (FProblemsVisible[i] = 'Y') then {don't want if already filtered}
817 begin
818 if (Piece(FAllProblems[i], U ,11) <> '') and {clinic not on user list}
819 (PLFilters.ClinicList.indexof(Piece(FAllProblems[i], U, 11)) < 0) then
820 FProblemsVisible[i] := 'N'
821 else if ((Piece(FAllProblems[i], U, 11) = '') and (not wantnulls)) then {no clinic recorded}
822 FProblemsVisible[i] := 'N';
823 end;
824 end
825 else
826 {conditionally filter for service - may be multiple selected}
827 begin
828 wantnulls := (PLFilters.ServiceList.indexof('-1') > -1);
829 if PLFilters.ServiceList.Count = 0 then exit;
830 if PLFilters.ServiceList[0] <> '0' then { 0 signifies all }
831 for i := 0 to pred(FAllProblems.count) do
832 if (Piece(FAllProblems[i], U, 1) <> '') and {don't want to disappear empty rows}
833 (FProblemsVisible[i] = 'Y') then {don't want if already filtered}
834 begin
835 if (Piece(FAllProblems[i], U, 12) <> '') and {Service not on user list}
836 (PLFilters.ServiceList.indexof(Piece(FAllProblems[i], U, 12)) < 0) then
837 FProblemsVisible[i] := 'N'
838 else if (Piece(FAllProblems[i], U, 12) = '') and (not wantnulls) then {no Service recorded}
839 FProblemsVisible[i] := 'N';
840 end;
841 end;
842end;
843
844procedure TfrmProblems.GetRowCount;
845var
846 ShownProbs, TotalProbs: integer;
847begin
848 if (wgProbData.Items.Count > 0) and (Piece(wgProbData.Items[0], U, 1) <> '') then
849 ShownProbs := wgProbData.Items.Count
850 else
851 ShownProbs := 0;
852
853 if (FAllProblems.Count > 0) and (Piece(FAllProblems[0], U, 1) <> '') then
854 TotalProbs := FAllProblems.Count
855 else
856 TotalProbs := 0;
857
858 case PLUser.usViewAct[1] of
859 'A': lblProbList.Caption := ACTIVE_LIST_CAP ;
860 'I': lblProbList.Caption := INACTIVE_LIST_CAP ;
861 'B': lblProbList.Caption := BOTH_LIST_CAP ;
862 'R': lblProbList.Caption := REMOVED_LIST_CAP ;
863 end;
864 lblProbList.Caption := lblProbList.Caption + ' (' + IntToStr(ShownProbs) + ' of ' + IntToStr(TotalProbs) + ')';
865 wgProbData.Caption := lblProbList.Caption;
866end;
867
868
869procedure TfrmProblems.UMPLLexicon(var Message:TMessage);
870begin
871 if PLProblem = '' then exit; {shouldn't happen but...}
872 if dlgProbs = nil then AddProblem;
873end;
874
875procedure TfrmProblems.SetGridPieces( Pieces: string);
876var
877 i, AdjustCol, cxUsed: Integer;
878 PieceSet: set of 0..High(GridColWidths);
879 x: string;
880begin
881 PieceSet := [];
882 x := Pieces;
883 while x <> '' do begin
884 PieceSet := PieceSet + [StrToIntDef(Piece(x, ',', 1), 1)-1];
885 if Pos(',', x) = 0 then
886 break;
887 x := Copy(x, Pos(',',x)+1, Length(x));
888 end;
889 AdjustCol := 0;
890 cxUsed := 0;
891 for i := 0 to High(GridColWidths) do
892 if i in PieceSet then
893 begin
894 if GridColWidths[i] > -1 then
895 begin
896 if GridColWidths[i] > 0 then
897 begin
898 HeaderControl.Sections[i].MaxWidth := 10000;
899 HeaderControl.Sections[i].Width := ForChars(GridColWidths[i], gFontWidth);
900 cxUsed := cxUsed + HeaderControl.Sections[i].Width;
901 end
902 else
903 begin
904 HeaderControl.Sections[i].Width := 0;
905 HeaderControl.Sections[i].MaxWidth := 0;
906 end;
907 end
908 else
909 AdjustCol := i;
910 end
911 else
912 begin
913 HeaderControl.Sections[i].Width := 0;
914 HeaderControl.Sections[i].MaxWidth := 0;
915 end;
916 HeaderControl.Sections[AdjustCol].AutoSize := True;
917 HeaderControl.Sections[AdjustCol].Width := HeaderControl.Width - cxUsed;
918 //mnuOptimizeFieldsClick(self); //******** test making compression, proportional, or no spacing on resize
919end;
920
921procedure TfrmProblems.pnlRightResize(Sender: TObject);
922begin
923 if PLUser = nil then exit;
924 if PLUser.usCurrentView = PL_IP_VIEW then
925 SetGridPieces('2,3,4,5,8,9')
926 else if PLUser.usCurrentView = PL_OP_VIEW then
927 SetGridPieces('2,3,4,5,7');
928 {have to do this to recover hidden rows}
929 ApplyViewFilters;
930 RefreshList;
931 GetRowCount;
932 //PostMessage(frmProblems.Handle, UM_PLFILTER,0,0);
933end;
934
935procedure TfrmProblems.FormCreate(Sender: TObject);
936begin
937 inherited;
938 FixHeaderControlDelphi2006Bug(HeaderControl);
939 FAllProblems := TStringList.Create;
940 FProblemsVisible := TStringList.Create;
941 FItemData := TStringList.Create;
942 PageID := CT_PROBLEMS;
943 GetFontInfo(Canvas.Handle, gFontWidth, gFontHeight);
944end;
945
946procedure TfrmProblems.LoadUserParams(Alist:TstringList);
947var
948 i: integer;
949begin
950 FastAssign(InitUser(User.DUZ), AList) ;
951 //FastAssign(InitUser(Encounter.Provider), AList) ;
952 PLUser := TPLUserParams.create(Alist);
953 FContextString := PLUser.usDefaultContext;
954 FFilterString := PLUser.usDefaultView + '/';
955 if PLFilters <> nil then
956 begin
957 if PLUser.usDefaultView = 'C' then with PLFilters.ClinicList do
958 for i := 0 to Count - 1 do
959 if Piece(Strings[i], U, 1) <> '-1' then
960 FFilterString := FFilterString + Piece(Strings[i], U, 1) + '/';
961 if PLUser.usDefaultView = 'S' then with PLFilters.ServiceList do
962 for i := 0 to Count - 1 do
963 if Piece(Strings[i], U, 1) <> '-1' then
964 FFilterString := FFilterString + Piece(Strings[i], U, 1) + '/';
965 end;
966 mnuViewComments.Checked := (PLUser.usViewComments = '1');
967 if PLUser.usTesting then
968 InfoBox('WARNING - Test User Parameters in Effect', 'Warning', MB_OK or MB_ICONWARNING);
969 pnlRightResize(Self);
970end;
971
972procedure TfrmProblems.LoadPatientParams(AList:TstringList);
973begin
974 FastAssign(InitPt(Patient.DFN), AList) ;
975 PLPt := TPLPt.create(Alist);
976end;
977
978procedure TfrmProblems.ClearGrid;
979var
980 i:integer;
981begin
982 with FAllProblems do for i := 0 to Count - 1 do
983 if Objects[i] <> nil then
984 begin
985 TStringList(Objects[i]).Free;
986 Objects[i] := nil;
987 end;
988 wgprobdata.Clear;
989 FAllProblems.Clear;
990 FProblemsVisible.Clear;
991end;
992
993
994procedure TfrmProblems.LoadPatientProblems(AList:TStringList; const Status:char; init:boolean);
995var {init should only be true when initializing a list for a new patient}
996 x, line, ver, prio, comments: string;
997 i, j, inact: Integer;
998 st: char;
999 CmtList: TStringList;
1000 //SCCond, tmpSCstr: string;
1001
1002 procedure ReverseList(Alist:TstringList);
1003 var
1004 i,j:integer;
1005 begin
1006 i:=0;
1007 j:=pred(Alist.count);
1008 while i<j do
1009 begin
1010 alist.exchange(i,j);
1011 inc(i);
1012 dec(j);
1013 end;
1014 end;
1015
1016begin {Body}
1017 CmtList := TStringList.Create;
1018 if PLFilters=nil then {create view filter lists}
1019 PLFilters:=TPLFilters.create;
1020 try
1021 ClearGrid;
1022 inact := 0;
1023 if PLPt = nil then
1024 begin
1025 InfoBox(TX_INVALID_PATIENT, TC_NO_PATIENT, MB_OK or MB_ICONWARNING);
1026 AList.Clear;
1027 AList.Add('No data available');
1028 end
1029 else
1030 begin
1031 st:=status;
1032 if st= '' then st := 'A'; {default to active list}
1033 FastAssign(ProblemList(Patient.DFN,St), AList) ;
1034 end;
1035 if Status = 'R' then
1036 SetGridPieces('3,4,5,7,8,9')
1037 else
1038 SetGridPieces('2,3,4,5,7,8,9');
1039 if Alist.count > 1 then Alist.delete(0); {get rid of first element - it is a list count}
1040 SortByPiece(AList, u, 6); { Sort by FM date/time }
1041 SetListFMDateTime('MMM dd yyyy',AList, u, 6); { Change FM date to MM/DD/YY }
1042 SetListFMDateTime('MMM dd yyyy',AList, u, 5); { Change FM date to MM/DD/YY }
1043 if PLUser.usReverseChronDisplay then {reverse chron order if required}
1044 ReverseList(Alist);
1045 {populate the grid}
1046 if ((Alist.Count = 1) and (pos('No data available', Alist[0]) > 0))then
1047 begin
1048 FAllProblems.Add('^^No problems found.');
1049 FProblemsVisible.Add('Y');
1050 RefreshList;
1051 Alist.Clear ;
1052 NoRowSelected;
1053 exit ;
1054 end ;
1055 for i := 0 to pred(Alist.count) do
1056 begin
1057 FAllProblems.Add('');
1058 FProblemsVisible.Add('Y');
1059 comments := '';
1060 CmtList.Clear;
1061 x := AList[i];
1062 if (Piece(x, U, 18) = '#') and (CharAt(UpperCase(Status), 1) in ['A', 'B', 'I', 'R']) then
1063 begin
1064 ver := '#'; // inactive ICD code flag takes precedence over unverified flag
1065 if (Piece(x, U, 2) = 'A') then inact := inact + 1;
1066 end
1067 else if (PlUSer.usVerifyTranscribed) and
1068 (Piece(x, U, 9) = 'T') then
1069 ver := '(u)'
1070 else
1071 ver := ' ';
1072 if Piece(x, U, 14) = 'A' then prio := ' * ' else prio := ' ' ;
1073 Line := '';
1074 SetPiece(Line, U, 2, Piece(x, U, 2) + prio + ver);
1075 if Piece(x, U, 15) = '1' then //problem has comments
1076 begin
1077 FastAssign(GetProblemComments(Piece(x, U, 1)), CmtList);
1078 if FAllProblems.Objects[i] = nil then FAllProblems.Objects[i]:= TStringList.Create;
1079 FastAssign(CmtList, TStringList(FAllProblems.Objects[i]));
1080 end;
1081
1082 SetPiece(Line, U, 3, Piece(x, U, 3));
1083 if PLUser.usViewComments = '1' then
1084 begin
1085 for j := 0 to CmtList.Count-1 do
1086 comments := comments + ' ' + CmtList.Strings[j] + #13#10;
1087 SetPiece(Line, U, 3, Piece(Line, U, 3) + #13#10 + comments);
1088 end;
1089 SetPiece(Line, U, 4, Trim(Piece(x, U, 5))); {onset date}
1090 SetPiece(Line, U, 5, Trim(Piece(x, U, 6))); {last updated}
1091 SetPiece(Line, U, 7, MixedCase(Piece(Piece(x, U, 10), ';', 2))); {location name}
1092 SetPiece(Line, U, 8, MixedCase(Piece(Piece(x, U, 12), ';', 2))); {provider name}
1093 SetPiece(Line, U, 9, MixedCase(Piece(Piece(x, U, 13), ';', 2))); {service name}
1094 {hidden cells}
1095 SetPiece(Line, U, 1, Piece(x, U, 1)); {problem IEN}
1096 SetPiece(Line, U, 6, Piece(x, U, 7)); {service connected status}
1097 SetPiece(Line, U, 11, Piece(Piece(x, U, 10), ';', 1)); {location IEN}
1098 SetPiece(Line, U, 13, Piece(x, U, 11)); {loc type}
1099 SetPiece(Line, U, 10, Piece(Piece(x, U, 12), ';', 1)); {responsible provider IEN}
1100 SetPiece(Line, U, 12, Piece(Piece(x, U, 13), ';', 1)); {service IEN}
1101 SetPiece(Line, U, 14, Piece(x, U, 4)); {code}
1102 SetPiece(Line, U, 15, Piece(x, U, 17)); {Service-connected conditions}
1103 SetPiece(Line, U, 16, Piece(x, U, 18)); {# = inactive ICD code stored with problem}
1104 FAllProblems[i] := Line;
1105 end;
1106 Alist.clear;
1107 if not init then
1108 SetViewFilters(Alist)
1109 else
1110 InitViewFilters(Alist);
1111 ApplyViewFilters;
1112 RefreshList;
1113 lstProbPick.ItemIndex := -1;
1114 if (ProbRec <> nil) and (ProbRec.PIFN <> '') then
1115 begin
1116 for i := 0 to wgProbData.Items.count-1 do
1117 if (Piece(MString(i), U, 1) = ProbRec.PIFN) then
1118 wgProbData.ItemIndex := i ;
1119 wgProbDataClick(Self);
1120 end
1121 else
1122 wgProbData.ItemIndex := -1;
1123 if (wgProbData.Items.Count > 0) and (wgProbData.ItemIndex > -1) then
1124 RowSelected
1125 else
1126 NoRowSelected;
1127 pnlRightResize(Self);
1128 if (not FWarningShown) and (inact > 0) and (CharAt(UpperCase(Status), 1) in ['A', 'B']) then
1129 begin
1130 InfoBox('There are ' + IntToStr(inact) + ' active problem(s) flagged with a "#" as having' + #13#10 +
1131 'inactive ICD codes as of today''s date. Please correct these' + #13#10 +
1132 'problems using the "Change" option.', 'Inactive ICD Codes Found', MB_ICONWARNING or MB_OK);
1133 FWarningShown := True;
1134 end;
1135 finally
1136 CmtList.Free;
1137 end;
1138end;
1139
1140procedure TfrmProblems.LoadUserCats(AList:TStringList);
1141begin
1142 if not PLUser.usUseLexicon then exit; {Bail out if not to use lexicon}
1143 Alist.clear;
1144 FastAssign(UserProblemCategories(Encounter.Provider,Encounter.Location), AList) ;
1145 if Alist.count = 0 then
1146 begin
1147 lstCatPick.Items.Add('-1^None defined - use OTHER') ;
1148 lstProbPick.Visible := False ;
1149 lblProblems.Visible := False ;
1150 exit ;
1151 end ;
1152 FastAssign(AList, lstCatPick.Items);
1153 lstCatPick.itemindex := 0;
1154 lstCatPickClick(frmProblems);
1155end;
1156
1157procedure TfrmProblems.LoadUserProbs(AList:TStringList);
1158var
1159 catien: string;
1160begin
1161 if not PLUser.usUseLexicon then exit; {Bail out if not to use lexicon}
1162 if lstCatPick.itemindex < 0 then exit; {bail out}
1163 Alist.clear;
1164 catien := IntToStr(lstCatPick.itemIEN);
1165 FastAssign(UserProblemList(catien), AList) ;
1166 {File 125.12, Each line contains: PROBLEM^DISPLAY TEXT^CODE^CODE IFN }
1167 {code ifn is derived}
1168 FastAssign(Alist, lstProbPick.Items);
1169end;
1170
1171procedure TfrmProblems.LoadProblems;
1172var
1173 AList: TStringList;
1174 i: integer;
1175begin
1176 pProviderID := 0;
1177 AList := TStringList.Create;
1178 try
1179 lstView.ItemIndex := -1;
1180 StatusText('Retrieving problem list...') ;
1181 if (PLUser = nil) or InitPatient then LoadUserParams(Alist);
1182 Alist.clear;
1183 if Patient.DFN <> '' then LoadPatientParams(Alist);
1184 Alist.clear;
1185 LoadPatientProblems(AList,PlUser.usViewAct[1],true); {initialize patient list}
1186 lstView.ItemIndex := -1;
1187 AList.clear;
1188 lstCatPick.Clear ;
1189 LoadUserCats(AList);
1190 {SET APPLICATION DEFAULTS}
1191 if (not PLUser.usPrimeUser) then
1192 begin {activities available to GMPLUSER only}
1193 mnuActRestore.enabled := False;
1194 mnuActRemove.enabled:=false;
1195 mnuViewRemoved.Enabled := False;
1196 popRemove.enabled:=false;
1197 popRestore.enabled := False;
1198 i := lstView.Items.IndexOf('Removed');
1199 if i > -1 then lstView.Items.Delete(i);
1200 mnuActVerify.enabled:=false;
1201 popVerify.enabled:=false;
1202 end;
1203 if (not PLUser.usVerifyTranscribed) then
1204 begin
1205 mnuActVerify.enabled:=false;
1206 popVerify.enabled:=false;
1207 end;
1208 finally
1209 AList.Free;
1210 StatusText('') ;
1211 end;
1212end;
1213
1214function TfrmProblems.HighlightDuplicate( NewProb: string; const Msg: string;
1215 DlgType: TMsgDlgType; Action: string): boolean;
1216var
1217 dup: string;
1218 cmplist: TstringList;
1219 cmpp, i: integer;
1220 collapserow: boolean;
1221begin
1222 Result := False;
1223 if Piece(newprob, U, 1) = '' then
1224 dup := CheckForDuplicateProblem('1', Piece(newprob, U, 2))
1225 else
1226 dup := CheckForDuplicateProblem(Piece(newprob,U,1), Piece(newprob, U, 2));
1227
1228 if (Piece(dup, U, 1) <> '0') then
1229 // if adding, check all existing problems for duplicates
1230 // if changing, exclude curent problem from duplicate check
1231 if (Action = 'ADD') or ((Action = 'CHANGE') and (Piece(dup, U, 1) <> ProbRec.PIFN)) then
1232 begin
1233 if (Piece(dup, U, 2) <> PLUser.usViewAct) and (PLUser.usViewAct <> 'B') then
1234 begin
1235 lstView.SelectByID(Piece(dup, U, 2));
1236 lstViewClick(Self);
1237 end;
1238 cmplist:=Tstringlist.create;
1239 try {find and highlight duplicate problem - match problem text minus trailing '*'}
1240 for i := 0 to FAllProblems.Count - 1 do
1241 cmpList.Add(TrimRight(Piece(Piece(Piece(FAllProblems[i], U, 3), #13, 1), '*', 1)));
1242 cmpp:=cmpList.indexof(TrimRight(Piece(Piece(newprob, U, 2), '*', 1)));
1243 finally
1244 cmplist.free;
1245 end;
1246 if cmpp > -1 then
1247 begin
1248 collapserow:= (FProblemsVisible[cmpp] <> 'Y');
1249 if CollapseRow then
1250 wgProbData.Items.Insert(0, FAllProblems[cmpp]);
1251 //translate from FAllProblems index to wgProbData index
1252 for i := 0 to wgProbData.Items.Count - 1 do
1253 begin
1254 if StrToInt(FItemData[i]) = cmpp then with wgProbData do
1255 begin
1256 TopIndex := i;
1257 ItemIndex := i;
1258 Selected[i] := True;
1259 break;
1260 end;
1261 end;
1262 case DlgType of
1263 mtInformation:
1264 InfoBox(Msg, 'Information', MB_OK or MB_ICONINFORMATION);
1265 mtConfirmation:
1266 Result := InfoBox(Msg, 'Confirmation', MB_YESNO or MB_ICONQUESTION) <> IDYES;
1267 end;
1268 if collapserow then wgProbData.Items.Delete(0);
1269 end;
1270 end;
1271end;
1272
1273procedure TfrmProblems.AddProblem;
1274const
1275 TX799 = '799.9';
1276var
1277 newprob: string;
1278begin
1279 if (PLPt.ptDead<>'') then {Check for dead patient}
1280 if InfoBox('This Patient has been deceased since ' + PLPt.ptDead + #13#10 +
1281 ' Proceed with problem addition?', 'Confirmation', MB_YESNO or MB_ICONQUESTION) = IDNO then
1282 exit; {bail out - if don't want to add to dead}
1283 {problems are in the form of: ien^.01^icd^icdifn , although only the .01 is required}
1284 if PLProblem <> '' then
1285 begin
1286 newProb:=PLProblem;
1287 PLProblem:='';
1288 end
1289 else if edProbEnt.text<>'' then
1290 begin
1291 newprob:= u + edProbEnt.text + u + TX799 + u; {free text problem entry from editbox}
1292 edProbEnt.Visible := False;
1293 lblProbEnt.Visible := False;
1294 edProbEnt.Text := '';
1295 end
1296 else if lstProbPick.itemindex > -1 then {problem selected from user list}
1297 {Each line contains: PROBLEM^DISPLAY TEXT^CODE^CODE IFN }
1298 newprob:=lstProbPick.Items[lstProbPick.itemindex];
1299 if NewProb='' then exit; {should never happen}
1300 bbCancel.Enabled := False ;
1301 bbOtherProb.enabled:=false; {don't let them invoke lexicon till add completed}
1302
1303 // ============= new duplicate checking code ===================
1304 if HighlightDuplicate(NewProb, 'This problem is a duplicate of the highlighted problem'
1305 + #13#10 + ' Proceed?', mtConfirmation, 'ADD') then
1306 begin
1307 bbCancel.Enabled := True ;
1308 bbOtherProb.enabled:=true; {don't let them invoke lexicon till add completed}
1309 exit; {bail out - if don't want dups}
1310 end ;
1311//============================== End new code =========================
1312 if ProbRec = nil then
1313 begin
1314 pnlRight.Caption := lblProbList.caption ;
1315 lblProbList.caption:='Add Problem';
1316 wgProbData.Caption := lblProbList.Caption;
1317 pnlProbDlg.Visible := True;
1318 pnlProbDlg.BringToFront ;
1319 dlgProbs:=TFrmDlgProb.create(pnlProbDlg);
1320 dlgProbs.HorzScrollBar.Range := dlgProbs.ClientWidth;
1321 dlgProbs.VertScrollBar.Range := dlgProbs.ClientHeight;
1322 dlgProbs.parent:=pnlProbDlg;
1323 dlgProbs.Align := alClient ;
1324 dlgProbs.Reason:='A';
1325 dlgProbs.SubjProb:=newprob;
1326 dlgProbs.show;
1327 PostMessage(dlgProbs.Handle, UM_TAKEFOCUS, 0, 0);
1328 end
1329 else
1330 InfoBox('Current Add/Edit/Display activity must be completed' + #13#10 +
1331 'before another record may be added',
1332 'Information', MB_OK or MB_ICONINFORMATION);
1333end;
1334
1335procedure TfrmProblems.EditProblem(const why: char);
1336var
1337 prob: string;
1338 reas: string;
1339begin
1340 prob := Piece(MString(wgProbData.ItemIndex), U, 1);
1341 if (prob <> '') and (ProbRec = nil) then
1342 begin
1343 StatusText('Retrieving selected problem...') ;
1344 bbCancel.Enabled := False ;
1345 bbOtherProb.enabled := false; {don't let them invoke lexicon till edit completed}
1346 case why of
1347 'E','e','C','c' : reas := 'Edit Problem';
1348 'D','d' : reas := 'Display Problem';
1349 'R','r' : reas := 'Remove Problem';
1350 end;
1351 pnlRight.Caption := lblProbList.caption ;
1352 lblProbList.caption := reas;
1353 wgProbData.Caption := lblProbList.Caption;
1354 pnlProbDlg.Visible := True;
1355 pnlProbDlg.BringToFront ;
1356 dlgProbs := TFrmDlgProb.create(pnlProbDlg);
1357 dlgProbs.HorzScrollBar.Range := dlgProbs.ClientWidth;
1358 dlgProbs.VertScrollBar.Range := dlgProbs.ClientHeight;
1359 dlgProbs.parent := pnlProbDlg;
1360 dlgProbs.Align := alClient ;
1361 dlgProbs.Reason := why;
1362 with wgProbData do dlgProbs.subjProb:=prob + u + Piece(Piece(MString(itemindex), U, 3), #13, 1) + u + Piece(MString(itemindex), U, 14);
1363 StatusText('') ;
1364 dlgProbs.Show;
1365 PostMessage(dlgProbs.Handle, UM_TAKEFOCUS, 0, 0);
1366 end
1367 else
1368 begin
1369 case why of
1370 'E','e','C','c' : reas := 'Edited';
1371 'D','d' : reas := 'Displayed';
1372 'R','r' : reas := 'Removed';
1373 end;
1374 InfoBox('Current Add/Edit/Display activity must be completed' + #13#10 +
1375 'before another record may be ' + reas,
1376 'Information', MB_OK or MB_ICONINFORMATION);
1377 end;
1378end;
1379
1380procedure TfrmProblems.UpdateProblem(const why:char; Line: string; AllProblemsIndex: integer);
1381var
1382 Alist: TstringList;
1383 ProblemIFN: string;
1384 sv: string;
1385 i: integer;
1386
1387begin
1388 alist := TstringList.create;
1389 try
1390 problemIFN := Piece(Line, U, 1);
1391 {get the basic info - could shortcut, but try this for now}
1392 FastAssign(EditLoad(ProblemIFN, pProviderID, PLPt.ptVAMC), AList) ;
1393 probRec := TProbrec.create(Alist);
1394 probRec.PIFN := problemIFN;
1395 ProbRec.RespProvider.DHCPtoKeyVal(inttostr(Encounter.Provider) + u + Encounter.ProviderName); {REV - V13}
1396 Alist.clear;
1397 case why of
1398 'I': begin
1399 ProbRec.status := 'I';
1400 {assume resolution date now with this option. user should do full edit otherwise}
1401 ProbRec.DateResStr := 'T';
1402 Probrec.DateModStr := 'T';
1403 FastAssign(ProblemUpdate(ProbRec.AltFilerObject), AList) ;
1404 end;
1405 'V': begin
1406 if not IsActiveICDCode(ProbRec.Diagnosis.extern) then
1407 begin
1408 InfoBox(TX_INACTIVE_CODE, TC_INACTIVE_CODE, MB_ICONWARNING or MB_OK);
1409 exit;
1410 end;
1411 Probrec.condition := 'P';
1412 Probrec.DateModStr := 'T';
1413 FastAssign(ProblemVerify(ProbRec.PIFN), AList) ;
1414 end;
1415 end;
1416
1417 if Alist.count<1 then {show error message}
1418 InfoBox('Unable to update record ', 'Information', MB_OK or MB_ICONINFORMATION)
1419 else if Alist[0]<'1' then
1420 InfoBox('Unable to update record: ' + #13#10 + ' ' + Alist[1] + ' (' + Probrec.PIFN + ')',
1421 'Information', MB_OK or MB_ICONINFORMATION)
1422 {show inactivated problem}
1423 else if (why='I') then
1424 begin
1425 if (PlUser.usViewAct='A') then
1426 FProblemsVisible[AllProblemsIndex] := 'N'
1427 else
1428 begin
1429 SetPiece(line, U, 2, 'I');
1430 FAllProblems[AllProblemsIndex] := line;
1431 end;
1432 end
1433 else if (why='V') then {show verified problem}
1434 begin
1435 sv := Piece(Line, U, 2);
1436 SetPiece(line, U, 2, Copy(sv,1,4)); //remove (u)
1437 FAllProblems[AllProblemsIndex] := line;
1438 end;
1439 finally
1440 with frmCover do
1441 for i := ComponentCount - 1 downto 0 do
1442 begin
1443 if Components[i] is TORListBox then
1444 begin
1445 case Components[i].Tag of
1446 10: ListActiveProblems((Components[i] as TORListBox).Items);
1447 end;
1448 end;
1449 end;
1450 alist.free;
1451 ProbRec.free;
1452 ProbRec := nil;
1453 end;
1454end;
1455
1456procedure TfrmProblems.RestoreProblem;
1457const
1458 TC_RESTORE_EDIT = 'Unable to restore';
1459 TX_RESTORE_EDIT = 'This problem references an inactive ICD code,' + #13#10 +
1460 'and must be updated using the ''Change'' option' + #13#10 +
1461 'before it can be restored.' + #13#10 + #13#10 +
1462 'Would you like to edit this problem?';
1463var
1464 Alist:TstringList;
1465 i: integer;
1466 AProbRec: TProbRec;
1467 ProblemIFN: string;
1468begin
1469 Alist := TStringList.create;
1470 ProblemIFN := Piece(MString(wgProbData.ItemIndex), U, 1);
1471 FastAssign(EditLoad(ProblemIFN, pProviderID, PLPt.ptVAMC), AList) ;
1472 AProbRec:=TProbRec.Create(Alist); {create a problem object}
1473 try
1474 if not IsActiveICDCode(AProbRec.Diagnosis.extern) then
1475 begin
1476 if InfoBox(TX_RESTORE_EDIT, TC_RESTORE_EDIT, MB_YESNO or MB_ICONWARNING) = IDYES then
1477 begin
1478 AProbRec.Status := 'A';
1479 EditProblem('C');
1480 end
1481 else
1482 Exit;
1483 end
1484 else
1485 begin
1486 FastAssign(ProblemReplace(ProblemIFN), Alist) ;
1487 if Alist[0] <> '1' then
1488 InfoBox('Unable to restore the problem record: ' + #13#10 + ' (' + AProbrec.PIFN + ')',
1489 'Information', MB_OK or MB_ICONINFORMATION)
1490 else
1491 LoadPatientProblems(AList, 'R', False);
1492 GetRowCount;
1493 end;
1494 finally
1495 with frmCover do
1496 for i := ComponentCount - 1 downto 0 do
1497 begin
1498 if Components[i] is TORListBox then
1499 begin
1500 case Components[i].Tag of
1501 10: ListActiveProblems((Components[i] as TORListBox).Items);
1502 end;
1503 end;
1504 end;
1505 AList.free;
1506 AProbRec.Free;
1507 end;
1508end;
1509
1510procedure TfrmProblems.NoRowSelected;
1511begin
1512 mnuActDetails.enabled := false;
1513 mnuActChange.enabled := false;
1514 mnuActVerify.enabled := false;
1515 mnuActInactivate.enabled := false;
1516 mnuActRestore.enabled := false;
1517 mnuActRemove.enabled := false;
1518 mnuActAnnotate.enabled := false;
1519 popChange.enabled := false;
1520 popVerify.enabled := false;
1521 popInactivate.enabled := false;
1522 popRestore.enabled := false;
1523 popRemove.enabled := false;
1524 popAnnotate.enabled := false;
1525 popViewDetails.enabled := False;
1526end ;
1527
1528procedure TfrmProblems.RowSelected;
1529var
1530 AnyUnver, AnyAct: integer;
1531 i: integer;
1532begin
1533 if wgProbData.SelCount > 1 then
1534 begin
1535 mnuActDetails.enabled := false;
1536 mnuActChange.enabled := false;
1537 mnuActRestore.enabled := false;
1538 mnuActRemove.enabled := false;
1539 mnuActAnnotate.enabled := false;
1540 popChange.enabled := false;
1541 popRestore.enabled := false;
1542 popRemove.enabled := false;
1543 popAnnotate.enabled := false;
1544 popViewDetails.enabled := false;
1545 AnyUnver := 0;
1546 AnyAct := 0;
1547 for i := 0 to wgProbData.Count - 1 do
1548 begin
1549 if wgProbData.Selected[i] and (Copy(Piece(MString(i), U, 2),5,3)='(u)') then
1550 AnyUnver := AnyUnVer + 1;
1551 if wgProbData.Selected[i] and (Copy(Piece(MString(i), U, 2),1,1) = 'A') then
1552 AnyAct := AnyAct + 1;
1553 end;
1554 mnuActVerify.enabled := PLUser.usVerifyTranscribed and
1555 PLUser.usPrimeUser and (AnyUnver > 0);
1556 popVerify.enabled := PLUser.usVerifyTranscribed and
1557 PLUser.usPrimeUser and (AnyUnver > 0);
1558 mnuActInactivate.enabled := (AnyAct > 0);
1559 popInactivate.enabled := (AnyAct > 0);
1560 end
1561 else
1562 begin
1563 mnuActDetails.enabled := true;
1564 mnuActChange.enabled := true;
1565 mnuActRestore.enabled := PLUser.usPrimeUser;
1566 mnuActRemove.enabled := PLUser.usPrimeUser;
1567 mnuActAnnotate.enabled := true;
1568 popChange.enabled := true;
1569 popRestore.enabled := PLUser.usPrimeUser;
1570 popRemove.enabled := PLUser.usPrimeUser;
1571 popAnnotate.enabled := true;
1572 popViewDetails.enabled := true ;
1573 mnuActVerify.enabled := PLUser.usVerifyTranscribed and
1574 PLUser.usPrimeUser and
1575 (Copy(Piece(MString(wgProbData.ItemIndex), U, 2),5,3)='(u)') ;
1576 popVerify.enabled := PLUser.usVerifyTranscribed and
1577 PLUser.usPrimeUser and
1578 (Copy(Piece(MString(wgProbData.ItemIndex), U, 2),5,3)='(u)') ;
1579 mnuActInactivate.enabled := Copy(Piece(MString(wgProbData.ItemIndex), U, 2),1,1) = 'A' ;
1580 popInactivate.enabled := Copy(Piece(MString(wgProbData.ItemIndex), U, 2),1,1) = 'A' ;
1581 end;
1582
1583 //Disable menu actions for REMOVED problems list display
1584 if PLUser.usViewAct = 'R' then
1585 begin
1586 mnuActAnnotate.Enabled := False;
1587 mnuActChange.Enabled := False;
1588 mnuActInactivate.Enabled := False;
1589 mnuActRemove.Enabled := False;
1590 mnuActVerify.Enabled := False;
1591 popAnnotate.Enabled := False;
1592 popChange.Enabled := False;
1593 popInactivate.Enabled := False;
1594 popRemove.Enabled := False;
1595 popVerify.Enabled := False;
1596 end;
1597end ;
1598
1599procedure TfrmProblems.bbCancelClick(Sender: TObject);
1600begin
1601 inherited;
1602 //Hide Panels
1603 pnlButtons.Hide;
1604 pnlButtons.SendToBack;
1605 pnlProbCats.Hide;
1606 pnlProbCats.SendToBack;
1607
1608 //Show pnlView & Add Back to tab Order
1609 ShowPnlView;
1610end;
1611
1612procedure TfrmProblems.lstViewClick(Sender: TObject);
1613begin
1614 inherited;
1615 case lstView.ItemIndex of
1616 0: tag := 700 ; {Active}
1617 1: tag := 800 ; {Inactive}
1618 2: tag := 900 ; {Both}
1619 3: tag := 950 ; {Removed}
1620{ 4: tag := 975 ; {Filters...}
1621 end ;
1622 lstProbActsClick(Self) ;
1623 mnuOptimizeFieldsClick(self);
1624end;
1625
1626function EncounterPresent: Boolean;
1627{ make sure a location and provider are selected, returns false if not }
1628begin
1629 Result := True;
1630 if (Encounter.Provider = 0) or (Encounter.Location = 0) then
1631 begin
1632 UpdateEncounter(NPF_ALL); {*KCM*}
1633 frmFrame.DisplayEncounterText;
1634 end;
1635 if (Encounter.Provider = 0) or (Encounter.Location = 0) then
1636 begin
1637 if not frmFrame.CCOWDrivedChange then
1638 InfoBox(TX_PROV_LOC, TC_PROV_LOC, MB_OK or MB_ICONWARNING); {!!!}
1639 Result := False;
1640 end;
1641end;
1642
1643procedure TfrmProblems.FormDestroy(Sender: TObject);
1644begin
1645 ClearGrid;
1646 FItemData.Free;
1647 FAllProblems.Free;
1648 FProblemsVisible.Free;
1649 inherited;
1650end;
1651
1652procedure TfrmProblems.mnuViewSaveClick(Sender: TObject);
1653begin
1654 inherited;
1655 if PLPt = nil then
1656 begin
1657 InfoBox(TX_INVALID_PATIENT, TC_NO_PATIENT, MB_OK or MB_ICONWARNING);
1658 Exit;
1659 end;
1660 if InfoBox('Replace current defaults?','Confirmation', MB_YESNO or MB_ICONQUESTION) = IDYES then
1661 begin
1662 with PLUser do
1663 begin
1664 usDefaultContext := FContextString;
1665 usDefaultView := Piece(FFilterString, '/', 1);
1666 end;
1667 SaveViewPreferences(FFilterString + U + FContextString);
1668 end;
1669end;
1670
1671procedure TfrmProblems.mnuViewRestoreDefaultClick(Sender: TObject);
1672begin
1673 inherited;
1674 if PLPt = nil then
1675 begin
1676 InfoBox(TX_INVALID_PATIENT, TC_NO_PATIENT, MB_OK or MB_ICONWARNING);
1677 Exit;
1678 end;
1679 if PLFilters <> nil then
1680 begin
1681 PLFilters.Destroy;
1682 PLFilters := nil;
1683 end;
1684 if PLUser <> nil then
1685 begin
1686 PLUser.Destroy;
1687 PLUser := nil;
1688 end;
1689 ShowPnlView;
1690 LoadProblems ;
1691end;
1692
1693procedure TfrmProblems.mnuViewCommentsClick(Sender: TObject);
1694var
1695 x, line, comments: string;
1696 i, j: integer;
1697begin
1698 inherited;
1699 if PLPt = nil then
1700 begin
1701 InfoBox(TX_INVALID_PATIENT, TC_NO_PATIENT, MB_OK or MB_ICONWARNING);
1702 Exit;
1703 end;
1704 mnuViewComments.Checked := not mnuViewComments.Checked;
1705 SetPiece(FContextString, ';', 4, BOOLCHAR[mnuViewComments.Checked]);
1706 PLUser.usViewComments := BOOLCHAR[mnuViewComments.Checked];
1707 with FAllProblems do
1708 begin
1709 for i := 0 to Count - 1 do
1710 begin
1711 if Objects[i] = nil then continue;
1712 x := Piece(Piece(Strings[i], U, 3), #13, 1);
1713 if PLUser.usViewComments = '1' then
1714 begin
1715 comments := '';
1716 for j := 0 to TStringList(Objects[i]).Count - 1 do
1717 comments := comments + ' ' + TStringList(Objects[i]).Strings[j] + #13#10;
1718 //comments := comments + ' CMT: ' + TStringList(Items.Objects[i]).Strings[j] + #13#10;
1719 Line := Strings[i];
1720 SetPiece(Line, U, 3, x + #13#10 + comments);
1721 Strings[i] := Line;
1722 end
1723 else
1724 begin
1725 Line := Strings[i];
1726 SetPiece(Line, U, 3, x);
1727 Strings[i] := Line;
1728 end;
1729 end;
1730 end;
1731 RefreshList;
1732end;
1733
1734procedure TfrmProblems.RequestPrint;
1735begin
1736 inherited;
1737 if PLPt = nil then
1738 begin
1739 InfoBox(TX_INVALID_PATIENT, TC_NO_PATIENT, MB_OK or MB_ICONWARNING);
1740 Exit;
1741 end;
1742 uReportType := '';
1743 PrintReports(IntToStr(RPT_PROBLIST), 'Problem List')
1744end;
1745
1746procedure TfrmProblems.SetFontSize( NewFontSize: integer);
1747var
1748 OldParent: TWinControl;
1749begin
1750 OldParent := nil;
1751 if Assigned(dlgProbs) then begin
1752 OldParent := dlgProbs.Parent;
1753 dlgProbs.Parent := nil;
1754 end;
1755 try
1756 {These labels are hidden in an ORAutoPanel, so have to be sized manually}
1757 lblProbCats.Height := ResizeHeight( Font, MainFont, lblProbCats.Height);
1758 lblProblems.Height := ResizeHeight( Font, MainFont, lblProblems.Height);
1759 inherited SetFontSize( NewFontSize);
1760 finally
1761 if Assigned(dlgProbs) then
1762 dlgProbs.Parent := OldParent;
1763 end;
1764 if Assigned(dlgProbs) then
1765 dlgProbs.SetFontSize( MainFontSize);
1766 mnuOptimizeFieldsClick(self);
1767end;
1768
1769procedure TfrmProblems.RefreshList;
1770var
1771 i: integer;
1772begin
1773 RedrawSuspend(wgProbData.Handle);
1774 wgProbData.Clear;
1775 FItemData.Clear;
1776 for i := 0 to FAllProblems.Count-1 do
1777 if FProblemsVisible[i] = 'Y' then begin
1778 FItemData.Add(IntToStr(i));
1779 if Piece(FAllProblems[i], U, 1) <> '' then
1780 wgProbData.Items.Add(PlainText(FAllProblems[i]))
1781 else
1782 wgProbData.Items.Add(FAllProblems[i]);
1783 end;
1784 wgProbData.Invalidate;
1785 RedrawActivate(wgProbData.Handle);
1786end;
1787
1788procedure TfrmProblems.wgProbDataMeasureItem(Control: TWinControl;
1789 Index: Integer; var Height: Integer);
1790var
1791 ARect: TRect;
1792 x: string;
1793 NewHeight: Integer;
1794begin
1795 inherited;
1796 NewHeight := Height;
1797 with wgProbData do if Index < Items.Count then
1798 begin
1799 ARect := ItemRect(Index);
1800 ARect.Left := HeaderControl.Sections[0].Width + HeaderControl.Sections[1].Width + 2;
1801 ARect.Right := ARect.Left + HeaderControl.Sections[2].Width - 6;
1802 x := Piece(MString(Index), U, 3);
1803 NewHeight := WrappedTextHeightByFont( Canvas, Font, x, ARect);
1804 if NewHeight > 255 then NewHeight := 255; // windows appears to only look at 8 bits *KCM*
1805 if NewHeight < 13 then NewHeight := 13; // show at least one line *KCM*
1806 end; {if Index}
1807 Height := NewHeight;
1808end;
1809
1810procedure TfrmProblems.wgProbDataDrawItem(Control: TWinControl;
1811 Index: Integer; Rect: TRect; State: TOwnerDrawState);
1812var
1813 i: integer;
1814begin
1815 inherited;
1816 with wgProbData do if Index < Items.Count then
1817 begin
1818 ListGridDrawLines(wgProbData, HeaderControl, Index, State);
1819 for i := 0 to HeaderControl.Sections.Count -1 do
1820 ListGridDrawCell(wgProbData, HeaderControl, Index, i, Piece(MString(Index),U,i+1), i = 2);
1821 end; {if Index}
1822end;
1823
1824function TfrmProblems.PlainText(MString: string): string;
1825var
1826 i: integer;
1827begin
1828 result := '';
1829 with HeaderControl do
1830 for i := 0 to Sections.Count -1 do
1831 if Sections[i].MaxWidth > 0 then
1832 if Trim(Piece(MString, U, i+1)) <> '' then
1833 result := result + Sections[i].Text + ': ' + Piece(MString, U, i+1) + CRLF;
1834end;
1835
1836function TfrmProblems.MString(index: integer): string;
1837begin
1838 if index = -1 then
1839 result := ''
1840 else
1841 result := FAllProblems[StrToInt(FItemData[index])];
1842end;
1843
1844procedure TfrmProblems.HeaderControlSectionResize(
1845 HeaderControl: THeaderControl; Section: THeaderSection);
1846begin
1847 inherited;
1848 wgProbData.Invalidate;
1849 {FEvtColWidth := HeaderControl.Sections[0].Width; //code from fOrders
1850 RedrawSuspend(Self.Handle);
1851 //RedrawOrderList;
1852 RedrawActivate(Self.Handle);
1853 wgProbData.Invalidate;
1854 pnlRight.Refresh;
1855 pnlLeft.Refresh; }
1856end;
1857
1858{Tab Order tricks. Need to change
1859 lstView
1860
1861 bbNewProb
1862 bbOtherProb
1863 bbCancel
1864
1865 pnlProbDlg
1866 wgProbData
1867
1868to
1869 lstView
1870
1871 pnlProbDlg
1872 wgProbData
1873
1874 bbNewProb
1875 bbOtherProb
1876 bbCancel
1877}
1878
1879procedure TFrmProblems.lstViewExit(Sender: TObject);
1880begin
1881 inherited;
1882 if IncSecond(FMousing,1) < Now then
1883 begin
1884 if (Screen.ActiveControl = bbNewProb) or
1885 (Screen.ActiveControl = bbOtherProb) or
1886 (Screen.ActiveControl = bbCancel) then
1887 FindNextControl( bbCancel, True, True, False).SetFocus;
1888 end;
1889 FMousing := 0;
1890end;
1891
1892procedure TFrmProblems.pnlRightExit(Sender: TObject);
1893begin
1894 inherited;
1895 if IncSecond(FMousing,1) < Now then
1896 begin
1897 if (Screen.ActiveControl = frmFrame.pnlPatient) then
1898 begin
1899 if lstView.Visible then
1900 FindNextControl( lstView, True, True, False).SetFocus
1901 else
1902 FindNextControl( edProbEnt, True, True, False).SetFocus
1903 end
1904 else
1905 if (Screen.ActiveControl = bbNewProb) or
1906 (Screen.ActiveControl = bbOtherProb) or
1907 (Screen.ActiveControl = bbCancel) then
1908 begin
1909 if bbNewProb.Visible then
1910 FindNextControl( bbNewProb, False, True, False).SetFocus
1911 else
1912 FindNextControl( bbOtherProb, False, True, False).SetFocus;
1913 end;
1914 end;
1915 FMousing := 0;
1916end;
1917
1918procedure TFrmProblems.bbNewProbExit(Sender: TObject);
1919begin
1920 inherited;
1921 if IncSecond(FMousing,1) < Now then
1922 begin
1923 if (Screen.ActiveControl = pnlProbDlg) or
1924 (Screen.ActiveControl = wgProbData) then
1925 frmFrame.pnlPatient.SetFocus
1926 else
1927 if (Screen.ActiveControl = lstView) or
1928 (Screen.ActiveControl = lstCatPick) then
1929 FindNextControl( frmFrame.pnlPatient, False, True, False).SetFocus;
1930 end;
1931 FMousing := 0;
1932end;
1933
1934procedure TFrmProblems.frmFramePnlPatientExit(Sender: TObject);
1935begin
1936 FOldFramePnlPatientExit(Sender);
1937 inherited;
1938 if IncSecond(FMousing,1) < Now then
1939 begin
1940 if (Screen.ActiveControl = pnlProbDlg) or
1941 (Screen.ActiveControl = wgProbData) then
1942 FindNextControl( pnlProbDlg, False, True, False).SetFocus;
1943 end;
1944 FMousing := 0;
1945end;
1946
1947procedure TFrmProblems.FormHide(Sender: TObject);
1948begin
1949 inherited;
1950 frmFrame.pnlPatient.OnExit := FOldFramePnlPatientExit;
1951end;
1952
1953procedure TFrmProblems.FormShow(Sender: TObject);
1954begin
1955 inherited;
1956 FOldFramePnlPatientExit := frmFrame.pnlPatient.OnExit;
1957 frmFrame.pnlPatient.OnExit := frmFramePnlPatientExit;
1958end;
1959
1960procedure TfrmProblems.FormMouseMove(Sender: TObject; Shift: TShiftState;
1961 X, Y: Integer);
1962begin
1963 inherited;
1964 FMousing := Now;
1965end;
1966
1967procedure TfrmProblems.ShowPnlView;
1968begin
1969 pnlView.BringToFront;
1970 pnlView.Show;
1971 lstView.TabStop := true;
1972 bbNewProb.TabStop := true;
1973end;
1974
1975procedure TfrmProblems.ViewInfo(Sender: TObject);
1976begin
1977 inherited;
1978 frmFrame.ViewInfo(Sender);
1979end;
1980
1981procedure TfrmProblems.mnuViewInformationClick(Sender: TObject);
1982begin
1983 inherited;
1984 mnuViewDemo.Enabled := frmFrame.pnlPatient.Enabled;
1985 mnuViewVisits.Enabled := frmFrame.pnlVisit.Enabled;
1986 mnuViewPrimaryCare.Enabled := frmFrame.pnlPrimaryCare.Enabled;
1987 mnuViewMyHealtheVet.Enabled := not (Copy(frmFrame.laMHV.Hint, 1, 2) = 'No');
1988 mnuInsurance.Enabled := not (Copy(frmFrame.laVAA2.Hint, 1, 2) = 'No');
1989 mnuViewFlags.Enabled := frmFrame.lblFlag.Enabled;
1990 mnuViewRemoteData.Enabled := frmFrame.lblCirn.Enabled;
1991 mnuViewReminders.Enabled := frmFrame.pnlReminders.Enabled;
1992 mnuViewPostings.Enabled := frmFrame.pnlPostings.Enabled;
1993end;
1994
1995procedure TfrmProblems.mnuOptimizeFieldsClick(Sender: TObject);
1996var
1997 totalSectionsWidth, unitvalue: integer;
1998begin
1999 totalSectionsWidth := pnlRight.Width - 3;
2000 if totalSectionsWidth < 16 then exit;
2001 unitvalue := round(totalSectionsWidth / 16);
2002 with HeaderControl do
2003 begin
2004 if Sections[1].Width > 0 then Sections[1].Width := unitvalue;
2005 Sections[2].Width := pnlRight.Width - (unitvalue * 11) - 5;
2006 Sections[3].Width := unitvalue * 2;
2007 Sections[4].Width := unitvalue * 2;
2008 if Sections[6].Width > 0 then Sections[6].Width := unitvalue;
2009 if Sections[7].Width > 0 then Sections[7].Width := unitvalue * 2;
2010 if Sections[8].Width > 0 then Sections[8].Width := unitvalue * 2;
2011 if Sections[15].Width > 0 then Sections[15].Width := unitvalue;
2012 end;
2013 HeaderControlSectionResize(HeaderControl, HeaderControl.Sections[0]);
2014 HeaderControl.Repaint;
2015end;
2016
2017procedure TfrmProblems.HeaderControlSectionClick(
2018 HeaderControl: THeaderControl; Section: THeaderSection);
2019begin
2020 inherited;
2021 //if Section = HeaderControl.Sections[1] then
2022 mnuOptimizeFieldsClick(self);
2023end;
2024
2025procedure TfrmProblems.HeaderControlMouseUp(Sender: TObject;
2026 Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
2027var
2028 i: integer;
2029 totalSectionsWidth, originalwidth: integer;
2030begin
2031 inherited;
2032 totalSectionsWidth := getTotalSectionsWidth;
2033 if totalSectionsWidth > wgProbData.Width - 5 then
2034 begin
2035 originalwidth := 0;
2036 for i := 0 to HeaderControl.Sections.Count - 1 do
2037 originalwidth := originalwidth + origWidths[i];
2038 if originalwidth < totalSectionsWidth then
2039 begin
2040 for i := 0 to HeaderControl.Sections.Count - 1 do
2041 HeaderControl.Sections[i].Width := origWidths[i];
2042 wgProbData.Invalidate;
2043 end;
2044 end;
2045end;
2046
2047function TfrmProblems.getTotalSectionsWidth : integer;
2048var
2049 i: integer;
2050begin
2051 Result := 0;
2052 for i := 0 to HeaderControl.Sections.Count - 1 do
2053 Result := Result + HeaderControl.Sections[i].Width;
2054end;
2055
2056procedure TfrmProblems.HeaderControlMouseDown(Sender: TObject;
2057 Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
2058begin
2059 inherited;
2060 setSectionWidths;
2061end;
2062
2063procedure TfrmProblems.setSectionWidths;
2064var
2065 i: integer;
2066begin
2067 for i := 0 to 15 do
2068 origWidths[i] := HeaderControl.Sections[i].Width;
2069end;
2070
2071procedure TfrmProblems.sptHorzMoved(Sender: TObject);
2072begin
2073 inherited;
2074 mnuOptimizeFieldsClick(self);
2075end;
2076
2077initialization
2078 SpecifyFormIsNotADialog(TfrmProblems);
2079
2080end.
2081
2082
Note: See TracBrowser for help on using the repository browser.