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

unit fODBase;

{$OPTIMIZATION OFF}                              // REMOVE AFTER UNIT IS DEBUGGED

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, fAutoSz, StdCtrls,
  ORCtrls, ORFn, uConst, rOrders, rODBase, uCore, ComCtrls, ExtCtrls, Menus, Mask,
  Buttons, UBAGlobals, UBACore, VA508AccessibilityManager;

type
  TCtrlInit = class
  private
    Name:   string;
    Text:   string;
    ListID: string;
    List:   TStringList;
  public
    constructor Create;
    destructor Destroy; override;
  end;

  TCtrlInits = class
  private
    FDfltList: TList;
    FOIList:   TList;
    procedure ExtractInits(Src: TStrings; Dest: TList);
    function FindInitByName(const AName: string): TCtrlInit;
  public
    constructor Create;
    destructor Destroy; override;
    procedure ClearOI;
    function DefaultText(const ASection: string): string;
    procedure LoadDefaults(Src: TStrings);
    procedure LoadOrderItem(Src: TStrings);
    procedure SetControl(AControl: TControl; const ASection: string);
    procedure SetListOnly(AControl: TControl; const ASection: string);
    procedure SetPopupMenu(AMenu: TPopupMenu; AClickEvent: TNotifyEvent; const ASection: string);
    function TextOf(const ASection: string): string;
  end;

  TResponses = class
  private
    FDialog: string;
    FResponseList: TList;
    FPrompts: TList;
    FCopyOrder: string;
    FEditOrder: string;
    FTransferOrder: string;
    FDisplayGroup: Integer;
    FQuickOrder: Integer;
    FOrderChecks: TStringList;
    FVarLeading:  string;
    FVarTrailing: string;
    FEventType: Char;
    FEventIFN: Integer;
    FEventName: string;
    FSpecialty: Integer;
    FEffective: TFMDateTime;
    FParentEvent: TParentEvent;
    FLogTime:   TFMDateTime;
    FViewName: string;
    FCancel: boolean;
    FOrderContainsObjects: boolean;
    function FindResponseByIEN(APromptIEN, AnInstance: Integer): TResponse;
    function GetOrderText: string;
    function IENForPrompt(const APromptID: string): Integer;
    procedure SetDialog(Value: string);
    procedure SetCopyOrder(const AnID: string);
    procedure SetEditOrder(const AnID: string);
    procedure SetQuickOrder(AnIEN: Integer);
    procedure SetQuickOrderByID(const AnID: string);
    procedure FormatResponse(var FormattedText: string; var ExcludeText: Boolean;
              APrompt: TPrompt; const x: string; AnInstance: Integer);
    function FindPromptByIEN(AnIEN: Integer): TPrompt;
    procedure AppendChildren(var ParentText: string; ChildPrompts: string; AnInstance: Integer);
    procedure BuildOCItems(AList: TStringList; var AStartDtTm: string; const AFillerID: string);
  public
    constructor Create;
    destructor Destroy; override;
    procedure Clear; overload;
    procedure Clear(const APromptID: string; SaveInstance: Integer = 0); overload;
    function EValueFor(const APromptID: string; AnInstance: Integer): string;
    function GetIENForPrompt(const APromptID: string): Integer;
    function FindResponseByName(const APromptID: string; AnInstance: Integer): TResponse;
    function PromptExists(const APromptID: string):boolean;
    function InstanceCount(const APromptID: string): Integer;
    function IValueFor(const APromptID: string; AnInstance: Integer): string;
    function NextInstance(const APromptID: string; LastInstance: Integer): Integer;
    function OrderCRC: string;
    procedure Remove(const APromptID: string; AnInstance: Integer);
    procedure SaveQuickOrder(var ANewIEN: Integer; const ADisplayName: string);
    procedure SaveOrder(var AnOrder: TOrder; DlgIEN: Integer; IsIMOOrder: boolean = False);
    procedure SetControl(AControl: TControl; const APromptID: string; AnInstance: Integer);
    procedure SetEventDelay(AnEvent: TOrderDelayEvent);
    procedure SetPromptFormat(const APromptID, NewFormat: string);
    procedure Update(const APromptID: string; AnInstance: Integer;
      const AnIValue, AnEValue: string);
    property Dialog: string            read FDialog         write SetDialog;
    property DisplayGroup: Integer     read FDisplayGroup   write FDisplayGroup;
    property CopyOrder:    string      read FCopyOrder      write SetCopyOrder;
    property EditOrder:    string      read FEditOrder;  //  write SetEditOrder;
    property TransferOrder:string      read FTransferOrder  write FTransferOrder;
    property EventType:    Char        read FEventType;
    property EventIFN:     integer     read FEventIFN       write FEventIFN;
    property EventName:    string      read FEventName      write FEventName;
    property LogTime:      TFMDateTime read FLogTime        write FLogTime;
    property QuickOrder:   Integer     read FQuickOrder     write SetQuickOrder;
    property OrderChecks:  TStringList read FOrderChecks    write FOrderChecks;
    property OrderText:    string      read GetOrderText;
    property VarLeading:   string      read FVarLeading     write FVarLeading;
    property VarTrailing:  string      read FVarTrailing    write FVarTrailing;
    property TheList:      TList       read FResponseList   write FResponseList;
    property Cancel:       boolean     read FCancel         write FCancel;
    property OrderContainsObjects: boolean read FOrderContainsObjects write FOrderContainsObjects;
  end;

  TCallOnExit = procedure;

  TfrmODBase = class(TfrmAutoSz)
    memOrder: TCaptionMemo;
    cmdAccept: TButton;
    cmdQuit: TButton;
    pnlMessage: TPanel;
    imgMessage: TImage;
    memMessage: TRichEdit;
    procedure cmdQuitClick(Sender: TObject);
    procedure cmdAcceptClick(Sender: TObject);
    procedure FormKeyPress(Sender: TObject; var Key: Char);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure memMessageMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure pnlMessageExit(Sender: TObject);
    procedure pnlMessageMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure pnlMessageMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
  private
    FIsSupply:  Boolean;
    FAbortOrder:   Boolean;
    FAllowQO:      Boolean;
    FAutoAccept:   Boolean;
    FClosing:      Boolean;
    FChanging:     Boolean;
    FDialogIEN:    Integer;
    FDisplayGroup: Integer;
    FFillerID:     string;
    FFromQuit:     Boolean;
    FAcceptOK:     Boolean;
    FCtrlInits:    TCtrlInits;
    FResponses:    TResponses;
    FPreserve:     TList;
    FRefNum:       Integer;
    FOrderAction:  Integer;
    FKeyVariables: string;
    FCallOnExit:   TCallOnExit;
    FTestMode:     Boolean;
    FDlgFormID:    Integer;
    FDfltCopay:    String;
    FEvtForPassDischarge:  Char;
    FEvtID    :    Integer;
    FEvtType  :    Char;
    FEvtName  :    string;
    FIncludeOIPI:  boolean;
    FIsIMO:        boolean;  //imo
    FMessageClickX: integer;
    FMessageClickY: integer;
    function AcceptOrderChecks: Boolean;
    procedure ClearDialogControls;
    function GetKeyVariable(const Index: string): string;
    function GetEffectiveDate: TFMDateTime;
    procedure SetDisplayGroup(Value: Integer);
    procedure SetFillerID(const Value: string);
    procedure DoSetFontSize( FontSize: integer);
  protected
    function LESValidationCheck: boolean;
    procedure InitDialog; virtual;
    procedure SetDialogIEN(Value: Integer); virtual;
    procedure Validate(var AnErrMsg: string); virtual;
    procedure updateSig; virtual;
    function ValidSave: Boolean;
    procedure ShowOrderMessage(Show: boolean);
  public
    function OrderForInpatient: Boolean;
    procedure SetDefaultCoPay(AnOrderID: string);
    procedure OrderMessage(const AMessage: string);
    procedure PreserveControl(AControl: TControl);
    procedure SetupDialog(OrderAction: Integer; const ID: string); virtual;
    procedure SetFontSize( FontSize: integer); virtual;
    procedure SetKeyVariables(const VarStr: string);
    procedure TabClose(var CanClose: Boolean);
    property AbortOrder:  Boolean       read FAbortOrder   write FAbortOrder;
    property AcceptOK:  Boolean         read FAcceptOK;
    property AllowQuickOrder: Boolean   read FAllowQO      write FAllowQO;
    property AutoAccept: Boolean        read FAutoAccept   write FAutoAccept;
    property CallOnExit: TCallOnExit    read FCallOnExit   write FCallOnExit;
    property Changing:  Boolean         read FChanging     write FChanging;
    property Closing:   Boolean         read FClosing;
    property CtrlInits: TCtrlInits      read FCtrlInits    write FCtrlInits;
    property DialogIEN: Integer         read FDialogIEN    write SetDialogIEN;
    property DisplayGroup: Integer      read FDisplayGroup write SetDisplayGroup;
    property EffectiveDate: TFMDateTime read GetEffectiveDate;
    property FillerID: string           read FFillerID     write SetFillerID;
    property KeyVariable[const Index: string]: string read GetKeyVariable;
    property RefNum: Integer            read FRefNum       write FRefNum;
    property Responses: TResponses      read FResponses    write FResponses;
    property TestMode: Boolean          read FTestMode     write FTestMode;
    property DlgFormID: Integer         read FDlgFormID    write FDlgFormID;
    property DfltCopay: string          read FDfltCopay    write FDfltCopay;
    property EvtForPassDischarge: Char  read FEvtForPassDischarge  write FEvtForPassDischarge;
    property EvtID: integer             read FEvtID        write FEvtID;
    property EvtType: Char              read FEvtType      write FEvtType;
    property EvtName: String            read FEvtName      write FEvtName;
    property IncludeOIPI: boolean       read FIncludeOIPI  write FIncludeOIPI;
    property IsIMO:boolean              read FIsIMO        write FIsIMO;
    property IsSupply: boolean          read FIsSupply     write FIsSupply;
  end;

