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

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

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