source: cprs/branches/HealthSevak-CPRS/CPRS-Chart/Orders/fODReleaseEvent.pas@ 1707

Last change on this file since 1707 was 1693, checked in by healthsevak, 10 years ago

Committing the files for first time to this new branch
File size: 9.3 KB
Line 
1unit fODReleaseEvent;
2
3interface
4
5uses
6 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
7 StdCtrls, ExtCtrls, ORFn, CheckLst, ORCtrls, fAutoSz, fBase508Form,
8 VA508AccessibilityManager;
9
10type
11 TfrmOrdersReleaseEvent = class(TfrmBase508Form)
12 pnlMiddle: TPanel;
13 pnlBottom: TPanel;
14 btnOK: TButton;
15 btnCancel: TButton;
16 cklstOrders: TCaptionCheckListBox;
17 lblRelease: TLabel;
18 procedure btnCancelClick(Sender: TObject);
19 procedure FormCreate(Sender: TObject);
20 procedure btnOKClick(Sender: TObject);
21 procedure FormDestroy(Sender: TObject);
22 procedure cklstOrdersMeasureItem(Control: TWinControl; Index: Integer;
23 var AHeight: Integer);
24 procedure cklstOrdersDrawItem(Control: TWinControl; Index: Integer;
25 Rect: TRect; State: TOwnerDrawState);
26 procedure cklstOrdersMouseMove(Sender: TObject; Shift: TShiftState; X,
27 Y: Integer);
28 private
29 { Private declarations }
30 OKPressed: boolean;
31 FLastHintItem: integer;
32 FOldHintPause: integer;
33 FOldHintHidePause: integer;
34 FComplete: boolean;
35 FCurrTS: string;
36 public
37 { Public declarations }
38 property CurrTS: string read FCurrTS write FCurrTS;
39 end;
40
41//procedure ExecuteReleaseEventOrders(AnOrderList: TList);
42function ExecuteReleaseEventOrders(AnOrderList: TList): boolean;
43
44implementation
45{$R *.DFM}
46
47uses rCore, rOrders, uConst, fOrdersPrint, uCore, uOrders, fOrders, rODLab, fRptBox,
48 VAUtils;
49
50const
51 TX_SAVERR1 = 'The error, ';
52 TX_SAVERR2 = ', occurred while trying to release:' + CRLF + CRLF;
53 TC_SAVERR = 'Error Saving Order';
54
55//procedure ExecuteReleaseEventOrders(AnOrderList: TList);
56function ExecuteReleaseEventOrders(AnOrderList: TList): boolean;
57const
58 TXT_RELEASE = #13 + #13 + ' The following orders will be released to service:';
59var
60 i,j,idx: integer;
61 AOrder: TOrder;
62 OrdersLst: TStringlist;
63 OrderText, LastCheckedPtEvt, SpeCap: string;
64 frmOrdersReleaseEvent: TfrmOrdersReleaseEvent;
65 AList: TStringList;
66
67 function FindOrderText(const AnID: string): string;
68 var
69 i: Integer;
70 begin
71 Result := '';
72 with AnOrderList do for i := 0 to Count - 1 do
73 with TOrder(Items[i]) do if ID = AnID then
74 begin
75 Result := Text;
76 Break;
77 end;
78 end;
79
80begin
81 frmOrdersReleaseEvent := TfrmOrdersReleaseEvent.Create(Application);
82 try
83 frmOrdersReleaseEvent.CurrTS := Piece(GetCurrentSpec(Patient.DFN),'^',1);
84 if Length(frmOrdersReleaseEvent.CurrTS)>0 then
85 SpeCap := #13 + ' The current treating specialty is ' + frmOrdersReleaseEvent.CurrTS
86 else
87 SpeCap := #13 + ' No treating specialty is available.';
88 ResizeFormToFont(TForm(frmOrdersReleaseEvent));
89 if Patient.Inpatient then
90 frmOrdersReleaseEvent.lblRelease.Caption := ' ' + Patient.Name + ' is currently admitted to '
91 + Encounter.LocationName + SpeCap + TXT_RELEASE
92 else
93 begin
94 if Encounter.Location > 0 then
95 frmOrdersReleaseEvent.lblRelease.Caption := ' ' + Patient.Name + ' is currently at '
96 + Encounter.LocationName + SpeCap + TXT_RELEASE
97 else
98 frmOrdersReleaseEvent.lblRelease.Caption := ' ' + Patient.Name + ' is currently an outpatient.' + SpeCap + TXT_RELEASE;
99 end;
100 with frmOrdersReleaseEvent do
101 cklstOrders.Caption := lblRelease.Caption;
102 with AnOrderList do for i := 0 to Count - 1 do
103 begin
104 AOrder := TOrder(Items[i]);
105 idx := frmOrdersReleaseEvent.cklstOrders.Items.AddObject(AOrder.Text,AOrder);
106 frmOrdersReleaseEvent.cklstOrders.Checked[idx] := True;
107 end;
108 frmOrdersReleaseEvent.ShowModal;
109 if frmOrdersReleaseEvent.OKPressed then
110 begin
111 OrdersLst := TStringList.Create;
112 for j := 0 to frmOrdersReleaseEvent.cklstOrders.Items.Count - 1 do
113 begin
114 if frmOrdersReleaseEvent.cklstOrders.Checked[j] then
115 OrdersLst.Add(TOrder(frmOrdersReleaseEvent.cklstOrders.Items.Objects[j]).ID);
116 end;
117 StatusText('Releasing Orders to Service...');
118 SendReleaseOrders(OrdersLst);
119 LastCheckedPtEvt := '';
120
121 //CQ #15813 Modired code to look for error string mentioned in CQ and change strings to conts - JCS
122 with OrdersLst do if Count > 0 then for i := 0 to Count - 1 do
123 begin
124 if Pos('E', Piece(OrdersLst[i], U, 2)) > 0 then
125 begin
126 OrderText := FindOrderText(Piece(OrdersLst[i], U, 1));
127 if Piece(OrdersLst[i],U,4) = TX_SAVERR_PHARM_ORD_NUM_SEARCH_STRING then
128 InfoBox(TX_SAVERR1 + Piece(OrdersLst[i], U, 4) + TX_SAVERR2 + OrderText + CRLF + CRLF +
129 TX_SAVERR_PHARM_ORD_NUM, TC_SAVERR, MB_OK)
130 else if Piece(OrdersLst[i],U,4) = TX_SAVERR_IMAGING_PROC_SEARCH_STRING then
131 InfoBox(TX_SAVERR1 + Piece(OrdersLst[i], U, 4) + TX_SAVERR2 + OrderText + CRLF + CRLF +
132 TX_SAVERR_IMAGING_PROC, TC_SAVERR, MB_OK)
133 else
134 InfoBox(TX_SAVERR1 + Piece(OrdersLst[i], U, 4) + TX_SAVERR2 + OrderText,
135 TC_SAVERR, MB_OK);
136 end;
137 end;
138 // CQ 10226, PSI-05-048 - advise of auto-change from LC to WC on lab orders
139 AList := TStringList.Create;
140 try
141 CheckForChangeFromLCtoWCOnRelease(AList, Encounter.Location, OrdersLst);
142 if AList.Text <> '' then
143 ReportBox(AList, 'Changed Orders', TRUE);
144 finally
145 AList.Free;
146 end;
147 PrintOrdersOnSignRelease(OrdersLst, NO_PROVIDER);
148
149 with AnOrderList do for i := 0 to Count - 1 do with TOrder(Items[i]) do
150 begin
151 if EventPtr <> LastCheckedPtEvt then
152 begin
153 LastCheckedPtEvt := EventPtr;
154 if CompleteEvt(EventPtr,EventName,False) then
155 frmOrdersReleaseEvent.FComplete := True;
156 end;
157 end;
158 StatusText('');
159 ordersLst.Free;
160 with AnOrderList do for i := 0 to Count - 1 do UnlockOrder(TOrder(Items[i]).ID);
161 if frmOrdersReleaseEvent.FComplete then
162 begin
163 frmOrders.InitOrderSheetsForEvtDelay;
164 frmOrders.ClickLstSheet;
165 end;
166 frmOrdersReleaseEvent.FComplete := False;
167 Result := True;
168 end else
169 Result := False;
170 Except
171 on E: exception do
172 Result := false;
173 end;
174 {finally
175 with AnOrderList do for i := 0 to Count - 1 do UnlockOrder(TOrder(Items[i]).ID);
176 if frmOrdersReleaseEvent.FComplete then
177 begin
178 frmOrders.InitOrderSheetsForEvtDelay;
179 frmOrders.ClickLstSheet;
180 end;
181 frmOrdersReleaseEvent.FComplete := False;
182 end;}
183end;
184
185procedure TfrmOrdersReleaseEvent.btnCancelClick(Sender: TObject);
186begin
187 Close;
188end;
189
190procedure TfrmOrdersReleaseEvent.FormCreate(Sender: TObject);
191begin
192 inherited;
193 OKPressed := False;
194 FLastHintItem := -1;
195 FComplete := False;
196 FOldHintPause := Application.HintPause;
197 FCurrTS := '';
198 Application.HintPause := 250;
199 FOldHintHidePause := Application.HintHidePause;
200 Application.HintHidePause := 30000;
201end;
202
203procedure TfrmOrdersReleaseEvent.btnOKClick(Sender: TObject);
204var
205 i: integer;
206 beSelected: boolean;
207begin
208 beSelected := False;
209 for i := 0 to cklstOrders.Items.Count - 1 do
210 begin
211 if cklstOrders.Checked[i] then
212 begin
213 beSelected := True;
214 Break;
215 end;
216 end;
217 if not beSelected then
218 begin
219 ShowMsg('You have to select at least one order!');
220 Exit;
221 end;
222 OKPressed := True;
223 Close;
224end;
225
226procedure TfrmOrdersReleaseEvent.FormDestroy(Sender: TObject);
227begin
228 inherited;
229 Application.HintPause := FOldHintPause;
230 Application.HintHidePause := FOldHintHidePause;
231end;
232
233procedure TfrmOrdersReleaseEvent.cklstOrdersMeasureItem(
234 Control: TWinControl; Index: Integer; var AHeight: Integer);
235var
236 x:string;
237 ARect: TRect;
238begin
239 inherited;
240 AHeight := MainFontHeight + 2;
241 with cklstOrders do if Index < Items.Count then
242 begin
243 x := FilteredString(Items[Index]);
244 ARect := ItemRect(Index);
245 AHeight := WrappedTextHeightByFont( cklstOrders.Canvas, Font, x, ARect);
246 if AHeight > 255 then AHeight := 255;
247 if AHeight < 13 then AHeight := 13;
248 end;
249end;
250
251procedure TfrmOrdersReleaseEvent.cklstOrdersDrawItem(Control: TWinControl;
252 Index: Integer; Rect: TRect; State: TOwnerDrawState);
253var
254 x: string;
255 ARect: TRect;
256begin
257 inherited;
258 x := '';
259 ARect := Rect;
260 with cklstOrders do
261 begin
262 Canvas.FillRect(ARect);
263 Canvas.Pen.Color := Get508CompliantColor(clSilver);
264 Canvas.MoveTo(0, ARect.Bottom - 1);
265 Canvas.LineTo(ARect.Right, ARect.Bottom - 1);
266 if Index < Items.Count then
267 begin
268 X := FilteredString(Items[Index]);
269 DrawText(Canvas.handle, PChar(x), Length(x), ARect, DT_LEFT or DT_NOPREFIX or DT_WORDBREAK);
270 end;
271 end;
272end;
273
274procedure TfrmOrdersReleaseEvent.cklstOrdersMouseMove(Sender: TObject;
275 Shift: TShiftState; X, Y: Integer);
276var
277 Itm: integer;
278begin
279 inherited;
280 Itm := cklstOrders.ItemAtPos(Point(X, Y), TRUE);
281 if (Itm >= 0) then
282 begin
283 if (Itm <> FLastHintItem) then
284 begin
285 Application.CancelHint;
286 cklstOrders.Hint := TrimRight(cklstOrders.Items[Itm]);
287 FLastHintItem := Itm;
288 Application.ActivateHint(Point(X, Y));
289 end;
290 end else
291 begin
292 cklstOrders.Hint := '';
293 FLastHintItem := -1;
294 Application.CancelHint;
295 end;
296end;
297
298end.
Note: See TracBrowser for help on using the repository browser.