source: cprs/branches/foia-cprs/CPRS-Chart/Encounter/fProcedure.pas@ 1382

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

Adding foia-cprs branch

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