var
  frmODBase: TfrmODBase = nil;
  XfInToOutNow :boolean = False;       // it's used only for transfering Inpatient Meds to OutPatient Med for
                                       // immediately release (NO EVENT DELAY)
  XferOuttoInOnMeds : boolean = False; // it's used only for transfering Outpatient Meds to Inpatient Med for
                                       // immediately release (NO EVENT DELAY)
  ImmdCopyAct: boolean  = False;
  IsUDGroup: boolean = False;     // it's only used for copy inpatient med order.
  DEASig: string;                 // digital signature
  DupORIFN: string;               // it's used to identify the order number for duplicate orders in order checking
  NoFresh: boolean = False;        // EDO use only
  SaveAsCurrent: boolean = False;  // EDO use only
  CIDCOkToSave: boolean;   // CIDC only, used for consult orders.
  OrderSource: string = '';
  EventDefaultOD: integer = 0;    // If it's event default dialog?
  IsTransferAction: boolean = False;  

procedure ClearControl(AControl: TControl);
procedure ResetControl(AControl: TControl);

implementation

{$R *.DFM}

uses fOCAccept, uODBase, rCore, rMisc, fODMessage,
  fTemplateDialog, uEventHooks, uTemplates, rConsults,fOrders,uOrders,
  fFrame, uTemplateFields, fClinicWardMeds, fODDietLT, rODDiet, VAUtils;

const
  TX_ACCEPT = 'Accept the following order?' + CRLF + CRLF;
  TX_ACCEPT_CAP = 'Unsaved Order';
  TC_ORDERCHECKS = 'Order Checks';

{ Procedures shared with descendent forms }

procedure ClearControl(AControl: TControl);
{ clears a control, removes text and listbox items }
begin
  if AControl is TLabel then with TLabel(AControl) do Caption := ''
  else if AControl is TStaticText then with TStaticText(AControl) do Caption := ''
  else if AControl is TButton then with TButton(AControl) do Caption := ''
  else if AControl is TEdit then with TEdit(AControl) do Text := ''
  else if AControl is TMemo then with TMemo(AControl) do Clear
  else if AControl is TRichEdit then with TRichEdit(AControl) do Clear
  else if AControl is TORListBox then with TORListBox(AControl) do Clear
  else if AControl is TListBox then with TListBox(AControl) do Clear
  else if AControl is TORComboBox then with TORComboBox(AControl) do
  begin
    Items.Clear;
    Text := '';
  end
  else if AControl is TComboBox then with TComboBox(AControl) do
  begin
    Clear;
    Text := '';
  end;
end;

procedure ResetControl(AControl: TControl);
{ clears text, deselects items, does not remove listbox or combobox items }
begin
  if AControl is TLabel then with TLabel(AControl) do Caption := ''
  else if AControl is TStaticText then with TStaticText(AControl) do Caption := ''
  else if AControl is TButton then with TButton(AControl) do Caption := ''
  else if AControl is TEdit then with TEdit(AControl) do Text := ''
  else if AControl is TMemo then with TMemo(AControl) do Clear
  else if AControl is TRichEdit then with TRichEdit(AControl) do Clear
  else if AControl is TListBox then with TListBox(AControl) do ItemIndex := -1
  else if AControl is TORComboBox then with TORComboBox(AControl) do
  begin
    Text := '';
    ItemIndex := -1;
  end
  else if AControl is TComboBox then with TComboBox(AControl) do
  begin
    Text := '';
    ItemIndex := -1;
  end;
end;

{ TCtrlInit methods }

constructor TCtrlInit.Create;
begin
  List := TStringList.Create;
end;

destructor TCtrlInit.Destroy;
begin
  List.Free;
  inherited Destroy;
end;

{ TCtrlInits methods }

constructor TCtrlInits.Create;
{ create lists to store initial value for dialog and selected orderable item }
begin
  FDfltList := TList.Create;
  FOIList   := TList.Create;
end;

destructor TCtrlInits.Destroy;
{ free the objects used to store initialization information }
var
  i: Integer;
begin
  { free the objects in the lists first }
  with FDfltList do for i := 0 to Count - 1 do TCtrlInit(Items[i]).Free;
  FDfltList.Free;
  ClearOI;
  FOIList.Free;
  inherited Destroy;
end;

procedure TCtrlInits.ClearOI;
{ clears the records in FOIList, but not FDfltList }
var
  i: Integer;
begin
  with FOIList do for i := 0 to Count - 1 do TCtrlInit(Items[i]).Free;
  FOIList.Clear;
end;

