source: cprs/branches/tmg-cprs/CPRS-Chart/Orders/fOMSet.pas@ 1802

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

Initial upload of TMG-CPRS 1.0.26.69

File size: 11.6 KB
RevLine 
[453]1//kt -- Modified with SourceScanner on 8/8/2007
2unit fOMSet;
3
4interface
5
6uses
7 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
8 StdCtrls, CheckLst, rOrders, uConst, ORFn, rODMeds, fODBase,uCore,fOrders, fframe,
9 DKLang;
10
11type
12 TSetItem = class
13 DialogIEN: Integer;
14 DialogType: Char;
15 OIIEN: string;
16 InPkg: string;
17 OwnedBy: TComponent;
18 RefNum: Integer;
19 end;
20
21 TfrmOMSet = class(TForm)
22 lstSet: TCheckListBox;
23 cmdInterupt: TButton;
24 DKLanguageController1: TDKLanguageController;
25 procedure cmdInteruptClick(Sender: TObject);
26 procedure FormDestroy(Sender: TObject);
27 procedure FormClose(Sender: TObject; var Action: TCloseAction);
28 procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
29 procedure FormCreate(Sender: TObject);
30 private
31 DoingNextItem : Boolean;
32 CloseRequested : Boolean;
33 FDelayEvent: TOrderDelayEvent;
34 FClosing: Boolean;
35 FRefNum: Integer;
36 FActiveMenus: Integer;
37 FClosebyDeaCheck: Boolean;
38 function IsCreatedByMenu(ASetItem: TSetItem): boolean;
39 function DeaCheckPassed(OIIens: string; APkg: string; AnEventType: Char): boolean;
40 procedure DoNextItem;
41 procedure UMDestroy(var Message: TMessage); message UM_DESTROY;
42 procedure UMDelayEvent(var Message: TMessage); message UM_DELAYEVENT;
43 public
44 procedure InsertList(SetList: TStringList; AnOwner: TComponent; ARefNum: Integer;
45 const KeyVarStr: string; AnEventType:Char =#0);
46 procedure SetEventDelay(AnEvent: TOrderDelayEvent);
47 property RefNum: Integer read FRefNum write FRefNum;
48 end;
49
50var
51 frmOMSet: TfrmOMSet;
52
53implementation
54
55{$R *.DFM}
56
57uses uOrders, fOMNavA, rMisc, uODBase;
58
59//const
60//TX_STOP = 'Do you want to stop entering the current set of orders?'; <-- original line. //kt 8/8/2007
61//TC_STOP = 'Interrupt Order Set'; <-- original line. //kt 8/8/2007
62
63var
64 TX_STOP : string; //kt
65 TC_STOP : string; //kt
66
67procedure SetupVars;
68//kt Added entire function to replace constant declarations 8/8/2007
69begin
70 TX_STOP := DKLangConstW('fOMSet_Do_you_want_to_stop_entering_the_current_set_of_ordersx');
71 TC_STOP := DKLangConstW('fOMSet_Interrupt_Order_Set');
72end;
73
74procedure TfrmOMSet.SetEventDelay(AnEvent: TOrderDelayEvent);
75begin
76 FDelayEvent := AnEvent;
77end;
78
79procedure TfrmOMSet.InsertList(SetList: TStringList; AnOwner: TComponent; ARefNum: Integer;
80 const KeyVarStr: string; AnEventType: Char);
81{ expects SetList to be strings of DlgIEN^DlgType^DisplayName^OrderableItemIens }
82//const
83//TXT_DEAFAIL = 'You need have #DEA key to place the order '; <-- original line. //kt 8/8/2007
84//TXT_INSTRUCT = #13 + 'Click OK to continue, Click Cancel to terminate the current order process.'; <-- original line. //kt 8/8/2007
85var
86 i, InsertAt: Integer;
87 SetItem: TSetItem;
88 TXT_DEAFAIL : string; //kt
89 TXT_INSTRUCT : string; //kt
90
91begin
92 TXT_DEAFAIL := DKLangConstW('fOMSet_You_need_have_xDEA_key_to_place_the_order'); //kt added 8/8/2007
93 TXT_INSTRUCT := #13 + DKLangConstW('fOMSet_Click_OK_to_continuex_Click_Cancel_to_terminate_the_current_order_processx'); //kt added 8/8/2007
94 InsertAt := lstSet.ItemIndex + 1;
95 with SetList do for i := 0 to Count - 1 do
96 begin
97 SetItem := TSetItem.Create;
98 SetItem.DialogIEN := StrToIntDef(Piece(SetList[i], U, 1), 0);
99 SetItem.DialogType := CharAt(Piece(SetList[i], U, 2), 1);
100 SetItem.OIIEN := Piece(SetList[i], U, 4);
101 SetItem.InPkg := Piece(SetList[i], U, 5);
102 // put the Owner form and reference number in the last item
103 if i = Count - 1 then
104 begin
105 SetItem.OwnedBy := AnOwner;
106 SetItem.RefNum := ARefNum;
107 end;
108 if not DeaCheckPassed(SetItem.OIIEN, SetItem.InPkg, AnEventType) then
109 if InfoBox(TXT_DEAFAIL + Piece(SetList[i], U, 3) + TXT_INSTRUCT,
110// 'Warning', MB_OKCANCEL or MB_ICONWARNING) = IDOK then <-- original line. //kt 8/8/2007
111 DKLangConstW('fOMSet_Warning'), MB_OKCANCEL or MB_ICONWARNING) = IDOK then //kt added 8/8/2007
112 Continue
113 else
114 begin
115 FClosebyDeaCheck := True;
116 Close;
117 Exit;
118 end;
119 lstSet.Items.InsertObject(InsertAt, Piece(SetList[i], U, 3), SetItem);
120 Inc(InsertAt);
121 end;
122 PushKeyVars(KeyVarStr);
123 DoNextItem;
124end;
125
126procedure TfrmOMSet.DoNextItem;
127var
128 SetItem: TSetItem;
129 theOwner: TComponent;
130
131 procedure SkipToNext;
132 begin
133 lstSet.Checked[lstSet.ItemIndex] := True;
134 DoNextItem;
135 end;
136
137begin
138 DoingNextItem := true;
139 //frmFrame.UpdatePtInfoOnRefresh;
140 if FClosing then Exit;
141 if frmOrders <> nil then
142 begin
143 if (frmOrders.TheCurrentView<>nil) and (frmOrders.TheCurrentView.EventDelay.PtEventIFN>0)
144 and IsCompletedPtEvt(frmOrders.TheCurrentView.EventDelay.PtEventIFN) then
145 begin
146 FDelayEvent.EventType := #0;
147 FDelayEvent.EventIFN := 0;
148 FDelayEvent.TheParent := TParentEvent.Create;
149 FDelayEvent.EventName := '';
150 FDelayEvent.PtEventIFN := 0;
151 end;
152 end;
153 with lstSet do
154 begin
155 if ItemIndex >= Items.Count - 1 then
156 begin
157 Close;
158 Exit;
159 end;
160 ItemIndex := ItemIndex + 1;
161 SetItem := TSetItem(Items.Objects[ItemIndex]);
162 case SetItem.DialogType of
163 'A': if not ActivateAction(IntToStr(SetItem.DialogIEN), Self, ItemIndex) then
164 begin
165 if IsCreatedByMenu(SetItem) and (lstSet.ItemIndex < lstSet.Items.Count - 1) then
166 lstSet.Checked[lstSet.ItemIndex] := True
167 else SkipToNext;
168 end;
169 'D', 'Q': if not ActivateOrderDialog(IntToStr(SetItem.DialogIEN), FDelayEvent, Self, ItemIndex) then
170 begin
171 if IsCreatedByMenu(SetItem) and (lstSet.ItemIndex < lstSet.Items.Count - 1) then
172 lstSet.Checked[lstSet.ItemIndex] := True
173 else SkipToNext;
174 end;
175 'M': if ActivateOrderMenu( IntToStr(SetItem.DialogIEN), FDelayEvent, Self, ItemIndex)
176 then Inc(FActiveMenus)
177 else
178 begin
179 if IsCreatedByMenu(SetItem) and (lstSet.ItemIndex < lstSet.Items.Count - 1) then
180 lstSet.Checked[lstSet.ItemIndex] := True
181 else
182 SkipToNext;
183 end;
184 'O': begin
185// if (Self.Owner.Name = 'frmOMNavA') then theOwner := Self.Owner else theOwner := self; <-- original line. //kt 8/8/2007
186 if (Self.Owner.Name = DKLangConstW('fOMSet_frmOMNavA')) then theOwner := Self.Owner else theOwner := self; //kt added 8/8/2007
187 if not ActivateOrderSet( IntToStr(SetItem.DialogIEN), FDelayEvent, theOwner, ItemIndex) then
188 begin
189 if IsCreatedByMenu(SetItem) and (lstSet.ItemIndex < lstSet.Items.Count - 1) then
190 lstSet.Checked[lstSet.ItemIndex] := True
191 else SkipToNext;
192 end;
193 end;
194 else begin
195// InfoBox('Unsupported dialog type: ' + SetItem.DialogType, 'Error', MB_OK); <-- original line. //kt 8/8/2007
196 InfoBox(DKLangConstW('fOMSet_Unsupported_dialog_typex')+' ' + SetItem.DialogType, DKLangConstW('fOMSet_Error'), MB_OK); //kt added 8/8/2007
197 SkipToNext;
198 end;
199 end; {case}
200 end; {with lstSet}
201 DoingNextItem := false;
202end;
203
204procedure TfrmOMSet.UMDelayEvent(var Message: TMessage);
205begin
206 // ignore if delay from other than current itemindex
207 // (prevents completion of an order set from calling DoNextItem)
208 if Message.WParam = lstSet.ItemIndex then
209 if lstSet.ItemIndex < lstSet.Items.Count - 1 then DoNextItem else Close;
210 if CloseRequested then
211 Close;
212end;
213
214procedure TfrmOMSet.UMDestroy(var Message: TMessage);
215{ Received whenever activated item is finished. Posts to Owner if last item in the set. }
216var
217 SetItem: TSetItem;
218 RefNum: Integer;
219begin
220 RefNum := Message.WParam;
221 lstSet.Checked[RefNum] := True;
222 SetItem := TSetItem(lstSet.Items.Objects[RefNum]);
223 if SetItem.DialogType = 'M' then Dec(FActiveMenus);
224 if (SetItem.OwnedBy <> nil) and (SetItem.DialogType <> 'O') then
225 begin
226 PopKeyVars;
227 if ((lstSet.ItemIndex = lstSet.Count - 1) and (lstSet.Checked[lstSet.ItemIndex] = True)) then Close;
228 if {(SetItem.OwnedBy <> Self) and} (SetItem.OwnedBy is TWinControl) then
229 begin
230 SendMessage(TWinControl(SetItem.OwnedBy).Handle, UM_DESTROY, SetItem.RefNum, 0);
231 //Exit;
232 end;
233 end;
234 // let menu or dialog finish closing before going on to next item in the order set
235 While RefNum <= lstSet.Items.Count - 2 do
236 begin
237 if not (lstSet.Checked[RefNum+1]) then Break
238 else
239 begin
240 RefNum := RefNum + 1;
241 lstSet.ItemIndex := RefNum;
242 end;
243 end;
244 PostMessage(Handle, UM_DELAYEVENT, RefNum, 0);
245end;
246
247procedure TfrmOMSet.FormCreate(Sender: TObject);
248begin
249 FActiveMenus := 0;
250 FClosing := False;
251 FClosebyDeaCheck := False;
252 NoFresh := True;
253 CloseRequested := false;
254 DoingNextItem := false;
255end;
256
257procedure TfrmOMSet.FormDestroy(Sender: TObject);
258var
259 i: Integer;
260begin
261 with lstSet do for i := 0 to Items.Count - 1 do TSetItem(Items.Objects[i]).Free;
262 DestroyingOrderSet;
263end;
264
265procedure TfrmOMSet.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
266{ if this is not the last item in the set, prompt whether to interrupt processing }
267begin
268 SetupVars; //kt added 8/8/2007 to replace constants with vars.
269 if FClosebyDeaCheck then
270 CanClose := True
271 else if lstSet.ItemIndex < (lstSet.Items.Count - 1)
272 then CanClose := InfoBox(TX_STOP, TC_STOP, MB_YESNO) = IDYES;
273end;
274
275procedure TfrmOMSet.FormClose(Sender: TObject; var Action: TCloseAction);
276{ Notify remaining owners that their item is done (or - really never completed) }
277var
278 i: Integer;
279 SetItem: TSetItem;
280begin
281 // do we need to iterate thru and send messages where OwnedBy <> nil?
282 FClosing := True;
283 for i := 1 to FActiveMenus do PopLastMenu;
284 if lstSet.Items.Count > 0 then
285 begin
286 if lstSet.ItemIndex < 0 then lstSet.ItemIndex := 0;
287 with lstSet do for i := ItemIndex to Items.Count - 1 do
288 begin
289 SetItem := TSetItem(lstSet.Items.Objects[i]);
290 if (SetItem.OwnedBy <> nil) and (SetItem.OwnedBy is TWinControl)
291 then SendMessage(TWinControl(SetItem.OwnedBy).Handle, UM_DESTROY, SetItem.RefNum, 0);
292 end;
293 end;
294 SaveUserBounds(Self);
295 NoFresh := False;
296 Action := caFree;
297end;
298
299procedure TfrmOMSet.cmdInteruptClick(Sender: TObject);
300begin
301 if DoingNextItem then
302 CloseRequested := true //Fix for CQ: 8297
303 else
304 Close;
305end;
306
307function TfrmOMSet.DeaCheckPassed(OIIens: string; APkg: string; AnEventType: Char): boolean;
308var
309 tmpIenList: TStringList;
310 i: integer;
311 isInpt: boolean;
312begin
313 Result := True;
314 if Pos('PS',APkg) <> 1 then
315 Exit;
316 if Length(OIIens)=0 then Exit;
317 tmpIenList := TStringList.Create;
318 PiecesToList(OIIens,';',TStrings(tmpIenList));
319 case AnEventType of
320 'A','T': isInpt := True;
321 'D': isInpt := False;
322 else isInpt := Patient.Inpatient;
323 end;
324 for i := 0 to tmpIenList.Count - 1 do
325 if DEACheckFailed(StrToIntDef(tmpIenList[i],0), isInpt) then
326 begin
327 Result := False;
328 Break;
329 end;
330end;
331
332function TfrmOMSet.IsCreatedByMenu(ASetItem: TSetItem): boolean;
333begin
334 Result := False;
335//if (AsetItem.OwnedBy <> nil) and (ASetItem.OwnedBy.Name = 'frmOMNavA') then <-- original line. //kt 8/8/2007
336 if (AsetItem.OwnedBy <> nil) and (ASetItem.OwnedBy.Name = DKLangConstW('fOMSet_frmOMNavA')) then //kt added 8/8/2007
337 Result := True;
338end;
339
340end.
Note: See TracBrowser for help on using the repository browser.