source: cprs/branches/foia-cprs/CPRS-Chart/fProbs.pas@ 1381

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

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