source: cprs/trunk/CPRS-Chart/Orders/fODBase.pas@ 830

Last change on this file since 830 was 829, checked in by Kevin Toppenberg, 14 years ago

Upgrade to version 27

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