source: cprs/trunk/CPRS-Chart/Encounter/fProcedure.pas@ 1046

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

Upgrade to version 27
File size: 15.7 KB
Line 
1unit fProcedure;
2{Warning: The tab order has been changed in the OnExit event of several controls.
3 To change the tab order of lbSection, lbxSection, lbMods, and btnOther you must do it programatically.}
4
5interface
6
7uses
8 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
9 fPCEBase, StdCtrls, ComCtrls, CheckLst, ORCtrls, ExtCtrls, Buttons, uPCE, rPCE, ORFn,
10 fPCELex, fPCEOther, fPCEBaseGrid, fPCEBaseMain, VA508AccessibilityManager;
11
12type
13 TfrmProcedures = class(TfrmPCEBaseMain)
14 lblProcQty: TLabel;
15 spnProcQty: TUpDown;
16 txtProcQty: TCaptionEdit;
17 lbMods: TORListBox;
18 splRight: TSplitter;
19 lblMod: TLabel;
20 cboProvider: TORComboBox;
21 lblProvider: TLabel;
22 procedure txtProcQtyChange(Sender: TObject);
23 procedure FormCreate(Sender: TObject);
24 procedure FormResize(Sender: TObject); override;
25 procedure splRightMoved(Sender: TObject);
26 procedure clbListClick(Sender: TObject);
27 procedure lbGridSelect(Sender: TObject);
28 procedure btnSelectAllClick(Sender: TObject);
29 procedure lbModsClickCheck(Sender: TObject; Index: Integer);
30 procedure lbSectionClick(Sender: TObject);
31 procedure lbxSectionClickCheck(Sender: TObject; Index: Integer);
32 procedure btnOtherClick(Sender: TObject);
33 procedure btnRemoveClick(Sender: TObject);
34 procedure cboProviderNeedData(Sender: TObject; const StartFrom: String;
35 Direction, InsertAt: Integer);
36 procedure cboProviderChange(Sender: TObject);
37 procedure lbxSectionExit(Sender: TObject);
38 procedure lbModsExit(Sender: TObject);
39 procedure btnOtherExit(Sender: TObject);
40 private
41 FCheckingCode: boolean;
42 FCheckingMods: boolean;
43 FLastCPTCodes: string;
44 FModsReadOnly: boolean;
45 FProviderChanging: boolean;
46 FModsROChecked: string;
47 function MissingProvider: boolean;
48 protected
49 procedure UpdateNewItemStr(var x: string); override;
50 procedure UpdateControls; override;
51 procedure ShowModifiers;
52 procedure CheckModifiers;
53 public
54 function OK2SaveProcedures: boolean;
55 procedure InitTab(ACopyProc: TCopyItemsMethod; AListProc: TListSectionsProc);
56 end;
57
58var
59 frmProcedures: TfrmProcedures;
60
61implementation
62
63{$R *.DFM}
64
65uses
66 fEncounterFrame, uConst, rCore, VA508AccessibilityRouter;
67
68const
69 TX_PROC_PROV = 'Each procedure requires selection of a Provider before it can be saved.';
70 TC_PROC_PROV = 'Missing Procedure Provider';
71
72procedure TfrmProcedures.txtProcQtyChange(Sender: TObject);
73var
74 i: integer;
75
76begin
77 if(NotUpdating) then
78 begin
79 for i := 0 to lbGrid.Items.Count-1 do
80 if(lbGrid.Selected[i]) then
81 TPCEProc(lbGrid.Items.Objects[i]).Quantity := spnProcQty.Position;
82 GridChanged;
83 end;
84end;
85
86procedure TfrmProcedures.cboProviderChange(Sender: TObject);
87var
88 i: integer;
89begin
90 inherited;
91 if(NotUpdating) then
92 begin
93 for i := 0 to lbGrid.Items.Count-1 do
94 if(lbGrid.Selected[i]) then
95 TPCEProc(lbGrid.Items.Objects[i]).Provider := cboProvider.ItemIEN;
96 FProviderChanging := TRUE; // CQ 11707
97 try
98 GridChanged;
99 finally
100 FProviderChanging := FALSE;
101 end;
102 end;
103end;
104
105procedure TfrmProcedures.FormCreate(Sender: TObject);
106begin
107 inherited;
108 FTabName := CT_ProcNm;
109 FPCEListCodesProc := ListProcedureCodes;
110 cboProvider.InitLongList(uProviders.PCEProviderName);
111 FPCEItemClass := TPCEProc;
112 FPCECode := 'CPT';
113 FSectionTabCount := 1;
114 FormResize(Self);
115 lbMods.HideSelection := TRUE;
116end;
117
118procedure TfrmProcedures.UpdateNewItemStr(var x: string);
119begin
120 SetPiece(x, U, pnumProcQty, '1');
121 //x := x + U + '1';
122end;
123
124procedure TfrmProcedures.UpdateControls;
125var
126 ok, First: boolean;
127 SameQty: boolean;
128 SameProv: boolean;
129 i: integer;
130 Qty: integer;
131 Prov: int64;
132 Obj: TPCEProc;
133
134begin
135 inherited;
136 if(NotUpdating) then
137 begin
138 BeginUpdate;
139 try
140 ok := (lbGrid.SelCount > 0);
141 lblProcQty.Enabled := ok;
142 txtProcQty.Enabled := ok;
143 spnProcQty.Enabled := ok;
144 cboProvider.Enabled := ok;
145 lblProvider.Enabled := ok;
146 if(ok) then
147 begin
148 First := TRUE;
149 SameQty := TRUE;
150 SameProv := TRUE;
151 Prov := 0;
152 Qty := 1;
153 for i := 0 to lbGrid.Items.Count-1 do
154 begin
155 if lbGrid.Selected[i] then
156 begin
157 Obj := TPCEProc(lbGrid.Items.Objects[i]);
158 if(First) then
159 begin
160 First := FALSE;
161 Qty := Obj.Quantity;
162 Prov := Obj.Provider;
163 end
164 else
165 begin
166 if(SameQty) then
167 SameQty := (Qty = Obj.Quantity);
168 if(SameProv) then
169 SameProv := (Prov = Obj.Provider);
170 end;
171 end;
172 end;
173 if(SameQty) then
174 begin
175 spnProcQty.Position := Qty;
176 txtProcQty.Text := IntToStr(Qty);
177 txtProcQty.SelStart := length(txtProcQty.Text);
178 end
179 else
180 begin
181 spnProcQty.Position := 1;
182 txtProcQty.Text := '';
183 end;
184 if not FProviderChanging then // CQ 11707
185 begin
186 if(SameProv) then
187 cboProvider.SetExactByIEN(Prov, ExternalName(Prov, 200))
188 else
189 cboProvider.SetExactByIEN(uProviders.PCEProvider, uProviders.PCEProviderName);
190 //cboProvider.ItemIndex := -1; v22.8 - RV
191 end;
192 end
193 else
194 begin
195 txtProcQty.Text := '';
196 cboProvider.ItemIndex := -1;
197 end;
198// ShowModifiers;
199 finally
200 EndUpdate;
201 end;
202 end;
203end;
204
205procedure TfrmProcedures.FormResize(Sender: TObject);
206var
207 v, i: integer;
208 s: string;
209
210begin
211 inherited;
212 FSectionTabs[0] := -(lbxSection.width - LBCheckWidthSpace - MainFontWidth - ScrollBarWidth);
213 UpdateTabPos;
214 v := (lbMods.width - LBCheckWidthSpace - (4*MainFontWidth) - ScrollBarWidth);
215 s := '';
216 for i := 1 to 20 do
217 begin
218 if s <> '' then s := s + ',';
219 s := s + inttostr(v);
220 if(v<0) then
221 dec(v,32)
222 else
223 inc(v,32);
224 end;
225 lbMods.TabPositions := s;
226end;
227
228procedure TfrmProcedures.splRightMoved(Sender: TObject);
229begin
230 inherited;
231 lblMod.Left := lbMods.Left + pnlMain.Left;
232 FSplitterMove := TRUE;
233 FormResize(Sender);
234end;
235
236procedure TfrmProcedures.clbListClick(Sender: TObject);
237begin
238 inherited;
239 Sync2Section;
240 UpdateControls;
241 ShowModifiers;
242end;
243
244procedure TfrmProcedures.lbGridSelect(Sender: TObject);
245begin
246 inherited;
247 Sync2Grid;
248 ShowModifiers;
249end;
250
251procedure TfrmProcedures.btnSelectAllClick(Sender: TObject);
252begin
253 inherited;
254 Sync2Grid;
255 ShowModifiers;
256end;
257
258procedure TfrmProcedures.ShowModifiers;
259const
260 ModTxt = 'Modifiers';
261 ForTxt = ' for ';
262 Spaces = ' ';
263 CommonTxt = ' Common to Multiple Procedures';
264
265var
266 i, TopIdx: integer;
267// Needed,
268 Codes, ProcName, Hint, Msg: string;
269 Proc: TPCEProc;
270
271begin
272 if(not NotUpdating) then exit;
273 Codes := '';
274 ProcName := '';
275 Hint := '';
276// Needed := '';
277 for i := 0 to lbGrid.Items.Count-1 do
278 begin
279 if(lbGrid.Selected[i]) then
280 begin
281 Proc := TPCEProc(lbGrid.Items.Objects[i]);
282 Codes := Codes + Proc.Code + U;
283 if(ProcName = '') then
284 ProcName := Proc.Narrative
285 else
286 ProcName := CommonTxt;
287 if(Hint <> '') then
288 Hint := Hint + CRLF + Spaces;
289 Hint := Hint + Proc.Narrative;
290// Needed := Needed + Proc.Modifiers;
291 end;
292 end;
293 if(Codes = '') and (lbxSection.ItemIndex >= 0) then
294 begin
295 Codes := piece(lbxSection.Items[lbxSection.ItemIndex],U,1) + U;
296 ProcName := piece(lbxSection.Items[lbxSection.ItemIndex],U,2);
297 Hint := ProcName;
298// Needed := piece(lbxSection.Items[lbxSection.ItemIndex],U,4); Don't show expired codes!
299 end;
300 msg := ModTxt;
301 if(ProcName <> '') and (ProcName <> CommonTxt) then
302 msg := msg + ForTxt;
303 lblMod.Caption := msg + ProcName;
304 if(pos(CRLF,Hint)>0) then
305 Hint := ':' + CRLF + Spaces + Hint;
306 lblMod.Hint := msg + Hint;
307
308 if(FLastCPTCodes = Codes) then
309 TopIdx := lbMods.TopIndex
310 else
311 begin
312 TopIdx := 0;
313 FLastCPTCodes := Codes;
314 end;
315 ListCPTModifiers(lbMods.Items, Codes, ''); // Needed);
316 lbMods.TopIndex := TopIdx;
317 CheckModifiers;
318end;
319
320procedure TfrmProcedures.CheckModifiers;
321var
322 i, idx, cnt, mcnt: integer;
323 Code, Mods: string;
324 state: TCheckBoxState;
325
326begin
327 FModsReadOnly := TRUE;
328 if lbMods.Items.Count < 1 then exit;
329 FCheckingMods := TRUE;
330 try
331 cnt := 0;
332 Mods := ';';
333 for i := 0 to lbGrid.Items.Count-1 do
334 begin
335 if(lbGrid.Selected[i]) then
336 begin
337 inc(cnt);
338 Mods := Mods + TPCEProc(lbGrid.Items.Objects[i]).Modifiers;
339 FModsReadOnly := FALSE;
340 end;
341 end;
342 if(cnt = 0) and (lbxSection.ItemIndex >= 0) then
343 begin
344 Mods := ';' + UpdateModifierList(lbxSection.Items, lbxSection.ItemIndex);
345 cnt := 1;
346 end;
347 for i := 0 to lbMods.Items.Count-1 do
348 begin
349 state := cbUnchecked;
350 if(cnt > 0) then
351 begin
352 Code := ';' + piece(lbMods.Items[i], U, 1) + ';';
353 mcnt := 0;
354 repeat
355 idx := pos(Code, Mods);
356 if(idx > 0) then
357 begin
358 inc(mcnt);
359 delete(Mods, idx, length(Code) - 1);
360 end;
361 until (idx = 0);
362 if mcnt >= cnt then
363 State := cbChecked
364 else
365 if(mcnt > 0) then
366 State := cbGrayed;
367 end;
368 lbMods.CheckedState[i] := state;
369 end;
370 if FModsReadOnly then
371 begin
372 FModsROChecked := lbMods.CheckedString;
373 lbMods.Font.Color := clInactiveCaption;
374 end
375 else
376 lbMods.Font.Color := clWindowText;
377 finally
378 FCheckingMods := FALSE;
379 end;
380end;
381
382procedure TfrmProcedures.lbModsClickCheck(Sender: TObject; Index: Integer);
383var
384 i, idx: integer;
385 PCEObj: TPCEProc;
386 ModIEN: string;
387 DoChk, Add: boolean;
388
389begin
390 if FCheckingMods or (Index < 0) then exit;
391 if FModsReadOnly then
392 begin
393 lbMods.CheckedString := FModsROChecked;
394 exit;
395 end;
396 if(NotUpdating) then
397 begin
398 BeginUpdate;
399 try
400 DoChk := FALSE;
401 Add := (lbMods.Checked[Index]);
402 ModIEN := piece(lbMods.Items[Index],U,1) + ';';
403 for i := 0 to lbGrid.Items.Count-1 do
404 begin
405 if(lbGrid.Selected[i]) then
406 begin
407 PCEObj := TPCEProc(lbGrid.Items.Objects[i]);
408 idx := pos(';' + ModIEN, ';' + PCEObj.Modifiers);
409 if(idx > 0) then
410 begin
411 if not Add then
412 begin
413 delete(PCEObj.Modifiers, idx, length(ModIEN));
414 DoChk := TRUE;
415 end;
416 end
417 else
418 begin
419 if Add then
420 begin
421 PCEObj.Modifiers := PCEObj.Modifiers + ModIEN;
422 DoChk := TRUE;
423 end;
424 end;
425 end;
426 end;
427 finally
428 EndUpdate;
429 end;
430 if DoChk then
431 GridChanged;
432 end;
433end;
434
435procedure TfrmProcedures.lbModsExit(Sender: TObject);
436begin
437 inherited;
438 if TabIsPressed then
439 if btnOther.CanFocus then
440 btnOther.SetFocus;
441end;
442
443procedure TfrmProcedures.lbSectionClick(Sender: TObject);
444begin
445 inherited;
446 ShowModifiers;
447end;
448
449procedure TfrmProcedures.lbxSectionClickCheck(Sender: TObject;
450 Index: Integer);
451var
452 i: integer;
453begin
454 if FCheckingCode then exit;
455 FCheckingCode := TRUE;
456 try
457 inherited;
458 Sync2Grid;
459 lbxSection.Selected[Index] := True;
460 if(lbxSection.ItemIndex >= 0) and (lbxSection.ItemIndex = Index) and
461 (lbxSection.Checked[Index]) then
462 begin
463 UpdateModifierList(lbxSection.Items, Index); // CQ#16439
464 lbxSection.Checked[Index] := TRUE;
465 for i := 0 to lbGrid.Items.Count-1 do
466 begin
467 if(lbGrid.Selected[i]) then
468 with TPCEProc(lbGrid.Items.Objects[i]) do
469 begin
470 if(Category = GetCat) and
471 (Pieces(lbxSection.Items[Index], U, 1, 2) = Code + U + Narrative) then
472 begin
473 { TODO -oRich V. -cEncounters : v21/22 - Added this block to default provider for procedures.}
474 if Provider = 0 then Provider := uProviders.PCEProvider;
475 { uPCE.TPCEProviderList.PCEProvider function sorts this out automatically: }
476 { 1. Current CPRS encounter provider, if present and has active person class as of encounter date. }
477 { 2. Current user, if has active person class as of encounter date. }
478 { 3. Primary provider for the visit, if defined. }
479 { 4. No default. }
480 Modifiers := Piece(lbxSection.Items[lbxSection.ItemIndex], U, 4);
481 GridChanged;
482 lbxSection.Selected[Index] := True; // CQ#15493
483 exit;
484 end;
485 end;
486 end;
487 end;
488 finally
489 FCheckingCode := FALSE;
490 end;
491end;
492
493procedure TfrmProcedures.lbxSectionExit(Sender: TObject);
494begin
495 if TabIsPressed then begin
496 if lbMods.CanFocus then
497 lbMods.SetFocus;
498 end
499 else if ShiftTabIsPressed then
500 if lbSection.CanFocus then
501 lbSection.SetFocus;
502end;
503
504procedure TfrmProcedures.btnOtherClick(Sender: TObject);
505begin
506 inherited;
507 Sync2Grid;
508 ShowModifiers;
509end;
510
511procedure TfrmProcedures.btnOtherExit(Sender: TObject);
512begin
513 if TabIsPressed then begin
514 if lbGrid.CanFocus then
515 lbGrid.SetFocus;
516 end
517 else if ShiftTabIsPressed then
518 if lbMods.CanFocus then
519 lbMods.SetFocus;
520end;
521
522procedure TfrmProcedures.btnRemoveClick(Sender: TObject);
523begin
524 inherited;
525 Sync2Grid;
526 ShowModifiers;
527end;
528
529procedure TfrmProcedures.cboProviderNeedData(Sender: TObject;
530 const StartFrom: String; Direction, InsertAt: Integer);
531begin
532 inherited;
533 if(uEncPCEData.VisitCategory = 'E') then
534 cboProvider.ForDataUse(SubSetOfPersons(StartFrom, Direction))
535 else
536 cboProvider.ForDataUse(SubSetOfUsersWithClass(StartFrom, Direction,
537 FloatToStr(uEncPCEData.PersonClassDate)));
538end;
539
540function TfrmProcedures.OK2SaveProcedures: boolean;
541begin
542 Result := TRUE;
543 if MissingProvider then
544 begin
545 InfoBox(TX_PROC_PROV, TC_PROC_PROV, MB_OK or MB_ICONWARNING);
546 Result := False;
547 end;
548end;
549
550function TfrmProcedures.MissingProvider: boolean;
551var
552 i: integer;
553 AProc: TPCEProc;
554begin
555 { TODO -oRich V. -cEncounters : {v21 - Entry of a provider for each new CPT is now required}
556 {Existing CPTs on the encounter will NOT require entry of a provider}
557 {Monitor status of new service request #20020203.}
558 Result := False;
559
560 { Comment out the block below (and the "var" block above) }
561 { to allow but not require entry of a provider with each new CPT entered}
562//------------------------------------------------
563 for i := 0 to lbGrid.Items.Count - 1 do
564 begin
565 AProc := TPCEProc(lbGrid.Items.Objects[i]);
566 if AProc.fIsOldProcedure then continue;
567 if (AProc.Provider = 0) then
568 begin
569 Result := True;
570 lbGrid.ItemIndex := i;
571 exit;
572 end;
573 end;
574//-------------------------------------------------
575end;
576
577procedure TfrmProcedures.InitTab(ACopyProc: TCopyItemsMethod; AListProc: TListSectionsProc);
578var
579 i: integer;
580begin
581 inherited;
582 for i := 0 to lbGrid.Items.Count - 1 do
583 TPCEProc(lbGrid.Items.Objects[i]).fIsOldProcedure := True;
584end;
585
586initialization
587 SpecifyFormIsNotADialog(TfrmProcedures);
588
589end.
Note: See TracBrowser for help on using the repository browser.