close Warning: Can't use blame annotator: 
svn blame failed on cprs/branches/tmg-cprs/CPRS-Chart/fProbs.pas: 'GenericSWIGWrapper' object has no attribute '_wrap'

source: cprs/branches/tmg-cprs/CPRS-Chart/fProbs.pas@ 1156

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

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