Module

fODBase

Path

C:\CPRS\CPRS30\Orders\fODBase.pas

Last Modified

7/15/2014 3:26:40 PM

Comments

REMOVE AFTER UNIT IS DEBUGGED

Units Used in Interface

Name Comments
fAutoSz -
rODBase -
rOrders -
UBACore -
UBAGlobals -
uConst -
uCore -

Units Used in Implementation

Name Comments
fClinicWardMeds -
fFrame -
fOCAccept -
fODDietLT -
fODMessage -
fOrders -
fTemplateDialog -
rConsults -
rCore -
rMisc -
rODDiet -
uEventHooks -
uODBase -
uOrders -
uTemplateFields -
uTemplates -

Classes

Name Comments
TCtrlInit -
TCtrlInits -
TfrmODBase -
TResponses -

Procedures

Name Owner Declaration Scope Comments
AppendChildren TResponses procedure AppendChildren(var ParentText: string; ChildPrompts: string; AnInstance: Integer); Private -
AssignBPText - procedure AssignBPText(List: TStrings; const Value: string); Local -
BuildOCItems TResponses procedure BuildOCItems(AList: TStringList; var AStartDtTm: string; const AFillerID: string); Private -
Clear TResponses procedure Clear(const APromptID: string; SaveInstance: Integer = 0); overload; Public -
Clear TResponses procedure Clear; overload; Public Clears all information in the response multiple
ClearControl - procedure ClearControl(AControl: TControl); Interfaced
Procedures shared with descendent forms 

 clears a control, removes text and listbox items
