Module

fODReleaseEvent

Path

C:\CPRS\CPRS30\Orders\fODReleaseEvent.pas

Last Modified

7/15/2014 3:26:42 PM

Units Used in Interface

Name Comments
fAutoSz -
fBase508Form -

Units Used in Implementation

Name Comments
fOrders -
fOrdersPrint -
fRptBox -
rCore -
rODLab -
rOrders -
uConst -
uCore -
uOrders -

Classes

Name Comments
TfrmOrdersReleaseEvent -

Procedures

Name Owner Declaration Scope Comments
btnCancelClick TfrmOrdersReleaseEvent procedure btnCancelClick(Sender: TObject); Public/Published -
btnOKClick TfrmOrdersReleaseEvent procedure btnOKClick(Sender: TObject); Public/Published -
cklstOrdersDrawItem TfrmOrdersReleaseEvent procedure cklstOrdersDrawItem(Control: TWinControl; Index: Integer; Rect: TRect; State: TOwnerDrawState); Public/Published -
cklstOrdersMeasureItem TfrmOrdersReleaseEvent procedure cklstOrdersMeasureItem(Control: TWinControl; Index: Integer; var AHeight: Integer); Public/Published -
cklstOrdersMouseMove TfrmOrdersReleaseEvent procedure cklstOrdersMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); Public/Published -
FormCreate TfrmOrdersReleaseEvent procedure FormCreate(Sender: TObject); Public/Published -
FormDestroy TfrmOrdersReleaseEvent procedure FormDestroy(Sender: TObject); Public/Published -

Functions

Name Owner Declaration Scope Comments
ExecuteReleaseEventOrders - function ExecuteReleaseEventOrders(AnOrderList: TList): boolean; Interfaced
Procedure ExecuteReleaseEventOrders(AnOrderList: TList);
procedure ExecuteReleaseEventOrders(AnOrderList: TList);
FindOrderText - function FindOrderText(const AnID: string): string; Local -

Constants

Name Declaration Scope Comments
TC_SAVERR 'Error Saving Order' Global -
TX_SAVERR1 'The error, ' Global -
TX_SAVERR2 ', occurred while trying to release:' + CRLF + CRLF Global -


Module Source

1     unit fODReleaseEvent;
2     
3     interface
4     
5     uses
6       Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
7       StdCtrls, ExtCtrls, ORFn, CheckLst, ORCtrls, fAutoSz, fBase508Form,
8       VA508AccessibilityManager;
9     
10    type
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);
42    function ExecuteReleaseEventOrders(AnOrderList: TList): boolean;
43    
44    implementation
45    {$R *.DFM}
46    
47    uses rCore, rOrders, uConst, fOrdersPrint, uCore, uOrders, fOrders, rODLab, fRptBox,
48      VAUtils;
49    
50    const
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);
56    function ExecuteReleaseEventOrders(AnOrderList: TList): boolean;
57    const
58      TXT_RELEASE = #13 + #13 + '  The following orders will be released to service:';
59    var
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    
80    begin
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;}
183   end;
184   
185   procedure TfrmOrdersReleaseEvent.btnCancelClick(Sender: TObject);
186   begin
187     Close;
188   end;
189   
190   procedure TfrmOrdersReleaseEvent.FormCreate(Sender: TObject);
191   begin
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;
201   end;
202   
203   procedure TfrmOrdersReleaseEvent.btnOKClick(Sender: TObject);
204   var
205     i: integer;
206     beSelected: boolean;
207   begin
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;
224   end;
225   
226   procedure TfrmOrdersReleaseEvent.FormDestroy(Sender: TObject);
227   begin
228     inherited;
229     Application.HintPause := FOldHintPause;
230     Application.HintHidePause := FOldHintHidePause;
231   end;
232   
233   procedure TfrmOrdersReleaseEvent.cklstOrdersMeasureItem(
234     Control: TWinControl; Index: Integer; var AHeight: Integer);
235   var
236     x:string;
237     ARect: TRect;
238   begin
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;
249   end;
250   
251   procedure TfrmOrdersReleaseEvent.cklstOrdersDrawItem(Control: TWinControl;
252     Index: Integer; Rect: TRect; State: TOwnerDrawState);
253   var
254     x: string;
255     ARect: TRect;
256   begin
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;
272   end;
273   
274   procedure TfrmOrdersReleaseEvent.cklstOrdersMouseMove(Sender: TObject;
275     Shift: TShiftState; X, Y: Integer);
276   var
277     Itm: integer;
278   begin
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;
296   end;
297   
298   end.

Module Calls (2 levels)


fODReleaseEvent
 ├fBase508Form
 │ ├uConst
 │ └uHelpManager
 ├rOrders
 │ ├uCore
 │ ├rCore
 │ ├uConst
 │ ├UBAGlobals
 │ └UBACore
 ├uConst
 ├uCore...
 ├uOrders
 │ ├uConst
 │ ├rConsults
 │ ├rOrders...
 │ ├fODBase
 │ ├XuDsigS
 │ ├fODDiet
 │ ├fODMisc
 │ ├fODGen
 │ ├fODMedIn
 │ ├fODMedOut
 │ ├fODText
 │ ├fODConsult
 │ ├fODProc
 │ ├fODRad
 │ ├fODLab
 │ ├fODBBank
 │ ├fODMeds
 │ ├fODMedIV
 │ ├fODVitals
 │ ├fODAuto
 │ ├fOMNavA
 │ ├rCore...
 │ ├uCore...
 │ ├fFrame
 │ ├fEncnt
 │ ├fOMVerify
 │ ├fOrderSaveQuick
 │ ├fOMSet
 │ ├rMisc
 │ ├uODBase
 │ ├rODMeds
 │ ├fLkUpLocation
 │ ├fOrdersPrint
 │ ├fOMAction
 │ ├fARTAllgy
 │ ├fOMHTML
 │ ├fOrders
 │ ├rODBase
 │ ├fODChild
 │ ├fMeds
 │ ├rMeds
 │ ├rPCE
 │ ├fRptBox
 │ ├fODMedNVA
 │ ├fODChangeUnreleasedRenew
 │ ├rODAllergy
 │ ├UBAGlobals...
 │ └uTemplateFields
 ├fOrders...
 ├rODLab
 │ └uCore...
 └fRptBox...

Module Called-By (2 levels)


        fODReleaseEvent
              fOrders┘ 
            uOrders┤   
            fODBase┤   
             fFrame┤   
              rMisc┤   
            uODBase┤   
              fMeds┤   
          fOrdersDC┤   
          fOrdersCV┤   
            fOMNavA┤   
             fOMSet┤   
 fOrdersEvntRelease┤   
 fODReleaseEvent...┤   
         mEvntDelay┤   
          fODActive┤   
        fOrdersCopy┤   
           fMedCopy┤   
fActivateDeactivate┘