source: cprs/branches/tmg-cprs/CPRS-Chart/Encounter/fProcedure.pas@ 454

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

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