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

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

Initial upload of TMG-CPRS 1.0.26.69

File size: 67.5 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 //kt note: A better solution to the line above would be to trigger a selection
1267 //kt of a valid patient at this point, if I could figure out how to do that...
1268 x := OrderChecksOnDisplay(FillerID); //kt <-- Expects Patient.DFN to hold valid number...
1269 StatusText('');
1270 if Length(x) > 0 then InfoBox(x, TC_ORDERCHECKS, MB_OK);
1271 end;
1272end;
1273
1274{ Protected Calls (used by descendant forms) }
1275
1276procedure TfrmODBase.InitDialog;
1277begin
1278 ClearDialogControls;
1279 Responses.Clear;
1280 FAcceptOK := False;
1281 FAbortOrder := False;
1282end;
1283
1284function TfrmODBase.OrderForInpatient: Boolean;
1285var
1286 AnEventType: Char;
1287begin
1288 AnEventType := OrderEventTypeOnCreate;
1289 // if event type = #0, then it wasn't passed or we're not in create
1290 if AnEventType = #0 then AnEventType := Responses.FEventType;
1291 case AnEventType of
1292 'A','O': Result := True;
1293 'D': Result := False;
1294 'T':
1295 begin
1296 if IsPassEvt1(FEvtID,'T') then Result := False
1297 else Result := True;
1298 end
1299 else Result := Patient.Inpatient;
1300 end;
1301end;
1302
1303procedure TfrmODBase.ShowOrderMessage(Show: boolean);
1304begin
1305 if Show then
1306 begin
1307 pnlMessage.Visible := True;
1308 pnlMessage.BringToFront;
1309 memMessage.TabStop := True;
1310 end
1311 else
1312 begin
1313 pnlMessage.Visible := False;
1314 pnlMessage.SendToBack;
1315 memMessage.TabStop := False;
1316 end;
1317end;
1318
1319procedure TfrmODBase.OrderMessage(const AMessage: string);
1320{Caller needs to set pnlMessage.TabOrder}
1321begin
1322 memMessage.Lines.SetText(PChar(AMessage));
1323 //begin CQ: 2640
1324 memMessage.SelStart := 0; // Put at first character
1325 SendMessage(memMessage.Handle, WM_VSCROLL, SB_TOP, 0);
1326 //End CQ: 2640
1327 ShowOrderMessage(ContainsVisibleChar(AMessage));
1328end;
1329
1330procedure TfrmODBase.PreserveControl(AControl: TControl);
1331begin
1332 FPreserve.Add(AControl);
1333end;
1334
1335procedure TfrmODBase.SetDialogIEN(Value: Integer);
1336begin
1337 FDialogIEN := Value;
1338end;
1339
1340procedure TfrmODBase.SetupDialog(OrderAction: Integer; const ID: string);
1341begin
1342 FOrderAction := OrderAction;
1343 FAbortOrder := False;
1344 case OrderAction of
1345 ORDER_NEW: {nothing};
1346 ORDER_EDIT: Responses.SetEditOrder(ID);
1347 ORDER_COPY: Responses.SetCopyOrder(ID);
1348 ORDER_QUICK: Responses.SetQuickOrderByID(ID);
1349 end;
1350//if Responses.FEventType in ['A','D','T','M','O'] then Caption := Caption + ' (Delayed ' + Responses.FEventName + ')'; // ' (Event Delayed)'; <-- original line. //kt 8/8/2007
1351 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
1352//if OrderAction in [ORDER_EDIT, ORDER_COPY] then cmdQuit.Caption := 'Cancel'; <-- original line. //kt 8/8/2007
1353 if OrderAction in [ORDER_EDIT, ORDER_COPY] then cmdQuit.Caption := DKLangConstW('fODBase_Cancel'); //kt added 8/8/2007
1354end;
1355
1356function TfrmODBase.GetEffectiveDate: TFMDateTime;
1357begin
1358 Result := Responses.FEffective;
1359end;
1360
1361function TfrmODBase.GetKeyVariable(const Index: string): string;
1362begin
1363 if UpperCase(Index) = 'LRFZX' then Result := Piece(FKeyVariables, U, 1)
1364 else if UpperCase(Index) = 'LRFSAMP' then Result := Piece(FKeyVariables, U, 2)
1365 else if UpperCase(Index) = 'LRFSPEC' then Result := Piece(FKeyVariables, U, 3)
1366 else if UpperCase(Index) = 'LRFDATE' then Result := Piece(FKeyVariables, U, 4)
1367 else if UpperCase(Index) = 'LRFURG' then Result := Piece(FKeyVariables, U, 5)
1368 else if UpperCase(Index) = 'LRFSCH' then Result := Piece(FKeyVariables, U, 6)
1369 else if UpperCase(Index) = 'PSJNOPC' then Result := Piece(FKeyVariables, U, 7)
1370 else if UpperCase(Index) = 'GMRCNOPD' then Result := Piece(FKeyVariables, U, 8)
1371 else if UpperCase(Index) = 'GMRCNOAT' then Result := Piece(FKeyVariables, U, 9)
1372 else if UpperCase(Index) = 'GMRCREAF' then Result := Piece(FKeyVariables, U, 10)
1373 else Result := '';
1374end;
1375
1376procedure TfrmODBase.SetKeyVariables(const VarStr: string);
1377begin
1378 FKeyVariables := VarStr;
1379end;
1380
1381procedure TfrmODBase.Validate(var AnErrMsg: string);
1382//const
1383//TX_OR_DISABLED = 'Ordering has been disabled. Press Quit.'; <-- original line. //kt 8/8/2007
1384//TX_PAST_START = 'The start date may not be earlier than the present.'; <-- original line. //kt 8/8/2007
1385//TX_NO_LOCATION = 'A location must be identified.' + CRLF + <-- original line. //kt 8/8/2007
1386// '(Select File | Update Provider/Location)'; <-- original line. //kt 8/8/2007
1387//TX_NO_PROVIDER = 'A provider who is authorized to write orders must be indentified.' + CRLF + <-- original line. //kt 8/8/2007
1388// '(Select File | Update Provider/Location)'; <-- original line. //kt 8/8/2007
1389var
1390 StartStr,x: string;
1391 StartDt: TFMDateTime;
1392 TX_OR_DISABLED : string; //kt
1393 TX_PAST_START : string; //kt
1394 TX_NO_LOCATION : string; //kt
1395 TX_NO_PROVIDER : string; //kt
1396
1397begin
1398 TX_OR_DISABLED := DKLangConstW('fODBase_Ordering_has_been_disabledx__Press_Quitx'); //kt added 8/8/2007
1399 TX_PAST_START := DKLangConstW('fODBase_The_start_date_may_not_be_earlier_than_the_presentx'); //kt added 8/8/2007
1400 TX_NO_LOCATION := DKLangConstW('fODBase_A_location_must_be_identifiedx') + CRLF + //kt added 8/8/2007
1401 DKLangConstW('fODBase_xSelect_File_x_Update_ProviderxLocationx'); //kt added 8/8/2007
1402 TX_NO_PROVIDER := DKLangConstW('fODBase_A_provider_who_is_authorized_to_write_orders_must_be_indentifiedx') + CRLF + //kt added 8/8/2007
1403 DKLangConstW('fODBase_xSelect_File_x_Update_ProviderxLocationx'); //kt added 8/8/2007
1404
1405 AnErrMsg := '';
1406//if User.NoOrdering then AnErrMsg := 'Ordering has been disabled. Press Quit.'; <-- original line. //kt 8/8/2007
1407 if User.NoOrdering then AnErrMsg := DKLangConstW('fODBase_Ordering_has_been_disabledx__Press_Quitx'); //kt added 8/8/2007
1408 // take this out if we <don't> need to check for earlier start date/times
1409 // should this check be against FMNow??
1410 StartStr := Piece(Responses.IValueFor('START', 1), '.', 1);
1411 if not IsFMDateTime(StartStr)
1412 then StartDt := StrToFMDateTime(StartStr)
1413 else StartDt := StrToFloat(StartStr);
1414 if (StartDt > 0) and (StartDt < FMToday)
1415// then AnErrMsg := 'The start date may not be earlier than the present.'; <-- original line. //kt 8/8/2007
1416 then AnErrMsg := DKLangConstW('fODBase_The_start_date_may_not_be_earlier_than_the_presentx'); //kt added 8/8/2007
1417 //frmFrame.UpdatePtInfoOnRefresh;
1418 if (not Patient.Inpatient) and (Responses.EventIFN > 0) then x := ''
1419 else
1420 begin
1421 if Encounter.Location = 0 then AnErrMsg := TX_NO_LOCATION;
1422 end;
1423 if (Encounter.Provider = 0) or (PersonHasKey(Encounter.Provider, 'PROVIDER') = False)
1424 then AnErrMsg := TX_NO_PROVIDER;
1425 if IsPFSSActive and Responses.PromptExists('VISITSTR') then
1426 Responses.Update('VISITSTR', 1, Encounter.VisitStr, Encounter.VisitStr);
1427end;
1428
1429{ Form Calls }
1430
1431procedure TfrmODBase.FormCreate(Sender: TObject);
1432begin
1433 inherited;
1434 memOrder.Color := ReadOnlyColor;
1435 FAcceptOK := False;
1436 FAutoAccept := False;
1437 FChanging := False;
1438 FClosing := False;
1439 FFromQuit := False;
1440 FTestMode := False;
1441 FIncludeOIPI := True;
1442 FEvtForPassDischarge := #0;
1443 FCtrlInits := TCtrlInits.Create;
1444 FResponses := TResponses.Create;
1445 FPreserve := TList.Create;
1446 FIsIMO := False; //imo
1447 FIsSupply := False;
1448 {This next bit is mostly for the font size. It also sets the default size of
1449 order forms if it is not in the database. This is handy if a new user wants
1450 to have large fonts. However, in the general case, this will be resized
1451 through rMisc.SetFormPosition.}
1452 if not AutoSizeDisabled then
1453 ResizeFormToFont(self);
1454 DoSetFontSize(MainFontSize);
1455
1456 imgMessage.Picture.Icon.Handle := LoadIcon(0, IDI_ASTERISK);
1457 //if User.NoOrdering then cmdAccept.Enabled := False;
1458 if uCore.User.NoOrdering then cmdAccept.Enabled := False;
1459 FDlgFormID := OrderFormIDOnCreate;
1460 FEvtID := OrderEventIDOnCreate;
1461 FEvtType := OrderEventTypeOnCreate;
1462 FEvtName := OrderEventNameOnCreate;
1463end;
1464
1465procedure TfrmODBase.FormDestroy(Sender: TObject);
1466begin
1467 FCtrlInits.Free;
1468 FResponses.Free;
1469 FPreserve.Free;
1470 //DestroyingOrderDialog;
1471 if Assigned(FCallOnExit) then FCallOnExit;
1472 if (Owner <> nil) and (Owner is TWinControl)
1473 then SendMessage(TWinControl(Owner).Handle, UM_DESTROY, FRefNum, 0);
1474 inherited;
1475end;
1476
1477procedure TfrmODBase.FormKeyPress(Sender: TObject; var Key: Char);
1478{ causes RETURN to be treated as pressing a tab key (need to have user preference) }
1479begin
1480 inherited;
1481 if (Key = #13) and not (ActiveControl is TCustomMemo) then
1482 begin
1483 Key := #0;
1484 Perform(WM_NEXTDLGCTL, 0, 0);
1485 end;
1486end;
1487
1488{ Accept & Quit Buttons }
1489
1490function TfrmODBase.AcceptOrderChecks: Boolean;
1491{ returns True if order was accepted with order checks, false if order should be cancelled }
1492var
1493 StartDtTm: string;
1494 OIList: TStringList;
1495begin
1496 Result := True;
1497 Responses.OrderChecks.Clear;
1498 if not OrderChecksEnabled then Exit;
1499 OIList := TStringList.Create;
1500 try
1501// StatusText('Order Checking...'); <-- original line. //kt 8/8/2007
1502 StatusText(DKLangConstW('fODBase_Order_Checkingxxx')); //kt added 8/8/2007
1503 Responses.BuildOCItems(OIList, StartDtTm, FillerID);
1504 OrderChecksOnAccept(Responses.OrderChecks, FillerID, StartDtTm, OIList, DupORIFN);
1505 DupORIFN := '';
1506 StatusText('');
1507 Result := AcceptOrderWithChecks(Responses.OrderChecks);
1508 finally
1509 OIList.Free;
1510 end;
1511end;
1512
1513function TfrmODBase.ValidSave: Boolean;
1514//const
1515//TX_NO_SAVE = 'This order cannot be saved for the following reason(s):' + CRLF + CRLF; <-- original line. //kt 8/8/2007
1516//TX_NO_SAVE_CAP = 'Unable to Save Order'; <-- original line. //kt 8/8/2007
1517//TX_SAVE_ERR = 'Unexpected error - it was not possible to save this order.'; <-- original line. //kt 8/8/2007
1518var
1519 ErrMsg: string;
1520 NewOrder: TOrder;
1521 CanSign, OrderAction: Integer;
1522 //thisSourceOrder: TOrder;
1523 TX_NO_SAVE : string; //kt
1524 TX_NO_SAVE_CAP : string; //kt
1525 TX_SAVE_ERR : string; //kt
1526begin
1527 TX_NO_SAVE := DKLangConstW('fODBase_This_order_cannot_be_saved_for_the_following_reasonxsxx') + CRLF + CRLF; //kt added 8/8/2007
1528 TX_NO_SAVE_CAP := DKLangConstW('fODBase_Unable_to_Save_Order'); //kt added 8/8/2007
1529 TX_SAVE_ERR := DKLangConstW('fODBase_Unexpected_error_x_it_was_not_possible_to_save_this_orderx'); //kt added 8/8/2007
1530 Result := True;
1531 Validate(ErrMsg);
1532 if Length(ErrMsg) > 0 then
1533 begin
1534 InfoBox(TX_NO_SAVE + ErrMsg, TX_NO_SAVE_CAP, MB_OK);
1535 Result := False;
1536 Exit;
1537 end;
1538 if not AcceptOrderChecks then
1539 begin
1540 if AskAnotherOrder(DialogIEN) then
1541 InitDialog // ClearDialogControls is in InitDialog
1542 else
1543 begin
1544 ClearDialogControls; // to allow form to close without prompting to save order
1545 Close;
1546 end;
1547 Result := False;
1548 Exit;
1549 end;
1550 if FTestMode then
1551 begin
1552 Result := False;
1553 Exit;
1554 end;
1555 // LES validation checking for changed lab order
1556 if not LESValidationCheck then Exit;
1557 NewOrder := TOrder.Create;
1558
1559 Responses.SaveOrder(NewOrder, DialogIEN, FIsIMO);
1560
1561 if frmOrders.IsDefaultDlg then
1562 begin
1563 frmOrders.EventDefaultOrder := NewOrder.ID;
1564 frmOrders.EvtOrderList.Add(NewOrder.EventPtr + '^' + NewOrder.ID);
1565 frmOrders.IsDefaultDlg := False;
1566 end;
1567 if Length(DfltCopay)>0 then SetDefaultCoPayToNewOrder(NewOrder.ID, DfltCopay);
1568 if (Length(FEvtName)>0) then
1569 begin
1570// NewOrder.EventName := 'Delayed ' + MixedCase(FEvtName); <-- original line. //kt 8/8/2007
1571 NewOrder.EventName := DKLangConstW('fODBase_Delayed') + MixedCase(FEvtName); //kt added 8/8/2007
1572 FEvtName := '';
1573 end;
1574 if not ProcessOrderAcceptEventHook(NewOrder.ID, NewOrder.DGroup) then
1575 begin
1576 if NewOrder.ID <> '' then
1577 begin
1578 if (Encounter.Provider = User.DUZ) and User.CanSignOrders
1579 then CanSign := CH_SIGN_YES
1580 else CanSign := CH_SIGN_NA;
1581 if NewOrder.Signature = OSS_NOT_REQUIRE then CanSign := CH_SIGN_NA;
1582 Changes.Add(CH_ORD, NewOrder.ID, NewOrder.Text, Responses.FViewName, CanSign);
1583
1584 UBAGlobals.TargetOrderID := NewOrder.ID;
1585
1586 if Responses.EditOrder = '' then OrderAction := ORDER_NEW else OrderAction := ORDER_EDIT;
1587 SendMessage(Application.MainForm.Handle, UM_NEWORDER, OrderAction, Integer(NewOrder));
1588 end
1589 else InfoBox(TX_SAVE_ERR, TX_NO_SAVE_CAP, MB_OK);
1590 end;
1591 NewOrder.Free; // free here - recieving forms should get own copy using assign
1592end;
1593
1594procedure TfrmODBase.cmdAcceptClick(Sender: TObject);
1595//const
1596//TX_CMPTEVT = ' occurred since you started writing delayed orders. ' <-- original line. //kt 8/8/2007
1597// + 'The orders that were entered and signed have now been released. ' <-- original line. //kt 8/8/2007
1598// + 'Any unsigned orders will be released immediately upon signature. ' <-- original line. //kt 8/8/2007
1599// + '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
1600// + 'Orders delayed to this same event will remain delayed until the event occurs again.' <-- original line. //kt 8/8/2007
1601// + 'The Orders tab will now be refreshed and switched to the Active Orders view. ' <-- original line. //kt 8/8/2007
1602// + 'If you wish to continue to write active orders for this patient, ' <-- original line. //kt 8/8/2007
1603// + 'close this message window and continue as usual.'; <-- original line. //kt 8/8/2007
1604var
1605 theGrpName: string;
1606 alreadyClosed: boolean;
1607 TX_CMPTEVT : string; //kt
1608begin
1609 TX_CMPTEVT := DKLangConstW('fODBase_occurred_since_you_started_writing_delayed_ordersx') //kt added 8/8/2007
1610 + DKLangConstW('fODBase_The_orders_that_were_entered_and_signed_have_now_been_releasedx') //kt added 8/8/2007
1611 + DKLangConstW('fODBase_Any_unsigned_orders_will_be_released_immediately_upon_signaturex') //kt added 8/8/2007
1612 + #13#13
1613 + 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
1614 + DKLangConstW('fODBase_Orders_delayed_to_this_same_event_will_remain_delayed_until_the_event_occurs_againx') //kt added 8/8/2007
1615 + #13#13
1616 + DKLangConstW('fODBase_The_Orders_tab_will_now_be_refreshed_and_switched_to_the_Active_Orders_viewx') //kt added 8/8/2007
1617 + DKLangConstW('fODBase_If_you_wish_to_continue_to_write_active_orders_for_this_patientx') //kt added 8/8/2007
1618 + DKLangConstW('fODBase_close_this_message_window_and_continue_as_usualx'); //kt added 8/8/2007
1619 FAcceptOK := False;
1620 CIDCOkToSave := False;
1621 alreadyClosed := False;
1622 self.Responses.Cancel := False;
1623 if frmOrders <> nil then
1624 begin
1625 if (frmOrders.TheCurrentView <> nil) and (frmOrders.TheCurrentView.EventDelay.PtEventIFN>0) and IsCompletedPtEvt(frmOrders.TheCurrentView.EventDelay.PtEventIFN) then
1626 begin
1627// theGrpName := 'Delayed ' + frmOrders.TheCurrentView.EventDelay.EventName; <-- original line. //kt 8/8/2007
1628 theGrpName := DKLangConstW('fODBase_Delayed') + frmOrders.TheCurrentView.EventDelay.EventName; //kt added 8/8/2007
1629 SaveAsCurrent := True;
1630 end;
1631 end;
1632 if ValidSave then
1633 begin
1634 FAcceptOK := True;
1635 CIDCOkToSave := True;
1636 with Responses do
1637 if not FAutoAccept and (CopyOrder = '') and (EditOrder = '') and (TransferOrder = '')
1638 and AskAnotherOrder(DialogIEN)
1639 then InitDialog // ClearDialogControls is in InitDialog
1640 else
1641 begin
1642 ClearDialogControls; // to allow form to close without prompting to save order
1643 Close;
1644 alreadyClosed := True;
1645 end;
1646 if NoFresh then
1647 begin
1648 if SaveAsCurrent then
1649 begin
1650 SaveAsCurrent := False;
1651 with Responses do
1652 begin
1653 if not alreadyClosed then
1654 begin
1655 ClearDialogControls;
1656 Close;
1657 end;
1658 end;
1659 frmOrders.GroupChangesUpdate(theGrpName);
1660 Exit;
1661 end;
1662 end else
1663 begin
1664 if SaveAsCurrent then
1665 begin
1666 SaveAsCurrent := False;
1667 with Responses do
1668 begin
1669 if not alreadyClosed then
1670 begin
1671 ClearDialogControls;
1672 Close;
1673 end;
1674 end;
1675 frmOrders.GroupChangesUpdate(theGrpName);
1676 //EDONeedRefresh := True;
1677 Exit;
1678 end;
1679 end
1680 end; {if ValidSave}
1681 if SaveAsCurrent then
1682 SaveAsCurrent := False;
1683end;
1684
1685procedure TfrmODBase.cmdQuitClick(Sender: TObject);
1686begin
1687 inherited;
1688 Close;
1689end;
1690
1691procedure TfrmODBase.FormClose(Sender: TObject; var Action: TCloseAction);
1692begin
1693 SetupVars; //kt added 8/8/2007 to replace constants with vars.
1694 inherited;
1695 // unlock an order that is being edited if accept wasn't pressed
1696 // this unlock is currently done in ActivateOrderDialog
1697 //with Responses do if (Length(EditOrder) > 0) and (not FAcceptOK) then UnlockOrder(EditOrder);
1698 PopKeyVars;
1699 SaveUserBounds(Self);
1700 FClosing := True;
1701 Action := caFree;
1702 (*
1703 if User.NoOrdering then Exit;
1704 if Length(memOrder.Text) > 0 then
1705 if InfoBox(TX_ACCEPT + memOrder.Text, TX_ACCEPT_CAP, MB_YESNO) = ID_YES then
1706 if not ValidSave then
1707 begin
1708 FClosing := False;
1709 Action := caNone;
1710 end;
1711 *)
1712end;
1713
1714procedure TfrmODBase.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
1715begin
1716 SetupVars; //kt added 8/8/2007 to replace constants with vars.
1717 inherited;
1718 //self.Responses.Cancel := False;
1719 if User.NoOrdering then Exit;
1720 if FAbortOrder then exit;
1721 if FOrderAction in [ORDER_EDIT, ORDER_COPY] then Exit; // don't invoke verify dialog
1722 if FOrderAction = ORDER_QUICK then Exit; // should this be here??
1723 if frmFrame.ContextChanging then
1724 begin
1725 // close any sub-dialogs created by order dialog FIRST!!
1726 exit;
1727 end;
1728 if Length(memOrder.Text) > 0 then
1729 begin
1730 if InfoBox(TX_ACCEPT + memOrder.Text, TX_ACCEPT_CAP, MB_YESNO) = ID_YES
1731 then CanClose := ValidSave
1732 else memOrder.Text := ''; // so don't return False on subsequent CloseQuery
1733 end;
1734end;
1735
1736procedure TfrmODBase.TabClose(var CanClose: Boolean);
1737begin
1738 SetupVars; //kt added 8/8/2007 to replace constants with vars.
1739 inherited;
1740 CanClose := True;
1741 if Length(memOrder.Text) > 0 then
1742 if InfoBox(TX_ACCEPT + memOrder.Text, TX_ACCEPT_CAP, MB_YESNO) = ID_YES then
1743 if not ValidSave then CanClose := False;
1744 if CanClose then InitDialog;
1745end;
1746
1747procedure TfrmODBase.memMessageMouseUp(Sender: TObject;
1748 Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
1749begin
1750 inherited;
1751 ShowOrderMessage( False );
1752end;
1753
1754procedure TfrmODBase.SetDefaultCoPay(AnOrderID: string);
1755begin
1756 FDfltCopay := GetDefaultCopay(AnOrderID);
1757end;
1758
1759procedure TfrmODBase.DoSetFontSize( FontSize: integer);
1760begin
1761 if AutoSizeDisabled then
1762 ResizeAnchoredFormToFont( Self )
1763 else
1764 begin
1765 //You get to resize the window yourself!
1766 Font.Size := FontSize;
1767 memMessage.DefAttributes.Size := FontSize;
1768 end;
1769end;
1770
1771procedure TfrmODBase.SetFontSize( FontSize: integer);
1772begin
1773 DoSetFontSize( FontSize );
1774end;
1775
1776function TResponses.GetIENForPrompt(const APromptID: string): Integer;
1777var
1778 i: Integer;
1779begin
1780 Result := 0;
1781 with FPrompts do for i := 0 to Count - 1 do with TPrompt(Items[i]) do
1782 if (ID = APromptID) then
1783 begin
1784 Result := IEN;
1785 break;
1786 end;
1787end;
1788
1789procedure TfrmODBase.pnlMessageExit(Sender: TObject);
1790begin
1791 inherited;
1792 ShowOrderMessage(False);
1793end;
1794
1795procedure TfrmODBase.pnlMessageMouseDown(Sender: TObject;
1796 Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
1797begin
1798 inherited;
1799 FMessageClickX := X;
1800 FMessageClickY := Y;
1801end;
1802
1803procedure TfrmODBase.pnlMessageMouseMove(Sender: TObject;
1804 Shift: TShiftState; X, Y: Integer);
1805begin
1806 inherited;
1807 if (ssLeft in Shift) then
1808 pnlMessage.SetBounds(pnlMessage.Left + X - FMessageClickX, pnlMessage.Top + Y - FMessageClickY, pnlMessage.Width, pnlMessage.Height);
1809end;
1810
1811function TfrmODBase.LESValidationCheck: boolean;
1812var
1813 idx: integer;
1814 LESGrpList,LESRejectedReason: TStringList;
1815 IsLESOrder: boolean;
1816 TempMSG,LESODInfo: string;
1817begin
1818 Result := True;
1819 if Length(Responses.EditOrder)>1 then
1820 begin
1821 LESGrpList := TStringList.Create;
1822 PiecesToList(GetDispGroupForLES,'^',LESGrpList);
1823 IsLESOrder := False;
1824 for idx:=0 to LESGrpList.Count - 1 do
1825 if StrToIntDef(LESGrpList[idx],0) = Responses.DisplayGroup then
1826 begin
1827 IsLESOrder := True;
1828 Break;
1829 end;
1830 if IsLESOrder then
1831 begin
1832 TempMSG := '';
1833 LESODInfo := Patient.DFN +
1834 '^' + Responses.IValueFor('ORDERABLE',1) +
1835 '^' + IntToStr(Encounter.Location) +
1836 '^' + IntToStr(Encounter.Provider) +
1837 '^' + Responses.IValueFor('START',1);
1838 LESRejectedReason := TStringList.Create;
1839 LESValidationForChangedLabOrder(LESRejectedReason,LESODInfo);
1840 if LESRejectedReason.Count > 0 then
1841 begin
1842 for idx := 0 to LESRejectedReason.Count - 1 do
1843 begin
1844 if Length(LESRejectedReason[idx])>0 then
1845 TempMSG := TempMSG + #13 + LESRejectedReason[idx];
1846 end;
1847 if Length(TempMSG)>0 then
1848 begin
1849 ShowMessage(TempMSG);
1850 Result := False;
1851 end;
1852 end;
1853 end;
1854 end;
1855end;
1856
1857
1858end.
1859
Note: See TracBrowser for help on using the repository browser.