source: cprs/branches/foia-cprs/CPRS-Chart/Orders/fODBase.pas@ 459

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

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