ClearDialogControls TfrmODBase procedure ClearDialogControls; Private Private calls
ClearOI TCtrlInits procedure ClearOI; Public Clears the records in FOIList, but not FDfltList
cmdAcceptClick TfrmODBase procedure cmdAcceptClick(Sender: TObject); Public/Published -
cmdQuitClick TfrmODBase procedure cmdQuitClick(Sender: TObject); Public/Published -
DoSetFontSize TfrmODBase procedure DoSetFontSize( FontSize: integer); Private -
ExtractInits TCtrlInits procedure ExtractInits(Src: TStrings; Dest: TList); Private Load a list with TCtrlInit records (source strings are those passed from server
FormatResponse TResponses procedure FormatResponse(var FormattedText: string; var ExcludeText: Boolean; APrompt: TPrompt; const x: string; AnInstance: Integer); Private -
FormClose TfrmODBase procedure FormClose(Sender: TObject; var Action: TCloseAction); Public/Published -
FormCloseQuery TfrmODBase procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean); Public/Published -
FormCreate TfrmODBase procedure FormCreate(Sender: TObject); Public/Published Form Calls
FormDestroy TfrmODBase procedure FormDestroy(Sender: TObject); Public/Published -
FormKeyPress TfrmODBase procedure FormKeyPress(Sender: TObject; var Key: Char); Public/Published Causes RETURN to be treated as pressing a tab key (need to have user preference)
InitDialog TfrmODBase procedure InitDialog; virtual; Protected Protected Calls (used by descendant forms)
LoadDefaults TCtrlInits procedure LoadDefaults(Src: TStrings); Public Loads control initialization information for the dialog
LoadOrderItem TCtrlInits procedure LoadOrderItem(Src: TStrings); Public Loads control initialization information for the orderable item
memMessageMouseUp TfrmODBase procedure memMessageMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Public/Published -
OrderMessage TfrmODBase procedure OrderMessage(const AMessage: string); Public Caller needs to set pnlMessage.TabOrder
pnlMessageExit TfrmODBase procedure pnlMessageExit(Sender: TObject); Public/Published -
pnlMessageMouseDown TfrmODBase procedure pnlMessageMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Public/Published -
pnlMessageMouseMove TfrmODBase procedure pnlMessageMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); Public/Published -
PreserveControl TfrmODBase procedure PreserveControl(AControl: TControl); Public -
Remove TResponses procedure Remove(const APromptID: string; AnInstance: Integer); Public -
ResetControl - procedure ResetControl(AControl: TControl); Interfaced Clears text, deselects items, does not remove listbox or combobox items
SaveOrder TResponses procedure SaveOrder(var AnOrder: TOrder; DlgIEN: Integer; IsIMOOrder: boolean = False); Public -
SaveQuickOrder TResponses procedure SaveQuickOrder(var ANewIEN: Integer; const ADisplayName: string); Public -
SetControl TCtrlInits procedure SetControl(AControl: TControl; const ASection: string); Public Initializes a control to the information in a section (~section from server)
SetControl TResponses procedure SetControl(AControl: TControl; const APromptID: string; AnInstance: Integer); Public Sets the value of a control, uses ID string & instance to find the right response entry
SetCopyOrder TResponses procedure SetCopyOrder(const AnID: string); Private Sets responses to the values for an order that is created by copying
SetDefaultCoPay TfrmODBase procedure SetDefaultCoPay(AnOrderID: string); Public -
SetDialog TResponses procedure SetDialog(Value: string); Private Loads formatting information for a dialog
SetDialogIEN TfrmODBase procedure SetDialogIEN(Value: Integer); virtual; Protected -
SetDisplayGroup TfrmODBase procedure SetDisplayGroup(Value: Integer); Private -
SetEditOrder TResponses procedure SetEditOrder(const AnID: string); Private Sets responses to the values for an order that is about to be edited
SetEventDelay TResponses procedure SetEventDelay(AnEvent: TOrderDelayEvent); Public -
SetFillerID TfrmODBase procedure SetFillerID(const Value: string); Private -
SetFontSize TfrmODBase procedure SetFontSize( FontSize: integer); virtual; Public -
SetKeyVariables TfrmODBase procedure SetKeyVariables(const VarStr: string); Public -
SetListOnly TCtrlInits procedure SetListOnly(AControl: TControl; const ASection: string); Public Assigns list portion to a control from a section (used to set ShortList for meds)
SetPopupMenu TCtrlInits procedure SetPopupMenu(AMenu: TPopupMenu; AClickEvent: TNotifyEvent; const ASection: string); Public Populates a popup menu with items in a list, leaves the maximum text width in Tag
SetPromptFormat TResponses procedure SetPromptFormat(const APromptID, NewFormat: string); Public -
SetQuickOrder TResponses procedure SetQuickOrder(AnIEN: Integer); Private Sets responses to a quick order value - this is used by the QuickOrder property
SetQuickOrderByID TResponses procedure SetQuickOrderByID(const AnID: string); Private Sets responses to a quick order value
SetupDialog TfrmODBase procedure SetupDialog(OrderAction: Integer; const ID: string); virtual; Public -
ShowOrderMessage TfrmODBase procedure ShowOrderMessage(Show: boolean); Protected -
TabClose TfrmODBase procedure TabClose(var CanClose: Boolean); Public -
Update TResponses procedure Update(const APromptID: string; AnInstance: Integer; const AnIValue, AnEValue: string); Public For a given Prompt,Instance update or create the associated response object
updateSig TfrmODBase procedure updateSig; virtual; Protected -
Validate TfrmODBase procedure Validate(var AnErrMsg: string); virtual; Protected -

Functions

Name Owner Declaration Scope Comments
AcceptOrderChecks TfrmODBase function AcceptOrderChecks: Boolean; Private
Accept & Quit Buttons 

 returns True if order was accepted with order checks, false if order should be cancelled
DefaultText TCtrlInits function DefaultText(const ASection: string): string; Public -
EValueFor TResponses function EValueFor(const APromptID: string; AnInstance: Integer): string; Public -
FindInitByName TCtrlInits function FindInitByName(const AName: string): TCtrlInit; Private Look first in FOIList, then in FDfltList for initial values identified by name (~section)
FindPromptByIEN TResponses function FindPromptByIEN(AnIEN: Integer): TPrompt; Private -
FindResponseByIEN TResponses function FindResponseByIEN(APromptIEN, AnInstance: Integer): TResponse; Private -
FindResponseByName TResponses function FindResponseByName(const APromptID: string; AnInstance: Integer): TResponse; Public -
GetEffectiveDate TfrmODBase function GetEffectiveDate: TFMDateTime; Private -
GetIENForPrompt TResponses function GetIENForPrompt(const APromptID: string): Integer; Public -
GetKeyVariable TfrmODBase function GetKeyVariable(const Index: string): string; Private -
GetOrderText TResponses function GetOrderText: string; Private Loop thru the response objects and build the order text
IENForPrompt TResponses function IENForPrompt(const APromptID: string): Integer; Private -
InstanceCount TResponses function InstanceCount(const APromptID: string): Integer; Public -
IValueFor TResponses function IValueFor(const APromptID: string; AnInstance: Integer): string; Public -
LESValidationCheck TfrmODBase function LESValidationCheck: boolean; Protected -
NextInstance TResponses function NextInstance(const APromptID: string; LastInstance: Integer): Integer; Public -
OrderCRC TResponses function OrderCRC: string; Public -
OrderForInpatient TfrmODBase function OrderForInpatient: Boolean; Public -
PromptExists TResponses function PromptExists(const APromptID: string):boolean; Public -
SortPromptsBySequence - function SortPromptsBySequence(Item1, Item2: Pointer): Integer; Global TResponses methods
TextOf TCtrlInits function TextOf(const ASection: string): string; Public -
ValidSave TfrmODBase function ValidSave: Boolean; Protected ThisSourceOrder: TOrder;

