source: cprs/trunk/CPRS-Chart/Encounter/fPCEBaseMain.pas@ 896

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

Upgrade to version 27
File size: 16.1 KB
Line 
1unit fPCEBaseMain;
2{Warning: The tab order has been changed in the OnExit event of several controls.
3 To change the tab order of lbSection, lbxSection, and btnOther you must do it programatically.}
4
5interface
6
7uses
8 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
9 fPCEBaseGrid, ComCtrls, StdCtrls, ORCtrls, ExtCtrls, Buttons, rPCE, uPCE,
10 CheckLst, ORFn, VA508AccessibilityManager;
11
12type
13 TCopyItemsMethod = procedure(Dest: TStrings) of object;
14 TListSectionsProc = procedure(Dest: TStrings);
15
16 TfrmPCEBaseMain = class(TfrmPCEBaseGrid)
17 lbSection: TORListBox;
18 edtComment: TCaptionEdit;
19 lblSection: TLabel;
20 lblList: TLabel;
21 lblComment: TLabel;
22 btnRemove: TButton;
23 btnOther: TButton;
24 bvlMain: TBevel;
25 btnSelectAll: TButton;
26 lbxSection: TORListBox;
27 pnlMain: TPanel;
28 pnlLeft: TPanel;
29 splLeft: TSplitter;
30 procedure lbSectionClick(Sender: TObject);
31 procedure btnOtherClick(Sender: TObject);
32 procedure edtCommentExit(Sender: TObject);
33 procedure edtCommentChange(Sender: TObject);
34 procedure btnRemoveClick(Sender: TObject);
35 procedure clbListClick(Sender: TObject);
36 procedure lbGridSelect(Sender: TObject);
37 procedure FormDestroy(Sender: TObject);
38 procedure btnSelectAllClick(Sender: TObject);
39 procedure FormResize(Sender: TObject); virtual;
40 procedure clbListMouseDown(Sender: TObject; Button: TMouseButton;
41 Shift: TShiftState; X, Y: Integer);
42 procedure lbxSectionClickCheck(Sender: TObject; Index: Integer);
43 procedure splLeftMoved(Sender: TObject);
44 procedure edtCommentKeyPress(Sender: TObject; var Key: Char);
45 procedure lbSectionExit(Sender: TObject);
46 procedure btnOtherExit(Sender: TObject);
47 procedure lbxSectionExit(Sender: TObject);
48 procedure lbGridExit(Sender: TObject);
49 procedure FormCreate(Sender: TObject);
50 private
51 FCommentItem: integer;
52 FCommentChanged: boolean;
53 FUpdateCount: integer;
54 FSectionPopulated: boolean;
55 //FUpdatingGrid: boolean; moved to 'protected' so frmDiagnoses can see it (RV)
56 protected
57 FUpdatingGrid: boolean;
58 FPCEListCodesProc: TPCEListCodesProc;
59 FPCEItemClass: TPCEItemClass;
60 FPCECode: string;
61 FSplitterMove: boolean;
62 function GetCat: string;
63 procedure UpdateNewItemStr(var x: string); virtual;
64// procedure UpdateNewItem(APCEItem: TPCEItem); virtual;
65 procedure GridChanged; virtual;
66 procedure UpdateControls; override;
67 procedure BeginUpdate;
68 procedure EndUpdate;
69 function NotUpdating: boolean;
70 procedure CheckOffEntries;
71 procedure UpdateTabPos;
72 procedure Sync2Grid;
73 procedure Sync2Section;
74 public
75 procedure AllowTabChange(var AllowChange: boolean); override;
76 procedure InitTab(ACopyProc: TCopyItemsMethod; AListProc: TListSectionsProc);
77 end;
78
79var
80 frmPCEBaseMain: TfrmPCEBaseMain;
81
82const
83 LBCheckWidthSpace = 18;
84
85implementation
86
87uses fPCELex, fPCEOther, fEncounterFrame, fHFSearch, VA508AccessibilityRouter,
88 ORCtrlsVA508Compatibility, fBase508Form;
89
90{$R *.DFM}
91
92type
93 TLBSectionManager = class(TORListBox508Manager)
94 public
95 function GetItemInstructions(Component: TWinControl): string; override;
96 function GetState(Component: TWinControl): string; override;
97 end;
98
99procedure TfrmPCEBaseMain.lbSectionClick(Sender: TObject);
100begin
101 inherited;
102 ClearGrid;
103 FPCEListCodesProc(lbxSection.Items, lbSection.ItemIEN);
104 CheckOffEntries;
105 FSectionPopulated := TRUE;
106end;
107
108procedure TfrmPCEBaseMain.lbSectionExit(Sender: TObject);
109begin
110 inherited;
111 if TabIsPressed then
112 if lbxSection.CanFocus then
113 lbxSection.SetFocus;
114end;
115
116procedure TfrmPCEBaseMain.UpdateNewItemStr(var x: string);
117begin
118end;
119
120procedure TfrmPCEBaseMain.GridChanged;
121var
122 i: integer;
123 tmpList: TStringList;
124begin
125 tmpList := TStringList.Create;
126 BeginUpdate;
127 try
128 SaveGridSelected;
129 FastAssign(lbGrid.Items, tmpList);
130 for i := 0 to lbGrid.Items.Count-1 do
131 begin
132 //lbGrid.Items[i] := TPCEItem(lbGrid.Items.Objects[i]).ItemStr; v22.5 - RV
133 tmpList[i] := TPCEItem(lbGrid.Items.Objects[i]).ItemStr;
134 tmpList.Objects[i] := lbGrid.Items.Objects[i];
135 end;
136 //FastAssign(tmpList,lbGrid.Items); //cq: 13228 Causin a/v errors.
137 lbGrid.Items.Assign(tmpList); //cq: 13228
138 RestoreGridSelected;
139 SyncGridData;
140 finally
141 EndUpdate;
142 tmpList.Free;
143 end;
144 UpdateControls;
145end;
146
147//procedure TfrmPCEBaseMain.UpdateNewItem(APCEItem: TPCEItem);
148//begin
149//end;
150
151procedure TfrmPCEBaseMain.btnOtherClick(Sender: TObject);
152var
153 x, Code: string;
154 APCEItem: TPCEItem;
155 SrchCode: integer;
156begin
157 inherited;
158 ClearGrid;
159 SrchCode := (Sender as TButton).Tag;
160 if(SrchCode <= LX_Threshold) then
161 LexiconLookup(Code, SrchCode)
162 else
163 if(SrchCode = PCE_HF) then
164 HFLookup(Code)
165 else
166 OtherLookup(Code, SrchCode);
167 btnOther.SetFocus;
168 if Code <> '' then
169 begin
170 x := FPCECode + U + Piece(Code, U, 1) + U + U + Piece(Code, U, 2);
171 if FPCEItemClass = TPCEProc then
172 SetPiece(x, U, pnumProvider, IntToStr(uProviders.PCEProvider));
173 UpdateNewItemStr(x);
174 APCEItem := FPCEItemClass.Create;
175 APCEItem.SetFromString(x);
176// UpdateNewItem(APCEItem);
177 GridIndex := lbGrid.Items.AddObject(APCEItem.ItemStr, APCEItem);
178 SyncGridData;
179 end;
180 UpdateControls;
181end;
182
183procedure TfrmPCEBaseMain.btnOtherExit(Sender: TObject);
184begin
185 inherited;
186 if TabIsPressed then begin
187 if lbGrid.CanFocus then
188 lbGrid.SetFocus
189 end
190 else if ShiftTabIsPressed then
191 if lbxSection.CanFocus then
192 lbxSection.SetFocus;
193end;
194
195procedure TfrmPCEBaseMain.edtCommentExit(Sender: TObject);
196begin
197 inherited;
198 if(FCommentChanged) then
199 begin
200 FCommentChanged := FALSE;
201 if(FCommentItem >= 0) then
202 TPCEItem(lbGrid.Items.Objects[FCommentItem]).Comment := edtComment.text;
203 end;
204end;
205
206procedure TfrmPCEBaseMain.AllowTabChange(var AllowChange: boolean);
207begin
208 edtCommentExit(Self);
209end;
210
211procedure TfrmPCEBaseMain.edtCommentChange(Sender: TObject);
212begin
213 inherited;
214 FCommentItem := GridIndex;
215 FCommentChanged := TRUE;
216end;
217
218procedure TfrmPCEBaseMain.btnRemoveClick(Sender: TObject);
219var
220 i, j: Integer;
221 APCEItem: TPCEItem;
222 CurCategory: string;
223
224begin
225 inherited;
226 FUpdatingGrid := TRUE;
227 try
228 for i := lbGrid.Items.Count-1 downto 0 do if(lbGrid.Selected[i]) then
229 begin
230 CurCategory := GetCat;
231 APCEItem := TPCEDiag(lbGrid.Items.Objects[i]);
232 if APCEItem.Category = CurCategory then
233 begin
234 with APCEItem do for j := 0 to lbxSection.Items.Count - 1 do
235 if ORFn.Pieces(lbxSection.Items[j], U, 1, 2) = Code + U + Narrative then
236 lbxSection.Checked[j] := False;
237 end;
238 APCEItem.Free;
239 lbGrid.Items.Delete(i);
240 end;
241 ClearGrid;
242 finally
243 FUpdatingGrid := FALSE;
244 end;
245end;
246
247procedure TfrmPCEBaseMain.UpdateControls;
248var
249 CommentOK: boolean;
250
251begin
252 btnSelectAll.Enabled := (lbGrid.Items.Count > 0);
253 btnRemove.Enabled := (lbGrid.SelCount > 0);
254 if(NotUpdating) then
255 begin
256 BeginUpdate;
257 try
258 inherited;
259 CommentOK := (lbGrid.SelCount = 1);
260 lblComment.Enabled := CommentOK;
261 edtComment.Enabled := CommentOK;
262 if(CommentOK) then
263 edtComment.Text := TPCEItem(lbGrid.Items.Objects[GridIndex]).Comment
264 else
265 edtComment.Text := '';
266 finally
267 EndUpdate;
268 end;
269 end;
270end;
271
272procedure TfrmPCEBaseMain.clbListClick(Sender: TObject);
273begin
274 inherited;
275// with clbList do
276// if(ItemIndex >= 0) and (not(Checked[ItemIndex])) then
277// ClearGrid;
278end;
279
280procedure TfrmPCEBaseMain.lbGridExit(Sender: TObject);
281begin
282 inherited;
283 if ShiftTabIsPressed then
284 if btnOther.CanFocus then
285 btnOther.SetFocus;
286end;
287
288procedure TfrmPCEBaseMain.lbGridSelect(Sender: TObject);
289begin
290 inherited;
291// clbList.ItemIndex := -1;
292 UpdateControls;
293end;
294
295procedure TfrmPCEBaseMain.FormCreate(Sender: TObject);
296begin
297 inherited FormCreate(Sender);
298 lbxSection.HideSelection := TRUE;
299 amgrMain.ComponentManager[lbSection] := TLBSectionManager.Create;
300end;
301
302procedure TfrmPCEBaseMain.FormDestroy(Sender: TObject);
303var
304 i:integer;
305
306begin
307 inherited;
308 with lbGrid.Items do for i := 0 to Count - 1 do TPCEItem(Objects[i]).Free;
309end;
310
311procedure TfrmPCEBaseMain.InitTab(ACopyProc: TCopyItemsMethod; AListProc: TListSectionsProc);
312begin
313 AListProc(lbSection.Items);
314 ACopyProc(lbGrid.Items);
315 lbSection.ItemIndex := 0;
316 lbSectionClick(lbSection);
317 ClearGrid;
318 GridChanged;
319// CheckOffEntries;
320end;
321
322procedure TfrmPCEBaseMain.BeginUpdate;
323begin
324 inc(FUpdateCount);
325end;
326
327procedure TfrmPCEBaseMain.EndUpdate;
328begin
329 if(FUpdateCount > 0) then
330 dec(FUpdateCount);
331end;
332
333function TfrmPCEBaseMain.NotUpdating: boolean;
334begin
335 Result := (FUpdateCount = 0);
336end;
337
338procedure TfrmPCEBaseMain.CheckOffEntries;
339{ TODO -oRich V. -cCode Set Versioning : Uncomment these lines to prevent acceptance of existing inactive DX codes. }
340(*const
341 TX_INACTIVE_ICD_CODE1 = 'The diagnosis of "';
342 TX_INACTIVE_ICD_CODE2 = '" entered for this encounter' + #13#10 + 'contains an inactive ICD code of "';
343 TX_INACTIVE_ICD_CODE3 = '" as of the encounter date, and will be removed.' + #13#10#13#10 +
344 'Please select another diagnosis.';
345 TC_INACTIVE_ICD_CODE = 'Diagnosis Contains Inactive Code';*)
346var
347 i, j: Integer;
348 CurCategory, CodeNarr: string;
349 APCEItem: TPCEItem;
350begin
351 FUpdatingGrid := TRUE;
352 try
353 if(lbSection.Items.Count < 1) then exit;
354 CurCategory := GetCat;
355 for i := lbGrid.Items.Count - 1 downto 0 do
356 begin
357 APCEItem := TPCEItem(lbGrid.Items.Objects[i]);
358 if APCEItem.Category = CurCategory then
359 begin
360 CodeNarr := APCEItem.Code + U + APCEItem.Narrative;
361 for j := 0 to lbxSection.Items.Count - 1 do
362 if ORFn.Pieces(lbxSection.Items[j], U, 1, 2) = CodeNarr then
363 begin
364{ TODO -oRich V. -cCode Set Versioning : Uncomment these lines to prevent acceptance of existing inactive DX codes. }
365(* if (CurCategory = 'Problem List Items') and (Piece(lbxSection.Items[j], U, 5) = '#') then
366 begin
367 InfoBox(TX_INACTIVE_ICD_CODE1 + APCEItem.Narrative + TX_INACTIVE_ICD_CODE2 +
368 APCEItem.Code + TX_INACTIVE_ICD_CODE3, TC_INACTIVE_ICD_CODE, MB_ICONWARNING or MB_OK);
369 lbxSection.Checked[j] := False;
370 APCEItem.Free;
371 lbGrid.Items.Delete(i);
372 end
373 else*)
374 lbxSection.Checked[j] := True;
375 end;
376 end;
377 end;
378 finally
379 FUpdatingGrid := FALSE;
380 end;
381end;
382
383procedure TfrmPCEBaseMain.btnSelectAllClick(Sender: TObject);
384var
385 i: integer;
386
387begin
388 inherited;
389 BeginUpdate;
390 try
391 for i := 0 to lbGrid.Items.Count-1 do
392 lbGrid.Selected[i] := TRUE;
393 finally
394 EndUpdate;
395 end;
396 UpdateControls;
397end;
398
399procedure TfrmPCEBaseMain.FormResize(Sender: TObject);
400begin
401 if FSplitterMove then
402 FSplitterMove := FALSE
403 else
404 inherited;
405end;
406
407procedure TfrmPCEBaseMain.clbListMouseDown(Sender: TObject;
408 Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
409begin
410 inherited;
411// if(Button <> mbLeft) then
412// clbList.Itemindex := clbList.itemAtPos(Point(X,Y), TRUE);
413end;
414
415function TfrmPCEBaseMain.GetCat: string;
416begin
417 Result := '';
418 if(lbSection.Items.Count > 0) and (lbSection.ItemIndex >= 0) then
419 Result := Piece(lbSection.Items[lbSection.ItemIndex], U, 2);
420end;
421
422procedure TfrmPCEBaseMain.lbxSectionClickCheck(Sender: TObject;
423 Index: Integer);
424var
425 i, j: Integer;
426 x, x0, CodeCatNarr: string;
427 APCEItem: TPCEItem;
428 Found, DoSync: boolean;
429
430begin
431 inherited;
432 if FUpdatingGrid or FClosing then exit;
433 DoSync := FALSE;
434 x0 := GetCat;
435 for i := 0 to lbxSection.Items.Count-1 do
436 begin
437 x := x0 + U + ORFn.Pieces(lbxSection.Items[i], U, 1, 2);
438 CodeCatNarr := Piece(x, U, 2) + U + Piece(x, U, 1) + U + Piece(x, U, 3);
439 Found := FALSE;
440 for j := lbGrid.Items.Count - 1 downto 0 do
441 begin
442 APCEItem := TPCEItem(lbGrid.Items.Objects[j]);
443 with APCEItem do if CodeCatNarr = Code + U + Category + U + Narrative then
444 begin
445 Found := TRUE;
446 if(lbxSection.Checked[i]) then break;
447 APCEItem.Free;
448 lbGrid.Items.Delete(j);
449 end;
450 end;
451 if(lbxSection.Checked[i] and (not Found)) then
452 begin
453 x := FPCECode + U + CodeCatNarr;
454 if FPCEItemClass = TPCEProc then
455 SetPiece(x, U, pnumProvider, IntToStr(uProviders.PCEProvider));
456 UpdateNewItemStr(x);
457 APCEItem := FPCEItemClass.Create;
458 APCEItem.SetFromString(x);
459 GridIndex := lbGrid.Items.AddObject(APCEItem.ItemStr, APCEItem);
460 DoSync := TRUE;
461 end;
462 end;
463 if(DoSync) then
464 SyncGridData;
465 UpdateControls;
466end;
467
468procedure TfrmPCEBaseMain.lbxSectionExit(Sender: TObject);
469begin
470 inherited;
471 if TabIsPressed then begin
472 if btnOther.CanFocus then
473 btnOther.SetFocus
474 end
475 else if ShiftTabIsPressed then
476 if lbSection.CanFocus then
477 lbSection.SetFocus;
478end;
479
480procedure TfrmPCEBaseMain.UpdateTabPos;
481begin
482 lbxSection.TabPositions := SectionString;
483end;
484
485procedure TfrmPCEBaseMain.splLeftMoved(Sender: TObject);
486begin
487 inherited;
488 lblList.Left := lbxSection.Left + pnlMain.Left;
489 FSplitterMove := TRUE;
490 FormResize(Sender);
491end;
492
493procedure TfrmPCEBaseMain.Sync2Grid;
494var
495 i, idx, cnt, NewIdx: Integer;
496 CodeNarr: string;
497 APCEItem: TPCEItem;
498
499begin
500 if(FUpdatingGrid or FClosing) then exit;
501 FUpdatingGrid := TRUE;
502 try
503 cnt := 0;
504 idx := -1;
505 for i := 0 to lbGrid.Items.Count - 1 do
506 begin
507 if(lbGrid.Selected[i]) then
508 begin
509 if(idx < 0) then idx := i;
510 inc(cnt);
511 if(cnt > 1) then break;
512 end;
513 end;
514 NewIdx := -1;
515 if(cnt = 1) then
516 begin
517 APCEItem := TPCEItem(lbGrid.Items.Objects[idx]);
518 if APCEItem.Category = GetCat then
519 begin
520 CodeNarr := APCEItem.Code + U + APCEItem.Narrative;
521 for i := 0 to lbxSection.Items.Count - 1 do
522 begin
523 if Pieces(lbxSection.Items[i], U, 1, 2) = CodeNarr then
524 begin
525 NewIdx := i;
526 break;
527 end;
528 end;
529 end;
530 end;
531 lbxSection.ItemIndex := NewIdx;
532 finally
533 FUpdatingGrid := FALSE;
534 end;
535end;
536
537procedure TfrmPCEBaseMain.Sync2Section;
538var
539 i, idx: Integer;
540 ACode: string;
541
542begin
543 if(FUpdatingGrid or FClosing) then exit;
544 FUpdatingGrid := TRUE;
545 try
546 idx := lbxSection.ItemIndex;
547 if(idx >= 0) then
548 ACode := GetCat + U + Pieces(lbxSection.Items[idx], U, 1, 2)
549 else
550 ACode := '~@^~@^@~';
551 for i := 0 to lbGrid.Items.Count - 1 do
552 begin
553 with TPCEItem(lbGrid.Items.Objects[i]) do
554 lbGrid.Selected[i] := (ACode = (Category + U + Code + U + Narrative));
555 end;
556 finally
557 FUpdatingGrid := FALSE;
558 end;
559end;
560
561procedure TfrmPCEBaseMain.edtCommentKeyPress(Sender: TObject;
562 var Key: Char);
563begin
564 inherited;
565 if (Key = '?') and
566 ((edtComment.Text = '') or (edtComment.SelStart = 0)) then
567 Key := #0;
568end;
569
570{ TLBSectionManager }
571
572function TLBSectionManager.GetItemInstructions(Component: TWinControl): string;
573var
574 lb : TORListBox;
575 idx: integer;
576begin
577 lb := TORListBox(Component);
578 idx := lb.ItemIndex;
579 if (idx >= 0) and lb.Selected[idx] then
580 Result := 'Press space bar to populate ' +
581 TfrmPCEBaseMain(Component.Owner).FTabName + ' section'
582 else
583 result := inherited GetItemInstructions(Component);
584end;
585
586function TLBSectionManager.GetState(Component: TWinControl): string;
587var
588 frm: TfrmPCEBaseMain;
589begin
590 Result := '';
591 frm := TfrmPCEBaseMain(Component.Owner);
592 if frm.FSectionPopulated then
593 begin
594 frm.FSectionPopulated := FALSE;
595 Result := frm.FTabName + ' section populated with ' +
596 inttostr(frm.lbxSection.Count) + ' items';
597 end;
598end;
599
600initialization
601 SpecifyFormIsNotADialog(TfrmPCEBaseMain);
602
603end.
Note: See TracBrowser for help on using the repository browser.