source: cprs/trunk/CPRS-Chart/Orders/fOrdersRenew.pas@ 1035

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

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