Global Variables

Name Type Declaration Comments
CIDCOkToSave Boolean CIDCOkToSave: boolean; CIDC only, used for consult orders.
DEASig UnicodeString DEASig: string; Digital signature
DupORIFN UnicodeString DupORIFN: string; It's used to identify the order number for duplicate orders in order checking
EventDefaultOD Integer EventDefaultOD: integer = 0; If it's event default dialog?
frmODBase TfrmODBase frmODBase: TfrmODBase = nil; -
ImmdCopyAct Boolean ImmdCopyAct: boolean = False; Immediately release (NO EVENT DELAY)
IsTransferAction Boolean IsTransferAction: boolean = False; -
IsUDGroup Boolean IsUDGroup: boolean = False; It's only used for copy inpatient med order.
NoFresh Boolean NoFresh: boolean = False; EDO use only
OrderSource UnicodeString OrderSource: string = ''; -
SaveAsCurrent Boolean SaveAsCurrent: boolean = False; EDO use only
XferOuttoInOnMeds Boolean XferOuttoInOnMeds : boolean = False;
Immediately release (NO EVENT DELAY)

 it's used only for transfering Outpatient Meds to Inpatient Med for
XfInToOutNow Boolean XfInToOutNow :boolean = False; It's used only for transfering Inpatient Meds to OutPatient Med for

Constants

Name Declaration Scope Comments
TC_ORDERCHECKS 'Order Checks' Global -
TX_ACCEPT 'Accept the following order?' + CRLF + CRLF Global -
TX_ACCEPT_CAP 'Unsaved Order' Global -


Module Source

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

Module Calls (2 levels)


fODBase
 ├fAutoSz
 │ └fBase508Form
 ├uConst
 ├rOrders
 │ ├uCore
 │ ├rCore
 │ ├uConst
 │ ├UBAGlobals
 │ └UBACore
 ├rODBase
 │ ├uCore...
 │ ├uConst
 │ ├rOrders...
 │ ├uOrders
 │ ├uODBase
 │ └fODBase...
 ├uCore...
 ├UBAGlobals...
 ├UBACore...
 ├fOCAccept
 │ ├fAutoSz...
 │ ├rOrders...
 │ └fOCMonograph
 ├uODBase...
 ├rCore...
 ├rMisc
 │ └fOrders
 ├fTemplateDialog
 │ ├uTemplates
 │ ├fBase508Form...
 │ ├uConst
 │ ├dShared
 │ ├uTemplateFields
 │ ├fRptBox
 │ ├uInit
 │ ├rMisc...
 │ └uDlgComponents
 ├uEventHooks
 │ ├CPRSChart_TLB
 │ ├uCore...
 │ └rEventHooks
 ├uTemplates...
 ├rConsults
 │ ├rCore...
 │ ├uCore...
 │ ├uConsults
 │ └uTIU
 ├fOrders...
 ├uOrders...
 ├fFrame
 │ ├fPage
 │ ├uConst
 │ ├VERGENCECONTEXTORLib_TLB
 │ ├fBase508Form...
 │ ├XuDsigS
 │ ├rCore...
 │ ├fPtSelMsg
 │ ├fPtSel
 │ ├fCover
 │ ├fProbs
 │ ├fMeds
 │ ├fOrders...
 │ ├rOrders...
 │ ├fNotes
 │ ├fConsults
 │ ├fDCSumm
 │ ├rMisc...
 │ ├fLabs
 │ ├fReports
 │ ├rReports
 │ ├fPtDemo
 │ ├fEncnt
 │ ├fPtCWAD
 │ ├uCore...
 │ ├fAbout
 │ ├fReview
 │ ├fxBroker
 │ ├fxLists
 │ ├fxServer
 │ ├fRptBox...
 │ ├rODAllergy
 │ ├uInit...
 │ ├fLabInfo
 │ ├uReminders
 │ ├fReminderTree
 │ ├fDeviceSelect
 │ ├fDrawers
 │ ├fReminderDialog
 │ ├fOptions
 │ ├fGraphs
 │ ├fGraphData
 │ ├rTemplates
 │ ├fSurgery
 │ ├rSurgery
 │ ├uEventHooks...
 │ ├uSignItems
 │ ├rECS
 │ ├fIconLegend
 │ ├uOrders...
 │ ├uSpell
 │ ├uOrPtf
 │ ├fPatientFlagMulti
 │ ├fAlertForward
 │ ├UBAGlobals...
 │ ├UBACore...
 │ ├fOrdersSign
 │ ├uVitals
 │ ├fMHTest
 │ ├uFormMonitor
 │ ├fOtherSchedule
 │ ├uVA508CPRSCompatibility
 │ ├fIVRoutes
 │ ├fPrintLocation
 │ ├fTemplateEditor
 │ └fCombatVet
 ├fODDietLT
 │ ├fAutoSz...
 │ ├fODBase...
 │ ├rODBase...
 │ ├rCore...
 │ ├uCore...
 │ ├rODDiet
 │ ├uConst
 │ └rOrders...
 └rODDiet...