procedure TCtrlInits.ExtractInits(Src: TStrings; Dest: TList);
{ load a list with TCtrlInit records (source strings are those passed from server }
var
  i: Integer;
  ACtrlInit: TCtrlInit;
begin
  i := 0;
  while i < Src.Count do
  begin
    if CharAt(Src[i], 1) = '~' then
    begin
      ACtrlInit := TCtrlInit.Create;
      with ACtrlInit do
      begin
        Name := Copy(Src[i], 2, Length(Src[i]));
        List := TStringList.Create;
        Inc(i);
        while (i < Src.Count) and (CharAt(Src[i], 1) <> '~') do
        begin
          if CharAt(Src[i], 1) = 'i' then List.Add(Copy(Src[i], 2, 255));
          if CharAt(Src[i], 1) = 't' then List.Add(Copy(Src[i], 2, 255));
          if CharAt(Src[i], 1) = 'd' then
          begin
            Text := Piece(Src[i], U, 2);
            ListID := Copy(Piece(Src[i], U, 1), 2, 255);
          end;
          Inc(i);
        end; {while i & CharAt...}
        Dest.Add(ACtrlInit);
      end; {with ACtrlDflt}
    end; {if CharAt}
  end; {while i}
end;


procedure TCtrlInits.LoadDefaults(Src: TStrings);
{ loads control initialization information for the dialog }
begin
  FDfltList.Clear;              
  ExtractInits(Src, FDfltList);
end;

procedure TCtrlInits.LoadOrderItem(Src: TStrings);
{ loads control initialization information for the orderable item }
begin
  ClearOI;
  ExtractInits(Src, FOIList);
end;

function TCtrlInits.FindInitByName(const AName: string): TCtrlInit;
{ look first in FOIList, then in FDfltList for initial values identified by name (~section) }
var
  i: Integer;
begin
  Result := nil;
  with FOIList do
    for i := 0 to Count - 1 do if TCtrlInit(Items[i]).Name = AName then
    begin
      Result := TCtrlInit(Items[i]);
      break;
    end;
  if Result = nil then with FDfltList do
    for i := 0 to Count - 1 do if TCtrlInit(Items[i]).Name = AName then
    begin
      Result := TCtrlInit(Items[i]);
      break;
    end;
end;

procedure TCtrlInits.SetControl(AControl: TControl; const ASection: string);
{ initializes a control to the information in a section (~section from server) }
var
  CtrlInit: TCtrlInit;
begin
  ClearControl(AControl);
  CtrlInit := FindInitByName(ASection);
  if CtrlInit = nil then Exit;
  if AControl is TLabel then with TLabel(AControl) do Caption := CtrlInit.Text
  else if AControl is TStaticText then with TStaticText(AControl) do Caption := CtrlInit.Text
  else if AControl is TButton then with TButton(AControl) do Caption := CtrlInit.Text
  else if AControl is TEdit then with TEdit(AControl) do Text := CtrlInit.Text
  else if AControl is TMemo then FastAssign(CtrlInit.List, TMemo(AControl).Lines)
  else if AControl is TRichEdit then QuickCopy(CtrlInit.List, TRichEdit(AControl))
  else if AControl is TORListBox then FastAssign(CtrlInit.List, TORListBox(AControl).Items)
  else if AControl is TListBox then FastAssign(CtrlInit.List, TListBox(AControl).Items)
  else if AControl is TComboBox then with TComboBox(AControl) do
  begin
    FastAssign(CtrlInit.List, TComboBox(AControl).Items);
    Text := CtrlInit.Text;
  end
  else if AControl is TORComboBox then with TORComboBox(AControl) do
  begin
    FastAssign(CtrlInit.List, TORComboBox(AControl).Items);
    if LongList then InitLongList(Text) else Text := CtrlInit.Text;
    SelectByID(CtrlInit.ListID);
  end;
  { need to add SelectByID for combobox & listbox }
end;

procedure TCtrlInits.SetListOnly(AControl: TControl; const ASection: string);
{ assigns list portion to a control from a section (used to set ShortList for meds) }
var
  CtrlInit: TCtrlInit;
begin
  CtrlInit := FindInitByName(ASection);
  if CtrlInit = nil then Exit;
  if      AControl is TMemo       then FastAssign(CtrlInit.List, TMemo(AControl).Lines)
  else if AControl is TORListBox  then FastAssign(CtrlInit.List, TORListBox(AControl).Items)
  else if AControl is TListBox    then FastAssign(CtrlInit.List, TListBox(AControl).Items)
  else if AControl is TComboBox   then FastAssign(CtrlInit.List, TComboBox(AControl).Items)
  else if AControl is TORComboBox then FastAssign(CtrlInit.List, TORComboBox(AControl).Items);
end;

procedure TCtrlInits.SetPopupMenu(AMenu: TPopupMenu; AClickEvent: TNotifyEvent; const ASection: string);
{ populates a popup menu with items in a list, leaves the maximum text width in Tag }
var
  i, MaxWidth: Integer;
  CtrlInit: TCtrlInit;
  AMenuItem: TMenuItem;
begin
  CtrlInit := FindInitByName(ASection);
  // clear the current menu entries
  for i := AMenu.Items.Count - 1 downto 0 do
  begin
    AMenuItem := AMenu.Items[i];
    if AMenuItem <> nil then
    begin
      AMenu.Items.Delete(i);
      AMenuItem.Free;
    end;
  end;
  MaxWidth := 0;
  for i := 0 to CtrlInit.List.Count - 1 do
  begin
    AMenuItem := TMenuItem.Create(Application);
    AMenuItem.Caption := CtrlInit.List[i];
    AMenuItem.OnClick := AClickEvent;
    AMenu.Items.Add(AMenuItem);
    MaxWidth := HigherOf(MaxWidth, Application.MainForm.Canvas.TextWidth(CtrlInit.List[i]));
  end;
  AMenu.Tag := MaxWidth;
end;

function TCtrlInits.DefaultText(const ASection: string): string;
var
  CtrlInit: TCtrlInit;
begin
  Result := '';
  CtrlInit := FindInitByName(ASection);
  if CtrlInit <> nil then Result := CtrlInit.ListID;
end;

function TCtrlInits.TextOf(const ASection: string): string;
var
  CtrlInit: TCtrlInit;
begin
  Result := '';
  CtrlInit := FindInitByName(ASection);
  if CtrlInit <> nil then Result := CtrlInit.List.Text;
end;

{ TResponses methods }

function SortPromptsBySequence(Item1, Item2: Pointer): Integer;
{ compare function used to sort formatting info by sequence - used by TResponses.SetDialog}
var
  Prompt1, Prompt2: TPrompt;
begin
  Prompt1 := TPrompt(Item1);
  Prompt2 := TPrompt(Item2);
  if Prompt1.Sequence < Prompt2.Sequence then Result := -1
  else if Prompt1.Sequence > Prompt2.Sequence then Result := 1
  else Result := 0;
end;

constructor TResponses.Create;
begin
  FResponseList := TList.Create;
  FPrompts := TList.Create;
  FOrderChecks := TStringList.Create;
  FEventType := #0;
  FParentEvent := TParentEvent.Create;
  FLogTime := 0;
end;

destructor TResponses.Destroy;
{ frees all response objects before freeing list }
var
  i: Integer;
begin
  Clear;
  FOrderChecks.Free;
  FResponseList.Free;
  with FPrompts do for i := 0 to Count - 1 do TPrompt(Items[i]).Free;
  FPrompts.Free;
  inherited Destroy;
end;

procedure TResponses.Clear;
{ clears all information in the response multiple }
var
  i: Integer;
begin
  FVarLeading  := '';
  FVarTrailing := '';
  FQuickOrder  := 0;
  //FCopyOrder  := '';  // don't clear FCopyOrder either?
  // don't clear FEditOrder or it will cause a new order to be created instead of an edit
  with FResponseList do for i := 0 to Count - 1 do TResponse(Items[i]).Free;
  FResponseList.Clear;
  FOrderChecks.Clear;
end;

procedure TResponses.Clear(const APromptID: string; SaveInstance: Integer = 0);
var
  AResponse: TResponse;
  i: Integer;
begin
  with FResponseList do
    for i := Count - 1 downto SaveInstance do
    begin
      AResponse := TResponse(Items[i]);
      if AResponse.PromptID = APromptID then
      begin
        AResponse.Free;
        FResponseList.Delete(i);
      end; {if AResponse}
    end; {for}
end;

procedure TResponses.SetDialog(Value: string);
{ loads formatting information for a dialog }
var
  i: Integer;
begin
  with FPrompts do for i := 0 to Count - 1 do TPrompt(Items[i]).Free;
  FPrompts.Clear;
  FDialog := Value;
  LoadDialogDefinition(FPrompts, FDialog);
  FPrompts.Sort(SortPromptsBySequence);
end;

procedure TResponses.SetCopyOrder(const AnID: string);
{ sets responses to the values for an order that is created by copying }
var
  HasObjects: boolean;
begin
  if AnID = '' then
  begin
    FCopyOrder := AnID;
    Exit;
  end;
  Clear;
  LoadResponses(FResponseList, AnID, HasObjects);                      // Example AnID=C123456;1-3604
  FCopyOrder := Copy(Piece(AnID, '-', 1), 2, Length(AnID));
  FOrderContainsObjects := HasObjects;
end;

procedure TResponses.SetEditOrder(const AnID: string);
{ sets responses to the values for an order that is about to be edited }
var
  HasObjects: boolean;
begin
  Clear;
  LoadResponses(FResponseList, AnID, HasObjects);                      // Example AnID=X123456;1
  FEditOrder := Copy(Piece(AnID, '-', 1), 2, Length(AnID));
  FOrderContainsObjects := HasObjects;
end;

procedure TResponses.SetQuickOrder(AnIEN: Integer);
{ sets responses to a quick order value - this is used by the QuickOrder property}
var
  HasObjects: boolean;
begin
  Clear;
  LoadResponses(FResponseList, IntToStr(AnIEN), HasObjects);           // Example AnIEN=134
  FQuickOrder := AnIEN;
  FOrderContainsObjects := HasObjects;
end;

procedure TResponses.SetQuickOrderByID(const AnID: string);
{ sets responses to a quick order value }
var
  HasObjects: boolean;
begin
  Clear;
  LoadResponses(FResponseList, AnID, HasObjects);                      // Example AnID=134-3645
  FQuickOrder := StrToIntDef(Piece(AnID, '-', 1), 0);      // 2nd '-' piece is $H seconds
  FOrderContainsObjects := HasObjects;
end;

procedure TResponses.BuildOCItems(AList: TStringList; var AStartDtTm: string;
  const AFillerID: string);
var
  i, TheInstance: Integer;
  OrderableIEN, PkgPart: string;
begin
  if EditOrder <> '' then DupORIFN := EditOrder;
  if CopyOrder <> '' then DupORIFN := CopyOrder;
  //if {(CopyOrder <> '') or} (EditOrder <> '') then Exit;  // only check new orders
  with FResponseList do for i := 0 to Count - 1 do with TResponse(Items[i]) do
    if (PromptID = 'ORDERABLE') or (PromptID = 'ADDITIVE') then
    begin
      OrderableIEN := IValue;
      TheInstance := Instance;
      PkgPart := '';
      if AFillerID = 'LR' then PkgPart := '^LR^' + IValueFor('SPECIMEN', TheInstance);
      if (AFillerID = 'PSI') or (AFillerID = 'PSO') or (AFillerID = 'PSH')
        then PkgPart := U + AFillerID + U + IValueFor('DRUG', TheInstance);
        // was -- then PkgPart := '^PS^' + IValueFor('DRUG', TheInstance);
      if AFillerID = 'PSIV' then
      begin
        if PromptID = 'ORDERABLE' then PkgPart := '^PSIV^B;' + IValueFor('VOLUME', TheInstance);
        if PromptID = 'ADDITIVE'  then PkgPart := '^PSIV^A';
      end;
      AList.Add(OrderableIEN + PkgPart);
    end;
  AStartDtTm := IValueFor('START', 1);
end;

function TResponses.EValueFor(const APromptID: string; AnInstance: Integer): string;
var
  i: Integer;
begin
  Result := '';
  with FResponseList do for i := 0 to Count - 1 do with TResponse(Items[i]) do
    if (PromptID = APromptID) and (Instance = AnInstance) then
    begin
      Result := EValue;
      break;
    end;
end;

function TResponses.IValueFor(const APromptID: string; AnInstance: Integer): string;
var
  i: Integer;
begin
  Result := '';
  with FResponseList do for i := 0 to Count - 1 do with TResponse(Items[i]) do
    if (PromptID = APromptID) and (Instance = AnInstance) then
    begin
      Result := IValue;
      break;
    end;
end;

function TResponses.PromptExists(const APromptID: string): boolean;
var
  i: Integer;
begin
  Result := False;
  with FPrompts do for i := 0 to Count - 1 do with TPrompt(Items[i]) do
    if (ID = APromptID) then Result :=  True;
end;

function TResponses.FindResponseByName(const APromptID: string; AnInstance: Integer): TResponse;
var
  i: Integer;
begin
  Result := nil;
  with FResponseList do for i := 0 to Count - 1 do with TResponse(Items[i]) do
    if (PromptID = APromptID) and (Instance = AnInstance) then
    begin
      Result := TResponse(Items[i]);
      break;
    end;
end;

function TResponses.IENForPrompt(const APromptID: string): Integer;
var
  i: Integer;
begin
  Result := 0;
  with FPrompts do for i := 0 to Count - 1 do with TPrompt(Items[i]) do
    if (ID = APromptID) then
    begin
      Result := IEN;
      break;
    end;
end;

function TResponses.InstanceCount(const APromptID: string): Integer;
var
  i: Integer;
begin
  Result := 0;
  with FResponseList do for i := 0 to Count - 1 do with TResponse(Items[i]) do
    if (PromptID = APromptID) then Inc(Result);
end;

function TResponses.NextInstance(const APromptID: string; LastInstance: Integer): Integer;
var
  i: Integer;
begin
  Result := 0;
  with FResponseList do for i := 0 to Count - 1 do with TResponse(Items[i]) do
    if (PromptID = APromptID) and (Instance > LastInstance) and
      ((Result = 0) or ((Result > 0) and (Instance < Result))) then Result := Instance;
end;

function TResponses.FindResponseByIEN(APromptIEN, AnInstance: Integer): TResponse;
var
  i: Integer;
begin
  Result := nil;
  with FResponseList do for i := 0 to Count - 1 do with TResponse(Items[i]) do
    if (PromptIEN = APromptIEN) and (Instance = AnInstance) then
    begin
      Result := TResponse(Items[i]);
      break;
    end;
end;

procedure TResponses.FormatResponse(var FormattedText: string; var ExcludeText: Boolean;
  APrompt: TPrompt; const x: string; AnInstance: Integer);
var
  AValue: string;
  PromptIEN: Integer;
  Related: TResponse;
begin
  FormattedText := '';
  ExcludeText := True;
  with APrompt do
  begin
    if FmtCode = '@' then Exit;                // skip this response
    if CharAt(FmtCode, 1) = '@' then           // exclude if related response exists
    begin
      PromptIEN := StrToIntDef(Copy(FmtCode, 2, Length(FmtCode)), 0);
      if (FindResponseByIEN(PromptIEN, AnInstance) <> nil) then Exit;
    end;
    if CharAt(FmtCode, 1) = '*' then           // include if related response exists
    begin
      PromptIEN := StrToIntDef(Copy(FmtCode, 2, Length(FmtCode)), 0);
      if FindResponseByIEN(PromptIEN, AnInstance) = nil then Exit;
    end;
    if CharAt(FmtCode, 1) = '#' then           // include if related response = value
    begin
      AValue := Copy(FmtCode, Pos('=', FmtCode) + 1, Length(FmtCode));
      PromptIEN := StrToIntDef(Copy(Piece(FmtCode, '=', 1), 2, Length(FmtCode)), 0);
      Related := FindResponseByIEN(PromptIEN, AnInstance);
      if Related = nil then Exit;
      if not (Related.EValue = AValue) then Exit;
    end;
    if CharAt(FmtCode, 1) = '=' then           // exclude if related response has same text
    begin
      PromptIEN := StrToIntDef(Copy(FmtCode, 2, Length(FmtCode)), 0);
      Related := FindResponseByIEN(PromptIEN, AnInstance);
      if (Related <> nil) and ((Pos(Related.EValue, x) > 0) or (Pos(x, Related.EValue) > 0)) then Exit;
    end;
    ExcludeText := False;
    if (Length(x) = 0) or (CompareText(x, Omit) = 0) then Exit;
    FormattedText := x;
    if IsChild and (Length(Leading) > 0) and (CharAt(Leading, 1) <> '@')
      then FormattedText := Leading + ' ' + FormattedText;
    if IsChild and (Length(Trailing) > 0) and (CharAt(Trailing, 1) <> '@')
      then FormattedText := FormattedText + ' ' + Trailing;
  end; {with APrompt}
end;

function TResponses.FindPromptByIEN(AnIEN: Integer): TPrompt;
var
  i: Integer;
begin
  Result := nil;
  with FPrompts do for i := 0 to Count - 1 do with TPrompt(Items[i]) do
    if IEN = AnIEN then
    begin
      Result := TPrompt(Items[i]);
      break;
    end;
end;

procedure TResponses.AppendChildren(var ParentText: string; ChildPrompts: string; AnInstance: Integer);
var
  x, Segment: string;
  Boundary, ChildIEN: Integer;
  ExcludeText: Boolean;
  AResponse: TResponse;
  APrompt: TPrompt;
begin
  while Length(ChildPrompts) > 0 do
  begin
    Boundary := Pos('~', ChildPrompts);
    if Boundary = 0 then Boundary := Length(ChildPrompts) + 1;
    Segment := Copy(ChildPrompts, 1, Boundary - 1);
    Delete(ChildPrompts, 1, Boundary);
    ChildIEN := StrToIntDef(Segment, 0);
    APrompt := FindPromptByIEN(ChildIEN);
    if APrompt <> nil then
    begin
      AResponse := FindResponseByIEN(APrompt.IEN, AnInstance);
      if AResponse <> nil then
      begin
        FormatResponse(x, ExcludeText, APrompt, AResponse.EValue, AnInstance);
        //x := FormatResponse(APrompt, AResponse.EValue, AnInstance);
        if not ExcludeText then
        begin
          if (Length(ParentText) > 0) and (Length(x) > 0) then ParentText := ParentText + ' ';
          ParentText := ParentText + x;
        end; {if not ExcludeText}
      end; {if AResponse}
    end; {if APrompt}
  end; {while Length}
end; {AppendChildren}

function TResponses.GetOrderText: string;
{ loop thru the response objects and build the order text }
var
  i, AnInstance, NumInstance: Integer;
  x, Segment: string;
  ExcludeText, StartNewline: Boolean;
  AResponse: TResponse;
  APrompt: TPrompt;
begin
  Result := '';
  with FPrompts do for i := 0 to Count - 1 do
  begin
    APrompt := TPrompt(Items[i]);
    if APrompt.Sequence = 0 then Continue;   // skip if prompt not in formatting sequence
    NumInstance := 0;
    Segment := '';
    AnInstance := NextInstance(APrompt.ID, 0);
    while AnInstance > 0 do
    begin
      Inc(NumInstance);
      AResponse := FindResponseByName(APrompt.ID, AnInstance);
      FormatResponse(x, ExcludeText, APrompt, AResponse.EValue, AnInstance);
      //x := FormatResponse(APrompt, AResponse.EValue, AnInstance);
      if not ExcludeText then
      begin
        if Length(APrompt.Children) > 0 then AppendChildren(x, APrompt.Children, AnInstance);
        if Length(x) > 0 then
        begin
          // should the newline property be checked for children, too?
          if APrompt.NewLine and (Length(Result) > 0) then x := CRLF + x;
          if NumInstance > 1     then Segment := Segment + ',';
          if Length(Segment) > 0 then Segment := Segment + ' ';
          Segment := Segment + x;
        end; {if Length(x)}
      end; {if not ExcudeText}
      AnInstance := NextInstance(APrompt.ID, AnInstance);
    end; {while AnInstance}
    if NumInstance > 0 then with APrompt do
    begin
      if Length(Segment) > 0 then
      begin
        if Copy(Segment, 1, 2) = CRLF then
        begin
          Segment := Copy(Segment, 3, Length(Segment));
          StartNewline := True;
        end
        else StartNewline := False;
        if (Length(Leading) > 0) then
        begin
          if (CharAt(Leading, 1) <> '@')
            then Segment := Leading + ' ' + Segment
            else Segment := FVarLeading + ' ' + Segment;
        end; {if Length(Leading)}
        if StartNewline then Segment := CRLF + Segment;
        if (Length(Trailing) > 0) then
        begin
          if (CharAt(Trailing, 1) <> '@')
            then Segment := Segment + ' ' + Trailing
            else Segment := Segment + ' ' + FVarTrailing;
        end; {if Length(Trailing)}
      end; {if Length(Segment)}
      if Length(Result) > 0 then Result := Result + ' ';
      Result := Result + Segment;
    end; {with APrompt}
  end; {with FPrompts}
end; {GetOrderText}

procedure TResponses.Update(const APromptID: string; AnInstance: Integer;
  const AnIValue, AnEValue: string);
{ for a given Prompt,Instance update or create the associated response object }
var
  AResponse: TResponse;
begin
  AResponse := FindResponseByName(APromptID, AnInstance);
  if AResponse = nil then
  begin
    AResponse := TResponse.Create;
    AResponse.PromptID := APromptID;
    AResponse.PromptIEN := IENForPrompt(APromptID);
    AResponse.Instance := AnInstance;
    FResponseList.Add(AResponse);
  end;
  AResponse.IValue := AnIValue;
  AResponse.EValue := AnEValue;
end;

function TResponses.OrderCRC: string;
const
  CRC_WIDTH = 8;
var
  i: Integer;
  x: string;
  tmplst: TStringList;
begin
  tmplst := TStringList.Create;
  try
    with FResponseList do for i := 0 to Count - 1 do with TResponse(Items[i]) do
    begin
      if IValue = TX_WPTYPE then x := EValue else x := IValue;
      tmplst.Add(IntToStr(PromptIEN) + U + IntToStr(Instance) + U + x);
    end;
    Result := IntToHex(CRCForStrings(tmplst), CRC_WIDTH);
  finally
    tmplst.Free;
  end;
end;

procedure TResponses.Remove(const APromptID: string; AnInstance: Integer);
var
  AResponse: TResponse;
begin
  AResponse := FindResponseByName(APromptID, AnInstance);
  if AResponse <> nil then
  begin
    FResponseList.Remove(AResponse);
    AResponse.Free;
  end;
end;

procedure TResponses.SaveQuickOrder(var ANewIEN: Integer; const ADisplayName: string);
begin
  if FDisplayGroup = ClinDisp then  //Clin. Meds share same quick order definition with Inpt. Meds
    PutQuickOrder(ANewIEN, OrderCRC, ADisplayName, InptDisp, FResponseList)
  else
    PutQuickOrder(ANewIEN, OrderCRC, ADisplayName, FDisplayGroup, FResponseList)
end;

procedure TResponses.SaveOrder(var AnOrder: TOrder; DlgIEN: Integer; IsIMOOrder: boolean);
var
  ConstructOrder: TConstructOrder;
  i,j: integer;
  QOUDGroup: boolean;
  NewPtEvtPtr: Integer;  // ptr to #100.2
  APtEvtPtr: string;
begin
  //IMOLoc := 0;
  NewPtEvtPtr := 0;
  QOUDGroup := False;
  if FQuickOrder > 0 then
  begin
   DlgIEN := FQuickOrder;
   QOUDGroup := CheckQOGroup( IntToStr(FQuickOrder) );
  end;
  AnOrder.EditOf := FEditOrder;  // null if new order, otherwise ORIFN of original order
  with ConstructOrder do
  begin
    if XfInToOutNow then
      DialogName := FDialog + '^O'
    else DialogName := FDialog;
    LeadText     := FVarLeading;
    TrailText    := FVarTrailing;
    DGroup       := FDisplayGroup;
    OrderItem    := DlgIEN;
    DelayEvent   := FEventType;
    Specialty    := FSpecialty;
    Effective    := FEffective;
    LogTime      := FLogTime;
    OCList       := FOrderChecks;
    DigSig       := DEASig;
    IsIMODialog  := IsIMOOrder;       //IMO
    if IsIMODialog then
      DGroup := ClinDisp;
    //AGP Change 26.35, 26.41 8518 added text order
    //AGP Change 26.55 remove IMO functionality for inpatient
    (*if (Patient.Inpatient = true) and (IsValidIMOLoc(encounter.Location,Patient.DFN)=true) and
      ((ConstructOrder.DialogName = 'PSJ OR PAT OE') or (ConstructOrder.DialogName = 'PSJI OR PAT FLUID OE') or
      (ConstructOrder.DialogName = 'OR GXTEXT WORD PROCESSING ORDE')) and
      ((FEditOrder = '') and (Self.FEventName = '') and (Self.FCopyOrder = '')) then
      begin
       if frmClinicWardMeds.ClinicOrWardLocation(Encounter.location) = Encounter.Location then
          begin
            ConstructOrder.IsIMODialog := True;
            ConstructOrder.DGroup := ClinDisp;
          end
       else IMOLoc := Patient.Location;
      end; *)
    //AGP Change 26.51, change logic to set text orders to IMO for outpatients at an outpatient location.
    //AGP Text orders are only treated as IMO if the order display group is a nursing display group
    if (Patient.Inpatient = False) and (IsValidIMOLoc(encounter.Location,Patient.DFN)=true) and
       (((pos('OR GXTEXT WORD PROCESSING ORDER',ConstructOrder.DialogName)>0) and (ConstructOrder.DGroup = NurDisp)) or
       ((ConstructOrder.DialogName = 'OR GXMISC GENERAL') and (ConstructOrder.DGroup = NurDisp)) or
       ((ConstructOrder.DialogName = 'OR GXTEXT TEXT ONLY ORDER') and (ConstructOrder.DGroup = NurDisp))) and //AGP Change CQ #10757
      ((FEditOrder = '') and (Self.FEventName = '') and (Self.FCopyOrder = '')) then
         begin
            ConstructOrder.IsIMODialog := True;
            ConstructOrder.DGroup := ClinDisp;
          end;
    IsEventDefaultOR := EventDefaultOD;
    if IsUDGroup or QOUDGroup then
    begin
      for i := 0 to FResponseList.Count - 1 do
       if UpperCase(TResponse(FResponseList.Items[i]).PromptID) = 'PICKUP' then
       begin
          FResponseList.Delete(i);
          Break;
       end;
    end;

    if SaveAsCurrent then
      ConstructOrder.DelayEvent := #0;

    ResponseList := FResponseList;
    if (FEventIFN>0) and (EventExist(Patient.DFN, FEventIFN)>0) then
    begin
      APtEvtPtr   := IntToStr(EventExist(Patient.DFN, FEventIFN));
      PTEventPtr  := APtEvtPtr;
      //PutNewOrder(AnOrder, ConstructOrder, OrderSource, IMOLoc);
      PutNewOrder(AnOrder, ConstructOrder, OrderSource);
      if not SaveAsCurrent then
      begin
        AnOrder.EventPtr  := PTEventPtr;
        AnOrder.EventName := 'Delayed ' + MixedCase(Piece(EventInfo(APtEvtPtr),'^',4));
      end;
    end
    else
    begin
      //PutNewOrder(AnOrder, ConstructOrder, OrderSource, IMOLoc);
      PutNewOrder(AnOrder, ConstructOrder, OrderSource);
      if not SaveAsCurrent then
      begin
        if (FEventIFN > 0) and (FParentEvent.ParentIFN > 0) then
        begin
          {For a child event, create a parent event in 100.2 first}
          SaveEvtForOrder(Patient.DFN, FParentEvent.ParentIFN, AnOrder.ID);
          NewPtEvtPtr := EventExist(Patient.DFN, FParentEvent.ParentIFN);
          AnOrder.EventPtr := IntToStr(NewPtEvtPtr);
          AnOrder.EventName := 'Delayed ' + MixedCase(Piece(EventInfo(IntToStr(NewPtEvtPtr)),'^',4));
          {Then create the child event in 100.2}
          SaveEvtForOrder(Patient.DFN, FEventIFN, '');
          NewPtEvtPtr := EventExist(Patient.DFN, FEventIFN);
        end
        else if (FEventIFN > 0) and (FParentEvent.ParentIFN = 0) then
        begin
          SaveEvtForOrder(Patient.DFN, FEventIFN, AnOrder.ID);
          NewPtEvtPtr := EventExist(Patient.DFN, FEventIFN);
          AnOrder.EventPtr := IntToStr(NewPtEvtPtr);
          AnOrder.EventName := 'Delayed ' + MixedCase(Piece(EventInfo(IntToStr(NewPtEvtPtr)),'^',4));
        end;
        if FEventIFN > 0 then
        begin
          for j := 1 to frmOrders.lstSheets.Items.Count - 1 do
          begin
            if FEventIFN = StrToInt( Piece(Piece(frmOrders.lstSheets.Items[j],'^',1),';',1) ) then
            begin
              frmOrders.lstSheets.Items[j] := IntToStr( NewPtEvtPtr) + '^' + Piece(frmOrders.lstSheets.Items[j],'^',2);
              frmOrders.lstSheets.ItemIndex := j;
            end;
          end;
        end;
      end;
    end;
    DEASig := ''; //PKI
  end;
  AnOrder.EditOf := FEditOrder;
{Begin BillingAware}
  if  rpcGetBAMasterSwStatus then
  begin
     UBAGlobals.BAOrderID := '';
     UBAGlobals.BAOrderID := AnOrder.ID;
  end;
{Begin BillingAware}
end;

procedure TResponses.SetControl(AControl: TControl; const APromptID: string; AnInstance: Integer);
{ sets the value of a control, uses ID string & instance to find the right response entry }
var
  i: Integer;
  AResponse: TResponse;
  IEN: integer;
  HasObjects: boolean;

  procedure AssignBPText(List: TStrings; const Value: string);
  var
    tmp, cptn, DocInfo: string;
    LType: TTemplateLinkType;

  begin
    DocInfo := '';
    LType := DisplayGroupToLinkType(DisplayGroup);
    cptn := 'Reason for Request: ' + EValueFor('ORDERABLE', 1);
    tmp := Value;
    case LType of
      ltConsult:   IEN := StrToIntDef(GetServiceIEN(IValueFor('ORDERABLE', 1)),0);
      ltProcedure: IEN := StrToIntDef(GetProcedureIEN(IValueFor('ORDERABLE', 1)),0);
      else         IEN := 0;
    end;
    ExpandOrderObjects(tmp, HasObjects);
    FOrderContainsObjects := FOrderContainsObjects or HasObjects;
    if IEN <> 0 then
      begin
        // template will execute on copy order if commented out  (tried to eliminate for CSV v22, RV)
        //
        //if (Length(tmp) > 0) and (not HasTemplateField(tmp)) then
        //  CheckBoilerplate4Fields(tmp, cptn)
        //else

        // CQ #11669 - changing an existing order shouldn't restart template - JM
          if assigned(frmODBase) and (frmODBase.FOrderAction = ORDER_EDIT) then
            CheckBoilerplate4Fields(tmp, cptn)
          else
            ExecuteTemplateOrBoilerPlate(tmp, IEN, LType, nil, cptn, DocInfo);
      end
    else
      CheckBoilerplate4Fields(tmp, cptn);
    List.Text := tmp;
  end;

begin
  AResponse := FindResponseByName(APromptID, AnInstance);
  if AResponse = nil then Exit;
  if AControl is TLabel then with TLabel(AControl) do Caption := AResponse.EValue
  else if AControl is TStaticText then with TStaticText(AControl) do Caption := AResponse.EValue
  else if AControl is TButton then with TButton(AControl) do Caption := AResponse.EValue
  else if AControl is TEdit then with TEdit(AControl) do Text := AResponse.EValue
  else if AControl is TMaskEdit then with TMaskEdit(AControl) do Text := AResponse.EValue
  else if AControl is TCheckBox then with TCheckBox(AControl) do
    Checked := (StrToIntDef(AResponse.IValue,0) > 0) or
               (UpperCase(AResponse.IValue) = 'Y')
  else if AControl is TMemo then with TMemo(AControl) do AssignBPText(Lines, AResponse.EValue)
  else if AControl is TRichEdit then with TRichEdit(AControl) do AssignBPText(Lines, AResponse.EValue)
  else if AControl is TORListBox then with TORListBox(AControl) do
  begin
    for i := 0 to Items.Count - 1 do
      if Piece(Items[i], U, 1) = AResponse.IValue then ItemIndex := i;
  end
  else if AControl is TListBox then with TListBox(AControl) do
  begin
    for i := 0 to Items.Count - 1 do
      if Items[i] = AResponse.EValue then ItemIndex := i;
  end
  else if AControl is TComboBox then with TComboBox(AControl) do
  begin
    for i := 0 to Items.Count - 1 do
      if Items[i] = AResponse.EValue then ItemIndex := i;
    Text := AResponse.EValue;
  end
  else if AControl is TORComboBox then with TORComboBox(AControl) do
  begin
    if LongList then InitLongList(AResponse.EValue);
    SelectByID(AResponse.IValue);
    if (not LongList) and (ItemIndex < 0) then Text := AResponse.EValue;
  end;
end;

procedure TResponses.SetEventDelay(AnEvent: TOrderDelayEvent);
begin
  with AnEvent do if EventType in ['A','D','T','M','O'] then
  begin
    FEventIFN  := EventIFN;
    FEventName := EventName;
    FEventType := EventType;
    FSpecialty := Specialty;
    FEffective := Effective;
    FViewName := 'Delayed ' + MixedCase(EventName);
    FParentEvent := TParentEvent(AnEvent.TheParent);
  end;
end;

procedure TResponses.SetPromptFormat(const APromptID, NewFormat: string);
var
  i: Integer;
begin
  with FPrompts do for i := 0 to Count - 1 do with TPrompt(Items[i]) do
    if (ID = APromptID) then FmtCode := NewFormat;
end;

{ Private calls }

procedure TfrmODBase.ClearDialogControls;
var
  i: Integer;
begin
  FChanging := True;
  for i := 0 to ControlCount - 1 do
  begin
    // need to check if control is container & clear it's children also
    if (Controls[i] is TLabel) or (Controls[i] is TButton) or (Controls[i] is TStaticText) then Continue;
    if FPreserve.IndexOf(Controls[i]) < 0 then ClearControl(Controls[i]);
  end;
  FChanging := False;
  ShowOrderMessage( False );
end;

procedure TfrmODBase.SetDisplayGroup(Value: Integer);
begin
  FDisplayGroup := Value;
  Responses.FDisplayGroup := Value;
end;

procedure TfrmODBase.SetFillerID(const Value: string);
var
  x: string;
begin
  FFillerID := Value;
  if AddFillerAppID(FFillerID) and OrderChecksEnabled then
  begin
    StatusText('Order Checking...');
    x := OrderChecksOnDisplay(FillerID);
    StatusText('');
    if Length(x) > 0 then InfoBox(x, TC_ORDERCHECKS, MB_OK);
  end;
end;

{ Protected Calls (used by descendant forms) }

procedure TfrmODBase.InitDialog;
begin
  ClearDialogControls;
  Responses.Clear;
  FAcceptOK := False;
  FAbortOrder := False;
end;

function TfrmODBase.OrderForInpatient: Boolean;
var
  AnEventType: Char;
begin
  AnEventType := OrderEventTypeOnCreate;
  // if event type = #0, then it wasn't passed or we're not in create
  if AnEventType = #0 then AnEventType := Responses.FEventType;
  case AnEventType of
  'A','O': Result := True;
  'D': Result := False;
  'T':
  begin
    if IsPassEvt1(FEvtID,'T') then  Result := False
    else Result := True;
  end
  else Result := Patient.Inpatient;
  end;
end;

procedure TfrmODBase.ShowOrderMessage(Show: boolean);
begin
  if Show then
  begin
    pnlMessage.Visible := True;
    pnlMessage.BringToFront;
    memMessage.TabStop := True;
  end
  else
  begin
    pnlMessage.Visible := False;
    pnlMessage.SendToBack;
    memMessage.TabStop := False;
  end;
end;

procedure TfrmODBase.OrderMessage(const AMessage: string);
{Caller needs to set pnlMessage.TabOrder}
begin
  memMessage.Lines.SetText(PChar(AMessage));
  //begin CQ: 2640
  memMessage.SelStart := 0; // Put at first character
  SendMessage(memMessage.Handle, WM_VSCROLL, SB_TOP, 0);
  //End CQ: 2640
  ShowOrderMessage(ContainsVisibleChar(AMessage));
end;

procedure TfrmODBase.PreserveControl(AControl: TControl);
begin
  FPreserve.Add(AControl);
end;

procedure TfrmODBase.SetDialogIEN(Value: Integer);
begin
  FDialogIEN := Value;
end;

procedure TfrmODBase.SetupDialog(OrderAction: Integer; const ID: string);
begin
  FOrderAction := OrderAction;
  FAbortOrder := False;
  case OrderAction of
  ORDER_NEW:   {nothing};
  ORDER_EDIT:  Responses.SetEditOrder(ID);
  ORDER_COPY:  Responses.SetCopyOrder(ID);
  ORDER_QUICK: Responses.SetQuickOrderByID(ID);
  end;
  if Responses.FEventType in ['A','D','T','M','O'] then Caption := Caption + ' (Delayed ' + Responses.FEventName + ')'; // ' (Event Delayed)';
  if OrderAction in [ORDER_EDIT, ORDER_COPY] then cmdQuit.Caption := 'Cancel';
end;

function TfrmODBase.GetEffectiveDate: TFMDateTime;
begin
  Result := Responses.FEffective;
end;

function TfrmODBase.GetKeyVariable(const Index: string): string;
begin
  if      UpperCase(Index) = 'LRFZX'    then Result := Piece(FKeyVariables, U, 1)
  else if UpperCase(Index) = 'LRFSAMP'  then Result := Piece(FKeyVariables, U, 2)
  else if UpperCase(Index) = 'LRFSPEC'  then Result := Piece(FKeyVariables, U, 3)
  else if UpperCase(Index) = 'LRFDATE'  then Result := Piece(FKeyVariables, U, 4)
  else if UpperCase(Index) = 'LRFURG'   then Result := Piece(FKeyVariables, U, 5)
  else if UpperCase(Index) = 'LRFSCH'   then Result := Piece(FKeyVariables, U, 6)
  else if UpperCase(Index) = 'PSJNOPC'  then Result := Piece(FKeyVariables, U, 7)
  else if UpperCase(Index) = 'GMRCNOPD' then Result := Piece(FKeyVariables, U, 8)
  else if UpperCase(Index) = 'GMRCNOAT' then Result := Piece(FKeyVariables, U, 9)
  else if UpperCase(Index) = 'GMRCREAF' then Result := Piece(FKeyVariables, U, 10)
  else                                       Result := '';
end;

procedure TfrmODBase.SetKeyVariables(const VarStr: string);
begin
  FKeyVariables := VarStr;
end;

procedure TfrmODBase.Validate(var AnErrMsg: string);
const
  TX_OR_DISABLED = 'Ordering has been disabled.  Press Quit.';
  TX_PAST_START  = 'The start date may not be earlier than the present.';
  TX_NO_LOCATION = 'A location must be identified.' + CRLF +
                   '(Select File | Update Provider/Location)';
  TX_NO_PROVIDER = 'A provider who is authorized to write orders must be indentified.' + CRLF +
                   '(Select File | Update Provider/Location)';
var
  StartStr,x: string;
  StartDt: TFMDateTime;
begin
  AnErrMsg := '';
  if User.NoOrdering then AnErrMsg := 'Ordering has been disabled.  Press Quit.';
  // take this out if we <don't> need to check for earlier start date/times
  // should this check be against FMNow??
  StartStr := Piece(Responses.IValueFor('START', 1), '.', 1);
  if not IsFMDateTime(StartStr)
    then StartDt := StrToFMDateTime(StartStr)
    else StartDt := StrToFloat(StartStr);
  if (StartDt > 0) and (StartDt < FMToday)
    then AnErrMsg := 'The start date may not be earlier than the present.';
  //frmFrame.UpdatePtInfoOnRefresh;
  if (not Patient.Inpatient) and (Responses.EventIFN > 0) then x := ''
  else
  begin
    if Encounter.Location = 0 then AnErrMsg := TX_NO_LOCATION;
  end;
  if (Encounter.Provider = 0) or (PersonHasKey(Encounter.Provider, 'PROVIDER') = False)
    then AnErrMsg := TX_NO_PROVIDER;
  if IsPFSSActive and Responses.PromptExists('VISITSTR') then
    Responses.Update('VISITSTR', 1, Encounter.VisitStr, Encounter.VisitStr);
end;

{ Form Calls }

procedure TfrmODBase.FormCreate(Sender: TObject);
begin
  inherited;
  frmODBase   := Self;
  FAcceptOK   := False;
  FAutoAccept := False;
  FChanging   := False;
  FClosing    := False;
  FFromQuit   := False;
  FTestMode   := False;
  FIncludeOIPI := True;
  FEvtForPassDischarge := #0;
  FCtrlInits  := TCtrlInits.Create;
  FResponses  := TResponses.Create;
  FPreserve   := TList.Create;
  FIsIMO      := False;          //imo
  FIsSupply := False;
  {This next bit is mostly for the font size.  It also sets the default size of
  order forms if it is not in the database.  This is handy if a new user wants
  to have large fonts.  However, in the general case, this will be resized
  through rMisc.SetFormPosition.}
  if not AutoSizeDisabled then
    ResizeFormToFont(self);
  DoSetFontSize(MainFontSize);

  imgMessage.Picture.Icon.Handle := LoadIcon(0, IDI_ASTERISK);
  //if User.NoOrdering then cmdAccept.Enabled := False;
  if uCore.User.NoOrdering then cmdAccept.Enabled := False;
  FDlgFormID := OrderFormIDOnCreate;
  FEvtID     := OrderEventIDOnCreate;
  FEvtType   := OrderEventTypeOnCreate;
  FEvtName   := OrderEventNameOnCreate;
  DefaultButton := cmdAccept;
end;

procedure TfrmODBase.FormDestroy(Sender: TObject);
begin
  frmODBase := nil;
  FCtrlInits.Free;
  FResponses.Free;
  FPreserve.Free;
  //DestroyingOrderDialog;
  if Assigned(FCallOnExit) then FCallOnExit;
  if (Owner <> nil) and (Owner is TWinControl)
    then SendMessage(TWinControl(Owner).Handle, UM_DESTROY, FRefNum, 0);
  inherited;
end;

procedure TfrmODBase.FormKeyPress(Sender: TObject; var Key: Char);
{ causes RETURN to be treated as pressing a tab key (need to have user preference) }
begin
  inherited;
  if (Key = #13) and not (ActiveControl is TCustomMemo) then
  begin
    Key := #0;
    Perform(WM_NEXTDLGCTL, 0, 0);
  end;
end;

{ Accept & Quit Buttons }

function TfrmODBase.AcceptOrderChecks: Boolean;
{ returns True if order was accepted with order checks, false if order should be cancelled }
var
  StartDtTm: string;
  OIList: TStringList;
begin
  Result := True;
  Responses.OrderChecks.Clear;
  if not OrderChecksEnabled then Exit;
  OIList := TStringList.Create;
  try
    StatusText('Order Checking...');
    Responses.BuildOCItems(OIList, StartDtTm, FillerID);
    OrderChecksOnAccept(Responses.OrderChecks, FillerID, StartDtTm, OIList, DupORIFN);
    DupORIFN := '';
    StatusText('');
    Result :=  AcceptOrderWithChecks(Responses.OrderChecks);
  finally
    OIList.Free;
  end;
end;

function TfrmODBase.ValidSave: Boolean;
const
  TX_NO_SAVE     = 'This order cannot be saved for the following reason(s):' + CRLF + CRLF;
  TX_NO_SAVE_CAP = 'Unable to Save Order';
  TX_SAVE_ERR    = 'Unexpected error - it was not possible to save this order.';
var
  ErrMsg: string;
  NewOrder: TOrder;
  CanSign, OrderAction: Integer;
  IsDelayOrder: boolean;
  //thisSourceOrder: TOrder;
begin
  Result := True;
  Validate(ErrMsg);
  IsDelayOrder := False;
  if Length(ErrMsg) > 0 then
  begin
    InfoBox(TX_NO_SAVE + ErrMsg, TX_NO_SAVE_CAP, MB_OK);
    Result := False;
    Exit;
  end;
  if not AcceptOrderChecks then
  begin
    if AskAnotherOrder(DialogIEN) then
        InitDialog           // ClearDialogControls is in InitDialog
      else
        begin
          ClearDialogControls;    // to allow form to close without prompting to save order
          Close;
        end;
    Result := False;
    Exit;
  end;
  if FTestMode then
  begin
    Result := False;
    Exit;
  end;
  // LES validation checking for changed lab order
  if not LESValidationCheck then Exit;
  NewOrder := TOrder.Create;

  Responses.SaveOrder(NewOrder, DialogIEN, FIsIMO);

  if frmOrders.IsDefaultDlg then
  begin
    frmOrders.EventDefaultOrder := NewOrder.ID;
    frmOrders.EvtOrderList.Add(NewOrder.EventPtr + '^' + NewOrder.ID);
    frmOrders.IsDefaultDlg := False;
  end;
  if Length(DfltCopay)>0 then SetDefaultCoPayToNewOrder(NewOrder.ID, DfltCopay);
  if (Length(FEvtName)>0) then
  begin
    NewOrder.EventName := 'Delayed ' + MixedCase(FEvtName);
    FEvtName := '';
  end;
  if not ProcessOrderAcceptEventHook(NewOrder.ID, NewOrder.DGroup) then
  begin
    if NewOrder.ID <> '' then
    begin
      if (Encounter.Provider = User.DUZ) and User.CanSignOrders
        then CanSign := CH_SIGN_YES
        else CanSign := CH_SIGN_NA;
      if NewOrder.Signature = OSS_NOT_REQUIRE then CanSign := CH_SIGN_NA;
      if NewOrder.EventPtr <> '' then IsDelayOrder := True;
      Changes.Add(CH_ORD, NewOrder.ID, NewOrder.Text, Responses.FViewName, CanSign,'',0, NewOrder.DGroupName, False,IsDelayOrder);

    UBAGlobals.TargetOrderID := NewOrder.ID;

      if Responses.EditOrder = '' then OrderAction := ORDER_NEW else OrderAction := ORDER_EDIT;
      SendMessage(Application.MainForm.Handle, UM_NEWORDER, OrderAction, Integer(NewOrder));
    end
    else InfoBox(TX_SAVE_ERR, TX_NO_SAVE_CAP, MB_OK);
  end;
  NewOrder.Free;      // free here - recieving forms should get own copy using assign
end;

procedure TfrmODBase.cmdAcceptClick(Sender: TObject);
const
  TX_CMPTEVT = ' occurred since you started writing delayed orders. '
    + 'The orders that were entered and signed have now been released. '
    + 'Any unsigned orders will be released immediately upon signature. '
    + #13#13
    + 'To write new delayed orders for this event you need to click the write delayed orders button again and select the appropriate event. '
    + 'Orders delayed to this same event will remain delayed until the event occurs again.'
    + #13#13
    + 'The Orders tab will now be refreshed and switched to the Active Orders view. '
    + 'If you wish to continue to write active orders for this patient, '
    + 'close this message window and continue as usual.';
var
  theGrpName: string;
  alreadyClosed: boolean;
  LateTrayFields: TLateTrayFields;
  x, CxMsg: string;
begin
  FAcceptOK := False;
  CIDCOkToSave := False;
  alreadyClosed := False;
  self.Responses.Cancel := False;
  if frmOrders <> nil then
  begin
    if (frmOrders.TheCurrentView <> nil) and (frmOrders.TheCurrentView.EventDelay.PtEventIFN>0) and IsCompletedPtEvt(frmOrders.TheCurrentView.EventDelay.PtEventIFN) then
    begin
      theGrpName := 'Delayed ' + frmOrders.TheCurrentView.EventDelay.EventName;
      SaveAsCurrent := True;
    end;
  end;

  // check for diet orders that will be auto-DCd because of start/stop overlaps
  if Responses.Dialog = 'FHW1' then
  begin
    if (Self.EvtID <> 0) then
    begin
      CheckForAutoDCDietOrders(Self.EvtID, Self.DisplayGroup, '', CxMsg, cmdAccept);
      if CxMsg <> '' then
      begin
        if InfoBox(CxMsg + CRLF + CRLF +
           'Have you done either of the above?', 'Possible delayed order conflict',
           MB_ICONWARNING or MB_YESNO) = ID_NO
           then exit;
      end;
    end
    else if FAutoAccept then
    begin
      x := CurrentDietText;
      CheckForAutoDCDietOrders(0, Self.DisplayGroup, x, CxMsg, nil);
      if CxMsg <> '' then
      begin
        if InfoBox(CxMsg + CRLF +
                  'Are you sure?', 'Confirm', MB_ICONWARNING or MB_YESNO) = ID_NO then
        begin
          //AbortOrder := True;
          FAcceptOK := FALSE;
          //cmdQuitClick(Self);
          exit;
        end;
      end;
    end;
  end;

  if ValidSave then
  begin
    FAcceptOK := True;
    CIDCOkToSave := True;
    with Responses do
      if not FAutoAccept and (CopyOrder = '') and (EditOrder = '') and (TransferOrder = '')
        and AskAnotherOrder(DialogIEN)
        then InitDialog           // ClearDialogControls is in InitDialog
        else
        begin
          LateTrayFields.LateMeal := #0;
          with Responses do
            if FAutoAccept and ((Dialog = 'FHW1') or (Dialog = 'FHW OP MEAL') or (Dialog ='FHW SPECIAL MEAL')) then
            begin
              LateTrayCheck(Responses, Self.EvtID, not OrderForInpatient, LateTrayFields);
            end;
          ClearDialogControls;    // to allow form to close without prompting to save order
          with LateTrayFields do if LateMeal <> #0 then LateTrayOrder(LateTrayFields, OrderForInpatient);
          Close;
          alreadyClosed := True;
        end;
    if NoFresh then
    begin
      if SaveAsCurrent then
      begin
        SaveAsCurrent := False;
        with Responses do
        begin
          if not alreadyClosed then
          begin
            ClearDialogControls;
            Close;
          end;
        end;
        frmOrders.GroupChangesUpdate(theGrpName);
        Exit;
      end;
    end else
    begin
      if SaveAsCurrent then
      begin
        SaveAsCurrent := False;
        with Responses do
        begin
          if not alreadyClosed then
          begin
            ClearDialogControls;
            Close;
          end;
        end;
        frmOrders.GroupChangesUpdate(theGrpName);
        //EDONeedRefresh := True;
        Exit;
      end;
    end
  end; {if ValidSave}
  if SaveAsCurrent then
    SaveAsCurrent := False;
end;

procedure TfrmODBase.cmdQuitClick(Sender: TObject);
begin
  inherited;
  FFromQuit := True;
  Close;
end;

procedure TfrmODBase.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  inherited;
  // unlock an order that is being edited if accept wasn't pressed
  //   this unlock is currently done in ActivateOrderDialog
  //with Responses do if (Length(EditOrder) > 0) and (not FAcceptOK) then UnlockOrder(EditOrder);
  PopKeyVars;
  SaveUserBounds(Self);
  FClosing := True;
  Action := caFree;
  (*
  if User.NoOrdering then Exit;
  if Length(memOrder.Text) > 0 then
    if InfoBox(TX_ACCEPT + memOrder.Text, TX_ACCEPT_CAP, MB_YESNO) = ID_YES then
      if not ValidSave then
      begin
        FClosing := False;
        Action := caNone;
      end;
  *)
end;

procedure TfrmODBase.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  inherited;
  //self.Responses.Cancel := False;
  if User.NoOrdering then Exit;
  if FAbortOrder then exit;
  if FOrderAction in [ORDER_EDIT, ORDER_COPY] then Exit;  // don't invoke verify dialog
  if FOrderAction = ORDER_QUICK then Exit;                // should this be here??
  if frmFrame.ContextChanging then
    begin
      // close any sub-dialogs created by order dialog FIRST!!
      exit;
    end;
  if FFromQuit = False then updateSig;
  if Length(memOrder.Text) > 0 then
  begin
    if InfoBox(TX_ACCEPT + memOrder.Text, TX_ACCEPT_CAP, MB_YESNO) = ID_YES
      then CanClose := ValidSave
      else memOrder.Text := '';  // so don't return False on subsequent CloseQuery
  end;
end;

procedure TfrmODBase.TabClose(var CanClose: Boolean);
begin
  inherited;
  CanClose := True;
  if Length(memOrder.Text) > 0 then
    if InfoBox(TX_ACCEPT + memOrder.Text, TX_ACCEPT_CAP, MB_YESNO) = ID_YES then
      if not ValidSave then CanClose := False;
  if CanClose then InitDialog;
end;

procedure TfrmODBase.updateSig;
begin

end;

procedure TfrmODBase.memMessageMouseUp(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  inherited;
  ShowOrderMessage( False );
end;

procedure TfrmODBase.SetDefaultCoPay(AnOrderID: string);
begin
  FDfltCopay := GetDefaultCopay(AnOrderID);
end;

procedure TfrmODBase.DoSetFontSize( FontSize: integer);
begin
  if AutoSizeDisabled then
    ResizeAnchoredFormToFont( Self )
  else
  begin
    //You get to resize the window yourself!
    Font.Size := FontSize;
    memMessage.DefAttributes.Size := FontSize;
  end;
end;

procedure TfrmODBase.SetFontSize( FontSize: integer);
begin
  DoSetFontSize( FontSize );
end;

function TResponses.GetIENForPrompt(const APromptID: string): Integer;
var
  i: Integer;
begin
  Result := 0;
  with FPrompts do for i := 0 to Count - 1 do with TPrompt(Items[i]) do
    if (ID = APromptID) then
    begin
      Result := IEN;
      break;
    end;
end;

procedure TfrmODBase.pnlMessageExit(Sender: TObject);
begin
  inherited;
  ShowOrderMessage(False);
end;

procedure TfrmODBase.pnlMessageMouseDown(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  inherited;
  FMessageClickX := X;
  FMessageClickY := Y;
end;

procedure TfrmODBase.pnlMessageMouseMove(Sender: TObject;
  Shift: TShiftState; X, Y: Integer);
begin
  inherited;
  if (ssLeft in Shift) then
    pnlMessage.SetBounds(pnlMessage.Left + X - FMessageClickX, pnlMessage.Top + Y - FMessageClickY, pnlMessage.Width, pnlMessage.Height);
end;

function TfrmODBase.LESValidationCheck: boolean;
var
  idx: integer;
  LESGrpList,LESRejectedReason: TStringList;
  IsLESOrder: boolean;
  TempMSG,LESODInfo: string;
begin
  Result := True;
  if Length(Responses.EditOrder)>1 then
  begin
    LESGrpList := TStringList.Create;
    PiecesToList(GetDispGroupForLES,'^',LESGrpList);
    IsLESOrder := False;
    for idx:=0 to LESGrpList.Count - 1 do
      if StrToIntDef(LESGrpList[idx],0) = Responses.DisplayGroup then
      begin
        IsLESOrder := True;
        Break;
      end;
    if IsLESOrder then
    begin
      TempMSG := '';
      LESODInfo := Patient.DFN +
                  '^' + Responses.IValueFor('ORDERABLE',1) +
                  '^' + IntToStr(Encounter.Location) +
                  '^' + IntToStr(Encounter.Provider) +
                  '^' + Responses.IValueFor('START',1);
      LESRejectedReason := TStringList.Create;
      LESValidationForChangedLabOrder(LESRejectedReason,LESODInfo);
      if LESRejectedReason.Count > 0 then
      begin
        for idx := 0 to LESRejectedReason.Count - 1 do
        begin
          if Length(LESRejectedReason[idx])>0 then
            TempMSG := TempMSG + #13 + LESRejectedReason[idx];
        end;
        if Length(TempMSG)>0 then
        begin
          ShowMsg(TempMSG);
          Result := False;
        end;
      end;
    end;
  end;
end;


end.