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

Last change on this file since 1722 was 1679, checked in by healthsevak, 10 years ago

Updating the working copy to CPRS version 28
File size: 15.8 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 hdrOrders.Sections[0].Width := Round(self.width * 0.75);
265 hdrOrders.Sections[1].Width := Round(self.width * 0.25);
266 ResizeFormToFont(Self);
267 SetFormPosition(Self);
268end;
269
270procedure TfrmRenewOrders.FormResize(Sender: TObject);
271var
272i: integer;
273Height: integer;
274begin
275 inherited;
276 if lstorders.Count = 0 then exit;
277 for I := 0 to lstOrders.Count - 1 do
278 begin
279 Height := lstOrders.ItemRect(i).Bottom - lstOrders.ItemRect(i).Top;
280 lstOrdersMeasureItem(lstOrders,i,Height);
281 //ListGridDrawCell(lstOrders, hdrOrders, i, TEXT_COLUMN, x, WORD_WRAPPED);
282 end;
283end;
284
285procedure TfrmRenewOrders.lstOrdersMeasureItem(Control: TWinControl;
286 Index: Integer; var Height: Integer);
287var
288 x, tmp: string;
289 DateHeight, TextHeight: Integer;
290 AnOrder: TOrder;
291 RenewFields: TOrderRenewFields;
292begin
293 inherited;
294 AnOrder := TOrder(OrderList.Items[Index]);
295 if (AnOrder <> nil) then
296 begin
297 RenewFields := TOrderRenewFields(AnOrder.LinkObject);
298 with RenewFields do x := 'Start: ' + StartTime + CRLF + 'Stop: ' + StopTime;
299 //tmp := RenewFields.NewText;
300 tmp := LstOrders.Items.Strings[index];
301 TextHeight := MeasureColumnHeight(tmp,Index,TEXT_COLUMN);
302 DateHeight := MeasureColumnHeight(x, Index, DATE_COLUMN);
303 Height := HigherOf(TextHeight, DateHeight);
304 if Height > 255 then Height := 255; //This is maximum allowed by a windows listbox item.
305 end
306end;
307
308procedure TfrmRenewOrders.lstOrdersDrawItem(Control: TWinControl;
309 Index: Integer; Rect: TRect; State: TOwnerDrawState);
310var
311 x: string;
312 AnOrder: TOrder;
313 RenewFields: TOrderRenewFields;
314begin
315 inherited;
316 AnOrder := TOrder(lstOrders.Items.Objects[Index]);
317 if AnOrder <> nil then with AnOrder do
318 begin
319 RenewFields := TOrderRenewFields(AnOrder.LinkObject);
320 if RenewFields.BaseType = OD_TEXTONLY
321 then with RenewFields do x := 'Start: ' + StartTime + CRLF + 'Stop: ' + StopTime
322 else x := '';
323 ListGridDrawLines(lstOrders, hdrOrders, Index, State);
324 ListGridDrawCell(lstOrders, hdrOrders, Index, TEXT_COLUMN, RenewFields.NewText, WORD_WRAPPED);
325 ListGridDrawCell(lstOrders, hdrOrders, Index, DATE_COLUMN, x, WORD_WRAPPED);
326 end;
327end;
328
329procedure TfrmRenewOrders.lstOrdersClick(Sender: TObject);
330var
331 RenewFields: TOrderRenewFields;
332begin
333 inherited;
334 with lstOrders do
335 begin
336 if ItemIndex < 0 then Exit;
337 RenewFields := TOrderRenewFields(TOrder(Items.Objects[ItemIndex]).LinkObject);
338 case RenewFields.BaseType of
339 OD_MEDOUTPT: cmdChange.Caption := 'Change Refills/Pick Up...';
340 OD_TEXTONLY: cmdChange.Caption := 'Change Start/Stop...';
341 else cmdChange.Caption := 'Change...';
342 end;
343 with RenewFields do if (BaseType = OD_MEDOUTPT) or (BaseType = OD_TEXTONLY)
344 then cmdChange.Enabled := True
345 else cmdChange.Enabled := False;
346 end;
347end;
348
349procedure TfrmRenewOrders.cmdChangeClick(Sender: TObject);
350var
351 StartPos: Integer;
352 x, NewComment, OldComment, OldRefills, OldPickup: string;
353 AnOrder: TOrder;
354 RenewFields: TOrderRenewFields;
355begin
356 inherited;
357 with lstOrders do
358 begin
359 if ItemIndex < 0 then Exit;
360 AnOrder := TOrder(Items.Objects[ItemIndex]);
361 RenewFields := TOrderRenewFields(AnOrder.LinkObject);
362 case RenewFields.BaseType of
363 OD_MEDOUTPT: with RenewFields do begin
364 OldRefills := IntToStr(Refills) + ' refills';
365 { reverse string to make sure getting last matching comment }
366 OldComment := UpperCase(ReverseStr(Comments));
367 OldPickup := PickupText(Pickup);
368 ExecuteRenewOutMed(Refills, Comments, Pickup, AnOrder);
369 NewComment := UpperCase(ReverseStr(Comments));
370 x := ReverseStr(NewText);
371 StartPos := Pos(OldComment, UpperCase(x));
372 if StartPos > 0
373 then x := Copy(x, 1, StartPos - 1) + NewComment +
374 Copy(x, StartPos + Length(OldComment), Length(x))
375 else x := NewComment + x;
376 NewText := ReverseStr(x);
377 x := NewText;
378 StartPos := Pos(OldRefills, x);
379 if StartPos > 0
380 then x := Copy(x, 1, StartPos - 1) + IntToStr(Refills) + ' refills' +
381 Copy(x, StartPos + Length(OldRefills), Length(x))
382 else x := x + ' ' + IntToStr(Refills) + ' refills';
383 StartPos := Pos(OldPickup, x);
384 if StartPos > 0
385 then x := Copy(x, 1, StartPos - 1) + PickupText(Pickup) +
386 Copy(x, StartPos + Length(OldPickup), Length(x))
387 else x := x + PickupText(Pickup);
388 NewText := x;
389 end;
390 OD_TEXTONLY: with RenewFields do ExecuteDateRange(StartTime, StopTime, DT_FUTURE+DT_TIMEOPT,
391 TC_START_STOP, TX_START_STOP, TX_LBL_START, TX_LBL_STOP);
392 end;
393 end;
394 lstOrders.Invalidate;
395end;
396
397procedure TfrmRenewOrders.cmdOKClick(Sender: TObject);
398begin
399 inherited;
400 OKPressed := True;
401 Close;
402end;
403
404procedure TfrmRenewOrders.cmdCancelClick(Sender: TObject);
405begin
406 inherited;
407 Close;
408end;
409
410function TfrmRenewOrders.MeasureColumnHeight(TheOrderText: string; Index,
411 Column: integer): integer;
412var
413 ARect: TRect;
414 cnt: integer;
415 x: string;
416begin
417 cnt := 0;
418 ARect.Left := 0;
419 ARect.Top := 0;
420 ARect.Bottom := 0;
421 ARect.Right := hdrOrders.Sections[Column].Width -6;
422 Result := WrappedTextHeightByFont(lstOrders.Canvas,lstOrders.Font,TheOrderText,ARect);
423 //AGP 28.0 this fix address the issue of WrappedTextHeightByFont appearing to not take in account CRLF
424 if Pos(CRLF, TheOrderText) > 0 then
425 begin
426 repeat
427 x := Copy(TheOrderText, 1, Pos(CRLF, TheOrderText) - 1);
428 if Length(x) = 0 then x := TheOrderText;
429 Delete(TheOrderText, 1, Length(x) + 2); {delete text + CRLF}
430 cnt := cnt + 1;
431 until TheOrderText = '';
432 if cnt > 0 then Result := Result + (cnt * Abs(self.Font.Height));
433 if Result > 255 then Result := 255;
434 end;
435
436end;
437
438function TfrmRenewOrders.AcceptOrderCheckOnRenew(const AnOrderID: string;
439 var OCList: TStringList): boolean;
440var
441 OIInfo,FillerID: string;
442 AnOIList: TStringList;
443 subI: integer;
444begin
445 AnOIList := TStringList.Create;
446 OIInfo := DataForOrderCheck(AnOrderID);
447 FillerID := Piece(OIInfo,'^',2);
448 subI := 1;
449 while Length(Piece(OIInfo,'|',subI))>1 do
450 begin
451 AnOIList.Add(Piece(OIInfo,'|',subI));
452 subI := subI + 1;
453 end;
454 OrderChecksOnAccept(OCList, FillerID, '', AnOIList, AnOrderID,'1');
455 Result := AcceptOrderWithChecks(OCList);
456end;
457
458procedure TfrmRenewOrders.FormClose(Sender: TObject;
459 var Action: TCloseAction);
460begin
461 inherited;
462 SaveUserBounds(Self);
463end;
464
465procedure TfrmRenewOrders.hdrOrdersSectionResize(HeaderControl: THeaderControl; Section: THeaderSection);
466begin
467 inherited;
468 lstOrders.Repaint; //CQ6367
469end;
470
471
472end.
Note: See TracBrowser for help on using the repository browser.