Module Called-By (2 levels)


                     fODBase
                   uOrders┤ 
                   uCore┤ │ 
              fODBase...┤ │ 
                 rODBase┤ │ 
                  fFrame┤ │ 
                 fOrders┤ │ 
             fOrdersSign┤ │ 
                   fMeds┤ │ 
               fARTAllgy┤ │ 
                  fNotes┤ │ 
               fConsults┤ │ 
         fReminderDialog┤ │ 
                 fReview┤ │ 
            fOrdersRenew┤ │ 
               fOrdersCV┤ │ 
                 fODMeds┤ │ 
                 fOMNavA┤ │ 
         fOrderSaveQuick┤ │ 
                  fOMSet┤ │ 
          fOrdersRelease┤ │ 
                 fOMHTML┤ │ 
               fODMedNVA┤ │ 
fODChangeUnreleasedRenew┤ │ 
          fOrdersOnChart┤ │ 
         fODReleaseEvent┤ │ 
               fODActive┘ │ 
                rODBase...┤ 
                fOrders...┤ 
                  fMeds...┤ 
                uSignItems┤ 
               fFrame...┤ │ 
          fOrdersSign...┤ │ 
              fReview...┘ │ 
                 fODDietLT┤ 
              fODBase...┤ │ 
                 fODDiet┘ │ 
                fODDiet...┤ 
                   fODMisc┤ 
              uOrders...┘ │ 
                    fODGen┤ 
              uOrders...┘ │ 
                  fODMedIn┤ 
              uOrders...┘ │ 
                 fODMedOut┤ 
              uOrders...┘ │ 
             fODMedComplex┤ 
            fODMedOut...┘ │ 
                   fODText┤ 
              uOrders...┘ │ 
                fODConsult┤ 
              uOrders...┤ │ 
              fOrders...┤ │ 
       fBALocalDiagnoses┘ │ 
                   fODProc┤ 
              uOrders...┘ │ 
                    fODRad┤ 
              uOrders...┘ │ 
                    fODLab┤ 
              uOrders...┤ │ 
       fODLabOthCollSamp┘ │ 
                  fODBBank┤ 
              uOrders...┘ │ 
                fODMeds...┤ 
                  fODMedIV┤ 
              uOrders...┘ │ 
                 fODVitals┤ 
              uOrders...┘ │ 
                   fODAuto┤ 
              uOrders...┘ │ 
                fOMNavA...┤ 
        fOrderSaveQuick...┤ 
                 fOMSet...┤ 
              fODMedNVA...┤ 
               fOrdersCopy┤ 
              fOrders...┤ │ 
              mEvntDelay┘ │ 
                  fMedCopy┤ 
                fMeds...┤ │ 
           mEvntDelay...┘ │ 
                  fODAllgy┘