source: cprs/branches/tmg-cprs/CPRS-Chart/Orders/fODBase.~pas@ 1117

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

Initial upload of TMG-CPRS 1.0.26.69

File size: 67.3 KB
Line 
1//kt -- Modified with SourceScanner on 8/8/2007
2unit fODBase;
3
4{$OPTIMIZATION OFF} // REMOVE AFTER UNIT IS DEBUGGED
5
6interface
7
8uses
9 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, fAutoSz, StdCtrls,
10 ORCtrls, ORFn, uConst, rOrders, rODBase, uCore, ComCtrls, ExtCtrls, Menus, Mask,
11 Buttons, UBAGlobals, UBACore, DKLang;
12
13type
14 TCtrlInit = class
15 private
16 Name: string;
17 Text: string;
18 ListID: string;
19 List: TStringList;
20 public
21 constructor Create;
22 destructor Destroy; override;
23 end;
24
25 TCtrlInits = class
26 private
27 FDfltList: TList;
28 FOIList: TList;
29 procedure ExtractInits(Src: TStrings; Dest: TList);
30 function FindInitByName(const AName: string): TCtrlInit;
31 public
32 constructor Create;
33 destructor Destroy; override;
34 procedure ClearOI;
35 function DefaultText(const ASection: string): string;
36 procedure LoadDefaults(Src: TStrings);
37 procedure LoadOrderItem(Src: TStrings);
38 procedure SetControl(AControl: TControl; const ASection: string);
39 procedure SetListOnly(AControl: TControl; const ASection: string);
40 procedure SetPopupMenu(AMenu: TPopupMenu; AClickEvent: TNotifyEvent; const ASection: string);
41 function TextOf(const ASection: string): string;
42 end;
43
44 TResponses = class
45 private
46 FDialog: string;
47 FResponseList: TList;
48 FPrompts: TList;
49 FCopyOrder: string;
50 FEditOrder: string;
51 FTransferOrder: string;
52 FDisplayGroup: Integer;
53 FQuickOrder: Integer;
54 FOrderChecks: TStringList;
55 FVarLeading: string;
56 FVarTrailing: string;
57 FEventType: Char;
58 FEventIFN: Integer;
59 FEventName: string;
60 FSpecialty: Integer;
61 FEffective: TFMDateTime;
62 FParentEvent: TParentEvent;
63 FLogTime: TFMDateTime;
64 FViewName: string;
65 FCancel: boolean;
66 FOrderContainsObjects: boolean;
67 function FindResponseByIEN(APromptIEN, AnInstance: Integer): TResponse;
68 function GetOrderText: string;
69 function IENForPrompt(const APromptID: string): Integer;
70 procedure SetDialog(Value: string);
71 procedure SetCopyOrder(const AnID: string);
72 procedure SetEditOrder(const AnID: string);
73 procedure SetQuickOrder(AnIEN: Integer);
74 procedure SetQuickOrderByID(const AnID: string);
75 procedure FormatResponse(var FormattedText: string; var ExcludeText: Boolean;
76 APrompt: TPrompt; const x: string; AnInstance: Integer);
77 function FindPromptByIEN(AnIEN: Integer): TPrompt;
78 procedure AppendChildren(var ParentText: string; ChildPrompts: string; AnInstance: Integer);
79 procedure BuildOCItems(AList: TStringList; var AStartDtTm: string; const AFillerID: string);
80 public
81 constructor Create;
82 destructor Destroy; override;
83 procedure Clear; overload;
84 procedure Clear(const APromptID: string; SaveInstance: Integer = 0); overload;
85 function EValueFor(const APromptID: string; AnInstance: Integer): string;
86 function GetIENForPrompt(const APromptID: string): Integer;
87 function FindResponseByName(const APromptID: string; AnInstance: Integer): TResponse;
88 function PromptExists(const APromptID: string):boolean;
89 function InstanceCount(const APromptID: string): Integer;
90 function IValueFor(const APromptID: string; AnInstance: Integer): string;
91 function NextInstance(const APromptID: string; LastInstance: Integer): Integer;
92 function OrderCRC: string;
93 procedure Remove(const APromptID: string; AnInstance: Integer);
94 procedure SaveQuickOrder(var ANewIEN: Integer; const ADisplayName: string);
95 procedure SaveOrder(var AnOrder: TOrder; DlgIEN: Integer; IsIMOOrder: boolean = False);
96 procedure SetControl(AControl: TControl; const APromptID: string; AnInstance: Integer);
97 procedure SetEventDelay(AnEvent: TOrderDelayEvent);
98 procedure SetPromptFormat(const APromptID, NewFormat: string);
99 procedure Update(const APromptID: string; AnInstance: Integer;
100 const AnIValue, AnEValue: string);
101 property Dialog: string read FDialog write SetDialog;
102 property DisplayGroup: Integer read FDisplayGroup write FDisplayGroup;
103 property CopyOrder: string read FCopyOrder write SetCopyOrder;
104 property EditOrder: string read FEditOrder; // write SetEditOrder;
105 property TransferOrder:string read FTransferOrder write FTransferOrder;
106 property EventType: Char read FEventType;
107 property EventIFN: integer read FEventIFN write FEventIFN;
108 property EventName: string read FEventName write FEventName;
109 property LogTime: TFMDateTime read FLogTime write FLogTime;
110 property QuickOrder: Integer read FQuickOrder write SetQuickOrder;
111 property OrderChecks: TStringList read FOrderChecks write FOrderChecks;
112 property OrderText: string read GetOrderText;
113 property VarLeading: string read FVarLeading write FVarLeading;
114 property VarTrailing: string read FVarTrailing write FVarTrailing;
115 property TheList: TList read FResponseList write FResponseList;
116 property Cancel: boolean read FCancel write FCancel;
117 property OrderContainsObjects: boolean read FOrderContainsObjects write FOrderContainsObjects;
118 end;
119
120 TCallOnExit = procedure;
121
122 TfrmODBase = class(TfrmAutoSz)
123 memOrder: TCaptionMemo;
124 cmdAccept: TButton;
125 cmdQuit: TButton;
126 pnlMessage: TPanel;
127 imgMessage: TImage;
128 memMessage: TRichEdit;
129 procedure cmdQuitClick(Sender: TObject);
130 procedure cmdAcceptClick(Sender: TObject);
131 procedure FormKeyPress(Sender: TObject; var Key: Char);
132 procedure FormCreate(Sender: TObject);
133 procedure FormDestroy(Sender: TObject);
134 procedure FormClose(Sender: TObject; var Action: TCloseAction);
135 procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
136 procedure memMessageMouseUp(Sender: TObject; Button: TMouseButton;
137 Shift: TShiftState; X, Y: Integer);
138 procedure pnlMessageExit(Sender: TObject);
139 procedure pnlMessageMouseDown(Sender: TObject; Button: TMouseButton;
140 Shift: TShiftState; X, Y: Integer);
141 procedure pnlMessageMouseMove(Sender: TObject; Shift: TShiftState; X,
142 Y: Integer);
143 private
144 FIsSupply: Boolean;
145 FAbortOrder: Boolean;
146 FAllowQO: Boolean;
147 FAutoAccept: Boolean;
148 FClosing: Boolean;
149 FChanging: Boolean;
150 FDialogIEN: Integer;
151 FDisplayGroup: Integer;
152 FFillerID: string;
153 FFromQuit: Boolean;
154 FAcceptOK: Boolean;
155 FCtrlInits: TCtrlInits;
156 FResponses: TResponses;
157 FPreserve: TList;
158 FRefNum: Integer;
159 FOrderAction: Integer;
160 FKeyVariables: string;
161 FCallOnExit: TCallOnExit;
162 FTestMode: Boolean;
163 FDlgFormID: Integer;
164 FDfltCopay: String;
165 FEvtForPassDischarge: Char;
166 FEvtID : Integer;
167 FEvtType : Char;
168 FEvtName : string;
169 FIncludeOIPI: boolean;
170 FIsIMO: boolean; //imo
171 FMessageClickX: integer;
172 FMessageClickY: integer;
173 function AcceptOrderChecks: Boolean;
174 procedure ClearDialogControls;
175 function GetKeyVariable(const Index: string): string;
176 function GetEffectiveDate: TFMDateTime;
177 procedure SetDisplayGroup(Value: Integer);
178 procedure SetFillerID(const Value: string);
179 procedure DoSetFontSize( FontSize: integer);
180 protected
181 function LESValidationCheck: boolean;
182 procedure InitDialog; virtual;
183 procedure SetDialogIEN(Value: Integer); virtual;
184 procedure Validate(var AnErrMsg: string); virtual;
185 function ValidSave: Boolean;
186 procedure ShowOrderMessage(Show: boolean);
187 public
188 function OrderForInpatient: Boolean;
189 procedure SetDefaultCoPay(AnOrderID: string);
190 procedure OrderMessage(const AMessage: string);
191 procedure PreserveControl(AControl: TControl);
192 procedure SetupDialog(OrderAction: Integer; const ID: string); virtual;
193 procedure SetFontSize( FontSize: integer); virtual;
194 procedure SetKeyVariables(const VarStr: string);
195 procedure TabClose(var CanClose: Boolean);
196 property AbortOrder: Boolean read FAbortOrder write FAbortOrder;
197 property AcceptOK: Boolean read FAcceptOK;
198 property AllowQuickOrder: Boolean read FAllowQO write FAllowQO;
199 property AutoAccept: Boolean read FAutoAccept write FAutoAccept;
200 property CallOnExit: TCallOnExit read FCallOnExit write FCallOnExit;
201 property Changing: Boolean read FChanging write FChanging;
202 property Closing: Boolean read FClosing;
203 property CtrlInits: TCtrlInits read FCtrlInits write FCtrlInits;
204 property DialogIEN: Integer read FDialogIEN write SetDialogIEN;
205 property DisplayGroup: Integer read FDisplayGroup write SetDisplayGroup;
206 property EffectiveDate: TFMDateTime read GetEffectiveDate;
207 property FillerID: string read FFillerID write SetFillerID;
208 property KeyVariable[const Index: string]: string read GetKeyVariable;
209 property RefNum: Integer read FRefNum write FRefNum;
210 property Responses: TResponses read FResponses write FResponses;
211 property TestMode: Boolean read FTestMode write FTestMode;
212 property DlgFormID: Integer read FDlgFormID write FDlgFormID;
213 property DfltCopay: string read FDfltCopay write FDfltCopay;
214 property EvtForPassDischarge: Char read FEvtForPassDischarge write FEvtForPassDischarge;
215 property EvtID: integer read FEvtID write FEvtID;
216 property EvtType: Char read FEvtType write FEvtType;
217 property EvtName: String read FEvtName write FEvtName;
218 property IncludeOIPI: boolean read FIncludeOIPI write FIncludeOIPI;
219 property IsIMO:boolean read FIsIMO write FIsIMO;
220 property IsSupply: boolean read FIsSupply write FIsSupply;
221 end;
222
223var
224 frmODBase: TfrmODBase;
225 XfInToOutNow :boolean = False; // it's used only for transfering Inpatient Meds to OutPatient Med for
226 // immediately release (NO EVENT DELAY)
227 XferOuttoInOnMeds : boolean = False; // it's used only for transfering Outpatient Meds to Inpatient Med for
228 // immediately release (NO EVENT DELAY)
229 ImmdCopyAct: boolean = False;
230 IsUDGroup: boolean = False; // it's only used for copy inpatient med order.
231 DEASig: string; // digital signature
232 DupORIFN: string; // it's used to identify the order number for duplicate orders in order checking
233 NoFresh: boolean = False; // EDO use only
234 SaveAsCurrent: boolean = False; // EDO use only
235 CIDCOkToSave: boolean; // CIDC only, used for consult orders.
236 OrderSource: string = '';
237 EventDefaultOD: integer = 0; // If it's event default dialog?
238 IsTransferAction: boolean = False;
239
240procedure ClearControl(AControl: TControl);
241procedure ResetControl(AControl: TControl);
242
243implementation
244
245{$R *.DFM}
246
247uses fOCAccept, uODBase, rCore, rMisc, fODMessage,
248 fTemplateDialog, uEventHooks, uTemplates, rConsults,fOrders,uOrders,
249 fFrame, uTemplateFields, fClinicWardMeds;
250
251//const
252//TX_ACCEPT = 'Accept the following order?' + CRLF + CRLF; <-- original line. //kt 8/8/2007
253//TX_ACCEPT_CAP = 'Unsaved Order'; <-- original line. //kt 8/8/2007
254//TC_ORDERCHECKS = 'Order Checks'; <-- original line. //kt 8/8/2007
255
256{ Procedures shared with descendent forms }
257
258var
259 TX_ACCEPT : string; //kt
260 TX_ACCEPT_CAP : string; //kt
261 TC_ORDERCHECKS : string; //kt
262
263
264procedure SetupVars;
265//kt Added entire function to replace constant declarations 8/8/2007
266begin
267 TX_ACCEPT := DKLangConstW('fODBase_Accept_the_following_orderx') + CRLF + CRLF;
268 TX_ACCEPT_CAP := DKLangConstW('fODBase_Unsaved_Order');
269 TC_ORDERCHECKS := DKLangConstW('fODBase_Order_Checks');
270end;
271
272procedure ClearControl(AControl: TControl);
273{ clears a control, removes text and listbox items }
274begin
275 if AControl is TLabel then with TLabel(AControl) do Caption := ''
276 else if AControl is TStaticText then with TStaticText(AControl) do Caption := ''
277 else if AControl is TButton then with TButton(AControl) do Caption := ''
278 else if AControl is TEdit then with TEdit(AControl) do Text := ''
279 else if AControl is TMemo then with TMemo(AControl) do Clear
280 else if AControl is TRichEdit then with TRichEdit(AControl) do Clear
281 else if AControl is TORListBox then with TORListBox(AControl) do Clear
282 else if AControl is TListBox then with TListBox(AControl) do Clear
283 else if AControl is TORComboBox then with TORComboBox(AControl) do
284 begin
285 Items.Clear;
286 Text := '';
287 end
288 else if AControl is TComboBox then with TComboBox(AControl) do
289 begin
290 Clear;
291 Text := '';
292 end;
293end;
294
295procedure ResetControl(AControl: TControl);
296{ clears text, deselects items, does not remove listbox or combobox items }
297begin
298 if AControl is TLabel then with TLabel(AControl) do Caption := ''
299 else if AControl is TStaticText then with TStaticText(AControl) do Caption := ''
300 else if AControl is TButton then with TButton(AControl) do Caption := ''
301 else if AControl is TEdit then with TEdit(AControl) do Text := ''
302 else if AControl is TMemo then with TMemo(AControl) do Clear
303 else if AControl is TRichEdit then with TRichEdit(AControl) do Clear
304 else if AControl is TListBox then with TListBox(AControl) do ItemIndex := -1
305 else if AControl is TORComboBox then with TORComboBox(AControl) do
306 begin
307 Text := '';
308 ItemIndex := -1;
309 end
310 else if AControl is TComboBox then with TComboBox(AControl) do
311 begin
312 Text := '';
313 ItemIndex := -1;
314 end;
315end;
316
317{ TCtrlInit methods }
318
319constructor TCtrlInit.Create;
320begin
321 List := TStringList.Create;
322end;
323
324destructor TCtrlInit.Destroy;
325begin
326 List.Free;
327 inherited Destroy;
328end;
329
330{ TCtrlInits methods }
331
332constructor TCtrlInits.Create;
333{ create lists to store initial value for dialog and selected orderable item }
334begin
335 FDfltList := TList.Create;
336 FOIList := TList.Create;
337end;
338
339destructor TCtrlInits.Destroy;
340{ free the objects used to store initialization information }
341var
342 i: Integer;
343begin
344 { free the objects in the lists first }
345 with FDfltList do for i := 0 to Count - 1 do TCtrlInit(Items[i]).Free;
346 FDfltList.Free;
347 ClearOI;
348 FOIList.Free;
349 inherited Destroy;
350end;
351
352procedure TCtrlInits.ClearOI;
353{ clears the records in FOIList, but not FDfltList }
354var
355 i: Integer;
356begin
357 with FOIList do for i := 0 to Count - 1 do TCtrlInit(Items[i]).Free;
358 FOIList.Clear;
359end;
360
361procedure TCtrlInits.ExtractInits(Src: TStrings; Dest: TList);
362{ load a list with TCtrlInit records (source strings are those passed from server }
363var
364 i: Integer;
365 ACtrlInit: TCtrlInit;
366begin
367 i := 0;
368 while i < Src.Count do
369 begin
370 if CharAt(Src[i], 1) = '~' then
371 begin
372 ACtrlInit := TCtrlInit.Create;
373 with ACtrlInit do
374 begin
375 Name := Copy(Src[i], 2, Length(Src[i]));
376 List := TStringList.Create;
377 Inc(i);
378 while (i < Src.Count) and (CharAt(Src[i], 1) <> '~') do
379 begin
380 if CharAt(Src[i], 1) = 'i' then List.Add(Copy(Src[i], 2, 255));
381 if CharAt(Src[i], 1) = 't' then List.Add(Copy(Src[i], 2, 255));
382 if CharAt(Src[i], 1) = 'd' then
383 begin
384 Text := Piece(Src[i], U, 2);
385 ListID := Copy(Piece(Src[i], U, 1), 2, 255);
386 end;
387 Inc(i);
388 end; {while i & CharAt...}
389 Dest.Add(ACtrlInit);
390 end; {with ACtrlDflt}
391 end; {if CharAt}
392 end; {while i}
393end;
394
395
396procedure TCtrlInits.LoadDefaults(Src: TStrings);
397{ loads control initialization information for the dialog }
398begin
399 FDfltList.Clear;
400 ExtractInits(Src, FDfltList);
401end;
402
403procedure TCtrlInits.LoadOrderItem(Src: TStrings);
404{ loads control initialization information for the orderable item }
405begin
406 ClearOI;
407 ExtractInits(Src, FOIList);
408end;
409
410function TCtrlInits.FindInitByName(const AName: string): TCtrlInit;
411{ look first in FOIList, then in FDfltList for initial values identified by name (~section) }
412var
413 i: Integer;
414begin
415 Result := nil;
416 with FOIList do
417 for i := 0 to Count - 1 do if TCtrlInit(Items[i]).Name = AName then
418 begin
419 Result := TCtrlInit(Items[i]);
420 break;
421 end;
422 if Result = nil then with FDfltList do
423 for i := 0 to Count - 1 do if TCtrlInit(Items[i]).Name = AName then
424 begin
425 Result := TCtrlInit(Items[i]);
426 break;
427 end;
428end;
429
430procedure TCtrlInits.SetControl(AControl: TControl; const ASection: string);
431{ initializes a control to the information in a section (~section from server) }
432var
433 CtrlInit: TCtrlInit;
434begin
435 ClearControl(AControl);
436 CtrlInit := FindInitByName(ASection);
437 if CtrlInit = nil then Exit;
438 if AControl is TLabel then with TLabel(AControl) do Caption := CtrlInit.Text
439 else if AControl is TStaticText then with TStaticText(AControl) do Caption := CtrlInit.Text
440 else if AControl is TButton then with TButton(AControl) do Caption := CtrlInit.Text
441 else if AControl is TEdit then with TEdit(AControl) do Text := CtrlInit.Text
442 else if AControl is TMemo then with TMemo(AControl) do Lines.Assign(CtrlInit.List)
443 else if AControl is TRichEdit then with TRichEdit(AControl) do Lines.Assign(CtrlInit.List)
444 else if AControl is TORListBox then with TORListBox(AControl) do Items.Assign(CtrlInit.List)
445 else if AControl is TListBox then with TListBox(AControl) do Items.Assign(CtrlInit.List)
446 else if AControl is TComboBox then with TComboBox(AControl) do
447 begin
448 Items.Assign(CtrlInit.List);
449 Text := CtrlInit.Text;
450 end
451 else if AControl is TORComboBox then with TORComboBox(AControl) do
452 begin
453 Items.Assign(CtrlInit.List);
454 if LongList then InitLongList(Text) else Text := CtrlInit.Text;
455 SelectByID(CtrlInit.ListID);
456 end;
457 { need to add SelectByID for combobox & listbox }
458end;
459
460procedure TCtrlInits.SetListOnly(AControl: TControl; const ASection: string);
461{ assigns list portion to a control from a section (used to set ShortList for meds) }
462var
463 CtrlInit: TCtrlInit;
464begin
465 CtrlInit := FindInitByName(ASection);
466 if CtrlInit = nil then Exit;
467 if AControl is TMemo then with TMemo(AControl) do Lines.Assign(CtrlInit.List)
468 else if AControl is TORListBox then with TORListBox(AControl) do Items.Assign(CtrlInit.List)
469 else if AControl is TListBox then with TListBox(AControl) do Items.Assign(CtrlInit.List)
470 else if AControl is TComboBox then with TComboBox(AControl) do Items.Assign(CtrlInit.List)
471 else if AControl is TORComboBox then with TORComboBox(AControl) do Items.Assign(CtrlInit.List);
472end;
473
474procedure TCtrlInits.SetPopupMenu(AMenu: TPopupMenu; AClickEvent: TNotifyEvent; const ASection: string);
475{ populates a popup menu with items in a list, leaves the maximum text width in Tag }
476var
477 i, MaxWidth: Integer;
478 CtrlInit: TCtrlInit;
479 AMenuItem: TMenuItem;
480begin
481 CtrlInit := FindInitByName(ASection);
482 // clear the current menu entries
483 for i := AMenu.Items.Count - 1 downto 0 do
484 begin
485 AMenuItem := AMenu.Items[i];
486 if AMenuItem <> nil then
487 begin
488 AMenu.Items.Delete(i);
489 AMenuItem.Free;
490 end;
491 end;
492 MaxWidth := 0;
493 for i := 0 to CtrlInit.List.Count - 1 do
494 begin
495 AMenuItem := TMenuItem.Create(Application);
496 AMenuItem.Caption := CtrlInit.List[i];
497 AMenuItem.OnClick := AClickEvent;
498 AMenu.Items.Add(AMenuItem);
499 MaxWidth := HigherOf(MaxWidth, Application.MainForm.Canvas.TextWidth(CtrlInit.List[i]));
500 end;
501 AMenu.Tag := MaxWidth;
502end;
503
504function TCtrlInits.DefaultText(const ASection: string): string;
505var
506 CtrlInit: TCtrlInit;
507begin
508 Result := '';
509 CtrlInit := FindInitByName(ASection);
510 if CtrlInit <> nil then Result := CtrlInit.ListID;
511end;
512
513function TCtrlInits.TextOf(const ASection: string): string;
514var
515 CtrlInit: TCtrlInit;
516begin
517 Result := '';
518 CtrlInit := FindInitByName(ASection);
519 if CtrlInit <> nil then Result := CtrlInit.List.Text;
520end;
521
522{ TResponses methods }
523
524function SortPromptsBySequence(Item1, Item2: Pointer): Integer;
525{ compare function used to sort formatting info by sequence - used by TResponses.SetDialog}
526var
527 Prompt1, Prompt2: TPrompt;
528begin
529 Prompt1 := TPrompt(Item1);
530 Prompt2 := TPrompt(Item2);
531 if Prompt1.Sequence < Prompt2.Sequence then Result := -1
532 else if Prompt1.Sequence > Prompt2.Sequence then Result := 1
533 else Result := 0;
534end;
535
536constructor TResponses.Create;
537begin
538 FResponseList := TList.Create;
539 FPrompts := TList.Create;
540 FOrderChecks := TStringList.Create;
541 FEventType := #0;
542 FParentEvent := TParentEvent.Create;
543 FLogTime := 0;
544end;
545
546destructor TResponses.Destroy;
547{ frees all response objects before freeing list }
548var
549 i: Integer;
550begin
551 Clear;
552 FOrderChecks.Free;
553 FResponseList.Free;
554 with FPrompts do for i := 0 to Count - 1 do TPrompt(Items[i]).Free;
555 FPrompts.Free;
556 inherited Destroy;
557end;
558
559procedure TResponses.Clear;
560{ clears all information in the response multiple }
561var
562 i: Integer;
563begin
564 FVarLeading := '';
565 FVarTrailing := '';
566 FQuickOrder := 0;
567 //FCopyOrder := ''; // don't clear FCopyOrder either?
568 // don't clear FEditOrder or it will cause a new order to be created instead of an edit
569 with FResponseList do for i := 0 to Count - 1 do TResponse(Items[i]).Free;
570 FResponseList.Clear;
571 FOrderChecks.Clear;
572end;
573
574procedure TResponses.Clear(const APromptID: string; SaveInstance: Integer = 0);
575var
576 AResponse: TResponse;
577 i: Integer;
578begin
579 with FResponseList do
580 for i := Count - 1 downto SaveInstance do
581 begin
582 AResponse := TResponse(Items[i]);
583 if AResponse.PromptID = APromptID then
584 begin
585 AResponse.Free;
586 FResponseList.Delete(i);
587 end; {if AResponse}
588 end; {for}
589end;
590
591procedure TResponses.SetDialog(Value: string);
592{ loads formatting information for a dialog }
593var
594 i: Integer;
595begin
596 with FPrompts do for i := 0 to Count - 1 do TPrompt(Items[i]).Free;
597 FPrompts.Clear;
598 FDialog := Value;
599 LoadDialogDefinition(FPrompts, FDialog);
600 FPrompts.Sort(SortPromptsBySequence);
601end;
602
603procedure TResponses.SetCopyOrder(const AnID: string);
604{ sets responses to the values for an order that is created by copying }
605var
606 HasObjects: boolean;
607begin
608 if AnID = '' then
609 begin
610 FCopyOrder := AnID;
611 Exit;
612 end;
613 Clear;
614 LoadResponses(FResponseList, AnID, HasObjects); // Example AnID=C123456;1-3604
615 FCopyOrder := Copy(Piece(AnID, '-', 1), 2, Length(AnID));
616 FOrderContainsObjects := HasObjects;
617end;
618
619procedure TResponses.SetEditOrder(const AnID: string);
620{ sets responses to the values for an order that is about to be edited }
621var
622 HasObjects: boolean;
623begin
624 Clear;
625 LoadResponses(FResponseList, AnID, HasObjects); // Example AnID=X123456;1
626 FEditOrder := Copy(Piece(AnID, '-', 1), 2, Length(AnID));
627 FOrderContainsObjects := HasObjects;
628end;
629
630procedure TResponses.SetQuickOrder(AnIEN: Integer);
631{ sets responses to a quick order value - this is used by the QuickOrder property}
632var
633 HasObjects: boolean;
634begin
635 Clear;
636 LoadResponses(FResponseList, IntToStr(AnIEN), HasObjects); // Example AnIEN=134
637 FQuickOrder := AnIEN;
638 FOrderContainsObjects := HasObjects;
639end;
640
641procedure TResponses.SetQuickOrderByID(const AnID: string);
642{ sets responses to a quick order value }
643var
644 HasObjects: boolean;
645begin
646 Clear;
647 LoadResponses(FResponseList, AnID, HasObjects); // Example AnID=134-3645
648 FQuickOrder := StrToIntDef(Piece(AnID, '-', 1), 0); // 2nd '-' piece is $H seconds
649 FOrderContainsObjects := HasObjects;
650end;
651
652procedure TResponses.BuildOCItems(AList: TStringList; var AStartDtTm: string;
653 const AFillerID: string);
654var
655 i, TheInstance: Integer;
656 OrderableIEN, PkgPart: string;
657begin
658 if EditOrder <> '' then DupORIFN := EditOrder;
659 if CopyOrder <> '' then DupORIFN := CopyOrder;
660 //if {(CopyOrder <> '') or} (EditOrder <> '') then Exit; // only check new orders
661 with FResponseList do for i := 0 to Count - 1 do with TResponse(Items[i]) do
662 if (PromptID = 'ORDERABLE') or (PromptID = 'ADDITIVE') then
663 begin
664 OrderableIEN := IValue;
665 TheInstance := Instance;
666 PkgPart := '';
667 if AFillerID = 'LR' then PkgPart := '^LR^' + IValueFor('SPECIMEN', TheInstance);
668 if (AFillerID = 'PSI') or (AFillerID = 'PSO') or (AFillerID = 'PSH')
669 then PkgPart := U + AFillerID + U + IValueFor('DRUG', TheInstance);
670 // was -- then PkgPart := '^PS^' + IValueFor('DRUG', TheInstance);
671 if AFillerID = 'PSIV' then
672 begin
673 if PromptID = 'ORDERABLE' then PkgPart := '^PSIV^B;' + IValueFor('VOLUME', TheInstance);
674 if PromptID = 'ADDITIVE' then PkgPart := '^PSIV^A';
675 end;
676 AList.Add(OrderableIEN + PkgPart);
677 end;
678 AStartDtTm := IValueFor('START', 1);
679end;
680
681function TResponses.EValueFor(const APromptID: string; AnInstance: Integer): string;
682var
683 i: Integer;
684begin
685 Result := '';
686 with FResponseList do for i := 0 to Count - 1 do with TResponse(Items[i]) do
687 if (PromptID = APromptID) and (Instance = AnInstance) then
688 begin
689 Result := EValue;
690 break;
691 end;
692end;
693
694function TResponses.IValueFor(const APromptID: string; AnInstance: Integer): string;
695var
696 i: Integer;
697begin
698 Result := '';
699 with FResponseList do for i := 0 to Count - 1 do with TResponse(Items[i]) do
700 if (PromptID = APromptID) and (Instance = AnInstance) then
701 begin
702 Result := IValue;
703 break;
704 end;
705end;
706
707function TResponses.PromptExists(const APromptID: string): boolean;
708var
709 i: Integer;
710begin
711 Result := False;
712 with FPrompts do for i := 0 to Count - 1 do with TPrompt(Items[i]) do
713 if (ID = APromptID) then Result := True;
714end;
715
716function TResponses.FindResponseByName(const APromptID: string; AnInstance: Integer): TResponse;
717var
718 i: Integer;
719begin
720 Result := nil;
721 with FResponseList do for i := 0 to Count - 1 do with TResponse(Items[i]) do
722 if (PromptID = APromptID) and (Instance = AnInstance) then
723 begin
724 Result := TResponse(Items[i]);
725 break;
726 end;
727end;
728
729function TResponses.IENForPrompt(const APromptID: string): Integer;
730var
731 i: Integer;
732begin
733 Result := 0;
734 with FPrompts do for i := 0 to Count - 1 do with TPrompt(Items[i]) do
735 if (ID = APromptID) then
736 begin
737 Result := IEN;
738 break;
739 end;
740end;
741
742function TResponses.InstanceCount(const APromptID: string): Integer;
743var
744 i: Integer;
745begin
746 Result := 0;
747 with FResponseList do for i := 0 to Count - 1 do with TResponse(Items[i]) do
748 if (PromptID = APromptID) then Inc(Result);
749end;
750
751function TResponses.NextInstance(const APromptID: string; LastInstance: Integer): Integer;
752var
753 i: Integer;
754begin
755 Result := 0;
756 with FResponseList do for i := 0 to Count - 1 do with TResponse(Items[i]) do
757 if (PromptID = APromptID) and (Instance > LastInstance) and
758 ((Result = 0) or ((Result > 0) and (Instance < Result))) then Result := Instance;
759end;
760
761function TResponses.FindResponseByIEN(APromptIEN, AnInstance: Integer): TResponse;
762var
763 i: Integer;
764begin
765 Result := nil;
766 with FResponseList do for i := 0 to Count - 1 do with TResponse(Items[i]) do
767 if (PromptIEN = APromptIEN) and (Instance = AnInstance) then
768 begin
769 Result := TResponse(Items[i]);
770 break;
771 end;
772end;
773
774procedure TResponses.FormatResponse(var FormattedText: string; var ExcludeText: Boolean;
775 APrompt: TPrompt; const x: string; AnInstance: Integer);
776var
777 AValue: string;
778 PromptIEN: Integer;
779 Related: TResponse;
780begin
781 FormattedText := '';
782 ExcludeText := True;
783 with APrompt do
784 begin
785 if FmtCode = '@' then Exit; // skip this response
786 if CharAt(FmtCode, 1) = '@' then // exclude if related response exists
787 begin
788 PromptIEN := StrToIntDef(Copy(FmtCode, 2, Length(FmtCode)), 0);
789 if (FindResponseByIEN(PromptIEN, AnInstance) <> nil) then Exit;
790 end;
791 if CharAt(FmtCode, 1) = '*' then // include if related response exists
792 begin
793 PromptIEN := StrToIntDef(Copy(FmtCode, 2, Length(FmtCode)), 0);
794 if FindResponseByIEN(PromptIEN, AnInstance) = nil then Exit;
795 end;
796 if CharAt(FmtCode, 1) = '#' then // include if related response = value
797 begin
798 AValue := Copy(FmtCode, Pos('=', FmtCode) + 1, Length(FmtCode));
799 PromptIEN := StrToIntDef(Copy(Piece(FmtCode, '=', 1), 2, Length(FmtCode)), 0);
800 Related := FindResponseByIEN(PromptIEN, AnInstance);
801 if Related = nil then Exit;
802 if not (Related.EValue = AValue) then Exit;
803 end;
804 if CharAt(FmtCode, 1) = '=' then // exclude if related response has same text
805 begin
806 PromptIEN := StrToIntDef(Copy(FmtCode, 2, Length(FmtCode)), 0);
807 Related := FindResponseByIEN(PromptIEN, AnInstance);
808 if (Related <> nil) and ((Pos(Related.EValue, x) > 0) or (Pos(x, Related.EValue) > 0)) then Exit;
809 end;
810 ExcludeText := False;
811 if (Length(x) = 0) or (CompareText(x, Omit) = 0) then Exit;
812 FormattedText := x;
813 if IsChild and (Length(Leading) > 0) and (CharAt(Leading, 1) <> '@')
814 then FormattedText := Leading + ' ' + FormattedText;
815 if IsChild and (Length(Trailing) > 0) and (CharAt(Trailing, 1) <> '@')
816 then FormattedText := FormattedText + ' ' + Trailing;
817 end; {with APrompt}
818end;
819
820function TResponses.FindPromptByIEN(AnIEN: Integer): TPrompt;
821var
822 i: Integer;
823begin
824 Result := nil;
825 with FPrompts do for i := 0 to Count - 1 do with TPrompt(Items[i]) do
826 if IEN = AnIEN then
827 begin
828 Result := TPrompt(Items[i]);
829 break;
830 end;
831end;
832
833procedure TResponses.AppendChildren(var ParentText: string; ChildPrompts: string; AnInstance: Integer);
834var
835 x, Segment: string;
836 Boundary, ChildIEN: Integer;
837 ExcludeText: Boolean;
838 AResponse: TResponse;
839 APrompt: TPrompt;
840begin
841 while Length(ChildPrompts) > 0 do
842 begin
843 Boundary := Pos('~', ChildPrompts);
844 if Boundary = 0 then Boundary := Length(ChildPrompts) + 1;
845 Segment := Copy(ChildPrompts, 1, Boundary - 1);
846 Delete(ChildPrompts, 1, Boundary);
847 ChildIEN := StrToIntDef(Segment, 0);
848 APrompt := FindPromptByIEN(ChildIEN);
849 if APrompt <> nil then
850 begin
851 AResponse := FindResponseByIEN(APrompt.IEN, AnInstance);
852 if AResponse <> nil then
853 begin
854 FormatResponse(x, ExcludeText, APrompt, AResponse.EValue, AnInstance);
855 //x := FormatResponse(APrompt, AResponse.EValue, AnInstance);
856 if not ExcludeText then
857 begin
858 if (Length(ParentText) > 0) and (Length(x) > 0) then ParentText := ParentText + ' ';
859 ParentText := ParentText + x;
860 end; {if not ExcludeText}
861 end; {if AResponse}
862 end; {if APrompt}
863 end; {while Length}
864end; {AppendChildren}
865
866function TResponses.GetOrderText: string;
867{ loop thru the response objects and build the order text }
868var
869 i, AnInstance, NumInstance: Integer;
870 x, Segment: string;
871 ExcludeText, StartNewline: Boolean;
872 AResponse: TResponse;
873 APrompt: TPrompt;
874begin
875 Result := '';
876 with FPrompts do for i := 0 to Count - 1 do
877 begin
878 APrompt := TPrompt(Items[i]);
879 if APrompt.Sequence = 0 then Continue; // skip if prompt not in formatting sequence
880 NumInstance := 0;
881 Segment := '';
882 AnInstance := NextInstance(APrompt.ID, 0);
883 while AnInstance > 0 do
884 begin
885 Inc(NumInstance);
886 AResponse := FindResponseByName(APrompt.ID, AnInstance);
887 FormatResponse(x, ExcludeText, APrompt, AResponse.EValue, AnInstance);
888 //x := FormatResponse(APrompt, AResponse.EValue, AnInstance);
889 if not ExcludeText then
890 begin
891 if Length(APrompt.Children) > 0 then AppendChildren(x, APrompt.Children, AnInstance);
892 if Length(x) > 0 then
893 begin
894 // should the newline property be checked for children, too?
895 if APrompt.NewLine and (Length(Result) > 0) then x := CRLF + x;
896 if NumInstance > 1 then Segment := Segment + ',';
897 if Length(Segment) > 0 then Segment := Segment + ' ';
898 Segment := Segment + x;
899 end; {if Length(x)}
900 end; {if not ExcudeText}
901 AnInstance := NextInstance(APrompt.ID, AnInstance);
902 end; {while AnInstance}
903 if NumInstance > 0 then with APrompt do
904 begin
905 if Length(Segment) > 0 then
906 begin
907 if Copy(Segment, 1, 2) = CRLF then
908 begin
909 Segment := Copy(Segment, 3, Length(Segment));
910 StartNewline := True;
911 end
912 else StartNewline := False;
913 if (Length(Leading) > 0) then
914 begin
915 if (CharAt(Leading, 1) <> '@')
916 then Segment := Leading + ' ' + Segment
917 else Segment := FVarLeading + ' ' + Segment;
918 end; {if Length(Leading)}
919 if StartNewline then Segment := CRLF + Segment;
920 if (Length(Trailing) > 0) then
921 begin
922 if (CharAt(Trailing, 1) <> '@')
923 then Segment := Segment + ' ' + Trailing
924 else Segment := Segment + ' ' + FVarTrailing;
925 end; {if Length(Trailing)}
926 end; {if Length(Segment)}
927 if Length(Result) > 0 then Result := Result + ' ';
928 Result := Result + Segment;
929 end; {with APrompt}
930 end; {with FPrompts}
931end; {GetOrderText}
932
933procedure TResponses.Update(const APromptID: string; AnInstance: Integer;
934 const AnIValue, AnEValue: string);
935{ for a given Prompt,Instance update or create the associated response object }
936var
937 AResponse: TResponse;
938begin
939 AResponse := FindResponseByName(APromptID, AnInstance);
940 if AResponse = nil then
941 begin
942 AResponse := TResponse.Create;
943 AResponse.PromptID := APromptID;
944 AResponse.PromptIEN := IENForPrompt(APromptID);
945 AResponse.Instance := AnInstance;
946 FResponseList.Add(AResponse);
947 end;
948 AResponse.IValue := AnIValue;
949 AResponse.EValue := AnEValue;
950end;
951
952function TResponses.OrderCRC: string;
953const
954 CRC_WIDTH = 8;
955var
956 i: Integer;
957 x: string;
958 tmplst: TStringList;
959begin
960 tmplst := TStringList.Create;
961 try
962 with FResponseList do for i := 0 to Count - 1 do with TResponse(Items[i]) do
963 begin
964 if IValue = TX_WPTYPE then x := EValue else x := IValue;
965 tmplst.Add(IntToStr(PromptIEN) + U + IntToStr(Instance) + U + x);
966 end;
967 Result := IntToHex(CRCForStrings(tmplst), CRC_WIDTH);
968 finally
969 tmplst.Free;
970 end;
971end;
972
973procedure TResponses.Remove(const APromptID: string; AnInstance: Integer);
974var
975 AResponse: TResponse;
976begin
977 AResponse := FindResponseByName(APromptID, AnInstance);
978 if AResponse <> nil then
979 begin
980 FResponseList.Remove(AResponse);
981 AResponse.Free;
982 end;
983end;
984
985procedure TResponses.SaveQuickOrder(var ANewIEN: Integer; const ADisplayName: string);
986begin
987 if FDisplayGroup = ClinDisp then //Clin. Meds share same quick order definition with Inpt. Meds
988 PutQuickOrder(ANewIEN, OrderCRC, ADisplayName, InptDisp, FResponseList)
989 else
990 PutQuickOrder(ANewIEN, OrderCRC, ADisplayName, FDisplayGroup, FResponseList)
991end;
992
993procedure TResponses.SaveOrder(var AnOrder: TOrder; DlgIEN: Integer; IsIMOOrder: boolean);
994var
995 ConstructOrder: TConstructOrder;
996 i,j: integer;
997 QOUDGroup: boolean;
998 NewPtEvtPtr: Integer; // ptr to #100.2
999 APtEvtPtr: string;
1000begin
1001 //IMOLoc := 0;
1002 NewPtEvtPtr := 0;
1003 QOUDGroup := False;
1004 if FQuickOrder > 0 then
1005 begin
1006 DlgIEN := FQuickOrder;
1007 QOUDGroup := CheckQOGroup( IntToStr(FQuickOrder) );
1008 end;
1009 AnOrder.EditOf := FEditOrder; // null if new order, otherwise ORIFN of original order
1010 with ConstructOrder do
1011 begin
1012 if XfInToOutNow then
1013 DialogName := FDialog + '^O'
1014 else DialogName := FDialog;
1015 LeadText := FVarLeading;
1016 TrailText := FVarTrailing;
1017 DGroup := FDisplayGroup;
1018 OrderItem := DlgIEN;
1019 DelayEvent := FEventType;
1020 Specialty := FSpecialty;
1021 Effective := FEffective;
1022 LogTime := FLogTime;
1023 OCList := FOrderChecks;
1024 DigSig := DEASig;
1025 IsIMODialog := IsIMOOrder; //IMO
1026 if IsIMODialog then
1027 DGroup := ClinDisp;
1028 //AGP Change 26.35, 26.41 8518 added text order
1029 //AGP Change 26.55 remove IMO functionality for inpatient
1030 (*if (Patient.Inpatient = true) and (IsValidIMOLoc(encounter.Location,Patient.DFN)=true) and
1031 ((ConstructOrder.DialogName = 'PSJ OR PAT OE') or (ConstructOrder.DialogName = 'PSJI OR PAT FLUID OE') or
1032 (ConstructOrder.DialogName = 'OR GXTEXT WORD PROCESSING ORDE')) and
1033 ((FEditOrder = '') and (Self.FEventName = '') and (Self.FCopyOrder = '')) then
1034 begin
1035 if frmClinicWardMeds.ClinicOrWardLocation(Encounter.location) = Encounter.Location then
1036 begin
1037 ConstructOrder.IsIMODialog := True;
1038 ConstructOrder.DGroup := ClinDisp;
1039 end
1040 else IMOLoc := Patient.Location;
1041 end; *)
1042 //AGP Change 26.51, change logic to set text orders to IMO for outpatients at an outpatient location.
1043 //AGP Text orders are only treated as IMO if the order display group is a nursing display group
1044 if (Patient.Inpatient = False) and (IsValidIMOLoc(encounter.Location,Patient.DFN)=true) and
1045 (((pos('OR GXTEXT WORD PROCESSING ORDE',ConstructOrder.DialogName)>0) and (ConstructOrder.DGroup = NurDisp)) or
1046 ((ConstructOrder.DialogName = 'OR GXMISC GENERAL') and (ConstructOrder.DGroup = NurDisp)) or
1047 ((ConstructOrder.DialogName = 'OR GXTEXT TEXT ONLY ORDER') and (ConstructOrder.DGroup = NurDisp))) and //AGP Change CQ #10757
1048 ((FEditOrder = '') and (Self.FEventName = '') and (Self.FCopyOrder = '')) then
1049 begin
1050 ConstructOrder.IsIMODialog := True;
1051 ConstructOrder.DGroup := ClinDisp;
1052 end;
1053 IsEventDefaultOR := EventDefaultOD;
1054 if IsUDGroup or QOUDGroup then
1055 begin
1056 for i := 0 to FResponseList.Count - 1 do
1057 if UpperCase(TResponse(FResponseList.Items[i]).PromptID) = 'PICKUP' then
1058 begin
1059 FResponseList.Delete(i);
1060 Break;
1061 end;
1062 end;
1063
1064 if SaveAsCurrent then
1065 ConstructOrder.DelayEvent := #0;
1066
1067 ResponseList := FResponseList;
1068 if (FEventIFN>0) and (EventExist(Patient.DFN, FEventIFN)>0) then
1069 begin
1070 APtEvtPtr := IntToStr(EventExist(Patient.DFN, FEventIFN));
1071 PTEventPtr := APtEvtPtr;
1072 //PutNewOrder(AnOrder, ConstructOrder, OrderSource, IMOLoc);
1073 PutNewOrder(AnOrder, ConstructOrder, OrderSource);
1074 if not SaveAsCurrent then
1075 begin
1076 AnOrder.EventPtr := PTEventPtr;
1077// AnOrder.EventName := 'Delayed ' + MixedCase(Piece(EventInfo(APtEvtPtr),'^',4)); <-- original line. //kt 8/8/2007
1078 AnOrder.EventName := DKLangConstW('fODBase_Delayed') + MixedCase(Piece(EventInfo(APtEvtPtr),'^',4)); //kt added 8/8/2007
1079 end;
1080 end
1081 else
1082 begin
1083 //PutNewOrder(AnOrder, ConstructOrder, OrderSource, IMOLoc);
1084 PutNewOrder(AnOrder, ConstructOrder, OrderSource);
1085 if not SaveAsCurrent then
1086 begin
1087 if (FEventIFN > 0) and (FParentEvent.ParentIFN > 0) then
1088 begin
1089 {For a child event, create a parent event in 100.2 first}
1090 SaveEvtForOrder(Patient.DFN, FParentEvent.ParentIFN, AnOrder.ID);
1091 NewPtEvtPtr := EventExist(Patient.DFN, FParentEvent.ParentIFN);
1092 AnOrder.EventPtr := IntToStr(NewPtEvtPtr);
1093// AnOrder.EventName := 'Delayed ' + MixedCase(Piece(EventInfo(IntToStr(NewPtEvtPtr)),'^',4)); <-- original line. //kt 8/8/2007
1094 AnOrder.EventName := DKLangConstW('fODBase_Delayed') + MixedCase(Piece(EventInfo(IntToStr(NewPtEvtPtr)),'^',4)); //kt added 8/8/2007
1095 {Then create the child event in 100.2}
1096 SaveEvtForOrder(Patient.DFN, FEventIFN, '');
1097 NewPtEvtPtr := EventExist(Patient.DFN, FEventIFN);
1098 end
1099 else if (FEventIFN > 0) and (FParentEvent.ParentIFN = 0) then
1100 begin
1101 SaveEvtForOrder(Patient.DFN, FEventIFN, AnOrder.ID);
1102 NewPtEvtPtr := EventExist(Patient.DFN, FEventIFN);
1103 AnOrder.EventPtr := IntToStr(NewPtEvtPtr);
1104// AnOrder.EventName := 'Delayed ' + MixedCase(Piece(EventInfo(IntToStr(NewPtEvtPtr)),'^',4)); <-- original line. //kt 8/8/2007
1105 AnOrder.EventName := DKLangConstW('fODBase_Delayed') + MixedCase(Piece(EventInfo(IntToStr(NewPtEvtPtr)),'^',4)); //kt added 8/8/2007
1106 end;
1107 if FEventIFN > 0 then
1108 begin
1109 for j := 1 to frmOrders.lstSheets.Items.Count - 1 do
1110 begin
1111 if FEventIFN = StrToInt( Piece(Piece(frmOrders.lstSheets.Items[j],'^',1),';',1) ) then
1112 begin
1113 frmOrders.lstSheets.Items[j] := IntToStr( NewPtEvtPtr) + '^' + Piece(frmOrders.lstSheets.Items[j],'^',2);
1114 frmOrders.lstSheets.ItemIndex := j;
1115 end;
1116 end;
1117 end;
1118 end;
1119 end;
1120 DEASig := ''; //PKI
1121 end;
1122 AnOrder.EditOf := FEditOrder;
1123{Begin BillingAware}
1124 if rpcGetBAMasterSwStatus then
1125 begin
1126 UBAGlobals.BAOrderID := '';
1127 UBAGlobals.BAOrderID := AnOrder.ID;
1128 end;
1129{Begin BillingAware}
1130end;
1131
1132procedure TResponses.SetControl(AControl: TControl; const APromptID: string; AnInstance: Integer);
1133{ sets the value of a control, uses ID string & instance to find the right response entry }
1134var
1135 i: Integer;
1136 AResponse: TResponse;
1137 IEN: integer;
1138 HasObjects: boolean;
1139
1140 procedure AssignBPText(List: TStrings; const Value: string);
1141 var
1142 tmp, cptn, DocInfo: string;
1143 LType: TTemplateLinkType;
1144
1145 begin
1146 DocInfo := '';
1147 LType := DisplayGroupToLinkType(DisplayGroup);
1148// cptn := 'Reason for Request: ' + EValueFor('ORDERABLE', 1); <-- original line. //kt 8/8/2007
1149 cptn := DKLangConstW('fODBase_Reason_for_Requestx')+' ' + EValueFor(DKLangConstW('fODBase_ORDERABLE'), 1); //kt added 8/8/2007
1150 tmp := Value;
1151 case LType of
1152 ltConsult: IEN := StrToIntDef(GetServiceIEN(IValueFor('ORDERABLE', 1)),0);
1153 ltProcedure: IEN := StrToIntDef(GetProcedureIEN(IValueFor('ORDERABLE', 1)),0);
1154 else IEN := 0;
1155 end;
1156 ExpandOrderObjects(tmp, HasObjects);
1157 FOrderContainsObjects := FOrderContainsObjects or HasObjects;
1158 if IEN <> 0 then
1159 begin
1160 // template will execute on copy order if commented out (tried to eliminate for CSV v22, RV)
1161 //
1162 //if (Length(tmp) > 0) and (not HasTemplateField(tmp)) then
1163 // CheckBoilerplate4Fields(tmp, cptn)
1164 //else
1165 ExecuteTemplateOrBoilerPlate(tmp, IEN, LType, nil, cptn, DocInfo);
1166 end
1167 else
1168 CheckBoilerplate4Fields(tmp, cptn);
1169 List.Text := tmp;
1170 end;
1171
1172begin
1173 AResponse := FindResponseByName(APromptID, AnInstance);
1174 if AResponse = nil then Exit;
1175 if AControl is TLabel then with TLabel(AControl) do Caption := AResponse.EValue
1176 else if AControl is TStaticText then with TStaticText(AControl) do Caption := AResponse.EValue
1177 else if AControl is TButton then with TButton(AControl) do Caption := AResponse.EValue
1178 else if AControl is TEdit then with TEdit(AControl) do Text := AResponse.EValue
1179 else if AControl is TMaskEdit then with TMaskEdit(AControl) do Text := AResponse.EValue
1180 else if AControl is TCheckBox then with TCheckBox(AControl) do
1181 Checked := (StrToIntDef(AResponse.IValue,0) > 0) or
1182 (UpperCase(AResponse.IValue) = 'Y')
1183 else if AControl is TMemo then with TMemo(AControl) do AssignBPText(Lines, AResponse.EValue)
1184 else if AControl is TRichEdit then with TRichEdit(AControl) do AssignBPText(Lines, AResponse.EValue)
1185 else if AControl is TORListBox then with TORListBox(AControl) do
1186 begin
1187 for i := 0 to Items.Count - 1 do
1188 if Piece(Items[i], U, 1) = AResponse.IValue then ItemIndex := i;
1189 end
1190 else if AControl is TListBox then with TListBox(AControl) do
1191 begin
1192 for i := 0 to Items.Count - 1 do
1193 if Items[i] = AResponse.EValue then ItemIndex := i;
1194 end
1195 else if AControl is TComboBox then with TComboBox(AControl) do
1196 begin
1197 for i := 0 to Items.Count - 1 do
1198 if Items[i] = AResponse.EValue then ItemIndex := i;
1199 Text := AResponse.EValue;
1200 end
1201 else if AControl is TORComboBox then with TORComboBox(AControl) do
1202 begin
1203 if LongList then InitLongList(AResponse.EValue);
1204 SelectByID(AResponse.IValue);
1205 if (not LongList) and (ItemIndex < 0) then Text := AResponse.EValue;
1206 end;
1207end;
1208
1209procedure TResponses.SetEventDelay(AnEvent: TOrderDelayEvent);
1210begin
1211 with AnEvent do if EventType in ['A','D','T','M','O'] then
1212 begin
1213 FEventIFN := EventIFN;
1214 FEventName := EventName;
1215 FEventType := EventType;
1216 FSpecialty := Specialty;
1217 FEffective := Effective;
1218// FViewName := 'Delayed ' + MixedCase(EventName); <-- original line. //kt 8/8/2007
1219 FViewName := DKLangConstW('fODBase_Delayed') + MixedCase(EventName); //kt added 8/8/2007
1220 FParentEvent := TParentEvent(AnEvent.TheParent);
1221 end;
1222end;
1223
1224procedure TResponses.SetPromptFormat(const APromptID, NewFormat: string);
1225var
1226 i: Integer;
1227begin
1228 with FPrompts do for i := 0 to Count - 1 do with TPrompt(Items[i]) do
1229 if (ID = APromptID) then FmtCode := NewFormat;
1230end;
1231
1232{ Private calls }
1233
1234procedure TfrmODBase.ClearDialogControls;
1235var
1236 i: Integer;
1237begin
1238 FChanging := True;
1239 for i := 0 to ControlCount - 1 do
1240 begin
1241 // need to check if control is container & clear it's children also
1242 if (Controls[i] is TLabel) or (Controls[i] is TButton) or (Controls[i] is TStaticText) then Continue;
1243 if FPreserve.IndexOf(Controls[i]) < 0 then ClearControl(Controls[i]);
1244 end;
1245 FChanging := False;
1246 ShowOrderMessage( False );
1247end;
1248
1249procedure TfrmODBase.SetDisplayGroup(Value: Integer);
1250begin
1251 FDisplayGroup := Value;
1252 Responses.FDisplayGroup := Value;
1253end;
1254
1255procedure TfrmODBase.SetFillerID(const Value: string);
1256var
1257 x: string;
1258begin
1259 SetupVars; //kt added 8/8/2007 to replace constants with vars.
1260 FFillerID := Value;
1261 if AddFillerAppID(FFillerID) and OrderChecksEnabled then
1262 begin
1263// StatusText('Order Checking...'); <-- original line. //kt 8/8/2007
1264 StatusText(DKLangConstW('fODBase_Order_Checkingxxx')); //kt added 8/8/2007
1265 //if Patient.DFN = '' then exit; //kt added 6/18/08
1266 x := OrderChecksOnDisplay(FillerID);
1267 StatusText('');
1268 if Length(x) > 0 then InfoBox(x, TC_ORDERCHECKS, MB_OK);
1269 end;
1270end;
1271
1272{ Protected Calls (used by descendant forms) }
1273
1274procedure TfrmODBase.InitDialog;
1275begin
1276 ClearDialogControls;
1277 Responses.Clear;
1278 FAcceptOK := False;
1279 FAbortOrder := False;
1280end;
1281
1282function TfrmODBase.OrderForInpatient: Boolean;
1283var
1284 AnEventType: Char;
1285begin
1286 AnEventType := OrderEventTypeOnCreate;
1287 // if event type = #0, then it wasn't passed or we're not in create
1288 if AnEventType = #0 then AnEventType := Responses.FEventType;
1289 case AnEventType of
1290 'A','O': Result := True;
1291 'D': Result := False;
1292 'T':
1293 begin
1294 if IsPassEvt1(FEvtID,'T') then Result := False
1295 else Result := True;
1296 end
1297 else Result := Patient.Inpatient;
1298 end;
1299end;
1300
1301procedure TfrmODBase.ShowOrderMessage(Show: boolean);
1302begin
1303 if Show then
1304 begin
1305 pnlMessage.Visible := True;
1306 pnlMessage.BringToFront;
1307 memMessage.TabStop := True;
1308 end
1309 else
1310 begin
1311 pnlMessage.Visible := False;
1312 pnlMessage.SendToBack;
1313 memMessage.TabStop := False;
1314 end;
1315end;
1316
1317procedure TfrmODBase.OrderMessage(const AMessage: string);
1318{Caller needs to set pnlMessage.TabOrder}
1319begin
1320 memMessage.Lines.SetText(PChar(AMessage));
1321 //begin CQ: 2640
1322 memMessage.SelStart := 0; // Put at first character
1323 SendMessage(memMessage.Handle, WM_VSCROLL, SB_TOP, 0);
1324 //End CQ: 2640
1325 ShowOrderMessage(ContainsVisibleChar(AMessage));
1326end;
1327
1328procedure TfrmODBase.PreserveControl(AControl: TControl);
1329begin
1330 FPreserve.Add(AControl);
1331end;
1332
1333procedure TfrmODBase.SetDialogIEN(Value: Integer);
1334begin
1335 FDialogIEN := Value;
1336end;
1337
1338procedure TfrmODBase.SetupDialog(OrderAction: Integer; const ID: string);
1339begin
1340 FOrderAction := OrderAction;
1341 FAbortOrder := False;
1342 case OrderAction of
1343 ORDER_NEW: {nothing};
1344 ORDER_EDIT: Responses.SetEditOrder(ID);
1345 ORDER_COPY: Responses.SetCopyOrder(ID);
1346 ORDER_QUICK: Responses.SetQuickOrderByID(ID);
1347 end;
1348//if Responses.FEventType in ['A','D','T','M','O'] then Caption := Caption + ' (Delayed ' + Responses.FEventName + ')'; // ' (Event Delayed)'; <-- original line. //kt 8/8/2007
1349 if Responses.FEventType in ['A','D','T','M','O'] then Caption := Caption + DKLangConstW('fODBase_xDelayed')+' ' + Responses.FEventName + ')'; // DKLangConstW('fODBase_xEvent_Delayedx'); //kt added 8/8/2007
1350//if OrderAction in [ORDER_EDIT, ORDER_COPY] then cmdQuit.Caption := 'Cancel'; <-- original line. //kt 8/8/2007
1351 if OrderAction in [ORDER_EDIT, ORDER_COPY] then cmdQuit.Caption := DKLangConstW('fODBase_Cancel'); //kt added 8/8/2007
1352end;
1353
1354function TfrmODBase.GetEffectiveDate: TFMDateTime;
1355begin
1356 Result := Responses.FEffective;
1357end;
1358
1359function TfrmODBase.GetKeyVariable(const Index: string): string;
1360begin
1361 if UpperCase(Index) = 'LRFZX' then Result := Piece(FKeyVariables, U, 1)
1362 else if UpperCase(Index) = 'LRFSAMP' then Result := Piece(FKeyVariables, U, 2)
1363 else if UpperCase(Index) = 'LRFSPEC' then Result := Piece(FKeyVariables, U, 3)
1364 else if UpperCase(Index) = 'LRFDATE' then Result := Piece(FKeyVariables, U, 4)
1365 else if UpperCase(Index) = 'LRFURG' then Result := Piece(FKeyVariables, U, 5)
1366 else if UpperCase(Index) = 'LRFSCH' then Result := Piece(FKeyVariables, U, 6)
1367 else if UpperCase(Index) = 'PSJNOPC' then Result := Piece(FKeyVariables, U, 7)
1368 else if UpperCase(Index) = 'GMRCNOPD' then Result := Piece(FKeyVariables, U, 8)
1369 else if UpperCase(Index) = 'GMRCNOAT' then Result := Piece(FKeyVariables, U, 9)
1370 else if UpperCase(Index) = 'GMRCREAF' then Result := Piece(FKeyVariables, U, 10)
1371 else Result := '';
1372end;
1373
1374procedure TfrmODBase.SetKeyVariables(const VarStr: string);
1375begin
1376 FKeyVariables := VarStr;
1377end;
1378
1379procedure TfrmODBase.Validate(var AnErrMsg: string);
1380//const
1381//TX_OR_DISABLED = 'Ordering has been disabled. Press Quit.'; <-- original line. //kt 8/8/2007
1382//TX_PAST_START = 'The start date may not be earlier than the present.'; <-- original line. //kt 8/8/2007
1383//TX_NO_LOCATION = 'A location must be identified.' + CRLF + <-- original line. //kt 8/8/2007
1384// '(Select File | Update Provider/Location)'; <-- original line. //kt 8/8/2007
1385//TX_NO_PROVIDER = 'A provider who is authorized to write orders must be indentified.' + CRLF + <-- original line. //kt 8/8/2007
1386// '(Select File | Update Provider/Location)'; <-- original line. //kt 8/8/2007
1387var
1388 StartStr,x: string;
1389 StartDt: TFMDateTime;
1390 TX_OR_DISABLED : string; //kt
1391 TX_PAST_START : string; //kt
1392 TX_NO_LOCATION : string; //kt
1393 TX_NO_PROVIDER : string; //kt
1394
1395begin
1396 TX_OR_DISABLED := DKLangConstW('fODBase_Ordering_has_been_disabledx__Press_Quitx'); //kt added 8/8/2007
1397 TX_PAST_START := DKLangConstW('fODBase_The_start_date_may_not_be_earlier_than_the_presentx'); //kt added 8/8/2007
1398 TX_NO_LOCATION := DKLangConstW('fODBase_A_location_must_be_identifiedx') + CRLF + //kt added 8/8/2007
1399 DKLangConstW('fODBase_xSelect_File_x_Update_ProviderxLocationx'); //kt added 8/8/2007
1400 TX_NO_PROVIDER := DKLangConstW('fODBase_A_provider_who_is_authorized_to_write_orders_must_be_indentifiedx') + CRLF + //kt added 8/8/2007
1401 DKLangConstW('fODBase_xSelect_File_x_Update_ProviderxLocationx'); //kt added 8/8/2007
1402
1403 AnErrMsg := '';
1404//if User.NoOrdering then AnErrMsg := 'Ordering has been disabled. Press Quit.'; <-- original line. //kt 8/8/2007
1405 if User.NoOrdering then AnErrMsg := DKLangConstW('fODBase_Ordering_has_been_disabledx__Press_Quitx'); //kt added 8/8/2007
1406 // take this out if we <don't> need to check for earlier start date/times
1407 // should this check be against FMNow??
1408 StartStr := Piece(Responses.IValueFor('START', 1), '.', 1);
1409 if not IsFMDateTime(StartStr)
1410 then StartDt := StrToFMDateTime(StartStr)
1411 else StartDt := StrToFloat(StartStr);
1412 if (StartDt > 0) and (StartDt < FMToday)
1413// then AnErrMsg := 'The start date may not be earlier than the present.'; <-- original line. //kt 8/8/2007
1414 then AnErrMsg := DKLangConstW('fODBase_The_start_date_may_not_be_earlier_than_the_presentx'); //kt added 8/8/2007
1415 //frmFrame.UpdatePtInfoOnRefresh;
1416 if (not Patient.Inpatient) and (Responses.EventIFN > 0) then x := ''
1417 else
1418 begin
1419 if Encounter.Location = 0 then AnErrMsg := TX_NO_LOCATION;
1420 end;
1421 if (Encounter.Provider = 0) or (PersonHasKey(Encounter.Provider, 'PROVIDER') = False)
1422 then AnErrMsg := TX_NO_PROVIDER;
1423 if IsPFSSActive and Responses.PromptExists('VISITSTR') then
1424 Responses.Update('VISITSTR', 1, Encounter.VisitStr, Encounter.VisitStr);
1425end;
1426
1427{ Form Calls }
1428
1429procedure TfrmODBase.FormCreate(Sender: TObject);
1430begin
1431 inherited;
1432 memOrder.Color := ReadOnlyColor;
1433 FAcceptOK := False;
1434 FAutoAccept := False;
1435 FChanging := False;
1436 FClosing := False;
1437 FFromQuit := False;
1438 FTestMode := False;
1439 FIncludeOIPI := True;
1440 FEvtForPassDischarge := #0;
1441 FCtrlInits := TCtrlInits.Create;
1442 FResponses := TResponses.Create;
1443 FPreserve := TList.Create;
1444 FIsIMO := False; //imo
1445 FIsSupply := False;
1446 {This next bit is mostly for the font size. It also sets the default size of
1447 order forms if it is not in the database. This is handy if a new user wants
1448 to have large fonts. However, in the general case, this will be resized
1449 through rMisc.SetFormPosition.}
1450 if not AutoSizeDisabled then
1451 ResizeFormToFont(self);
1452 DoSetFontSize(MainFontSize);
1453
1454 imgMessage.Picture.Icon.Handle := LoadIcon(0, IDI_ASTERISK);
1455 //if User.NoOrdering then cmdAccept.Enabled := False;
1456 if uCore.User.NoOrdering then cmdAccept.Enabled := False;
1457 FDlgFormID := OrderFormIDOnCreate;
1458 FEvtID := OrderEventIDOnCreate;
1459 FEvtType := OrderEventTypeOnCreate;
1460 FEvtName := OrderEventNameOnCreate;
1461end;
1462
1463procedure TfrmODBase.FormDestroy(Sender: TObject);
1464begin
1465 FCtrlInits.Free;
1466 FResponses.Free;
1467 FPreserve.Free;
1468 //DestroyingOrderDialog;
1469 if Assigned(FCallOnExit) then FCallOnExit;
1470 if (Owner <> nil) and (Owner is TWinControl)
1471 then SendMessage(TWinControl(Owner).Handle, UM_DESTROY, FRefNum, 0);
1472 inherited;
1473end;
1474
1475procedure TfrmODBase.FormKeyPress(Sender: TObject; var Key: Char);
1476{ causes RETURN to be treated as pressing a tab key (need to have user preference) }
1477begin
1478 inherited;
1479 if (Key = #13) and not (ActiveControl is TCustomMemo) then
1480 begin
1481 Key := #0;
1482 Perform(WM_NEXTDLGCTL, 0, 0);
1483 end;
1484end;
1485
1486{ Accept & Quit Buttons }
1487
1488function TfrmODBase.AcceptOrderChecks: Boolean;
1489{ returns True if order was accepted with order checks, false if order should be cancelled }
1490var
1491 StartDtTm: string;
1492 OIList: TStringList;
1493begin
1494 Result := True;
1495 Responses.OrderChecks.Clear;
1496 if not OrderChecksEnabled then Exit;
1497 OIList := TStringList.Create;
1498 try
1499// StatusText('Order Checking...'); <-- original line. //kt 8/8/2007
1500 StatusText(DKLangConstW('fODBase_Order_Checkingxxx')); //kt added 8/8/2007
1501 Responses.BuildOCItems(OIList, StartDtTm, FillerID);
1502 OrderChecksOnAccept(Responses.OrderChecks, FillerID, StartDtTm, OIList, DupORIFN);
1503 DupORIFN := '';
1504 StatusText('');
1505 Result := AcceptOrderWithChecks(Responses.OrderChecks);
1506 finally
1507 OIList.Free;
1508 end;
1509end;
1510
1511function TfrmODBase.ValidSave: Boolean;
1512//const
1513//TX_NO_SAVE = 'This order cannot be saved for the following reason(s):' + CRLF + CRLF; <-- original line. //kt 8/8/2007
1514//TX_NO_SAVE_CAP = 'Unable to Save Order'; <-- original line. //kt 8/8/2007
1515//TX_SAVE_ERR = 'Unexpected error - it was not possible to save this order.'; <-- original line. //kt 8/8/2007
1516var
1517 ErrMsg: string;
1518 NewOrder: TOrder;
1519 CanSign, OrderAction: Integer;
1520 //thisSourceOrder: TOrder;
1521 TX_NO_SAVE : string; //kt
1522 TX_NO_SAVE_CAP : string; //kt
1523 TX_SAVE_ERR : string; //kt
1524begin
1525 TX_NO_SAVE := DKLangConstW('fODBase_This_order_cannot_be_saved_for_the_following_reasonxsxx') + CRLF + CRLF; //kt added 8/8/2007
1526 TX_NO_SAVE_CAP := DKLangConstW('fODBase_Unable_to_Save_Order'); //kt added 8/8/2007
1527 TX_SAVE_ERR := DKLangConstW('fODBase_Unexpected_error_x_it_was_not_possible_to_save_this_orderx'); //kt added 8/8/2007
1528 Result := True;
1529 Validate(ErrMsg);
1530 if Length(ErrMsg) > 0 then
1531 begin
1532 InfoBox(TX_NO_SAVE + ErrMsg, TX_NO_SAVE_CAP, MB_OK);
1533 Result := False;
1534 Exit;
1535 end;
1536 if not AcceptOrderChecks then
1537 begin
1538 if AskAnotherOrder(DialogIEN) then
1539 InitDialog // ClearDialogControls is in InitDialog
1540 else
1541 begin
1542 ClearDialogControls; // to allow form to close without prompting to save order
1543 Close;
1544 end;
1545 Result := False;
1546 Exit;
1547 end;
1548 if FTestMode then
1549 begin
1550 Result := False;
1551 Exit;
1552 end;
1553 // LES validation checking for changed lab order
1554 if not LESValidationCheck then Exit;
1555 NewOrder := TOrder.Create;
1556
1557 Responses.SaveOrder(NewOrder, DialogIEN, FIsIMO);
1558
1559 if frmOrders.IsDefaultDlg then
1560 begin
1561 frmOrders.EventDefaultOrder := NewOrder.ID;
1562 frmOrders.EvtOrderList.Add(NewOrder.EventPtr + '^' + NewOrder.ID);
1563 frmOrders.IsDefaultDlg := False;
1564 end;
1565 if Length(DfltCopay)>0 then SetDefaultCoPayToNewOrder(NewOrder.ID, DfltCopay);
1566 if (Length(FEvtName)>0) then
1567 begin
1568// NewOrder.EventName := 'Delayed ' + MixedCase(FEvtName); <-- original line. //kt 8/8/2007
1569 NewOrder.EventName := DKLangConstW('fODBase_Delayed') + MixedCase(FEvtName); //kt added 8/8/2007
1570 FEvtName := '';
1571 end;
1572 if not ProcessOrderAcceptEventHook(NewOrder.ID, NewOrder.DGroup) then
1573 begin
1574 if NewOrder.ID <> '' then
1575 begin
1576 if (Encounter.Provider = User.DUZ) and User.CanSignOrders
1577 then CanSign := CH_SIGN_YES
1578 else CanSign := CH_SIGN_NA;
1579 if NewOrder.Signature = OSS_NOT_REQUIRE then CanSign := CH_SIGN_NA;
1580 Changes.Add(CH_ORD, NewOrder.ID, NewOrder.Text, Responses.FViewName, CanSign);
1581
1582 UBAGlobals.TargetOrderID := NewOrder.ID;
1583
1584 if Responses.EditOrder = '' then OrderAction := ORDER_NEW else OrderAction := ORDER_EDIT;
1585 SendMessage(Application.MainForm.Handle, UM_NEWORDER, OrderAction, Integer(NewOrder));
1586 end
1587 else InfoBox(TX_SAVE_ERR, TX_NO_SAVE_CAP, MB_OK);
1588 end;
1589 NewOrder.Free; // free here - recieving forms should get own copy using assign
1590end;
1591
1592procedure TfrmODBase.cmdAcceptClick(Sender: TObject);
1593//const
1594//TX_CMPTEVT = ' occurred since you started writing delayed orders. ' <-- original line. //kt 8/8/2007
1595// + 'The orders that were entered and signed have now been released. ' <-- original line. //kt 8/8/2007
1596// + 'Any unsigned orders will be released immediately upon signature. ' <-- original line. //kt 8/8/2007
1597// + 'To write new delayed orders for this event you need to click the write delayed orders button again and select the appropriate event. ' <-- original line. //kt 8/8/2007
1598// + 'Orders delayed to this same event will remain delayed until the event occurs again.' <-- original line. //kt 8/8/2007
1599// + 'The Orders tab will now be refreshed and switched to the Active Orders view. ' <-- original line. //kt 8/8/2007
1600// + 'If you wish to continue to write active orders for this patient, ' <-- original line. //kt 8/8/2007
1601// + 'close this message window and continue as usual.'; <-- original line. //kt 8/8/2007
1602var
1603 theGrpName: string;
1604 alreadyClosed: boolean;
1605 TX_CMPTEVT : string; //kt
1606begin
1607 TX_CMPTEVT := DKLangConstW('fODBase_occurred_since_you_started_writing_delayed_ordersx') //kt added 8/8/2007
1608 + DKLangConstW('fODBase_The_orders_that_were_entered_and_signed_have_now_been_releasedx') //kt added 8/8/2007
1609 + DKLangConstW('fODBase_Any_unsigned_orders_will_be_released_immediately_upon_signaturex') //kt added 8/8/2007
1610 + #13#13
1611 + DKLangConstW('fODBase_To_write_new_delayed_orders_for_this_event_you_need_to_click_the_write_delayed_orders_button_again_and_select_the_appropriate_eventx') //kt added 8/8/2007
1612 + DKLangConstW('fODBase_Orders_delayed_to_this_same_event_will_remain_delayed_until_the_event_occurs_againx') //kt added 8/8/2007
1613 + #13#13
1614 + DKLangConstW('fODBase_The_Orders_tab_will_now_be_refreshed_and_switched_to_the_Active_Orders_viewx') //kt added 8/8/2007
1615 + DKLangConstW('fODBase_If_you_wish_to_continue_to_write_active_orders_for_this_patientx') //kt added 8/8/2007
1616 + DKLangConstW('fODBase_close_this_message_window_and_continue_as_usualx'); //kt added 8/8/2007
1617 FAcceptOK := False;
1618 CIDCOkToSave := False;
1619 alreadyClosed := False;
1620 self.Responses.Cancel := False;
1621 if frmOrders <> nil then
1622 begin
1623 if (frmOrders.TheCurrentView <> nil) and (frmOrders.TheCurrentView.EventDelay.PtEventIFN>0) and IsCompletedPtEvt(frmOrders.TheCurrentView.EventDelay.PtEventIFN) then
1624 begin
1625// theGrpName := 'Delayed ' + frmOrders.TheCurrentView.EventDelay.EventName; <-- original line. //kt 8/8/2007
1626 theGrpName := DKLangConstW('fODBase_Delayed') + frmOrders.TheCurrentView.EventDelay.EventName; //kt added 8/8/2007
1627 SaveAsCurrent := True;
1628 end;
1629 end;
1630 if ValidSave then
1631 begin
1632 FAcceptOK := True;
1633 CIDCOkToSave := True;
1634 with Responses do
1635 if not FAutoAccept and (CopyOrder = '') and (EditOrder = '') and (TransferOrder = '')
1636 and AskAnotherOrder(DialogIEN)
1637 then InitDialog // ClearDialogControls is in InitDialog
1638 else
1639 begin
1640 ClearDialogControls; // to allow form to close without prompting to save order
1641 Close;
1642 alreadyClosed := True;
1643 end;
1644 if NoFresh then
1645 begin
1646 if SaveAsCurrent then
1647 begin
1648 SaveAsCurrent := False;
1649 with Responses do
1650 begin
1651 if not alreadyClosed then
1652 begin
1653 ClearDialogControls;
1654 Close;
1655 end;
1656 end;
1657 frmOrders.GroupChangesUpdate(theGrpName);
1658 Exit;
1659 end;
1660 end else
1661 begin
1662 if SaveAsCurrent then
1663 begin
1664 SaveAsCurrent := False;
1665 with Responses do
1666 begin
1667 if not alreadyClosed then
1668 begin
1669 ClearDialogControls;
1670 Close;
1671 end;
1672 end;
1673 frmOrders.GroupChangesUpdate(theGrpName);
1674 //EDONeedRefresh := True;
1675 Exit;
1676 end;
1677 end
1678 end; {if ValidSave}
1679 if SaveAsCurrent then
1680 SaveAsCurrent := False;
1681end;
1682
1683procedure TfrmODBase.cmdQuitClick(Sender: TObject);
1684begin
1685 inherited;
1686 Close;
1687end;
1688
1689procedure TfrmODBase.FormClose(Sender: TObject; var Action: TCloseAction);
1690begin
1691 SetupVars; //kt added 8/8/2007 to replace constants with vars.
1692 inherited;
1693 // unlock an order that is being edited if accept wasn't pressed
1694 // this unlock is currently done in ActivateOrderDialog
1695 //with Responses do if (Length(EditOrder) > 0) and (not FAcceptOK) then UnlockOrder(EditOrder);
1696 PopKeyVars;
1697 SaveUserBounds(Self);
1698 FClosing := True;
1699 Action := caFree;
1700 (*
1701 if User.NoOrdering then Exit;
1702 if Length(memOrder.Text) > 0 then
1703 if InfoBox(TX_ACCEPT + memOrder.Text, TX_ACCEPT_CAP, MB_YESNO) = ID_YES then
1704 if not ValidSave then
1705 begin
1706 FClosing := False;
1707 Action := caNone;
1708 end;
1709 *)
1710end;
1711
1712procedure TfrmODBase.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
1713begin
1714 SetupVars; //kt added 8/8/2007 to replace constants with vars.
1715 inherited;
1716 //self.Responses.Cancel := False;
1717 if User.NoOrdering then Exit;
1718 if FAbortOrder then exit;
1719 if FOrderAction in [ORDER_EDIT, ORDER_COPY] then Exit; // don't invoke verify dialog
1720 if FOrderAction = ORDER_QUICK then Exit; // should this be here??
1721 if frmFrame.ContextChanging then
1722 begin
1723 // close any sub-dialogs created by order dialog FIRST!!
1724 exit;
1725 end;
1726 if Length(memOrder.Text) > 0 then
1727 begin
1728 if InfoBox(TX_ACCEPT + memOrder.Text, TX_ACCEPT_CAP, MB_YESNO) = ID_YES
1729 then CanClose := ValidSave
1730 else memOrder.Text := ''; // so don't return False on subsequent CloseQuery
1731 end;
1732end;
1733
1734procedure TfrmODBase.TabClose(var CanClose: Boolean);
1735begin
1736 SetupVars; //kt added 8/8/2007 to replace constants with vars.
1737 inherited;
1738 CanClose := True;
1739 if Length(memOrder.Text) > 0 then
1740 if InfoBox(TX_ACCEPT + memOrder.Text, TX_ACCEPT_CAP, MB_YESNO) = ID_YES then
1741 if not ValidSave then CanClose := False;
1742 if CanClose then InitDialog;
1743end;
1744
1745procedure TfrmODBase.memMessageMouseUp(Sender: TObject;
1746 Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
1747begin
1748 inherited;
1749 ShowOrderMessage( False );
1750end;
1751
1752procedure TfrmODBase.SetDefaultCoPay(AnOrderID: string);
1753begin
1754 FDfltCopay := GetDefaultCopay(AnOrderID);
1755end;
1756
1757procedure TfrmODBase.DoSetFontSize( FontSize: integer);
1758begin
1759 if AutoSizeDisabled then
1760 ResizeAnchoredFormToFont( Self )
1761 else
1762 begin
1763 //You get to resize the window yourself!
1764 Font.Size := FontSize;
1765 memMessage.DefAttributes.Size := FontSize;
1766 end;
1767end;
1768
1769procedure TfrmODBase.SetFontSize( FontSize: integer);
1770begin
1771 DoSetFontSize( FontSize );
1772end;
1773
1774function TResponses.GetIENForPrompt(const APromptID: string): Integer;
1775var
1776 i: Integer;
1777begin
1778 Result := 0;
1779 with FPrompts do for i := 0 to Count - 1 do with TPrompt(Items[i]) do
1780 if (ID = APromptID) then
1781 begin
1782 Result := IEN;
1783 break;
1784 end;
1785end;
1786
1787procedure TfrmODBase.pnlMessageExit(Sender: TObject);
1788begin
1789 inherited;
1790 ShowOrderMessage(False);
1791end;
1792
1793procedure TfrmODBase.pnlMessageMouseDown(Sender: TObject;
1794 Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
1795begin
1796 inherited;
1797 FMessageClickX := X;
1798 FMessageClickY := Y;
1799end;
1800
1801procedure TfrmODBase.pnlMessageMouseMove(Sender: TObject;
1802 Shift: TShiftState; X, Y: Integer);
1803begin
1804 inherited;
1805 if (ssLeft in Shift) then
1806 pnlMessage.SetBounds(pnlMessage.Left + X - FMessageClickX, pnlMessage.Top + Y - FMessageClickY, pnlMessage.Width, pnlMessage.Height);
1807end;
1808
1809function TfrmODBase.LESValidationCheck: boolean;
1810var
1811 idx: integer;
1812 LESGrpList,LESRejectedReason: TStringList;
1813 IsLESOrder: boolean;
1814 TempMSG,LESODInfo: string;
1815begin
1816 Result := True;
1817 if Length(Responses.EditOrder)>1 then
1818 begin
1819 LESGrpList := TStringList.Create;
1820 PiecesToList(GetDispGroupForLES,'^',LESGrpList);
1821 IsLESOrder := False;
1822 for idx:=0 to LESGrpList.Count - 1 do
1823 if StrToIntDef(LESGrpList[idx],0) = Responses.DisplayGroup then
1824 begin
1825 IsLESOrder := True;
1826 Break;
1827 end;
1828 if IsLESOrder then
1829 begin
1830 TempMSG := '';
1831 LESODInfo := Patient.DFN +
1832 '^' + Responses.IValueFor('ORDERABLE',1) +
1833 '^' + IntToStr(Encounter.Location) +
1834 '^' + IntToStr(Encounter.Provider) +
1835 '^' + Responses.IValueFor('START',1);
1836 LESRejectedReason := TStringList.Create;
1837 LESValidationForChangedLabOrder(LESRejectedReason,LESODInfo);
1838 if LESRejectedReason.Count > 0 then
1839 begin
1840 for idx := 0 to LESRejectedReason.Count - 1 do
1841 begin
1842 if Length(LESRejectedReason[idx])>0 then
1843 TempMSG := TempMSG + #13 + LESRejectedReason[idx];
1844 end;
1845 if Length(TempMSG)>0 then
1846 begin
1847 ShowMessage(TempMSG);
1848 Result := False;
1849 end;
1850 end;
1851 end;
1852 end;
1853end;
1854
1855
1856end.
1857
Note: See TracBrowser for help on using the repository browser.