source: cprs/branches/tmg-cprs/CPRS-Chart/Orders/fOrdersRenew.~pas@ 453

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

Initial upload of TMG-CPRS 1.0.26.69
File size: 18.0 KB
Line 
1//kt -- Modified with SourceScanner on 8/8/2007
2unit fOrdersRenew;
3
4interface
5
6uses
7 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
8 fAutoSz, StdCtrls, ORFn, ComCtrls, uConst, rODMeds, uOrders, fOCAccept,
9 ExtCtrls, uODBase, ORCtrls, DKLang;
10
11type
12 TfrmRenewOrders = class(TfrmAutoSz)
13 hdrOrders: THeaderControl;
14 pnlBottom: TPanel;
15 cmdCancel: TButton;
16 cmdOK: TButton;
17 cmdChange: TButton;
18 lstOrders: TCaptionListBox;
19 procedure FormCreate(Sender: TObject);
20 procedure cmdOKClick(Sender: TObject);
21 procedure cmdCancelClick(Sender: TObject);
22 procedure lstOrdersMeasureItem(Control: TWinControl; Index: Integer;
23 var Height: Integer);
24 procedure lstOrdersDrawItem(Control: TWinControl; Index: Integer;
25 Rect: TRect; State: TOwnerDrawState);
26 procedure lstOrdersClick(Sender: TObject);
27 procedure cmdChangeClick(Sender: TObject);
28 procedure FormClose(Sender: TObject; var Action: TCloseAction);
29 procedure FormShow(Sender: TObject);
30 procedure hdrOrdersSectionResize(HeaderControl: THeaderControl;
31 Section: THeaderSection);
32 private
33 OKPressed: Boolean;
34 OrderList: TList;
35 function MeasureColumnHeight(TheOrderText: string; Index: Integer; Column: integer):integer;
36 function AcceptOrderCheckOnRenew(const AnOrderID: string; var OCList: TStringList): boolean;
37 end;
38
39function ExecuteRenewOrders(var SelectedList: TList): Boolean;
40
41implementation
42
43{$R *.DFM}
44
45uses rOrders, fDateRange, fRenewOutMed, uCore, rCore, rMisc, UBAGlobals;
46
47const
48 TEXT_COLUMN = 0;
49 DATE_COLUMN = 1;
50 WORD_WRAPPED = True;
51
52//TC_START_STOP = 'Change Start/Stop Dates'; <-- original line. //kt 8/8/2007
53//TX_START_STOP = 'Enter the start and stop times for this order. Stop time is optional.'; <-- original line. //kt 8/8/2007
54//TX_LBL_START = 'Start Date/Time'; <-- original line. //kt 8/8/2007
55//TX_LBL_STOP = 'Stop Date/Time'; <-- original line. //kt 8/8/2007
56//TX_NO_DEA = 'Provider must have a DEA# or VA# to review this order'; <-- original line. //kt 8/8/2007
57//TC_NO_DEA = 'DEA# Required'; <-- original line. //kt 8/8/2007
58//TC_ORDERCHECKS = 'Order Checks'; <-- original line. //kt 8/8/2007
59
60var
61 TC_START_STOP : string; //kt
62 TX_START_STOP : string; //kt
63 TX_LBL_START : string; //kt
64 TX_LBL_STOP : string; //kt
65 TX_NO_DEA : string; //kt
66 TC_NO_DEA : string; //kt
67 TC_ORDERCHECKS : string; //kt
68
69
70procedure SetupVars;
71//kt Added entire function to replace constant declarations 8/8/2007
72begin
73 TC_START_STOP := DKLangConstW('fOrdersRenew_Change_StartxStop_Dates');
74 TX_START_STOP := DKLangConstW('fOrdersRenew_Enter_the_start_and_stop_times_for_this_orderx__Stop_time_is_optionalx');
75 TX_LBL_START := DKLangConstW('fOrdersRenew_Start_DatexTime');
76 TX_LBL_STOP := DKLangConstW('fOrdersRenew_Stop_DatexTime');
77 TX_NO_DEA := DKLangConstW('fOrdersRenew_Provider_must_have_a_DEAx_or_VAx_to_review_this_order');
78 TC_NO_DEA := DKLangConstW('fOrdersRenew_DEAx_Required');
79 TC_ORDERCHECKS := DKLangConstW('fOrdersRenew_Order_Checks');
80end;
81
82function PickupText(const x: string): string;
83begin
84 case CharAt(x, 1) of
85//'C': Result := ' (administered in Clinic)'; <-- original line. //kt 8/8/2007
86 'C': Result := DKLangConstW('fOrdersRenew_xadministered_in_Clinicx'); //kt added 8/8/2007
87//'M': Result := ' (deliver by Mail)'; <-- original line. //kt 8/8/2007
88 'M': Result := DKLangConstW('fOrdersRenew_xdeliver_by_Mailx'); //kt added 8/8/2007
89//'W': Result := ' (pick up at Window)'; <-- original line. //kt 8/8/2007
90 'W': Result := DKLangConstW('fOrdersRenew_xpick_up_at_Windowx'); //kt added 8/8/2007
91 else Result := '';
92 end;
93end;
94
95function ExecuteRenewOrders(var SelectedList: TList): Boolean;
96//const
97//TC_IMO_ERROR = 'Inpatient medication order on outpatient authorization required'; <-- original line. //kt 8/8/2007
98var
99 frmRenewOrders: TfrmRenewOrders;
100 RenewFields: TOrderRenewFields;
101 AnOrder, TheOrder: TOrder;
102 OriginalID, RNFillerID,x: string;
103 OrderableItemIen: integer;
104 TreatAsIMOOrder, IsAnIMOOrder: boolean;
105 PassDeaList: TList;
106 IsInpt: boolean;
107 i,j: Integer;
108 //m: integer; //BAPHII 1.3.2
109 PkgInfo:string;
110 PlainText,RnErrMsg: string;
111 TD: TFMDateTime;
112 OrchkList: TStringList;
113 TC_IMO_ERROR : string; //kt
114
115 function OrderForInpatient: Boolean;
116 begin
117 Result := Patient.Inpatient;
118 end;
119begin
120 SetupVars; //kt added 8/8/2007 to replace constants with vars.
121 TC_IMO_ERROR := DKLangConstW('fOrdersRenew_Inpatient_medication_order_on_outpatient_authorization_required'); //kt added 8/8/2007
122
123 Result := False;
124 IsAnIMOOrder := False;
125 RnErrMsg := '';
126
127 if SelectedList.Count = 0 then Exit;
128
129 PassDeaList := TList.Create;
130 OrchkList := TStringList.Create;
131 frmRenewOrders := TfrmRenewOrders.Create(Application);
132
133 try
134 frmRenewOrders.OrderList := SelectedList;
135 ResizeFormToFont(TForm(frmRenewOrders));
136 IsInpt := OrderForInpatient;
137
138 with frmRenewOrders.OrderList do
139 for j := 0 to Count - 1 do
140 begin
141 TheOrder := TOrder(Items[j]);
142 PkgInfo := GetPackageByOrderID(TheOrder.ID);
143
144 if Pos('PS',PkgInfo)=1 then
145 begin
146 OrderableItemIen := GetOrderableIen(TheOrder.ID);
147
148 if DEACheckFailed(OrderableItemIen, IsInPt) then
149 begin
150 InfoBox(TX_NO_DEA + #13 + TheOrder.Text, TC_NO_DEA, MB_OK);
151 UnlockOrder(TheOrder.ID);
152 end
153 else PassDeaList.Add(frmRenewOrders.OrderList.Items[j]);
154 end
155 else
156 PassDeaList.Add(frmRenewOrders.OrderList.Items[j]);
157 end;
158
159 frmRenewOrders.OrderList.Clear;
160 frmRenewOrders.OrderList := PassDeaList;
161
162 for i := frmRenewOrders.OrderList.Count - 1 downto 0 do
163 begin
164 AnOrder := TOrder(frmRenewOrders.OrderList.Items[i]);
165 if not IMOActionValidation('RENEW^'+ AnOrder.ID,IsAnIMOOrder,RnErrMsg,'C') then
166 begin
167 frmRenewOrders.OrderList.Delete(i);
168 ShowMsgOn(Length(RnErrMsg) > 0, RnErrMsg, TC_IMO_ERROR);
169 end;
170 RnErrMsg := '';
171 end;
172
173 with frmRenewOrders.OrderList do
174 for i := 0 to Count - 1 do
175 begin
176 AnOrder := TOrder(Items[i]);
177 RenewFields := TOrderRenewFields.Create;
178 LoadRenewFields(RenewFields, AnOrder.ID);
179 RenewFields.NewText := AnOrder.Text + PickupText(RenewFields.Pickup);
180 AnOrder.LinkObject := RenewFields;
181 PlainText := '';
182
183 if RenewFields.NewText <> '' then
184 PlainText := PlainText + frmRenewOrders.hdrOrders.Sections[TEXT_COLUMN].Text + ': ' + RenewFields.NewText + CRLF;
185
186 if RenewFields.BaseType = OD_TEXTONLY then
187 with RenewFields do
188// PlainText := PlainText + 'Start: ' + StartTime + CRLF + 'Stop: ' + StopTime; <-- original line. //kt 8/8/2007
189 PlainText := PlainText + DKLangConstW('fOrdersRenew_Startx') + StartTime + CRLF + DKLangConstW('fOrdersRenew_Stopx') + StopTime; //kt added 8/8/2007
190
191 frmRenewOrders.lstOrders.Items.AddObject(PlainText, AnOrder);
192 end;
193
194 if frmRenewOrders.OrderList.Count < 1 then
195 frmRenewOrders.Close
196 else
197 frmRenewOrders.ShowModal;
198
199 if frmRenewOrders.OKPressed then
200 begin
201 with frmRenewOrders.OrderList do
202 for i := Count - 1 downto 0 do
203 begin
204 OrchkList.Clear;
205 AnOrder := TOrder(Items[i]);
206 OriginalID := AnOrder.ID;
207
208 //BAPHII 1.3.2 - Pick up source-order ID here
209 UBAGlobals.SourceOrderID := OriginalID; //BAPHII 1.3.2
210 UBAGlobals.CopyTreatmentFactorsDxsToRenewedOrder; //BAPHII 1.3.2
211
212 if CheckOrderGroup(OriginalID) = 1 then
213 RNFillerID := 'PSI'
214 else if CheckOrderGroup(OriginalID) = 2 then
215 RNFillerID := 'PSO';
216
217 if AddFillerAppID(RNFillerID) and OrderChecksEnabled then
218 begin
219// StatusText('Order Checking...'); <-- original line. //kt 8/8/2007
220 StatusText(DKLangConstW('fOrdersRenew_Order_Checkingxxx')); //kt added 8/8/2007
221 x := OrderChecksOnDisplay(RNFillerID);
222 StatusText('');
223 if Length(x) > 0 then InfoBox(x, TC_ORDERCHECKS, MB_OK);
224 end;
225
226 TreatAsIMOOrder := False;
227
228 if not frmRenewOrders.AcceptOrderCheckOnRenew(AnOrder.ID,OrchkList) then
229 begin
230 frmRenewOrders.OrderList.Delete(i);
231 Continue;
232 end;
233
234 if IsIMOOrder(OriginalID) then //IMO
235 begin
236 TD := FMToday;
237 if IsValidIMOLoc(Encounter.Location, Patient.DFN) and (Encounter.DateTime > TD) then
238 TreatAsIMOOrder := True;
239 if Patient.Inpatient then TreatAsIMOOrder := True;
240 end;
241
242 RenewFields := TOrderRenewFields(AnOrder.LinkObject);
243
244 //PSI-COMPLEX Start
245 if IsComplexOrder(OriginalID) then
246 begin
247 if TreatAsIMOOrder then
248 RenewOrder(AnOrder, RenewFields,1,Encounter.DateTime,OrchkList)
249 else
250 RenewOrder(AnOrder, RenewFields,1,0,OrchkList);
251
252 AnOrder.ActionOn := OriginalID + '=RN';
253 SendMessage(Application.MainForm.Handle, UM_NEWORDER, ORDER_CPLXRN, Integer(AnOrder));
254 end
255 //PSI-COMPLEX End
256 else
257 begin
258 if TreatAsIMOOrder then
259 RenewOrder(AnOrder, RenewFields,0,Encounter.DateTime,OrchkList)
260 else
261 RenewOrder(AnOrder, RenewFields,0,0,OrchkList);
262
263 AnOrder.ActionOn := OriginalID + '=RN';
264 SendMessage(Application.MainForm.Handle, UM_NEWORDER, ORDER_ACT, Integer(AnOrder));
265 end;
266 end;
267
268 Result := True;
269
270 end
271
272 else
273 with frmRenewOrders.OrderList do
274 for i := 0 to Count - 1 do
275 UnlockOrder(TOrder(Items[i]).ID);
276 finally
277 // free all the TOrderRenewFields that were created
278 SelectedList := frmRenewOrders.OrderList;
279
280 with frmRenewOrders.OrderList do for i := 0 to Count - 1 do
281 begin
282 AnOrder := TOrder(Items[i]);
283 RenewFields := TOrderRenewFields(AnOrder.LinkObject);
284 RenewFields.Free;
285 AnOrder.LinkObject := nil;
286 end;
287 frmRenewOrders.Release;
288 end;
289end;
290
291procedure TfrmRenewOrders.FormCreate(Sender: TObject);
292begin
293 inherited;
294 lstOrders.Color := ReadOnlyColor;
295 OKPressed := False;
296end;
297
298procedure TfrmRenewOrders.lstOrdersMeasureItem(Control: TWinControl;
299 Index: Integer; var Height: Integer);
300var
301 x: string;
302 DateHeight, TextHeight: Integer;
303 AnOrder: TOrder;
304 RenewFields: TOrderRenewFields;
305begin
306 inherited;
307 AnOrder := TOrder(OrderList.Items[Index]);
308 if AnOrder <> nil then
309 begin
310 RenewFields := TOrderRenewFields(AnOrder.LinkObject);
311// with RenewFields do x := 'Start: ' + StartTime + CRLF + 'Stop: ' + StopTime; <-- original line. //kt 8/8/2007
312 with RenewFields do x := DKLangConstW('fOrdersRenew_Startx') + StartTime + CRLF + DKLangConstW('fOrdersRenew_Stopx') + StopTime; //kt added 8/8/2007
313 TextHeight := MeasureColumnHeight(RenewFields.NewText,Index,TEXT_COLUMN);
314 DateHeight := MeasureColumnHeight(x, Index, DATE_COLUMN);
315 Height := HigherOf(TextHeight, DateHeight);
316 if Height > 255 then Height := 255; //This is maximum allowed by a windows listbox item.
317 end
318end;
319
320procedure TfrmRenewOrders.lstOrdersDrawItem(Control: TWinControl;
321 Index: Integer; Rect: TRect; State: TOwnerDrawState);
322var
323 x: string;
324 AnOrder: TOrder;
325 RenewFields: TOrderRenewFields;
326begin
327 inherited;
328 AnOrder := TOrder(lstOrders.Items.Objects[Index]);
329 if AnOrder <> nil then with AnOrder do
330 begin
331 RenewFields := TOrderRenewFields(AnOrder.LinkObject);
332 if RenewFields.BaseType = OD_TEXTONLY
333// then with RenewFields do x := 'Start: ' + StartTime + CRLF + 'Stop: ' + StopTime <-- original line. //kt 8/8/2007
334 then with RenewFields do x := DKLangConstW('fOrdersRenew_Startx') + StartTime + CRLF + DKLangConstW('fOrdersRenew_Stopx') + StopTime //kt added 8/8/2007
335 else x := '';
336 ListGridDrawLines(lstOrders, hdrOrders, Index, State);
337 ListGridDrawCell(lstOrders, hdrOrders, Index, TEXT_COLUMN, RenewFields.NewText, WORD_WRAPPED);
338 ListGridDrawCell(lstOrders, hdrOrders, Index, DATE_COLUMN, x, WORD_WRAPPED);
339 end;
340end;
341
342procedure TfrmRenewOrders.lstOrdersClick(Sender: TObject);
343var
344 RenewFields: TOrderRenewFields;
345begin
346 inherited;
347 with lstOrders do
348 begin
349 if ItemIndex < 0 then Exit;
350 RenewFields := TOrderRenewFields(TOrder(Items.Objects[ItemIndex]).LinkObject);
351 case RenewFields.BaseType of
352// OD_MEDOUTPT: cmdChange.Caption := 'Change Refills/Pick Up...'; <-- original line. //kt 8/8/2007
353 OD_MEDOUTPT: cmdChange.Caption := DKLangConstW('fOrdersRenew_Change_RefillsxPick_Upxxx'); //kt added 8/8/2007
354// OD_TEXTONLY: cmdChange.Caption := 'Change Start/Stop...'; <-- original line. //kt 8/8/2007
355 OD_TEXTONLY: cmdChange.Caption := DKLangConstW('fOrdersRenew_Change_StartxStopxxx'); //kt added 8/8/2007
356// else cmdChange.Caption := 'Change...'; <-- original line. //kt 8/8/2007
357 else cmdChange.Caption := DKLangConstW('fOrdersRenew_Changexxx'); //kt added 8/8/2007
358 end;
359 with RenewFields do if (BaseType = OD_MEDOUTPT) or (BaseType = OD_TEXTONLY)
360 then cmdChange.Enabled := True
361 else cmdChange.Enabled := False;
362 end;
363end;
364
365procedure TfrmRenewOrders.cmdChangeClick(Sender: TObject);
366var
367 StartPos: Integer;
368 x, NewComment, OldComment, OldRefills, OldPickup: string;
369 AnOrder: TOrder;
370 RenewFields: TOrderRenewFields;
371begin
372 SetupVars; //kt added 8/8/2007 to replace constants with vars.
373 inherited;
374 with lstOrders do
375 begin
376 if ItemIndex < 0 then Exit;
377 AnOrder := TOrder(Items.Objects[ItemIndex]);
378 RenewFields := TOrderRenewFields(AnOrder.LinkObject);
379 case RenewFields.BaseType of
380 OD_MEDOUTPT: with RenewFields do begin
381// OldRefills := IntToStr(Refills) + ' refills'; <-- original line. //kt 8/8/2007
382 OldRefills := IntToStr(Refills) + DKLangConstW('fOrdersRenew_refills'); //kt added 8/8/2007
383 { reverse string to make sure getting last matching comment }
384 OldComment := UpperCase(ReverseStr(Comments));
385 OldPickup := PickupText(Pickup);
386 ExecuteRenewOutMed(Refills, Comments, Pickup, AnOrder);
387 NewComment := UpperCase(ReverseStr(Comments));
388 x := ReverseStr(NewText);
389 StartPos := Pos(OldComment, UpperCase(x));
390 if StartPos > 0
391 then x := Copy(x, 1, StartPos - 1) + NewComment +
392 Copy(x, StartPos + Length(OldComment), Length(x))
393 else x := NewComment + x;
394 NewText := ReverseStr(x);
395 x := NewText;
396 StartPos := Pos(OldRefills, x);
397 if StartPos > 0
398// then x := Copy(x, 1, StartPos - 1) + IntToStr(Refills) + ' refills' + <-- original line. //kt 8/8/2007
399 then x := Copy(x, 1, StartPos - 1) + IntToStr(Refills) + DKLangConstW('fOrdersRenew_refills') + //kt added 8/8/2007
400 Copy(x, StartPos + Length(OldRefills), Length(x))
401// else x := x + ' ' + IntToStr(Refills) + ' refills'; <-- original line. //kt 8/8/2007
402 else x := x + ' ' + IntToStr(Refills) + DKLangConstW('fOrdersRenew_refills'); //kt added 8/8/2007
403 StartPos := Pos(OldPickup, x);
404 if StartPos > 0
405 then x := Copy(x, 1, StartPos - 1) + PickupText(Pickup) +
406 Copy(x, StartPos + Length(OldPickup), Length(x))
407 else x := x + PickupText(Pickup);
408 NewText := x;
409 end;
410 OD_TEXTONLY: with RenewFields do ExecuteDateRange(StartTime, StopTime, DT_FUTURE+DT_TIMEOPT,
411 TC_START_STOP, TX_START_STOP, TX_LBL_START, TX_LBL_STOP);
412 end;
413 end;
414 lstOrders.Invalidate;
415end;
416
417procedure TfrmRenewOrders.cmdOKClick(Sender: TObject);
418begin
419 inherited;
420 OKPressed := True;
421 Close;
422end;
423
424procedure TfrmRenewOrders.cmdCancelClick(Sender: TObject);
425begin
426 inherited;
427 Close;
428end;
429
430function TfrmRenewOrders.MeasureColumnHeight(TheOrderText: string; Index,
431 Column: integer): integer;
432var
433 ARect: TRect;
434begin
435 ARect.Left := 0;
436 ARect.Top := 0;
437 ARect.Bottom := 0;
438 ARect.Right := hdrOrders.Sections[Column].Width -6;
439 Result := WrappedTextHeightByFont(lstOrders.Canvas,lstOrders.Font,TheOrderText,ARect);
440end;
441
442function TfrmRenewOrders.AcceptOrderCheckOnRenew(const AnOrderID: string;
443 var OCList: TStringList): boolean;
444var
445 OIInfo,FillerID: string;
446 AnOIList: TStringList;
447begin
448 AnOIList := TStringList.Create;
449 OIInfo := DataForOrderCheck(AnOrderID);
450 FillerID := Piece(OIInfo,'^',2);
451 AnOIList.Add(OIInfo);
452 OrderChecksOnAccept(OCList, FillerID, '', AnOIList, AnOrderID);
453 Result := AcceptOrderWithChecks(OCList);
454end;
455
456procedure TfrmRenewOrders.FormClose(Sender: TObject;
457 var Action: TCloseAction);
458begin
459 inherited;
460 SaveUserBounds(Self);
461end;
462
463procedure TfrmRenewOrders.FormShow(Sender: TObject);
464begin
465 inherited;
466 SetFormPosition(Self);
467end;
468
469procedure TfrmRenewOrders.hdrOrdersSectionResize(HeaderControl: THeaderControl; Section: THeaderSection);
470begin
471 inherited;
472 lstOrders.Repaint; //CQ6367
473end;
474
475
476end.
Note: See TracBrowser for help on using the repository browser.