source: cprs/branches/tmg-cprs/CPRS-Chart/Orders/fOrdersDC.pas@ 770

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

Initial upload of TMG-CPRS 1.0.26.69

File size: 7.4 KB
Line 
1//kt -- Modified with SourceScanner on 8/8/2007
2unit fOrdersDC;
3
4interface
5
6uses
7 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
8 fAutoSz, StdCtrls, ORFn, ORCtrls, ExtCtrls, DKLang;
9
10type
11 TfrmDCOrders = class(TfrmAutoSz)
12 Label1: TLabel;
13 Panel1: TPanel;
14 lstOrders: TCaptionListBox;
15 Panel2: TPanel;
16 lblReason: TLabel;
17 lstReason: TORListBox;
18 cmdOK: TButton;
19 cmdCancel: TButton;
20 procedure FormCreate(Sender: TObject);
21 procedure cmdOKClick(Sender: TObject);
22 procedure cmdCancelClick(Sender: TObject);
23 procedure lstOrdersDrawItem(Control: TWinControl; Index: Integer;
24 Rect: TRect; State: TOwnerDrawState);
25 procedure lstOrdersMeasureItem(Control: TWinControl; Index: Integer;
26 var AHeight: Integer);
27 private
28 OKPressed: Boolean;
29 DCReason: Integer;
30 function MeasureColumnHeight(TheOrderText: string; Index: Integer):integer;
31 end;
32
33function ExecuteDCOrders(SelectedList: TList; var DelEvt: boolean): Boolean;
34
35implementation
36
37{$R *.DFM}
38
39uses rOrders, uCore, uConst, fOrders;
40
41function ExecuteDCOrders(SelectedList: TList; var DelEvt: boolean): Boolean;
42const
43 DCT_NEWORDER = 1;
44 DCT_DELETION = 2;
45 DCT_NEWSTATUS = 3;
46
47var
48 frmDCOrders: TfrmDCOrders;
49 AnOrder: TOrder;
50 i,CanSign, DCType: Integer;
51 NeedReason,NeedRefresh,OnCurrent: Boolean;
52 OriginalID,APtEvtID,APtEvtName,AnEvtInfo,tmpPtEvt: string;
53 PtEvtList: TStringList;
54begin
55 Result := False;
56 DelEvt := False;
57 OnCurrent := False;
58 NeedRefresh := False;
59 PtEvtList := TStringList.Create;
60 if SelectedList.Count = 0 then Exit;
61 frmDCOrders := TfrmDCOrders.Create(Application);
62 try
63 ResizeFormToFont(TForm(frmDCOrders));
64 NeedReason := False;
65 with SelectedList do for i := 0 to Count - 1 do
66 begin
67 AnOrder := TOrder(Items[i]);
68 frmDCOrders.lstOrders.Items.Add(AnOrder.Text);
69 if not ((AnOrder.Status = 11) and (AnOrder.Signature = 2)) then NeedReason := True;
70 end;
71 if NeedReason then
72 begin
73 frmDCOrders.lblReason.Visible := True;
74 frmDCOrders.lstReason.Visible := True;
75 end else
76 begin
77 frmDCOrders.lblReason.Visible := False;
78 frmDCOrders.lstReason.Visible := False;
79 end;
80 frmDCOrders.ShowModal;
81 if frmDCOrders.OKPressed then
82 begin
83 if (Encounter.Provider = User.DUZ) and User.CanSignOrders
84 then CanSign := CH_SIGN_YES
85 else CanSign := CH_SIGN_NA;
86 with SelectedList do for i := 0 to Count - 1 do
87 begin
88 AnOrder := TOrder(Items[i]);
89 OriginalID := AnOrder.ID;
90 PtEvtList.Add(AnOrder.EventPtr + '^' + AnOrder.EventName);
91 DCOrder(AnOrder, frmDCOrders.DCReason, DCType);
92 case DCType of
93 DCT_NEWORDER: begin
94 Changes.Add(CH_ORD, AnOrder.ID, AnOrder.Text, '', CanSign, AnOrder.ParentID);
95 AnOrder.ActionOn := OriginalID + '=DC';
96 end;
97 DCT_DELETION: begin
98 Changes.Remove(CH_ORD, OriginalID);
99 if (AnOrder.ID = '0') or (AnOrder.ID = '')
100 then AnOrder.ActionOn := OriginalID + '=DL' // delete order
101 else AnOrder.ActionOn := OriginalID + '=CA'; // cancel action
102 {else AnOrder.ActionOn := AnOrder.ID + '=CA'; - caused cancel from meds to not update orders}
103 UnlockOrder(OriginalID); // for deletion of unsigned DC
104 end;
105 DCT_NEWSTATUS: begin
106 AnOrder.ActionOn := OriginalID + '=DC';
107 UnlockOrder(OriginalID);
108 end;
109 else UnlockOrder(OriginalID);
110 end;
111 SendMessage(Application.MainForm.Handle, UM_NEWORDER, ORDER_ACT, Integer(AnOrder));
112 end;
113 if frmOrders.lstSheets.ItemIndex > -1 then
114 if CharAt(frmOrders.lstSheets.Items[frmOrders.lstSheets.ItemIndex],1)='C' then
115 OnCurrent := True;
116 if not OnCurrent then
117 begin
118 for i := 0 to PtEvtList.Count - 1 do
119 begin
120 if Length(PtEvtList[i])>1 then
121 begin
122 APtEvtID := Piece(PtEvtList[i],'^',1);
123 APtEvtName := Piece(PtEvtList[i],'^',2);
124 AnEvtInfo := EventInfo(APtEvtID);
125 if isExistedEvent(Patient.DFN,Piece(AnEvtInfo,'^',2),tmpPtEvt) and (DeleteEmptyEvt(APtEvtID,APtEvtName,False)) then
126 begin
127 NeedRefresh := True;
128 frmOrders.ChangesUpdate(APtEvtID);
129 end;
130 end;
131 end;
132 if NeedRefresh then
133 begin
134 frmOrders.InitOrderSheetsForEvtDelay;
135 frmOrders.lstSheets.ItemIndex := 0;
136 frmOrders.lstSheetsClick(nil);
137 DelEvt := True;
138 end;
139 end;
140 Result := True;
141 end
142 else with SelectedList do for i := 0 to Count - 1 do UnlockOrder(TOrder(Items[i]).ID);
143 finally
144 frmDCOrders.Release;
145 end;
146end;
147
148procedure TfrmDCOrders.FormCreate(Sender: TObject);
149var
150 DefaultIEN: Integer;
151begin
152 inherited;
153 OKPressed := False;
154 ListDCReasons(lstReason.Items, DefaultIEN);
155 lstReason.SelectByIEN(DefaultIEN);
156 { the following commented out so that providers can enter DC reasons }
157// if Encounter.Provider = User.DUZ then
158// begin
159// lblReason.Visible := False;
160// lstReason.Visible := False;
161// end;
162end;
163
164procedure TfrmDCOrders.cmdOKClick(Sender: TObject);
165//const
166//TX_REASON_REQ = 'A reason for discontinue must be selected.'; <-- original line. //kt 8/8/2007
167//TC_REASON_REQ = 'Missing Discontinue Reason'; <-- original line. //kt 8/8/2007
168var
169 TX_REASON_REQ : string; //kt
170 TC_REASON_REQ : string; //kt
171begin
172 TX_REASON_REQ := DKLangConstW('fOrdersDC_A_reason_for_discontinue_must_be_selectedx'); //kt added 8/8/2007
173 TC_REASON_REQ := DKLangConstW('fOrdersDC_Missing_Discontinue_Reason'); //kt added 8/8/2007
174 inherited;
175 if (lstReason.Visible) and (not (lstReason.ItemIEN > 0)) then
176 begin
177 InfoBox(TX_REASON_REQ, TC_REASON_REQ, MB_OK);
178 Exit;
179 end;
180 OKPressed := True;
181 DCReason := lstReason.ItemIEN;
182 Close;
183end;
184
185procedure TfrmDCOrders.cmdCancelClick(Sender: TObject);
186begin
187 inherited;
188 Close;
189end;
190
191procedure TfrmDCOrders.lstOrdersDrawItem(Control: TWinControl;
192 Index: Integer; Rect: TRect; State: TOwnerDrawState);
193var
194 x: string;
195 ARect: TRect;
196begin
197 inherited;
198 x := '';
199 ARect := Rect;
200 with lstOrders do
201 begin
202 Canvas.FillRect(ARect);
203 Canvas.Pen.Color := clSilver;
204 Canvas.MoveTo(0, ARect.Bottom - 1);
205 Canvas.LineTo(ARect.Right, ARect.Bottom - 1);
206 if Index < Items.Count then
207 begin
208 x := Items[Index];
209 DrawText(Canvas.handle, PChar(x), Length(x), ARect, DT_LEFT or DT_NOPREFIX or DT_WORDBREAK);
210 end;
211 end;
212end;
213
214procedure TfrmDCOrders.lstOrdersMeasureItem(Control: TWinControl;
215 Index: Integer; var AHeight: Integer);
216var
217 x:string;
218begin
219 inherited;
220 with lstOrders do if Index < Items.Count then
221 begin
222 x := Items[index];
223 AHeight := MeasureColumnHeight(x, Index);
224 end;
225end;
226
227function TfrmDCOrders.MeasureColumnHeight(TheOrderText: string;
228 Index: Integer): integer;
229var
230 ARect: TRect;
231begin
232 ARect.Left := 0;
233 ARect.Top := 0;
234 ARect.Bottom := 0;
235 ARect.Right := lstOrders.Width - 6;
236 Result := WrappedTextHeightByFont(lstOrders.Canvas,lstOrders.Font,TheOrderText,ARect);
237end;
238
239end.
Note: See TracBrowser for help on using the repository browser.