//kt -- Modified with SourceScanner on 7/17/2007 unit fFrame; { This is the main form for the CPRS GUI. It provides a patient-encounter-user framework which all the other forms of the GUI use. } {$OPTIMIZATION OFF} // REMOVE AFTER UNIT IS DEBUGGED {$WARN SYMBOL_PLATFORM OFF} {$DEFINE CCOWBROKER} {.$define debug} interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Tabs, ComCtrls, ExtCtrls, Menus, StdCtrls, Buttons, ORFn, fPage, uConst, ORCtrls, Trpcb, OleCtrls, VERGENCECONTEXTORLib_TLB, ComObj, AppEvnts, inifiles, //kt mod 6/29/07 ----- {$IFDEF USE_SKINS} ipSkinManager,//kt 9/7/08 {$ENDIF} fWebTab, DKLang, TntForms, TntStdCtrls, TntSystem, TntSysUtils; //kt end mod --------- type TfrmFrame = class(TForm) pnlToolbar: TPanel; stsArea: TStatusBar; tabPage: TTabControl; pnlPage: TPanel; bvlPageTop: TBevel; bvlToolTop: TBevel; pnlPatient: TKeyClickPanel; lblPtName: TStaticText; lblPtSSN: TStaticText; lblPtAge: TStaticText; pnlVisit: TKeyClickPanel; lblPtLocation: TStaticText; lblPtProvider: TStaticText; mnuFrame: TMainMenu; mnuFile: TMenuItem; mnuFileExit: TMenuItem; mnuFileOpen: TMenuItem; mnuFileReview: TMenuItem; Z1: TMenuItem; mnuFilePrint: TMenuItem; mnuEdit: TMenuItem; mnuEditUndo: TMenuItem; Z3: TMenuItem; mnuEditCut: TMenuItem; mnuEditCopy: TMenuItem; mnuEditPaste: TMenuItem; Z4: TMenuItem; mnuEditPref: TMenuItem; Prefs1: TMenuItem; mnu24pt1: TMenuItem; mnu18pt1: TMenuItem; mnu14pt1: TMenuItem; mnu12pt1: TMenuItem; mnu10pt1: TMenuItem; mnu8pt: TMenuItem; mnuHelp: TMenuItem; mnuHelpContents: TMenuItem; mnuHelpTutor: TMenuItem; Z5: TMenuItem; mnuHelpAbout: TMenuItem; mnuTools: TMenuItem; mnuView: TMenuItem; mnuViewChart: TMenuItem; mnuChartReports: TMenuItem; mnuChartLabs: TMenuItem; mnuChartDCSumm: TMenuItem; mnuChartCslts: TMenuItem; mnuChartNotes: TMenuItem; mnuChartOrders: TMenuItem; mnuChartMeds: TMenuItem; mnuChartProbs: TMenuItem; mnuChartCover: TMenuItem; mnuHelpBroker: TMenuItem; mnuFileEncounter: TMenuItem; mnuViewDemo: TMenuItem; mnuViewPostings: TMenuItem; mnuHelpLists: TMenuItem; Z6: TMenuItem; mnuHelpSymbols: TMenuItem; mnuFileNext: TMenuItem; Z7: TMenuItem; mnuFileRefresh: TMenuItem; pnlPrimaryCare: TKeyClickPanel; lblPtCare: TStaticText; lblPtAttending: TStaticText; pnlCIRN: TKeyClickPanel; lblCIRN: TLabel; lblCIRNData: TLabel; pnlReminders: TKeyClickPanel; imgReminder: TImage; mnuViewReminders: TMenuItem; anmtRemSearch: TAnimate; lstCIRNLocations: TORListBox; popCIRN: TPopupMenu; popCIRNSelectAll: TMenuItem; popCIRNSelectNone: TMenuItem; popCIRNClose: TMenuItem; mnuFilePrintSetup: TMenuItem; LabInfo1: TMenuItem; mnuFileNotifRemove: TMenuItem; Z8: TMenuItem; mnuToolsOptions: TMenuItem; mnuChartSurgery: TMenuItem; OROpenDlg: TOpenDialog; mnuFileResumeContext: TMenuItem; mnuFileResumeContextSet: TMenuItem; Useexistingcontext1: TMenuItem; mnuFileBreakContext: TMenuItem; pnlCCOW: TPanel; imgCCOW: TImage; pnlPatientSelected: TPanel; pnlNoPatientSelected: TPanel; pnlFlag: TKeyClickPanel; lblFlag: TLabel; pnlPostings: TKeyClickPanel; lblPtPostings: TStaticText; lblPtCWAD: TStaticText; mnuFilePrintSelectedItems: TMenuItem; popAlerts: TPopupMenu; mnuAlertContinue: TMenuItem; mnuAlertForward: TMenuItem; mnuAlertRenew: TMenuItem; AppEvents: TApplicationEvents; paVAA: TKeyClickPanel; mnuToolsGraphing: TMenuItem; laVAA2: TButton; laMHV: TButton; lblCIRNAvail: TLabel; mnuViewInformation: TMenuItem; mnuViewVisits: TMenuItem; mnuViewPrimaryCare: TMenuItem; mnuViewMyHealtheVet: TMenuItem; mnuInsurance: TMenuItem; mnuViewFlags: TMenuItem; mnuViewRemoteData: TMenuItem; DKLanguageController1: TDKLanguageController; EditDemographics: TMenuItem; PrintLabels1: TMenuItem; procedure tabPageChange(Sender: TObject); procedure FormCreate(Sender: TObject); procedure CheckForTMGPatch; procedure FormResize(Sender: TObject); procedure pnlPatientMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure pnlPatientMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure pnlVisitMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure pnlVisitMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure mnuFileExitClick(Sender: TObject); procedure pnlPostingsMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure pnlPostingsMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure mnuFontSizeClick(Sender: TObject); procedure mnuChartTabClick(Sender: TObject); procedure FormDestroy(Sender: TObject); procedure mnuFileOpenClick(Sender: TObject); procedure mnuHelpBrokerClick(Sender: TObject); procedure mnuFileEncounterClick(Sender: TObject); procedure mnuViewPostingsClick(Sender: TObject); procedure mnuHelpAboutClick(Sender: TObject); procedure mnuFileReviewClick(Sender: TObject); procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean); procedure mnuHelpListsClick(Sender: TObject); procedure ToolClick(Sender: TObject); procedure mnuEditClick(Sender: TObject); procedure mnuEditUndoClick(Sender: TObject); procedure mnuEditCutClick(Sender: TObject); procedure mnuEditCopyClick(Sender: TObject); procedure mnuEditPasteClick(Sender: TObject); procedure mnuHelpSymbolsClick(Sender: TObject); procedure FormClose(Sender: TObject; var Action: TCloseAction); procedure mnuFilePrintClick(Sender: TObject); procedure mnuGECStatusClick(Sender: TObject); procedure mnuFileNextClick(Sender: TObject); procedure stsAreaMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure stsAreaMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure stsAreaDrawPanel(StatusBar: TStatusBar; Panel: TStatusPanel; const Rect: TRect); procedure pnlPrimaryCareMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure pnlPrimaryCareMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); function FormHelp(Command: Word; Data: Integer; var CallHelp: Boolean): Boolean; procedure pnlRemindersMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure pnlRemindersMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure pnlCIRNClick(Sender: TObject); procedure lstCIRNLocationsClick(Sender: TObject); procedure popCIRNCloseClick(Sender: TObject); procedure popCIRNSelectAllClick(Sender: TObject); procedure popCIRNSelectNoneClick(Sender: TObject); procedure mnuFilePrintSetupClick(Sender: TObject); procedure lstCIRNLocationsChange(Sender: TObject); procedure LabInfo1Click(Sender: TObject); procedure mnuFileNotifRemoveClick(Sender: TObject); procedure mnuToolsOptionsClick(Sender: TObject); procedure mnuFileRefreshClick(Sender: TObject); procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); procedure FormActivate(Sender: TObject); procedure pnlPrimaryCareEnter(Sender: TObject); procedure pnlPrimaryCareExit(Sender: TObject); procedure pnlPatientClick(Sender: TObject); procedure pnlVisitClick(Sender: TObject); procedure pnlPrimaryCareClick(Sender: TObject); procedure pnlRemindersClick(Sender: TObject); procedure pnlPostingsClick(Sender: TObject); procedure ctxContextorCanceled(Sender: TObject); procedure ctxContextorCommitted(Sender: TObject); procedure ctxContextorPending(Sender: TObject; const aContextItemCollection: IDispatch); procedure mnuFileBreakContextClick(Sender: TObject); procedure mnuFileResumeContextGetClick(Sender: TObject); procedure mnuFileResumeContextSetClick(Sender: TObject); procedure pnlFlagMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure pnlFlagMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure pnlFlagClick(Sender: TObject); procedure mnuViewDemoClick(Sender: TObject); procedure mnuFilePrintSelectedItemsClick(Sender: TObject); procedure mnuAlertRenewClick(Sender: TObject); procedure mnuAlertForwardClick(Sender: TObject); procedure pnlFlagEnter(Sender: TObject); procedure pnlFlagExit(Sender: TObject); procedure tabPageMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure lstCIRNLocationsExit(Sender: TObject); procedure AppEventsActivate(Sender: TObject); procedure ScreenActiveFormChange(Sender: TObject); procedure AppEventsShortCut(var Msg: TWMKey; var Handled: Boolean); procedure mnuToolsClick(Sender: TObject); procedure mnuToolsGraphingClick(Sender: TObject); procedure pnlCIRNMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure pnlCIRNMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure laMHVClick(Sender: TObject); procedure laVAA2Click(Sender: TObject); procedure ViewInfo(Sender: TObject); procedure mnuViewInformationClick(Sender: TObject); procedure EditDemographicsClick(Sender: TObject); procedure tabPageDrawTab(Control: TCustomTabControl; TabIndex: Integer; const Rect: TRect; Active: Boolean); procedure PrintLabels1Click(Sender: TObject); private //kt Begin Mod (change Consts to Vars) 7/17/2007 TX_ECSOPT : string; TX_PTINQ : string; TX_NOTIF_STOP : string; TC_NOTIF_STOP : string; TX_UNK_NOTIF : string; TC_UNK_NOTIF : string; TX_NO_SURG_NOTIF : string; TC_NO_SURG_NOTIF : string; TX_VER1 : string; TX_VER2 : string; TX_VER3 : string; TX_VER_REQ : string; TX_VER_OLD : string; TX_VER_OLD2 : string; TX_VER_NEW : string; TC_VER : string; TC_CLIERR : string; TC_DGSR_ERR : string; TC_DGSR_SHOW : string; TC_DGSR_DENY : string; TX_DGSR_YESNO : string; TX_CCOW_LINKED : string; TX_CCOW_CHANGING: string; TX_CCOW_BROKEN : string; TX_CCOW_ERROR : string; TC_CCOW_ERROR : string; //kt End Mod ------------------- FJustEnteredApp : boolean; FCCOWInstalled: boolean; FCCOWContextChanging: boolean; FCCOWIconName: string; FCCOWDrivedChange: boolean; FCCOWBusy: boolean; FCCOWError: boolean; FNoPatientSelected: boolean; FRefreshing: boolean; FClosing: boolean; FContextChanging: Boolean; FChangeSource: Integer; FCreateProgress: Integer; FEditCtrl: TCustomEdit; FLastPage: TfrmPage; FNextButtonL: Integer; FNextButtonR: Integer; FNextButtonActive: Boolean; FNextButtonBitmap: TBitmap; FTerminate: Boolean; FTabChanged: TNotifyEvent; FOldActivate: TNotifyEvent; FOldActiveFormChange: TNotifyEvent; FECSAuthUser: Boolean; FFixedStatusWidth: integer; FPrevInPatient: Boolean; FFirstLoad: Boolean; FFlagList: TStringList; FPrevPtID: string; FVitalsDLLActive: boolean; FGraphFloatActive: boolean; FGraphContext: string; procedure RefreshFixedStatusWidth; procedure FocusApplicationTopForm; procedure AppActivated(Sender: TObject); procedure AppDeActivated(Sender: TObject); procedure AppException(Sender: TObject; E: Exception); function AllowContextChangeAll(var Reason: string): Boolean; procedure ClearPatient; procedure ChangeFont(NewFontSize: Integer); procedure LoadTabColors(ColorsList : TStringList); //kt added 8/8/08 procedure SaveTabColors(ColorsList : TStringList); //procedure CreateTab(var AnInstance: TObject; AClass: TClass; ATabID: integer; ALabel: string); procedure CreateTab(ATabID: integer; ALabel: string); procedure DetermineNextTab; function ExpandCommand(x: string): string; procedure FitToolbar; procedure LoadSizesForUser; procedure SaveSizesForUser; procedure LoadUserPreferences; procedure SaveUserPreferences; procedure SwitchToPage(NewForm: TfrmPage); function TabToPageID(Tab: Integer): Integer; function TimeoutCondition: boolean; function GetTimedOut: boolean; procedure TimeOutAction; procedure SetUserTools; procedure SetDebugMenu; procedure SetupPatient(AFlaggedList : TStringList = nil); //procedure SetUpCIRN; procedure RemindersChanged(Sender: TObject); procedure ReportsOnlyDisplay; procedure UMInitiate(var Message: TMessage); message UM_INITIATE; procedure UMNewOrder(var Message: TMessage); message UM_NEWORDER; procedure UMStatusText(var Message: TMessage); message UM_STATUSTEXT; procedure UMShowPage(var Message: TMessage); message UM_SHOWPAGE; procedure WMSetFocus(var Message: TMessage); message WM_SETFOCUS; procedure WMSysCommand(var Message: TMessage); message WM_SYSCOMMAND; procedure UpdateECSParameter(var CmdParameter: string); function ValidECSUser: boolean; procedure StartCCOWContextor; function AllowCCOWContextChange(var CCOWResponse: UserResponse; NewDFN: string): boolean; procedure UpdateCCOWContext; procedure CheckHyperlinkResponse(aContextItemCollection: IDispatch; var HyperlinkReason: string); procedure CheckForDifferentPatient(aContextItemCollection: IDispatch; var PtChanged: boolean); {$IFDEF CCOWBROKER} procedure CheckForDifferentUser(aContextItemCollection: IDispatch; var UserChanged: boolean); {$ENDIF} procedure HideEverything; procedure ShowEverything; //function FindBestCCOWDFN(var APatientName: string): string; function FindBestCCOWDFN: string; procedure HandleCCOWError(AMessage: string); procedure SetupVars; procedure DrawTab(Control: TCustomTabControl; TabIndex: Integer; const Rect: TRect; Color : TColor; Active: Boolean); //kt added 8/8/08 public EnduringPtSelSplitterPos: integer; SkinAtStartup : boolean; //kt 9/8/08 SkinChanged : boolean; //kt 9/8/08 CurrentSkinFile : string; //kt 9/8/08 TMGAbort : boolean; //kt 3/25/09 procedure ActivateCurrentSkin; //kt 9/8/08 procedure InactivateSkin; //kt 9/8/08 procedure SetBADxList; function PageIDToTab(PageID: Integer): Integer; procedure ShowHideChartTabMenus(AMenuItem: TMenuItem); procedure UpdatePtInfoOnRefresh; function TabExists(ATabID: integer): boolean; procedure DisplayEncounterText; property ChangeSource: Integer read FChangeSource; property CCOWContextChanging: Boolean read FCCOWContextChanging; property CCOWDrivedChange: Boolean read FCCOWDrivedChange; property CCOWBusy: Boolean read FCCOWBusy write FCCOWBusy; property ContextChanging: Boolean read FContextChanging; property TimedOut: Boolean read GetTimedOut; property Closing: Boolean read FClosing; property OnTabChanged: TNotifyEvent read FTabChanged write FTabChanged; property VitalsDLLActive: boolean read FVitalsDLLActive write FVitalsDLLActive; property GraphFloatActive: boolean read FGraphFloatActive write FGraphFloatActive; property GraphContext: string read FGraphContext write FGraphContext; procedure ToggleMenuItemChecked(Sender: TObject); procedure SetUpCIRN; procedure RenameTabs; //kt added procedure RenameATab(ATabID: integer; ALabel: string); //kt added procedure SetATabVisibility(ATabID: integer; Visible: boolean; ALabel:string='x'); //kt added procedure SetWebTabsPerServer; //kt added procedure SetOneWebTabPerServer(WebTabNum: integer; URLMsg : string); //kt added end; var frmFrame: TfrmFrame; uTabList: TStringList; TabColorsList : TStringList; //kt added 8/8/08 TabColorsEnabled : Boolean; //kt 8/09 uRemoteType : string; FlaggedPTList: TStringList; ctxContextor : TContextorControl; NextTab, LastTab: Integer; uToolsMaxed, uToolsWarned: boolean; boolTMGPatchInstalled: boolean; //elh 6/20/08 {$IFDEF USE_SKINS} SkinManager : TipSkinManager; {$ENDIF} const PASSCODE = '_gghwn7pghCrOJvOV61PtPvgdeEU2u5cRsGvpkVDjKT_H7SdKE_hqFYWsUIVT1H7JwT6Yz8oCtd2u2PALqWxibNXx3Yo8GPcTYsNaxW' + 'ZFo8OgT11D5TIvpu3cDQuZd3Yh_nV9jhkvb0ZBGdO9n-uNXPPEK7xfYWCI2Wp3Dsu9YDSd_EM34nvrgy64cqu9_jFJKJnGiXY96Lf1ecLiv4LT9qtmJ-BawYt7O9JZGAswi344BmmCbNxfgvgf0gfGZea'; function TX_IN_USE : string; //kt replaced local constant with global scope function implementation {$R *.DFM} {$R sBitmaps} {$R sRemSrch} uses ORNet, rCore, fPtSelMsg, fPtSel, fCover, fProbs, fMeds, fOrders, rOrders, fNotes, fConsults, fDCSumm, rMisc, Clipbrd, fLabs, fReports, rReports, fPtDemo, fEncnt, fPtCWAD, uCore, fAbout, fReview, fxBroker, fxLists, fxServer, ORSystem, fRptBox, fSplash, rODAllergy, uInit, fLabTests, fLabInfo, uReminders, fReminderTree, ORClasses, fDeviceSelect, fDrawers, fReminderDialog, ShellAPI, rVitals, fOptions, fGraphs, rTemplates, fSurgery, rSurgery, uEventHooks, uSignItems, fDefaultEvent,rECS, fIconLegend, uOrders, fPtSelOptns, DateUtils, uSpell, uOrPtf, fPatientFlagMulti, fAlertForward, UBAGlobals, fBAOptionsDiagnoses, UBACore, fOrdersSign, uVitals, fOrdersRenew, uFormMonitor, fImages //kt 8/19/05 , uTMGOptions //kt 2/10/10 {$IFDEF CCOWBROKER} , CCOW_const {$ENDIF} , fPtDemoEdit , fOptionsOther, fPtLabelPrint; var // RV 05/11/04 IsRunExecuted: Boolean = FALSE; // RV 05/11/04 GraphFloat: TfrmGraphs; tempFrmWebTab : TfrmWebTab; //kt added const // moved to uConst - RV v16 (* CT_NOPAGE = -1; // chart tab - none selected CT_UNKNOWN = 0; // chart tab - unknown (shouldn't happen) CT_COVER = 1; // chart tab - cover sheet CT_PROBLEMS = 2; // chart tab - problem list CT_MEDS = 3; // chart tab - medications screen CT_ORDERS = 4; // chart tab - doctor's orders CT_HP = 5; // chart tab - history & physical CT_NOTES = 6; // chart tab - progress notes CT_CONSULTS = 7; // chart tab - consults CT_DCSUMM = 8; // chart tab - discharge summaries CT_LABS = 9; // chart tab - laboratory results CT_REPORTS = 10; // chart tab - reports CT_SURGERY = 11; // chart tab - surgery*) FCP_UPDATE = 10; // form create about to check auto-update FCP_SETHOOK = 20; // form create about to set timeout hooks FCP_SERVER = 30; // form create about to connect to server FCP_CHKVER = 40; // form create about to check version FCP_OBJECTS = 50; // form create about to create core objects FCP_FORMS = 60; // form create about to create child forms FCP_PTSEL = 70; // form create about to select patient FCP_FINISH = 99; // form create finished successfully SHOW_NOTIFICATIONS = True; //kt 7-17-07 Begin mod. Constanst removed and converted to variables. //TX_IN_USE = 'VistA CPRS in use by: '; TX_OPTION = 'OR CPRS GUI CHART'; TX_ECSOPT = 'EC GUI CONTEXT'; //TX_PTINQ = 'Retrieving demographic information...'; //TX_NOTIF_STOP = 'Stop processing notifications?'; //TC_NOTIF_STOP = 'Currently Processing Notifications'; //TX_UNK_NOTIF = 'Unable to process the follow up action for this notification'; //TC_UNK_NOTIF = 'Follow Up Action Not Implemented'; //TX_NO_SURG_NOTIF = 'This notification must be processed using the Surgery tab, ' + CRLF + // 'which is not currently available to you.'; //TC_NO_SURG_NOTIF = 'Surgery Tab Not Available'; //TX_VER1 = 'This is version '; //TX_VER2 = ' of CPRSChart.exe.'; //TX_VER3 = CRLF + 'The running server version is '; //TX_VER_REQ = ' version server is required.'; //TX_VER_OLD = CRLF + 'It is strongly recommended that you upgrade.'; //TX_VER_OLD2 = CRLF + 'The program cannot be run until the client is upgraded.'; //TX_VER_NEW = CRLF + 'The program cannot be run until the server is upgraded.'; //TC_VER = 'Server/Client Incompatibility'; //TC_CLIERR = 'Client Specifications Mismatch'; //TC_DGSR_ERR = 'Remote Data Error'; //TC_DGSR_SHOW = 'Restricted Remote Record'; //TC_DGSR_DENY = 'Remote Access Denied'; //TX_DGSR_YESNO = CRLF + 'Do you want to continue accessing this remote patient record?'; //TX_CCOW_LINKED = 'Clinical Link On'; //TX_CCOW_CHANGING = 'Clinical link changing'; //TX_CCOW_BROKEN = 'Clinical link broken'; //TX_CCOW_ERROR = 'CPRS was unable to communicate with the CCOW Context Vault' + CRLF + // 'CCOW patient synchronization will be unavailable for the remainder of this session.'; //TC_CCOW_ERROR = 'CCOW Error'; //kt 7-17-07 end mod --------------- function TX_IN_USE : string; begin Result := DKLangConstW('fFrame_VistA_CPRS_in_use_byx'); //kt added 7/17/2007 end; procedure TfrmFrame.SetupVars; //kt Added entire function to replace constant declarations 7/17/2007 begin TX_PTINQ := DKLangConstW('fFrame_Retrieving_demographic_informationxxx'); //kt added 7/17/2007 TX_NOTIF_STOP := DKLangConstW('fFrame_Stop_processing_notificationsx'); //kt added 7/17/2007 TC_NOTIF_STOP := DKLangConstW('fFrame_Currently_Processing_Notifications'); //kt added 7/17/2007 TX_UNK_NOTIF := DKLangConstW('fFrame_Unable_to_process_the_follow_up_action_for_this_notification'); //kt added 7/17/2007 TC_UNK_NOTIF := DKLangConstW('fFrame_Follow_Up_Action_Not_Implemented'); //kt added 7/17/2007 TX_NO_SURG_NOTIF := DKLangConstW('fFrame_This_notification_must_be_processed_using_the_Surgery_tabx') + CRLF + DKLangConstW('fFrame_which_is_not_currently_available_to_youx'); //kt added 7/17/2007 TC_NO_SURG_NOTIF := DKLangConstW('fFrame_Surgery_Tab_Not_Available'); //kt added 7/17/2007 TX_VER1 := DKLangConstW('fFrame_This_is_version'); //kt added 7/17/2007 TX_VER2 := DKLangConstW('fFrame_of_CPRSChartxexex'); //kt added 7/17/2007 TX_VER3 := CRLF + DKLangConstW('fFrame_The_running_server_version_is'); //kt added 7/17/2007 TX_VER_REQ := DKLangConstW('fFrame_version_server_is_requiredx'); //kt added 7/17/2007 TX_VER_OLD := CRLF + DKLangConstW('fFrame_It_is_strongly_recommended_that_you_upgradex'); //kt added 7/17/2007 TX_VER_OLD2 := CRLF + DKLangConstW('fFrame_The_program_cannot_be_run_until_the_client_is_upgradedx'); //kt added 7/17/2007 TX_VER_NEW := CRLF + DKLangConstW('fFrame_The_program_cannot_be_run_until_the_server_is_upgradedx'); //kt added 7/17/2007 TC_VER := DKLangConstW('fFrame_ServerxClient_Incompatibility'); //kt added 7/17/2007 TC_CLIERR := DKLangConstW('fFrame_Client_Specifications_Mismatch'); //kt added 7/17/2007 TC_DGSR_ERR := DKLangConstW('fFrame_Remote_Data_Error'); //kt added 7/17/2007 TC_DGSR_SHOW := DKLangConstW('fFrame_Restricted_Remote_Record'); //kt added 7/17/2007 TC_DGSR_DENY := DKLangConstW('fFrame_Remote_Access_Denied'); //kt added 7/17/2007 TX_DGSR_YESNO := CRLF + DKLangConstW('fFrame_Do_you_want_to_continue_accessing_this_remote_patient_recordx'); //kt added 7/17/2007 TX_CCOW_LINKED := DKLangConstW('fFrame_Clinical_Link_On'); //kt added 7/17/2007 TX_CCOW_CHANGING := DKLangConstW('fFrame_Clinical_link_changing'); //kt added 7/17/2007 TX_CCOW_BROKEN := DKLangConstW('fFrame_Clinical_link_broken'); //kt added 7/17/2007 TX_CCOW_ERROR := DKLangConstW('fFrame_CPRS_was_unable_to_communicate_with_the_CCOW_Context_Vault') + CRLF + DKLangConstW('fFrame_CCOW_patient_synchronization_will_be_unavailable_for_the_remainder_of_this_sessionx'); //kt added 7/17/2007 TC_CCOW_ERROR := DKLangConstW('fFrame_CCOW_Error'); //kt added 7/17/2007 end; function TfrmFrame.TimeoutCondition: boolean; begin Result := (FCreateProgress < FCP_PTSEL); end; function TfrmFrame.GetTimedOut: boolean; begin Result := uInit.TimedOut; end; procedure TfrmFrame.TimeOutAction; begin if frmFrame.VitalsDLLActive then CloseVitalsDLL() else Close; end; { General Functions and Procedures } procedure TfrmFrame.AppException(Sender: TObject; E: Exception); var AnAddr: Pointer; ErrMsg: string; temp : integer; begin Application.NormalizeTopMosts; if (E is EIntError) then begin ErrMsg := E.Message + CRLF + // 'CreateProgress: ' + IntToStr(FCreateProgress) + CRLF + <-- original line. //kt 7/17/2007 DKLangConstW('fFrame_CreateProgressx') + IntToStr(FCreateProgress) + CRLF + //kt added 7/17/2007 // 'RPC Info: ' + RPCLastCall; <-- original line. //kt 7/17/2007 DKLangConstW('fFrame_RPC_Infox') + RPCLastCall; //kt added 7/17/2007 if EExternal(E).ExceptionRecord <> nil then begin AnAddr := EExternal(E).ExceptionRecord^.ExceptionAddress; // ErrMsg := ErrMsg + CRLF + 'Address was ' + IntToStr(Integer(AnAddr)); <-- original line. //kt 7/17/2007 ErrMsg := ErrMsg + CRLF + DKLangConstW('fFrame_Address_was') + IntToStr(Integer(AnAddr)); //kt added 7/17/2007 end; ShowMessage(ErrMsg); end else if (E is EBrokerError) then begin Application.ShowException(E); FCreateProgress := FCP_FORMS; Close; end else if (E is EOleException) then begin Application.ShowException(E); FCreateProgress := FCP_FORMS; Close; end else if (E is EInvalidOperation) then //kt 9/11/08 begin if E.Message = 'Cannot focus a disabled or invisible window' then begin i := 1; // do nothing end else Application.ShowException(E); end else Application.ShowException(E); Application.RestoreTopMosts; end; function TfrmFrame.AllowContextChangeAll(var Reason: string): Boolean; var Silent: Boolean; begin if pnlNoPatientSelected.Visible then begin Result := True; exit; end; FContextChanging := True; Result := True; if COMObjectActive or SpellCheckInProgress or VitalsDLLActive then begin Reason := 'COM_OBJECT_ACTIVE'; Result:= False; end; if Result then Result := frmCover.AllowContextChange(Reason); if Result then Result := frmProblems.AllowContextChange(Reason); if Result then Result := frmMeds.AllowContextChange(Reason); if Result then Result := frmOrders.AllowContextChange(Reason); if Result then Result := frmNotes.AllowContextChange(Reason); if Result then Result := frmConsults.AllowContextChange(Reason); if Result then Result := frmDCSumm.AllowContextChange(Reason); if Result then if Assigned(frmSurgery) then Result := frmSurgery.AllowContextChange(Reason);; if Result then Result := frmLabs.AllowContextChange(Reason);; if Result then Result := frmReports.AllowContextChange(Reason); if (not User.IsReportsOnly) then if Result and Changes.RequireReview then //Result := ReviewChanges(TimedOut); case BOOLCHAR[FCCOWContextChanging] of '1': begin if Changes.RequireReview then begin // Reason := 'Items will be left unsigned.'; <-- original line. //kt 7/17/2007 Reason := DKLangConstW('fFrame_Items_will_be_left_unsignedx'); //kt added 7/17/2007 Result := False; end else Result := True; end; '0': begin Silent := (TimedOut) or (Reason = 'COMMIT'); Result := ReviewChanges(Silent); end; end; FContextChanging := False; end; procedure TfrmFrame.ClearPatient; { call all pages to make sure patient related information is cleared (when switching patients) } begin if frmFrame.Timedout then Exit; // added to correct Access Violation when "Refresh Patient Information" selected lblPtName.Caption := ''; lblPtSSN.Caption := ''; lblPtAge.Caption := ''; pnlPatient.Caption := ''; lblPtCWAD.Caption := ''; //lblPtLocation.Caption := 'Visit Not Selected'; <-- original line. //kt 7/17/2007 lblPtLocation.Caption := DKLangConstW('fFrame_Visit_Not_Selected'); //kt added 7/17/2007 //lblPtProvider.Caption := 'Current Provider Not Selected'; <-- original line. //kt 7/17/2007 lblPtProvider.Caption := DKLangConstW('fFrame_Current_Provider_Not_Selected'); //kt added 7/17/2007 pnlVisit.Caption := lblPtLocation.Caption + CRLF + lblPtProvider.Caption; //lblPtCare.Caption := 'Primary Care Team Unassigned'; <-- original line. //kt 7/17/2007 lblPtCare.Caption := DKLangConstW('fFrame_Primary_Care_Team_Unassigned'); //kt added 7/17/2007 lblPtAttending.Caption := ''; pnlPrimaryCare.Caption := lblPtCare.Caption + ' ' + lblPtAttending.Caption; frmCover.ClearPtData; frmProblems.ClearPtData; frmMeds.ClearPtData; frmOrders.ClearPtData; frmNotes.ClearPtData; frmConsults.ClearPtData; frmDCSumm.ClearPtData; if Assigned(frmSurgery) then frmSurgery.ClearPtData; frmLabs.ClearPtData; frmReports.ClearPtData; tabPage.TabIndex := PageIDToTab(CT_NOPAGE); // to make sure DisplayPage gets called tabPageChange(tabPage); ClearReminderData; SigItems.Clear; lstCIRNLocations.Clear; uRemoteType := ''; ClearFlag; if Assigned(FlagList) then FlagList.Clear; HasFlag := False; HidePatientSelectMessages; if (GraphFloat <> nil) and GraphFloatActive then with GraphFloat do begin Initialize; DisplayData('top'); DisplayData('bottom'); lstCheck.Items.Clear; // Caption := 'CPRS Graphing - Patient: ' + MixedCase(Patient.Name); <-- original line. //kt 7/17/2007 Caption := DKLangConstW('fFrame_CPRS_Graphing_x_Patientx') + MixedCase(Patient.Name); //kt added 7/17/2007 end; end; procedure TfrmFrame.DisplayEncounterText; { updates the display in the header bar of encounter related information (location & provider) } begin with Encounter do begin if Length(LocationText) > 0 then lblPtLocation.Caption := LocationText // else lblPtLocation.Caption := 'Visit Not Selected'; <-- original line. //kt 7/17/2007 else lblPtLocation.Caption := DKLangConstW('fFrame_Visit_Not_Selected'); //kt added 7/17/2007 if Length(ProviderName) > 0 // then lblPtProvider.Caption := 'Provider: ' + ProviderName <-- original line. //kt 7/17/2007 then lblPtProvider.Caption := DKLangConstW('fFrame_Providerx') + ProviderName //kt added 7/17/2007 // else lblPtProvider.Caption := 'Current Provider Not Selected'; <-- original line. //kt 7/17/2007 else lblPtProvider.Caption := DKLangConstW('fFrame_Current_Provider_Not_Selected'); //kt added 7/17/2007 end; pnlVisit.Caption := lblPtLocation.Caption + CRLF + lblPtProvider.Caption; FitToolBar; end; { Form Events (Create, Destroy) ----------------------------------------------------------- } procedure TfrmFrame.RefreshFixedStatusWidth; begin with stsArea do FFixedStatusWidth := Panels[0].Width + Panels[2].Width + Panels[3].Width + Panels[4].Width; end; procedure TfrmFrame.FormCreate(Sender: TObject); { connect to server, create tab pages, select a patient, & initialize core objects } var ClientVer, ServerVer, ServerReq: string; tempS : string; //kt i : integer; //kt added 6/29/07 tempPosition : TTabPosition; //kt ImagesEnabled : boolean; //kt Connected : boolean; //kt 6/3/10 RetryConnect : integer; //kt 6/3/10 begin //kt 6/29/07 Begin modification ------------------- SetupVars; // Scan for language files in the app directory and register them in the LangManager object LangManager.ScanForLangFiles(WideExtractFileDir(WideParamStr(0)), '*.lng', False); //later, allow setting language from command line parameter //kt end modification ------------------------------ FJustEnteredApp := false; SizeHolder := TSizeHolder.Create; FOldActiveFormChange := Screen.OnActiveFormChange; Screen.OnActiveFormChange := ScreenActiveFormChange; if not (ParamSearch('CCOW')='DISABLE') then try StartCCOWContextor; except IsRunExecuted := False; FCCOWInstalled := False; pnlCCOW.Visible := False; mnuFileResumeContext.Visible := False; mnuFileBreakContext.Visible := False; end else begin IsRunExecuted := False; FCCOWInstalled := False; pnlCCOW.Visible := False; mnuFileResumeContext.Visible := False; mnuFileBreakContext.Visible := False; end; RefreshFixedStatusWidth; FTerminate := False; AutoUpdateCheck; FFlagList := TStringList.Create; // setup initial timeout here so can timeout logon FCreateProgress := FCP_SETHOOK; InitTimeOut(TimeoutCondition, TimeOutAction); // connect to the server and create an option context FCreateProgress := FCP_SERVER; {$IFDEF CCOWBROKER} EnsureBroker; if ctxContextor <> nil then begin if ParamSearch('CCOW') = 'PATIENTONLY' then RPCBrokerV.Contextor := nil else RPCBrokerV.Contextor := ctxContextor; end else RPCBrokerV.Contextor := nil; {$ENDIF} { //kt Original block if not ConnectToServer(TX_OPTION) then begin if Assigned(RPCBrokerV) then InfoBox(RPCBrokerV.RPCBError, 'Error', MB_OK or MB_ICONERROR); Close; Exit; end; } //kt begin mod 6/3/10 -------------- TMGAbort := False; //kt 3/25/09 repeat Connected := ConnectToServer(TX_OPTION); if not Connected then begin RetryConnect := mrCancel; if Assigned(RPCBrokerV) then begin RetryConnect := MessageDlg(RPCBrokerV.RPCBError, mtError, [mbRetry, mbCancel], 0); end; if RetryConnect <> mrRetry then begin Close; TMGAbort := True; //kt 3/25/09 Exit; end; end until Connected; //Exit command above will also abort loop //kt end mod ---------- if ctxContextor <> nil then begin if not (ParamSearch('CCOW') = 'PATIENTONLY') then ctxContextor.NotificationFilter := ctxContextor.NotificationFilter + ';User'; end; FECSAuthUser := ValidECSUser; uECSReport := TECSReport.Create; uECSReport.ECSPermit := FECSAuthUser; RPCBrokerV.CreateContext(TX_OPTION); Application.OnException := AppException; FOldActivate := Application.OnActivate; Application.OnActivate := AppActivated; Application.OnDeActivate := AppDeActivated; User := TUser.Create; // load language ini settings //elh added LangManager.LanguageID := uTMGOptions.ReadInteger('Language',1033); tempPosition := TTabPosition(uTMGOptions.ReadInteger('Tab Location',0)); if tempPosition > tpRight then tempPosition := tpBottom; fOptionsOther.SetTabPosition(tempPosition); {$IFDEF USE_SKINS} SkinManager := TipSkinManager.Create(self); {$ENDIF} SkinChanged := false; SkinAtStartup := uTMGOptions.ReadBool('Load Skin At Startup',false); CurrentSkinFile := uTMGOptions.ReadString('Default Skin','TMG_Extra\Skins\ICQ_Longhorn_v.1.2.ipz'); if SkinAtStartup then ActivateCurrentSkin; //kt -- end mod -- //frmFrame.Caption := TX_IN_USE + MixedCase(User.Name) + ' (' + RPCBrokerV.Server + ')'; //kt added //frmFrame.RenameTabs; //Resets names of tabs to correct translation //kt // create initial core objects FCreateProgress := FCP_OBJECTS; //User := TUser.Create; moved elh 2/12/10 // make sure we're using the matching server version FCreateProgress := FCP_CHKVER; ClientVer := ClientVersion(Application.ExeName); //kt Added: allows 'SPOOF-VER=x.x.x.x' command-line parameter ServerVer := ServerVersion(TX_OPTION, ClientVer); if (ServerVer = '0.0.0.0') then begin // InfoBox('Unable to determine current version of server.', TX_OPTION, MB_OK); <-- original line. //kt 7/17/2007 InfoBox(DKLangConstW('fFrame_Unable_to_determine_current_version_of_serverx'), TX_OPTION, MB_OK); //kt added 7/17/2007 Close; Exit; end; ServerReq := Piece(FileVersionValue(Application.ExeName, FILE_VER_INTERNALNAME), ' ', 1); tempS := Trim(ParamSearch('SPOOF-VER')); //kt added if tempS <>'' then ServerReq := tempS; //kt added if (ClientVer <> ServerReq) then begin // InfoBox('Client "version" does not match client "required" server.', TC_CLIERR, MB_OK); <-- original line. //kt 7/17/2007 InfoBox(DKLangConstW('fFrame_Client_xversionx_does_not_match_client_xrequiredx_serverx')+#10+#13+ #10+#13+ ' ' + DKLangConstW('fFrame_Server')+' = ''' + ServerVer + '''' + #10+#13+ ' ' + DKLangConstW('fFrame_ThisCPRS')+' = ''' + ClientVer + '''' + #10+#13+ #10+#13+ DKLangConstW('fFrame_Aborting') , TC_CLIERR, MB_OK); //kt added 7/17/2007, expanded 5/25/08 Close; Exit; end; if (CompareVersion(ServerVer, ServerReq) <> 0) then begin if (sCallV('ORWU DEFAULT DIVISION', [nil]) = '1') then begin // if (InfoBox('Proceed with mismatched Client and Server versions?', TC_CLIERR, MB_YESNO) = ID_NO) then <-- original line. //kt 7/17/2007 if (InfoBox(DKLangConstW('fFrame_Proceed_with_mismatched_Client_and_Server_versionsx'), TC_CLIERR, MB_YESNO) = ID_NO) then //kt added 7/17/2007 begin Close; Exit; end; end else begin if (CompareVersion(ServerVer, ServerReq) > 0) then // Server newer than Required begin // NEXT LINE COMMENTED OUT - CHANGED FOR VERSION 19.16, PATCH OR*3*155: // if GetUserParam('ORWOR REQUIRE CURRENT CLIENT') = '1' then if (true) then // "True" statement guarantees "required" current version client. begin InfoBox(TX_VER1 + ClientVer + TX_VER2 + CRLF + ServerReq + TX_VER_REQ + TX_VER3 + ServerVer + '.' + TX_VER_OLD2, TC_VER, MB_OK); Close; Exit; end; end else InfoBox(TX_VER1 + ClientVer + TX_VER2 + CRLF + ServerReq + TX_VER_REQ + TX_VER3 + ServerVer + '.' + TX_VER_OLD, TC_VER, MB_OK); end; if (CompareVersion(ServerVer, ServerReq) < 0) then // Server older then Required begin InfoBox(TX_VER1 + ClientVer + TX_VER2 + CRLF + ServerReq + TX_VER_REQ + TX_VER3 + ServerVer + '.' + TX_VER_NEW, TC_VER, MB_OK); Close; Exit; end; end; // Add future tabs here as they are created/implemented: if ( (not User.HasCorTabs) and (not User.HasRptTab) ) then begin // InfoBox('No valid tabs assigned', 'Tab Access Problem', MB_OK); <-- original line. //kt 7/17/2007 InfoBox(DKLangConstW('fFrame_No_valid_tabs_assigned'), DKLangConstW('fFrame_Tab_Access_Problem'), MB_OK); //kt added 7/17/2007 Close; Exit; end; CheckForTMGPatch; //Check For TMG Patch elh 6/20/08 // create creating core objects Patient := TPatient.Create; Encounter := TEncounter.Create; Changes := TChanges.Create; Notifications := TNotifications.Create; RemoteSites := TRemoteSiteList.Create; RemoteReports := TRemoteReportList.Create; uTabList := TStringList.Create; TabColorsList := TStringList.Create; //kt added 8/8/08 FlaggedPTList := TStringList.Create; HasFlag := False; FlagList := TStringList.Create; // set up structures specific to the user Caption := TX_IN_USE + MixedCase(User.Name) + ' (' + RPCBrokerV.Server + ')'; SetDebugMenu; if InteractiveRemindersActive then NotifyWhenRemindersChange(RemindersChanged); // load all the tab pages FCreateProgress := FCP_FORMS; //CreateTab(TObject(frmProblems), TfrmProblems, CT_PROBLEMS, 'Problems'); CreateTab(CT_PROBLEMS, DKLangConstW('fFrame_Problems')); //kt //kt original line --> CreateTab(CT_PROBLEMS, 'Problems'); CreateTab(CT_MEDS, DKLangConstW('fFrame_Meds')); //kt //kt original line --> CreateTab(CT_MEDS, 'Meds'); CreateTab(CT_ORDERS, DKLangConstW('fFrame_Orders')); //kt //kt original line --> CreateTab(CT_ORDERS, 'Orders'); CreateTab(CT_NOTES, DKLangConstW('fFrame_Notes')); //kt //kt original line --> CreateTab(CT_NOTES, 'Notes'); CreateTab(CT_CONSULTS, DKLangConstW('fFrame_Consults')); //kt //kt original line --> CreateTab(CT_CONSULTS, 'Consults'); if ShowSurgeryTab then CreateTab(CT_SURGERY, DKLangConstW('fFrame_Surgery')); //kt //kt original line --> if ShowSurgeryTab then CreateTab(CT_SURGERY, 'Surgery'); CreateTab(CT_DCSUMM, DKLangConstW('fFrame_D_C_Summ')); //kt //kt original line --> CreateTab(CT_DCSUMM, 'D/C Summ'); CreateTab(CT_LABS, DKLangConstW('fFrame_Labs')); //kt //kt original line --> CreateTab(CT_LABS, 'Labs'); CreateTab(CT_REPORTS, DKLangConstW('fFrame_Reports')); //kt //kt original line --> CreateTab(CT_REPORTS, 'Reports'); CreateTab(CT_COVER, DKLangConstW('fFrame_Cover_Sheet')); //kt //kt original line --> CreateTab(CT_COVER, 'Cover Sheet'); //kt original line --> CreateTab(CT_IMAGES, 'Images'); CreateTab(CT_IMAGES, DKLangConstW('fFrame_Images')); //kt ImagesEnabled := uTMGOptions.ReadBool('EnableImages',false); //kt if not ImagesEnabled then SetATabVisibility(CT_IMAGES, ImagesEnabled); //kt for i := CT_WEBTAB1 to CT_LAST_WEBTAB do begin CreateTab(i, IntToStr(i-CT_WEBTAB1+1)); //kt SetATabVisibility(i, false); //kt hide until activated by RPC end; LoadTabColors(TabColorsList); //kt added 8/8/08 TabPage.OwnerDraw := TabColorsEnabled; ShowHideChartTabMenus(mnuViewChart); // We defer calling LoadUserPreferences to UMInitiate, so that the font sizing // routines recognize this as the application's main form (this hasn't been // set yet). FNextButtonBitmap := TBitmap.Create; FNextButtonBitmap.LoadFromResourceName(hInstance, 'BMP_HANDRIGHT'); // set the timeout to DTIME now that there is a connection UpdateTimeOutInterval(User.DTIME * 1000); // DTIME * 1000 mSec // get a patient HandleNeeded; // make sure handle is there for ORWPT SHARE call FCreateProgress := FCP_PTSEL; Enabled := False; FFirstLoad := True; // First time to initialize the fFrame FCreateProgress := FCP_FINISH; pnlReminders.Visible := InteractiveRemindersActive; GraphFloatActive := false; GraphContext := ''; uRemoteType := ''; FPrevPtID := ''; SetUserTools; EditDemographics.Enabled := boolTMGPatchInstalled; //elh 6/20/08 EnduringPtSelSplitterPos := 0; if User.IsReportsOnly then // Reports Only tab. ReportsOnlyDisplay; // Calls procedure to hide all components/menus not needed. InitialOrderVariables; PostMessage(Handle, UM_INITIATE, 0, 0); // select patient after main form is created // mnuFileOpenClick(Self); // if Patient.DFN = '' then //*DFN* // begin // Close; // Exit; // end; // if WindowState = wsMinimized then WindowState := wsNormal; SetFormMonitoring(true); end; procedure TfrmFrame.ActivateCurrentSkin; begin {$IFDEF USE_SKINS} if SkinChanged = true then begin MessageDlg('For now, skins may be changed only ONCE'+#10+#13+ 'before restarting CPRS. Thank you.',mtInformation,[mbOK],0); exit; end; SkinChanged := true; SkinManager.SkinFile := ExtractFilePath (Application.ExeName) + CurrentSkinFile; if FileExists(SkinManager.SkinFile)=false then begin SkinManager.SkinFile := ''; end; if SkinManager.SkinFile <>'' then begin try SkinManager.Active := true; except on EInvalidOperation do begin MessageDlg('Error Applying Skin. Please try another.',mtInformation,[mbOK],0); end; else begin MessageDlg('Error Applying Skin. Please try another.',mtInformation,[mbOK],0); end; end; end else begin SkinManager.Active := false; end; {$ENDIF} end; procedure TfrmFrame.InactivateSkin; begin {$IFDEF USE_SKINS} SkinManager.Active := false; {$ENDIF} end; procedure TfrmFrame.RenameTabs; //kt added entire function; //Allows refresh of tab names after initial startup (i.e. when language has changed) begin RenameATab(CT_PROBLEMS, DKLangConstW('fFrame_Problems')); //kt RenameATab(CT_MEDS, DKLangConstW('fFrame_Meds')); //kt RenameATab(CT_ORDERS, DKLangConstW('fFrame_Orders')); //kt RenameATab(CT_NOTES, DKLangConstW('fFrame_Notes')); //kt RenameATab(CT_CONSULTS, DKLangConstW('fFrame_Consults')); //kt RenameATab(CT_SURGERY, DKLangConstW('fFrame_Surgery')); //kt RenameATab(CT_DCSUMM, DKLangConstW('fFrame_D_C_Summ')); //kt RenameATab(CT_LABS, DKLangConstW('fFrame_Labs')); //kt RenameATab(CT_REPORTS, DKLangConstW('fFrame_Reports')); //kt RenameATab(CT_COVER, DKLangConstW('fFrame_Cover_Sheet')); //kt //kt Note: WebTab names will be driven by a RPC call from server, so don't rename here. end; procedure TfrmFrame.RenameATab(ATabID: integer; ALabel: string); //kt added entire function; var index : integer; begin index := uTabList.IndexOf(IntToStr(ATabID)); if index > -1 then tabPage.Tabs.Strings[index] := ALabel; end; //kt added entire function; procedure TfrmFrame.SetATabVisibility(ATabID: integer; Visible: boolean; ALabel:string='x'); //kt Note: if Visible=True, then ALabel is expected to contain label for tab. (Not remembered from before setting visible=false) //Note: This presumes that CreateTab has already been called prior to setting visiblity. var index : integer; begin index := uTabList.IndexOf(IntToStr(ATabID)); if (index > -1) and (Visible=false) then begin uTabList.Delete(index); tabPage.Tabs.Delete(index); end else if (index < 0) and (Visible=true) then begin if ATabID = CT_COVER then begin uTabList.Insert(0, IntToStr(ATabID)); tabPage.Tabs.Insert(0, ALabel); tabPage.TabIndex := 0; end else begin uTabList.Add(IntToStr(ATabID)); tabPage.Tabs.Add(ALabel); end; end else if (index > -1) and (Visible=true) then begin tabPage.Tabs.Strings[index] := ALabel; //ensure label is correct. end; end; procedure TfrmFrame.SetWebTabsPerServer; //kt added entire function. var URLList: TStringList; i : integer; result : string; begin URLList := TStringList.Create; result := fWebTab.AskServerForURLs(URLList); try if piece(result,'^',1)='0' then begin MessageDlg(piece(result,'^',2),mtError,[mbOK],0); exit; end; if piece(result,'^',1)='1' then begin for i := 1 to URLList.Count-1 do begin SetOneWebTabPerServer(i, URLList[i]); end; end; finally URLList.Free; end; end; procedure TfrmFrame.SetOneWebTabPerServer(WebTabNum: integer; URLMsg : string); //kt added entire function. //Msg format: TabLabelName^URL // ^about:blank <-- will make tab visible, but blank // ^ <-- will make tab invisible //WebTabNum must be 1..(CT_LAST_WEBTAB-CT_WEBTAB1+1) var ATabID : integer; TabLabel,URL : string; begin ATabID := WebTabNum + CT_WEBTAB1 - 1; if (ATabID < CT_WEBTAB1) or (ATabID > CT_LAST_WEBTAB) then exit; TabLabel := piece (URLMsg,'^',1); URL := pieces (URLMsg,'^',2,32); //returns e.g. 'www.yahoo.com^^^^^^^^^^' etc, // This allows for ^ to be contained in URL itself (but final character will be trimmed) while URL[Length(URL)]='^' do begin //trim trailing '^'s Delete(URL,Length(URL),1); end; if URL='' then begin SetATabVisibility(ATabID, false); end else if URL<>'' then begin SetATabVisibility(ATabID, true, TabLabel); tempFrmWebTab := TfrmWebTab(frmWebTabs[WebTabNum-1]); if tempFrmWebTab <> nil then tempFrmWebTab.NagivateTo(URL); end; end; procedure TfrmFrame.StartCCOWContextor; begin try ctxContextor := TContextorControl.Create(Self); with ctxContextor do begin OnPending := ctxContextorPending; OnCommitted := ctxContextorCommitted; OnCanceled := ctxContextorCanceled; end; FCCOWBusy := False; FCCOWInstalled := True; FCCOWDrivedChange := False; ctxContextor.Run('CPRSChart', '', TRUE, 'Patient'); IsRunExecuted := True; except on exc : EOleException do begin IsRunExecuted := False; FreeAndNil(ctxContextor); try ctxContextor := TContextorControl.Create(Self); with ctxContextor do begin OnPending := ctxContextorPending; OnCommitted := ctxContextorCommitted; OnCanceled := ctxContextorCanceled; end; FCCOWBusy := False; FCCOWInstalled := True; FCCOWDrivedChange := False; ctxContextor.Run('CPRSChart' + '#', '', TRUE, 'Patient'); IsRunExecuted := True; if ParamSearch('CCOW') = 'FORCE' then begin mnuFileResumeContext.Enabled := False; mnuFileBreakContext.Visible := True; mnuFileBreakContext.Enabled := True; end else begin ctxContextor.Suspend; mnuFileResumeContext.Visible := True; mnuFileBreakContext.Visible := True; mnuFileBreakContext.Enabled := False; end; except IsRunExecuted := False; FCCOWInstalled := False; FreeAndNil(ctxContextor); pnlCCOW.Visible := False; mnuFileResumeContext.Visible := False; mnuFileBreakContext.Visible := False; end; end; end end; procedure TfrmFrame.UMInitiate(var Message: TMessage); begin NotifyOtherApps(NAE_OPEN, IntToStr(User.DUZ)); LoadUserPreferences; GetBAStatus(User.DUZ,Patient.DFN); mnuFileOpenClick(Self); Enabled := True; // If TimedOut, Close has already been called. if not TimedOut and (Patient.DFN = '') then Close; end; procedure TfrmFrame.FormDestroy(Sender: TObject); { free core objects used by CPRS } begin Application.OnActivate := FOldActivate; Screen.OnActiveFormChange := FOldActiveFormChange; FNextButtonBitmap.Free; uTabList.Free; //kt --- 8/8/08 start mod --- //kt uTMGOptions.WriteInteger('Language',LangManager.LanguageID); //ktSaveTabColors(TabColorsList); TabColorsList.Free; //kt uTMGOptions.WriteInteger('Tab Location',integer(tabPage.TabPosition)); //kt uTMGOptions.WriteBool('Load Skin At Startup',SkinAtStartup); //kt 9/11/08 //kt --- end mod --- FlaggedPTList.Free; RemoteSites.Free; RemoteReports.Free; Notifications.Free; Changes.Free; Encounter.Free; Patient.Free; User.Free; SizeHolder.Free; ctxContextor.Free; end; procedure TfrmFrame.FormCloseQuery(Sender: TObject; var CanClose: Boolean); { cancels close if the user cancels the ReviewChanges screen } var Reason: string; begin if (FCreateProgress < FCP_FINISH) then Exit; if User.IsReportsOnly then // Reports Only tab. exit; if TimedOut then begin if Changes.RequireReview then ReviewChanges(TimedOut); Exit; end; if not AllowContextChangeAll(Reason) then CanClose := False; end; procedure TfrmFrame.SetUserTools; var ToolItems: TToolItemList; i: Integer; UserTool: TMenuItem; MaxedOut: boolean; // OptionsClick: TNotifyEvent; begin if User.IsReportsOnly then // Reports Only tab. begin mnuTools.Clear; // Remove all current items. UserTool := TMenuItem.Create(Self); // UserTool.Caption := 'Options...'; <-- original line. //kt 7/17/2007 UserTool.Caption := DKLangConstW('fFrame_Optionsxxx'); //kt added 7/17/2007 // UserTool.Hint := 'Options'; <-- original line. //kt 7/17/2007 UserTool.Hint := DKLangConstW('fFrame_Options'); //kt added 7/17/2007 UserTool.OnClick := mnuToolsOptionsClick; mnuTools.Add(UserTool); // Add back the "Options" menu. exit; end; if User.GECStatus then begin UserTool := TMenuItem.Create(self); // UserTool.Caption := 'GEC Referral Status Display'; <-- original line. //kt 7/17/2007 UserTool.Caption := DKLangConstW('fFrame_GEC_Referral_Status_Display'); //kt added 7/17/2007 // UserTool.Hint := 'GEC Referral Status Display'; <-- original line. //kt 7/17/2007 UserTool.Hint := DKLangConstW('fFrame_GEC_Referral_Status_Display'); //kt added 7/17/2007 UserTool.OnClick := mnuGECStatusClick; mnuTools.Add(UserTool); // Add back the "Options" menu. //exit; end; GetToolMenu(ToolItems, MaxedOut); // For all other users, proceed normally with creation of Tools menu: for i := Low(ToolItems) to High(ToolItems) do begin // if (AnsiCompareText(ToolItems[i].Caption, 'Event Capture Interface') = 0 ) and <-- original line. //kt 7/17/2007 if (AnsiCompareText(ToolItems[i].Caption, DKLangConstW('fFrame_Event_Capture_Interface')) = 0 ) and //kt added 7/17/2007 (not uECSReport.ECSPermit) then begin ToolItems[i].Caption := ''; ToolItems[i].Action := ''; Break; end; end; if MaxedOut then begin uToolsMaxed := True; uToolsWarned := False; end; for i := 0 to MAX_TOOLITEMS do with ToolItems[i] do if Length(Caption) > 0 then begin UserTool := TMenuItem.Create(Self); UserTool.Caption := Caption; UserTool.Hint := Action; UserTool.OnClick := ToolClick; mnuTools.Insert(i, UserTool); end; end; procedure TfrmFrame.mnuToolsClick(Sender: TObject); //const //TX_TOO_MANY_TOOLS = 'Some defined items may not be shown'; <-- original line. //kt 7/17/2007 //TC_TOO_MANY_TOOLS = 'Tool Menu Limit Exceeded'; <-- original line. //kt 7/17/2007 var TX_TOO_MANY_TOOLS : string; TC_TOO_MANY_TOOLS : string; begin TX_TOO_MANY_TOOLS := DKLangConstW('fFrame_Some_defined_items_may_not_be_shown'); //kt added 7/17/2007 TC_TOO_MANY_TOOLS := DKLangConstW('fFrame_Tool_Menu_Limit_Exceeded'); //kt added 7/17/2007 if uToolsMaxed and (not uToolsWarned) then begin InfoBox(TX_TOO_MANY_TOOLS, TC_TOO_MANY_TOOLS, MB_ICONWARNING or MB_OK); uToolsWarned := True; end; end; procedure TfrmFrame.UpdateECSParameter(var CmdParameter: string); //ECS var vstID,AccVer,Svr,SvrPort,VUser: string; begin AccVer := ''; Svr := ''; SvrPort := ''; VUser := ''; if RPCBrokerV <> nil then begin AccVer := RPCBrokerV.AccessVerifyCodes; Svr := RPCBrokerV.Server; SvrPort := IntToStr(RPCBrokerV.ListenerPort); VUser := RPCBrokerV.User.DUZ; end; vstID := GetVisitID; CmdParameter :=' Svr=' +Svr +' SvrPort='+SvrPort +' VUser='+ VUser +' PtIEN='+ Patient.DFN +' PdIEN='+IntToStr(Encounter.Provider) +' vstIEN='+vstID +' locIEN='+IntToStr(Encounter.Location) +' Date=0' +' Division='+GetDivisionID; end; function TfrmFrame.ValidECSUser: boolean; //ECS var isTrue: boolean; begin Result := True; with RPCBrokerV do begin ShowErrorMsgs := semQuiet; Connected := True; try isTrue := CreateContext(TX_ECSOPT); if not isTrue then Result := False; ShowErrorMsgs := semRaise; except on E: Exception do begin ShowErrorMsgs := semRaise; Result := False; end; end; end; end; procedure TfrmFrame.FormClose(Sender: TObject; var Action: TCloseAction); //var // i: Integer; // UserTool: TMenuItem; begin FClosing := TRUE; SetFormMonitoring(false); if FCreateProgress < FCP_FINISH then FTerminate := True; FlushNotifierBuffer; if FCreateProgress = FCP_FINISH then NotifyOtherApps(NAE_CLOSE, ''); TerminateOtherAppNotification; if GraphFloat <> nil then begin if frmFrame.GraphFloatActive then GraphFloat.Close; GraphFloat.Release; end; // unhook the timeout hooks ShutDownTimeOut; // clearing changes will unlock notes if FCreateProgress = FCP_FINISH then Changes.Clear; // clear server side flag global tmp if FCreateProgress = FCP_FINISH then ClearFlag; // save user preferences if FCreateProgress = FCP_FINISH then SaveUserPreferences; // call close for each page in case there is any special processing if FCreateProgress > FCP_FORMS then begin mnuFrame.Merge(nil); frmCover.Close; //frmCover.Release; frmProblems.Close; //frmProblems.Release; frmMeds.Close; //frmMeds.Release; frmOrders.Close; //frmOrders.Release; frmNotes.Close; //frmNotes.Release; frmConsults.Close; //frmConsults.Release; frmDCSumm.Close; //frmDCSumm.Release; if Assigned(frmSurgery) then frmSurgery.Close; //frmSurgery.Release; frmLabs.Close; //frmLabs.Release; frmReports.Close; //frmReports.Release; end; // with mnuTools do for i := Count - 1 downto 0 do // begin // UserTool := Items[i]; // if UserTool <> nil then // begin // Delete(i); // UserTool.Free; // end; // end; //Application.ProcessMessages; // so everything finishes closing // if < FCP_FINISH we came here from inside FormCreate, so need to call terminate //if GraphFloat <> nil then GraphFloat.Release; if FCreateProgress < FCP_FINISH then Application.Terminate; end; procedure TfrmFrame.SetDebugMenu; var IsProgrammer: Boolean; begin IsProgrammer := User.HasKey('XUPROGMODE'); mnuHelpBroker.Visible := IsProgrammer; mnuHelpLists.Visible := IsProgrammer; mnuHelpSymbols.Visible := IsProgrammer; Z6.Visible := IsProgrammer; end; { Updates posted to MainForm --------------------------------------------------------------- } procedure TfrmFrame.UMNewOrder(var Message: TMessage); { post a notice of change in orders to all TPages, wParam=OrderAction, lParam=TOrder } var OrderAct: string; begin with Message do begin frmCover.NotifyOrder(WParam, TOrder(LParam)); frmProblems.NotifyOrder(WParam, TOrder(LParam)); frmMeds.NotifyOrder(WParam, TOrder(LParam)); frmOrders.NotifyOrder(WParam, TOrder(LParam)); frmNotes.NotifyOrder(WParam, TOrder(LParam)); frmConsults.NotifyOrder(WParam, TOrder(LParam)); frmDCSumm.NotifyOrder(WParam, TOrder(LParam)); if Assigned(frmSurgery) then frmSurgery.NotifyOrder(WParam, TOrder(LParam)); frmLabs.NotifyOrder(WParam, TOrder(LParam)); frmReports.NotifyOrder(WParam, TOrder(LParam)); lblPtCWAD.Caption := GetCWADInfo(Patient.DFN); if Length(lblPtCWAD.Caption) > 0 // then lblPtPostings.Caption := 'Postings' <-- original line. //kt 7/17/2007 then lblPtPostings.Caption := DKLangConstW('fFrame_Postings') //kt added 7/17/2007 // else lblPtPostings.Caption := 'No Postings'; <-- original line. //kt 7/17/2007 else lblPtPostings.Caption := DKLangConstW('fFrame_No_Postings'); //kt added 7/17/2007 pnlPostings.Caption := lblPtPostings.Caption + ' ' + lblPtCWAD.Caption; OrderAct := ''; case WParam of ORDER_NEW: OrderAct := 'NW'; ORDER_DC: OrderAct := 'DC'; ORDER_RENEW: OrderAct := 'RN'; ORDER_HOLD: OrderAct := 'HD'; ORDER_EDIT: OrderAct := 'XX'; ORDER_ACT: OrderAct := 'AC'; end; if Length(OrderAct) > 0 then NotifyOtherApps(NAE_ORDER, OrderAct + U + TOrder(LParam).ID); // add FillerID end; end; { Tab Selection (navigate between pages) --------------------------------------------------- } procedure TfrmFrame.WMSetFocus(var Message: TMessage); begin if (FLastPage <> nil) and (not TimedOut) and (not (csDestroying in FLastPage.ComponentState)) and FLastPage.Visible then FLastPage.FocusFirstControl; end; procedure TfrmFrame.UMShowPage(var Message: TMessage); { shows a page when the UM_SHOWPAGE message is received } begin if FCCOWDrivedChange then FCCOWDrivedChange := False; if FLastPage <> nil then FLastPage.DisplayPage; FChangeSource := CC_CLICK; // reset to click so we're only dealing with exceptions to click if assigned(FTabChanged) then FTabChanged(Self); end; procedure TfrmFrame.SwitchToPage(NewForm: TfrmPage); { unmerge/merge menus, bring page to top of z-order, call form-specific OnDisplay code } begin if FLastPage = NewForm then begin if Notifications.Active then PostMessage(Handle, UM_SHOWPAGE, 0, 0); Exit; end; if (FLastPage <> nil) then begin mnuFrame.Unmerge(FLastPage.Menu); FLastPage.Hide; end; if Assigned(NewForm) then begin {if ((FLastPage = frmOrders) and (NewForm.Name <> frmMeds.Name)) or ((FLastPage = frmMeds) and (NewForm.Name <> frmOrders.Name)) then begin if not CloseOrdering then Exit; end;} mnuFrame.Merge(NewForm.Menu); NewForm.Show; end; lstCIRNLocations.Visible := False; pnlCIRN.BevelOuter := bvRaised; lstCIRNLocations.SendToBack; mnuFilePrint.Enabled := False; // let individual page enable this mnuFilePrintSetup.Enabled := False; // let individual page enable this mnuFilePrintSelectedItems.Enabled := False; FLastPage := NewForm; if NewForm <> nil then begin if NewForm.Name = frmNotes.Name then frmNotes.Align := alClient else frmNotes.Align := alNone; if NewForm.Name = frmConsults.Name then frmConsults.Align := alClient else frmConsults.Align := alNone; if NewForm.Name = frmDCSumm.Name then frmDCSumm.Align := alClient else frmDCSumm.Align := alNone; if Assigned(frmSurgery) then if NewForm.Name = frmSurgery.Name then frmSurgery.Align := alclient else frmSurgery.Align := alNone; //kt -- start addition //below taken out 6/29/07 to achieve compile. Fix later... if Assigned (frmImages) and (NewForm.Name = frmImages.Name) then begin frmImages.Align := alClient; end else begin frmImages.Align := alNone; end; //kt -- end addition NewForm.BringToFront; // to cause tab switch to happen immediately NewForm.FocusFirstControl; Application.ProcessMessages; PostMessage(Handle, UM_SHOWPAGE, 0, 0); // this calls DisplayPage for the form end; end; procedure TfrmFrame.mnuChartTabClick(Sender: TObject); { use the Tag property of the menu item to switch to proper page } begin with Sender as TMenuItem do tabPage.TabIndex := PageIDToTab(Tag); LastTab := TabToPageID(tabPage.TabIndex) ; tabPageChange(tabPage); end; procedure TfrmFrame.tabPageChange(Sender: TObject); { switches to form linked to NewTab } var TabID : integer; //kt added. begin if (not User.IsReportsOnly) then begin TabID := TabToPageID((sender as TTabControl).TabIndex); //kt //kt original line --> case TabToPageID((sender as TTabControl).TabIndex) of case TabID of CT_NOPAGE: SwitchToPage(nil); CT_COVER: SwitchToPage(frmCover); CT_PROBLEMS: SwitchToPage(frmProblems); CT_MEDS: SwitchToPage(frmMeds); CT_ORDERS: SwitchToPage(frmOrders); CT_NOTES: SwitchToPage(frmNotes); CT_CONSULTS: SwitchToPage(frmConsults); CT_DCSUMM: SwitchToPage(frmDCSumm); CT_SURGERY: SwitchToPage(frmSurgery); CT_LABS: SwitchToPage(frmLabs); CT_REPORTS: SwitchToPage(frmReports); CT_WEBTAB1..CT_LAST_WEBTAB: SwitchToPage(frmWebTabs[TabID-CT_WEBTAB1]); //kt added 8/6/08 CT_IMAGES: SwitchToPage(frmImages); //kt 8/19/05 end; {case} end else // Reports Only tab. SwitchToPage(frmReports); end; function TfrmFrame.PageIDToTab(PageID: Integer): Integer; { returns the tab index that corresponds to a given PageID } VAR i: integer; begin i := uTabList.IndexOf(IntToStr(PageID)); Result := i; //Result := uTabList.IndexOf(IntToStr(PageID)); (* Result := -1; case PageID of CT_NOPAGE: Result := -1; CT_COVER: Result := 0; CT_PROBLEMS: Result := 1; CT_MEDS: Result := 2; CT_ORDERS: Result := 3; {CT_HP: Result := 4;} CT_NOTES: Result := 4; CT_CONSULTS: Result := 5; CT_DCSUMM: Result := 6; CT_LABS: Result := 7; CT_REPORTS: Result := 8; end;*) end; function TfrmFrame.TabToPageID(Tab: Integer): Integer; { returns the constant that identifies the page given a TabIndex } begin if (Tab > -1) and (Tab < uTabList.Count) then Result := StrToIntDef(uTabList[Tab], CT_UNKNOWN) else Result := CT_NOPAGE; (* case Tab of -1: Result := CT_NOPAGE; 0: Result := CT_COVER; 1: Result := CT_PROBLEMS; 2: Result := CT_MEDS; 3: Result := CT_ORDERS; {4: Result := CT_HP;} 4: Result := CT_NOTES; 5: Result := CT_CONSULTS; 6: Result := CT_DCSUMM; 7: Result := CT_LABS; 8: Result := CT_REPORTS; end;*) end; { File Menu Events ------------------------------------------------------------------------- } procedure TfrmFrame.SetupPatient(AFlaggedList : TStringList); var AMsg, SelectMsg: string; begin with Patient do begin ClearPatient; // must be called to avoid leaving previous patient's information visible! Visible := True; Application.ProcessMessages; lblPtName.Caption := Name; lblPtSSN.Caption := SSN; lblPtAge.Caption := FormatFMDateTime('mmm dd,yyyy', DOB) + ' (' + IntToStr(Age) + ')'; pnlPatient.Caption := lblPtName.Caption + ' ' + lblPtSSN.Caption + ' ' + lblPtAge.Caption; if Length(CWAD) > 0 // then lblPtPostings.Caption := 'Postings' <-- original line. //kt 7/17/2007 then lblPtPostings.Caption := DKLangConstW('fFrame_Postings') //kt added 7/17/2007 // else lblPtPostings.Caption := 'No Postings'; <-- original line. //kt 7/17/2007 else lblPtPostings.Caption := DKLangConstW('fFrame_No_Postings'); //kt added 7/17/2007 lblPtCWAD.Caption := CWAD; pnlPostings.Caption := lblPtPostings.Caption + ' ' + lblPtCWAD.Caption; if (Length(PrimaryTeam) > 0) or (Length(PrimaryProvider) > 0) then lblPtCare.Caption := PrimaryTeam + ' / ' + MixedCase(PrimaryProvider); // if Length(Attending) > 0 then lblPtAttending.Caption := 'Attending: ' + MixedCase(Attending); <-- original line. //kt 7/17/2007 if Length(Attending) > 0 then lblPtAttending.Caption := DKLangConstW('fFrame_Attendingx') + MixedCase(Attending); //kt added 7/17/2007 pnlPrimaryCare.Caption := lblPtCare.Caption + ' ' + lblPtAttending.Caption; SetUpCIRN; DisplayEncounterText; SetShareNode(DFN, Handle); with Patient do NotifyOtherApps(NAE_NEWPT, SSN + U + FloatToStr(DOB) + U + Name); SelectMsg := ''; if MeansTestRequired(Patient.DFN, AMsg) then SelectMsg := AMsg; if HasLegacyData(Patient.DFN, AMsg) then SelectMsg := SelectMsg + CRLF + AMsg; HasActiveFlg(FlagList, HasFlag, Patient.DFN); if HasFlag then begin pnlFlag.Enabled := True; lblFlag.Font.Color := clMaroon; lblFlag.Enabled := True; if (not FReFreshing) and (TriggerPRFPopUp(Patient.DFN)) then ShowFlags; end else begin pnlFlag.Enabled := False; lblFlag.Font.Color := clBtnFace; lblFlag.Enabled := False; end; FPrevPtID := patient.DFN; frmCover.UpdateVAAButton; //VAA CQ7525 (moved here in v26.30 (RV)) ProcessPatientChangeEventHook; if Length(SelectMsg) > 0 then ShowPatientSelectMessages(SelectMsg); end; end; procedure TfrmFrame.mnuFileNextClick(Sender: TObject); var SaveDFN, NewDFN: string; // *DFN* NextIndex: Integer; Reason: string; CCOWResponse: UserResponse; procedure UpdatePatientInfoForAlert; begin if Patient.Inpatient then begin Encounter.Inpatient := True; Encounter.Location := Patient.Location; Encounter.DateTime := Patient.AdmitTime; Encounter.VisitCategory := 'H'; end; if User.IsProvider then Encounter.Provider := User.DUZ; SetupPatient(FlaggedPTList); if (FlaggedPTList.IndexOf(Patient.DFN) < 0) then FlaggedPTList.Add(Patient.DFN); end; begin SaveDFN := Patient.DFN; Notifications.Next; if Notifications.Active then begin NewDFN := Notifications.DFN; //Patient.DFN := Notifications.DFN; //if SaveDFN <> Patient.DFN then if SaveDFN <> NewDFN then begin // newdfn does not have new patient.co information for CCOW call if (AllowContextChangeAll(Reason)) then begin RemindersStarted := FALSE; Patient.DFN := NewDFN; Encounter.Clear; Changes.Clear; if Assigned(FlagList) then begin FlagList.Clear; HasFlag := False; HasActiveFlg(FlagList, HasFlag, NewDFN); end; if FCCOWInstalled and (ctxContextor.State = csParticipating) then begin if (AllowCCOWContextChange(CCOWResponse, Patient.DFN)) then UpdatePatientInfoForAlert else begin case CCOWResponse of urCancel: begin Patient.DFN := SaveDFN; Notifications.Prior; Exit; end; urBreak: begin // do not revert to old DFN if context was manually broken by user - v26 (RV) if (ctxContextor.State = csParticipating) then Patient.DFN := SaveDFN; UpdatePatientInfoForAlert; end; else UpdatePatientInfoForAlert; end; end; end else UpdatePatientInfoForAlert end else begin Patient.DFN := SaveDFN; Notifications.Prior; Exit; end; end; stsArea.Panels.Items[1].Text := Notifications.Text; FChangeSource := CC_NOTIFICATION; NextIndex := PageIDToTab(CT_COVER); tabPage.TabIndex := CT_NOPAGE; tabPageChange(tabPage); mnuFileNotifRemove.Enabled := Notifications.Followup in [NF_FLAGGED_ORDERS, NF_ORDER_REQUIRES_ELEC_SIGNATURE, NF_MEDICATIONS_EXPIRING_INPT, NF_MEDICATIONS_EXPIRING_OUTPT, NF_UNVERIFIED_MEDICATION_ORDER, NF_UNVERIFIED_ORDER, NF_FLAGGED_OI_EXP_INPT, NF_FLAGGED_OI_EXP_OUTPT]; case Notifications.FollowUp of NF_LAB_RESULTS : NextIndex := PageIDToTab(CT_LABS); NF_FLAGGED_ORDERS : NextIndex := PageIDToTab(CT_ORDERS); NF_ORDER_REQUIRES_ELEC_SIGNATURE : NextIndex := PageIDToTab(CT_ORDERS); NF_ABNORMAL_LAB_RESULTS : NextIndex := PageIDToTab(CT_LABS); NF_IMAGING_RESULTS : NextIndex := PageIDToTab(CT_REPORTS); NF_CONSULT_REQUEST_RESOLUTION : NextIndex := PageIDToTab(CT_CONSULTS); NF_ABNORMAL_IMAGING_RESULTS : NextIndex := PageIDToTab(CT_REPORTS); NF_IMAGING_REQUEST_CANCEL_HELD : NextIndex := PageIDToTab(CT_ORDERS); NF_NEW_SERVICE_CONSULT_REQUEST : NextIndex := PageIDToTab(CT_CONSULTS); NF_CONSULT_REQUEST_CANCEL_HOLD : NextIndex := PageIDToTab(CT_CONSULTS); NF_SITE_FLAGGED_RESULTS : NextIndex := PageIDToTab(CT_ORDERS); NF_ORDERER_FLAGGED_RESULTS : NextIndex := PageIDToTab(CT_ORDERS); NF_ORDER_REQUIRES_COSIGNATURE : NextIndex := PageIDToTab(CT_ORDERS); NF_LAB_ORDER_CANCELED : NextIndex := PageIDToTab(CT_ORDERS); NF_STAT_RESULTS : if Piece(Piece(Notifications.AlertData, '|', 2), '@', 2) = 'LRCH' then NextIndex := PageIDToTab(CT_LABS) else if Piece(Piece(Notifications.AlertData, '|', 2), '@', 2) = 'GMRC' then NextIndex := PageIDToTab(CT_CONSULTS) else if Piece(Piece(Notifications.AlertData, '|', 2), '@', 2) = 'RA' then NextIndex := PageIDToTab(CT_REPORTS); NF_DNR_EXPIRING : NextIndex := PageIDToTab(CT_ORDERS); NF_MEDICATIONS_EXPIRING_INPT : NextIndex := PageIDToTab(CT_ORDERS); NF_MEDICATIONS_EXPIRING_OUTPT : NextIndex := PageIDToTab(CT_ORDERS); NF_UNVERIFIED_MEDICATION_ORDER : NextIndex := PageIDToTab(CT_ORDERS); NF_NEW_ORDER : NextIndex := PageIDToTab(CT_ORDERS); NF_IMAGING_RESULTS_AMENDED : NextIndex := PageIDToTab(CT_REPORTS); NF_CRITICAL_LAB_RESULTS : NextIndex := PageIDToTab(CT_LABS); NF_UNVERIFIED_ORDER : NextIndex := PageIDToTab(CT_ORDERS); NF_FLAGGED_OI_RESULTS : NextIndex := PageIDToTab(CT_ORDERS); NF_FLAGGED_OI_ORDER : NextIndex := PageIDToTab(CT_ORDERS); NF_DC_ORDER : NextIndex := PageIDToTab(CT_ORDERS); NF_CONSULT_UNSIGNED_NOTE : NextIndex := PageIDToTab(CT_CONSULTS); NF_DCSUMM_UNSIGNED_NOTE : NextIndex := PageIDToTab(CT_DCSUMM); NF_NOTES_UNSIGNED_NOTE : NextIndex := PageIDToTab(CT_NOTES); NF_CONSULT_REQUEST_UPDATED : NextIndex := PageIDToTab(CT_CONSULTS); NF_FLAGGED_OI_EXP_INPT : NextIndex := PageIDToTab(CT_ORDERS); NF_FLAGGED_OI_EXP_OUTPT : NextIndex := PageIDToTab(CT_ORDERS); NF_CONSULT_PROC_INTERPRETATION : NextIndex := PageIDToTab(CT_CONSULTS); NF_IMAGING_REQUEST_CHANGED : begin ReportBox(GetNotificationFollowUpText(Patient.DFN, Notifications.FollowUp, Notifications.AlertData), Pieces(Piece(Notifications.RecordID, U, 1), ':', 2, 3), True); Notifications.Delete; end; NF_LAB_THRESHOLD_EXCEEDED : NextIndex := PageIDToTab(CT_LABS); NF_SURGERY_UNSIGNED_NOTE : if TabExists(CT_SURGERY) then NextIndex := PageIDToTab(CT_SURGERY) else InfoBox(TX_NO_SURG_NOTIF, TC_NO_SURG_NOTIF, MB_OK); //NextIndex := PageIDToTab(CT_NOTES); else InfoBox(TX_UNK_NOTIF, TC_UNK_NOTIF, MB_OK); end; tabPage.TabIndex := NextIndex; tabPageChange(tabPage); end else mnuFileOpenClick(mnuFileNext); end; procedure TfrmFrame.SetBADxList; var i: smallint; begin if not Assigned(UBAGlobals.tempDxList) then begin UBAGlobals.tempDxList := TList.Create; UBAGlobals.tempDxList.Count := 0; Application.ProcessMessages; end else begin //Kill the old Dx list for i := 0 to pred(UBAGlobals.tempDxList.Count) do TObject(UBAGlobals.tempDxList[i]).Free; UBAGlobals.tempDxList.Clear; Application.ProcessMessages; //Create new Dx list for newly selected patient if not Assigned(UBAGlobals.tempDxList) then begin UBAGlobals.tempDxList := TList.Create; UBAGlobals.tempDxList.Count := 0; Application.ProcessMessages; end; end; end; procedure TfrmFrame.mnuFileOpenClick(Sender: TObject); { select a new patient & update the header displays (patient id, encounter, postings) } var SaveDFN, Reason: string; //NextTab: Integer; // moved up for visibility - v23.4 rV ok, OldRemindersStarted, PtSelCancelled: boolean; //i: smallint; CCOWResponse: UserResponse; begin SetWebTabsPerServer; //kt added PtSelCancelled := FALSE; DetermineNextTab; (* if (FRefreshing or User.UseLastTab) and (not FFirstLoad) then NextTab := TabToPageID(tabPage.TabIndex) else NextTab := User.InitialTab; if NextTab = CT_NOPAGE then NextTab := User.InitialTab; if User.IsReportsOnly then // Reports Only tab. NextTab := 0; // Only one tab should exist by this point in "REPORTS ONLY" mode. if not TabExists(NextTab) then NextTab := CT_COVER; if NextTab = CT_NOPAGE then NextTab := User.InitialTab; if NextTab = CT_ORDERS then if frmOrders <> nil then with frmOrders do begin if (lstSheets.ItemIndex > -1 ) and (TheCurrentView <> nil) and (theCurrentView.EventDelay.PtEventIFN>0) then PtEvtCompleted(TheCurrentView.EventDelay.PtEventIFN, TheCurrentView.EventDelay.EventName); end;*) if not AllowContextChangeAll(Reason) then Exit; // update status text here stsArea.Panels.Items[1].Text := ''; if (not User.IsReportsOnly) then begin if not FRefreshing then begin Notifications.Next; // avoid prompt if no more alerts selected to process {v14a RV} if Notifications.Active then begin if (InfoBox(TX_NOTIF_STOP, TC_NOTIF_STOP, MB_YESNO) = ID_NO) then begin Notifications.Prior; Exit; end; end; if Notifications.Active then Notifications.Prior; end; end; if FNoPatientSelected then SaveDFN := '' else SaveDFN := Patient.DFN; OldRemindersStarted := RemindersStarted; RemindersStarted := FALSE; try if FRefreshing then begin UpdatePtInfoOnRefresh; ok := TRUE; end else begin ok := FALSE; if (not User.IsReportsOnly) then begin if FCCOWInstalled and (ctxContextor.State = csParticipating) then begin UpdateCCOWContext; if not FCCOWError then begin FCCOWIconName := 'BMP_CCOW_LINKED'; pnlCCOW.Hint := TX_CCOW_LINKED; imgCCOW.Picture.Bitmap.LoadFromResourceName(hInstance, FCCOWIconName); end; end else begin FCCOWIconName := 'BMP_CCOW_BROKEN'; pnlCCOW.Hint := TX_CCOW_BROKEN; imgCCOW.Picture.BitMap.LoadFromResourceName(hInstance, FCCOWIconName); end; if (Patient.DFN = '') or (Sender = mnuFileOpen) or (Sender = mnuFileNext) or (Sender = mnuViewDemo) then SelectPatient(SHOW_NOTIFICATIONS, Font.Size, PtSelCancelled); if PtSelCancelled then exit; ShowEverything; DisplayEncounterText; FPrevInPatient := Patient.Inpatient; if Notifications.Active then begin // display 'next notification' button FNextButtonActive := True; with stsArea.Panels[2] do begin //Text := 'Next ->'; Bevel := pbRaised; end; mnuFileNext.Enabled := True; mnuFileNextClick(Self); end else begin // hide the 'next notification' button FNextButtonActive := False; with stsArea.Panels[2] do begin //Text := ''; Bevel := pbLowered; end; mnuFileNext.Enabled := False; mnuFileNotifRemove.Enabled := False; if Patient.DFN <> SaveDFN then ok := TRUE; end end else begin Notifications.Clear; SelectPatient(False, Font.Size, PtSelCancelled); // Call Pt. Sel. w/o notifications. if PtSelCancelled then exit; ShowEverything; DisplayEncounterText; FPrevInPatient := Patient.Inpatient; ok := TRUE; end; end; if ok then begin if FCCOWInstalled and (ctxContextor.State = csParticipating) and (not FRefreshing) then begin if (AllowCCOWContextChange(CCOWResponse, Patient.DFN)) then begin SetupPatient; tabPage.TabIndex := PageIDToTab(NextTab); tabPageChange(tabPage); end else begin case CCOWResponse of urCancel: UpdateCCOWContext; urBreak: begin // do not revert to old DFN if context was manually broken by user - v26 (RV) if (ctxContextor.State = csParticipating) then Patient.DFN := SaveDFN; SetupPatient; tabPage.TabIndex := PageIDToTab(NextTab); tabPageChange(tabPage); end; else begin SetupPatient; tabPage.TabIndex := PageIDToTab(NextTab); tabPageChange(tabPage); end; end; end; end else begin SetupPatient; tabPage.TabIndex := PageIDToTab(NextTab); tabPageChange(tabPage); end; end; finally if (not FRefreshing) and (Patient.DFN = SaveDFN) then RemindersStarted := OldRemindersStarted; FFirstLoad := False; end; {Begin BillingAware} if BILLING_AWARE then frmFrame.SetBADxList; //end IsBillingAware {End BillingAware} //frmCover.UpdateVAAButton; //VAA CQ7525 CQ#7933 - moved to SetupPatient, before event hook execution (RV) end; procedure TfrmFrame.DetermineNextTab; begin if (FRefreshing or User.UseLastTab) and (not FFirstLoad) then begin if (tabPage.TabIndex < 0) then NextTab := LastTab else NextTab := TabToPageID(tabPage.TabIndex); end else NextTab := User.InitialTab; if NextTab = CT_NOPAGE then NextTab := User.InitialTab; if User.IsReportsOnly then // Reports Only tab. NextTab := 0; // Only one tab should exist by this point in "REPORTS ONLY" mode. if not TabExists(NextTab) then NextTab := CT_COVER; if NextTab = CT_NOPAGE then NextTab := User.InitialTab; if NextTab = CT_ORDERS then if frmOrders <> nil then with frmOrders do begin if (lstSheets.ItemIndex > -1 ) and (TheCurrentView <> nil) and (theCurrentView.EventDelay.PtEventIFN>0) then PtEvtCompleted(TheCurrentView.EventDelay.PtEventIFN, TheCurrentView.EventDelay.EventName); end; end; procedure TfrmFrame.mnuFileEncounterClick(Sender: TObject); { displays encounter window and updates encounter display in case encounter was updated } begin UpdateEncounter(NPF_ALL); {*KCM*} DisplayEncounterText; end; procedure TfrmFrame.mnuFileReviewClick(Sender: TObject); { displays the Review Changes window (which resets the Encounter object) } var EventChanges: boolean; NameNeedLook: string; begin EventChanges := False; NameNeedLook := ''; UpdatePtInfoOnRefresh; if Changes.Count > 0 then begin if (frmOrders <> nil) and (frmOrders.TheCurrentView <> nil) and ( frmOrders.TheCurrentView.EventDelay.EventIFN>0) then begin EventChanges := True; NameNeedLook := frmOrders.TheCurrentView.ViewName; frmOrders.PtEvtCompleted(frmOrders.TheCurrentView.EventDelay.PtEventIFN, frmOrders.TheCurrentView.EventDelay.EventName); end; ReviewChanges(TimedOut, EventChanges); if TabToPageID(tabPage.TabIndex)= CT_MEDS then begin frmOrders.InitOrderSheets2(NameNeedLook); end; end //else InfoBox('No new changes to review/sign.', 'Review Changes', MB_OK); <-- original line. //kt 7/17/2007 else InfoBox(DKLangConstW('fFrame_No_new_changes_to_reviewxsignx'), DKLangConstW('fFrame_Review_Changes'), MB_OK); //kt added 7/17/2007 end; procedure TfrmFrame.mnuFileExitClick(Sender: TObject); { see the CloseQuery event } var i: smallint; begin try if BILLING_AWARE then begin if Assigned(tempDxList) then for i := 0 to pred(UBAGlobals.tempDxList.Count) do TObject(UBAGlobals.tempDxList[i]).Free; UBAGlobals.tempDxList.Clear; Application.ProcessMessages; end; //end IsBillingAware except on EAccessViolation do begin // {$ifdef debug}ShowMessage('Access Violation in procedure TfrmFrame.mnuFileExitClick()');{$endif} <-- original line. //kt 7/17/2007 {$ifdef debug}ShowMessage(DKLangConstW('fFrame_Access_Violation_in_procedure_TfrmFramexmnuFileExitClickxx'));{$endif} //kt added 7/17/2007 raise; end; on E: Exception do begin // {$ifdef debug}ShowMessage('Unhandled exception in procedure TfrmFrame.mnuFileExitClick()');{$endif} <-- original line. //kt 7/17/2007 {$ifdef debug}ShowMessage(DKLangConstW('fFrame_Unhandled_exception_in_procedure_TfrmFramexmnuFileExitClickxx'));{$endif} //kt added 7/17/2007 raise; end; end; Close; end; { View Menu Events ------------------------------------------------------------------------- } procedure TfrmFrame.mnuViewPostingsClick(Sender: TObject); begin end; { Tool Menu Events ------------------------------------------------------------------------- } function TfrmFrame.ExpandCommand(x: string): string; { look for 'macros' on the command line and expand them using current context } procedure Substitute(const Key, Data: string); var Stop, Start: Integer; begin Stop := Pos(Key, x) - 1; Start := Stop + Length(Key) + 1; x := Copy(x, 1, Stop) + Data + Copy(x, Start, Length(x)); end; begin if Pos('%MREF', x) > 0 then Substitute('%MREF', '^TMP(''ORWCHART'',' + MScalar('$J') + ',''' + DottedIPStr + ''',' + IntToHex(Handle, 8) + ')'); if Pos('%SRV', x) > 0 then Substitute('%SRV', RPCBrokerV.Server); if Pos('%PORT', x) > 0 then Substitute('%PORT', IntToStr(RPCBrokerV.ListenerPort)); if Pos('%DFN', x) > 0 then Substitute('%DFN', Patient.DFN); //*DFN* if Pos('%DUZ', x) > 0 then Substitute('%DUZ', IntToStr(User.DUZ)); Result := x; end; procedure TfrmFrame.ToolClick(Sender: TObject); { executes the program associated with an item on the Tools menu, the command line is stored in the item's hint property } //const //TXT_ECS_NOTFOUND = 'The ECS application is not found at the default directory,' + #13 + 'would you like manually search it?'; <-- original line. //kt 7/17/2007 //TC_ECS_NOTFOUND = 'Application Not Found'; <-- original line. //kt 7/17/2007 var x, AFile, Param, MenuCommand, ECSAppend, CapNm, curPath : string; IsECSInterface: boolean; TXT_ECS_NOTFOUND : string; TC_ECS_NOTFOUND : string; function TakeOutAmps(AString: string): string; var S1,S2: string; begin if Pos('&',AString)=0 then begin Result := AString; Exit; end; S1 := Piece(AString,'&',1); S2 := Piece(AString,'&',2); Result := S1 + S2; end; function ExcuteEC(AFile,APara: string): boolean; begin if (ShellExecute(Handle, 'open', PChar(AFile), PChar(Param), '', SW_NORMAL) > 32 ) then Result := True else begin if InfoBox(TXT_ECS_NOTFOUND, TC_ECS_NOTFOUND, MB_YESNO or MB_ICONERROR) = IDYES then begin if OROpenDlg.Execute then begin AFile := OROpenDlg.FileName; if Pos('ecs gui.exe',lowerCase(AFile))<1 then begin // ShowMessage('This is not a valid ECS application.'); <-- original line. //kt 7/17/2007 ShowMessage(DKLangConstW('fFrame_This_is_not_a_valid_ECS_applicationx')); //kt added 7/17/2007 Result := True; end else begin if (ShellExecute(Handle, 'open', PChar(AFile), PChar(Param), '', SW_NORMAL)<32) then Result := False else Result := True; end; end else Result := True; end else Result := True; end; end; function ExcuteECS(AFile, APara: string; var currPath: string): boolean; var commandline,RPCHandle: string; StartupInfo: TStartupInfo; ProcessInfo: TProcessInformation; begin FillChar(StartupInfo, SizeOf(TStartupInfo), 0); with StartupInfo do begin cb := SizeOf(TStartupInfo); dwFlags := STARTF_USESHOWWINDOW; wShowWindow := SW_SHOWNORMAL; end; commandline := AFile + Param; RPCHandle := GetAppHandle(RPCBrokerV); commandline := commandline + ' H=' + RPCHandle; if CreateProcess(nil, PChar(commandline), nil, nil, False, NORMAL_PRIORITY_CLASS, nil, nil, StartupInfo, ProcessInfo) then Result := True else begin if InfoBox(TXT_ECS_NOTFOUND, TC_ECS_NOTFOUND, MB_YESNO or MB_ICONERROR) = IDYES then begin if OROpenDlg.Execute then begin AFile := OROpenDlg.FileName; if Pos('ecs gui.exe',lowerCase(AFile))<1 then begin // ShowMessage('This is not a valid ECS application.'); <-- original line. //kt 7/17/2007 ShowMessage(DKLangConstW('fFrame_This_is_not_a_valid_ECS_applicationx')); //kt added 7/17/2007 Result := True; end else begin // SaveUserPath('Event Capture Interface='+AFile, currPath); <-- original line. //kt 7/17/2007 SaveUserPath(DKLangConstW('fFrame_Event_Capture_Interface')+'='+AFile, currPath); //kt added 7/17/2007 FillChar(StartupInfo, SizeOf(TStartupInfo), 0); with StartupInfo do begin cb := SizeOf(TStartupInfo); dwFlags := STARTF_USESHOWWINDOW; wShowWindow := SW_SHOWNORMAL; end; commandline := AFile + Param; RPCHandle := GetAppHandle(RPCBrokerV); commandline := commandline + ' H=' + RPCHandle; if not CreateProcess(nil, PChar(commandline), nil, nil, False, NORMAL_PRIORITY_CLASS, nil, nil,StartupInfo,ProcessInfo) then Result := False else Result := True; end; end else Result := True; end else Result := True; end; end; begin TXT_ECS_NOTFOUND := DKLangConstW('fFrame_The_ECS_application_is_not_found_at_the_default_directoryx') + #13 + DKLangConstW('fFrame_would_you_like_manually_search_itx'); //kt added 7/17/2007 TC_ECS_NOTFOUND := DKLangConstW('fFrame_Application_Not_Found'); //kt added 7/17/2007 MenuCommand := ''; ECSAppend := ''; IsECSInterface := False; curPath := ''; CapNm := LowerCase(TMenuItem(Sender).Caption); CapNm := TakeOutAmps(CapNm); if AnsiCompareText('event capture interface',CapNm)=0 then begin IsECSInterface := True; if FECSAuthUser then UpdateECSParameter(ECSAppend) else begin // ShowMessage('You don''t have permission to use ECS.'); <-- original line. //kt 7/17/2007 ShowMessage(DKLangConstW('fFrame_You_donxxt_have_permission_to_use_ECSx')); //kt added 7/17/2007 exit; end; end; MenuCommand := TMenuItem(Sender).Hint + ECSAppend; x := ExpandCommand(MenuCommand); if CharAt(x, 1) = '"' then begin x := Copy(x, 2, Length(x)); AFile := Copy(x, 1, Pos('"',x)-1); Param := Copy(x, Pos('"',x)+1, Length(x)); end else begin AFile := Piece(x, ' ', 1); Param := Copy(x, Length(AFile)+1, Length(x)); end; if IsECSInterface then begin if not ExcuteECS(AFile,Param,curPath) then ExcuteECS(AFile,Param,curPath); if Length(curPath)>0 then TMenuItem(Sender).Hint := curPath; end else if (Pos('ecs',LowerCase(AFile))>0) and (not IsECSInterface) then begin if not ExcuteEC(AFile,Param) then ExcuteEC(AFile,Param); end else begin ShellExecute(Handle, 'open', PChar(AFile), PChar(Param), '', SW_NORMAL); end; end; { Help Menu Events ------------------------------------------------------------------------- } procedure TfrmFrame.mnuHelpBrokerClick(Sender: TObject); { used for debugging - shows last n broker calls } begin ShowBroker; end; procedure TfrmFrame.mnuHelpListsClick(Sender: TObject); { used for debugging - shows internal contents of TORListBox } begin if Screen.ActiveControl is TListBox then DebugListItems(TListBox(Screen.ActiveControl)) // else InfoBox('Focus control is not a listbox', 'ListBox Data', MB_OK); <-- original line. //kt 7/17/2007 else InfoBox(DKLangConstW('fFrame_Focus_control_is_not_a_listbox'), DKLangConstW('fFrame_ListBox_Data'), MB_OK); //kt added 7/17/2007 end; procedure TfrmFrame.mnuHelpSymbolsClick(Sender: TObject); { used for debugging - shows current symbol table } begin DebugShowServer; end; procedure TfrmFrame.mnuHelpAboutClick(Sender: TObject); { displays the about screen } begin ShowAbout; end; { Status Bar Methods } procedure TfrmFrame.UMStatusText(var Message: TMessage); { displays status bar text (using the pointer to a text buffer passed in LParam) } begin stsArea.Panels.Items[0].Text := StrPas(PChar(Message.LParam)); stsArea.Refresh; end; procedure TfrmFrame.stsAreaMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if (FNextButtonActive) and (X > FNextButtonL) and (X < FNextButtonR) then begin stsArea.Panels[2].Bevel := pbLowered; popAlerts.AutoPopup := TRUE; end; end; procedure TfrmFrame.stsAreaMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if FNextButtonActive then begin stsArea.Panels[2].Bevel := pbRaised; popAlerts.AutoPopup := FALSE; if (X > FNextButtonL) and (X < FNextButtonR) then if Button = mbLeft then mnuFileNextClick(Self); end; end; procedure TfrmFrame.stsAreaDrawPanel(StatusBar: TStatusBar; Panel: TStatusPanel; const Rect: TRect); begin if FNextButtonActive then with StatusBar.Canvas do begin Draw(Rect.Left + 2, Rect.Top, FNextButtonBitmap); { draw bitmap } TextOut(Rect.Left + 20, Rect.Top + 2, 'Next'); { draw text to the right of the bitmap } end; end; { Toolbar Methods (make panels act like buttons) ------------------------------------------- } procedure TfrmFrame.pnlPatientMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); { emulate a button press in the patient identification panel } begin if pnlPatient.BevelOuter = bvLowered then exit; pnlPatient.BevelOuter := bvLowered; with lblPtName do SetBounds(Left+2, Top+2, Width, Height); with lblPtSSN do SetBounds(Left+2, Top+2, Width, Height); with lblPtAge do SetBounds(Left+2, Top+2, Width, Height); end; procedure TfrmFrame.pnlPatientMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); { emulate the button raising in the patient identification panel & call Patient Inquiry } begin if pnlPatient.BevelOuter = bvRaised then exit; pnlPatient.BevelOuter := bvRaised; with lblPtName do SetBounds(Left-2, Top-2, Width, Height); with lblPtSSN do SetBounds(Left-2, Top-2, Width, Height); with lblPtAge do SetBounds(Left-2, Top-2, Width, Height); end; procedure TfrmFrame.pnlVisitMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); { emulate a button press in the encounter panel } begin if User.IsReportsOnly then exit; pnlVisit.BevelOuter := bvLowered; //with lblStLocation do SetBounds(Left+2, Top+2, Width, Height); with lblPtLocation do SetBounds(Left+2, Top+2, Width, Height); with lblPtProvider do SetBounds(Left+2, Top+2, Width, Height); end; procedure TfrmFrame.pnlVisitMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); { emulate a button raising in the encounter panel and call Update Provider/Location } begin if User.IsReportsOnly then exit; pnlVisit.BevelOuter := bvRaised; //with lblStLocation do SetBounds(Left-2, Top-2, Width, Height); with lblPtLocation do SetBounds(Left-2, Top-2, Width, Height); with lblPtProvider do SetBounds(Left-2, Top-2, Width, Height); end; procedure TfrmFrame.pnlPrimaryCareMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin pnlPrimaryCare.BevelOuter := bvLowered; with lblPtCare do SetBounds(Left+2, Top+2, Width, Height); with lblPtAttending do SetBounds(Left+2, Top+2, Width, Height); end; procedure TfrmFrame.pnlPrimaryCareMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin pnlPrimaryCare.BevelOuter := bvRaised; with lblPtCare do SetBounds(Left-2, Top-2, Width, Height); with lblPtAttending do SetBounds(Left-2, Top-2, Width, Height); end; procedure TfrmFrame.pnlPostingsMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); { emulate a button press in the postings panel } begin pnlPostings.BevelOuter := bvLowered; with lblPtPostings do SetBounds(Left+2, Top+2, Width, Height); with lblPtCWAD do SetBounds(Left+2, Top+2, Width, Height); end; procedure TfrmFrame.pnlPostingsMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); { emulate a button raising in the posting panel and call Postings } begin pnlPostings.BevelOuter := bvRaised; with lblPtPostings do SetBounds(Left-2, Top-2, Width, Height); with lblPtCWAD do SetBounds(Left-2, Top-2, Width, Height); end; { Resize and Font-Change procedures -------------------------------------------------------- } procedure TfrmFrame.LoadSizesForUser; var s1, s2, s3, s4, Dummy: integer; panelBottom, panelMedIn : integer; begin ChangeFont(UserFontSize); SetUserBounds(TControl(frmFrame)); SetUserWidths(TControl(frmProblems.pnlLeft)); //SetUserWidths(TControl(frmMeds.pnlLeft)); SetUserWidths(TControl(frmOrders.pnlLeft)); SetUserWidths(TControl(frmNotes.pnlLeft)); SetUserWidths(TControl(frmConsults.pnlLeft)); SetUserWidths(TControl(frmDCSumm.pnlLeft)); if Assigned(frmSurgery) then SetUserWidths(TControl(frmSurgery.pnlLeft)); SetUserWidths(TControl(frmLabs.pnlLeft)); SetUserWidths(TControl(frmReports.pnlLeft)); SetUserColumns(TControl(frmOrders.hdrOrders)); SetUserColumns(TControl(frmMeds.hdrMedsIn)); // still need conversion SetUserColumns(TControl(frmMeds.hdrMedsOut)); SetUserBounds2(ReminderTreeName, RemTreeDlgLeft, RemTreeDlgTop, RemTreeDlgWidth, RemTreeDlgHeight); SetUserBounds2(RemDlgName, RemDlgLeft, RemDlgTop, RemDlgWidth, RemDlgHeight); SetUserBounds2(RemDlgSplitters, RemDlgSpltr1, RemDlgSpltr2, Dummy ,Dummy); SetUserBounds2(DrawerSplitters,s1, s2, s3, Dummy); if Assigned(frmSurgery) then frmSurgery.Drawers.LastOpenSize := Dummy; //CQ7315 frmNotes.Drawers.LastOpenSize := s1; frmConsults.Drawers.LastOpenSize := s2; frmDCSumm.Drawers.LastOpenSize := s3; with frmMeds do begin SetUserBounds2(frmMeds.Name+'Split', panelBottom, panelMedIn, Dummy, Dummy); if (panelBottom > frmMeds.Height-50) then panelBottom := frmMeds.Height-50; if (panelMedIn > panelBottom-50) then panelMedIn := panelBottom-50; frmMeds.pnlBottom.Height := panelBottom; frmMeds.pnlMedIn.Height := panelMedIn; //Meds Tab Non-VA meds columns SetUserColumns(TControl(hdrMedsNonVA)); //CQ7314 end; frmCover.DisableAlign; try SetUserBounds2(CoverSplitters1, s1, s2, s3, s4); if s1 > 0 then frmCover.pnl_1.Width := LowerOf( frmCover.pnl_not3.ClientWidth - 5, s1); if s2 > 0 then frmCover.pnl_3.Width := LowerOf( frmCover.pnlTop.ClientWidth - 5, s2); if s3 > 0 then frmCover.pnlTop.Height := LowerOf( frmCover.pnlBase.ClientHeight - 5, s3); if s4 > 0 then frmCover.pnl_4.Width := LowerOf( frmCover.pnlMiddle.ClientWidth - 5, s4); SetUserBounds2(CoverSplitters2, s1, s2, s3, Dummy); if s1 > 0 then frmCover.pnlBottom.Height := LowerOf( frmCover.pnlBase.ClientHeight - 5, s1); if s2 > 0 then frmCover.pnl_6.Width := LowerOf( frmCover.pnlBottom.ClientWidth - 5, s2); if s3 > 0 then frmCover.pnl_8.Width := LowerOf( frmCover.pnlBottom.ClientWidth - 5, s3); finally frmCover.EnableAlign; end; if ParamSearch('rez') = '640' then SetBounds(Left, Top, 648, 488); // for testing end; procedure TfrmFrame.SaveSizesForUser; var SizeList: TStringList; SurgTempHt: integer; begin SaveUserFontSize(MainFontSize); SizeList := TStringList.Create; try with SizeList do begin Add(StrUserBounds(frmFrame)); Add(StrUserWidth(frmProblems.pnlLeft)); //Add(StrUserWidth(frmMeds.pnlLeft)); Add(StrUserWidth(frmOrders.pnlLeft)); Add(StrUserWidth(frmNotes.pnlLeft)); Add(StrUserWidth(frmConsults.pnlLeft)); Add(StrUserWidth(frmDCSumm.pnlLeft)); if Assigned(frmSurgery) then Add(StrUserWidth(frmSurgery.pnlLeft)); Add(StrUserWidth(frmLabs.pnlLeft)); Add(StrUserWidth(frmReports.pnlLeft)); Add(StrUserColumns(frmOrders.hdrOrders)); Add(StrUserColumns(frmMeds.hdrMedsIn)); Add(StrUserColumns(frmMeds.hdrMedsOut)); Add(StrUserBounds2(ReminderTreeName, RemTreeDlgLeft, RemTreeDlgTop, RemTreeDlgWidth, RemTreeDlgHeight)); Add(StrUserBounds2(RemDlgName, RemDlgLeft, RemDlgTop, RemDlgWidth, RemDlgHeight)); Add(StrUserBounds2(RemDlgSplitters, RemDlgSpltr1, RemDlgSpltr2, 0 ,0)); //v26.47 - RV - access violation if Surgery Tab not enabled. Set to designer height as default. if Assigned(frmSurgery) then SurgTempHt := frmSurgery.Drawers.pnlTemplates.Height else SurgTempHt := 85; Add(StrUserBounds2(DrawerSplitters, frmNotes.Drawers.LastOpenSize, frmConsults.Drawers.LastOpenSize, frmDCSumm.Drawers.LastOpenSize, SurgTempHt)); // last parameter = CQ7315 Add(StrUserBounds2(CoverSplitters1, frmCover.pnl_1.Width, frmCover.pnl_3.Width, frmCover.pnlTop.Height, frmCover.pnl_4.Width)); Add(StrUserBounds2(CoverSplitters2, frmCover.pnlBottom.Height, frmCover.pnl_6.Width, frmCover.pnl_8.Width, 0)); //Meds Tab Splitters Add(StrUserBounds2(frmMeds.Name+'Split',frmMeds.pnlBottom.Height,frmMeds.pnlMedIn.Height,0,0)); //Meds Tab Non-VA meds columns Add(StrUserColumns(fMeds.frmMeds.hdrMedsNonVA)); //CQ7314 //Orders Tab columns Add(StrUserColumns(fOrders.frmOrders.hdrOrders)); //CQ6328 if EnduringPtSelSplitterPos <> 0 then Add(StrUserBounds2('frmPtSel.sptVert', EnduringPtSelSplitterPos, 0, 0, 0)); end; //Add sizes for forms that used SaveUserBounds() to save thier positions SizeHolder.AddSizesToStrList(SizeList); //Send the SizeList to the Database SaveUserSizes(SizeList); finally SizeList.Free; end; end; procedure TfrmFrame.FormResize(Sender: TObject); { need to resize tab forms specifically since they don't inherit resize event (because they are derived from TForm itself) } var i,index : integer; //kt begin if FTerminate or FClosing then Exit; if csDestroying in ComponentState then Exit; MoveWindow(frmCover.Handle, 0, 0, pnlPage.ClientWidth, pnlPage.ClientHeight, True); MoveWindow(frmProblems.Handle, 0, 0, pnlPage.ClientWidth, pnlPage.ClientHeight, True); MoveWindow(frmMeds.Handle, 0, 0, pnlPage.ClientWidth, pnlPage.ClientHeight, True); MoveWindow(frmOrders.Handle, 0, 0, pnlPage.ClientWidth, pnlPage.ClientHeight, True); MoveWindow(frmNotes.Handle, 0, 0, pnlPage.ClientWidth, pnlPage.ClientHeight, True); MoveWindow(frmConsults.Handle, 0, 0, pnlPage.ClientWidth, pnlPage.ClientHeight, True); MoveWindow(frmDCSumm.Handle, 0, 0, pnlPage.ClientWidth, pnlPage.ClientHeight, True); if Assigned(frmSurgery) then MoveWindow(frmSurgery.Handle, 0, 0, pnlPage.ClientWidth, pnlPage.ClientHeight, True); MoveWindow(frmLabs.Handle, 0, 0, pnlPage.ClientWidth, pnlPage.ClientHeight, True); MoveWindow(frmReports.Handle, 0, 0, pnlPage.ClientWidth, pnlPage.ClientHeight, True); for i := CT_WEBTAB1 to CT_LAST_WEBTAB do begin //kt added block. index := i-CT_WEBTAB1; if frmWebTabs[index]=nil then continue; tempFrmWebTab := TfrmWebTab(frmWebTabs[index]); if tempFrmWebTab <> nil then begin MoveWindow(tempFrmWebTab.Handle, 0, 0, pnlPage.ClientWidth, pnlPage.ClientHeight, True); //kt end; end; //kt MoveWindow(frmWebTab1.Handle, 0, 0, pnlPage.ClientWidth, pnlPage.ClientHeight, True); //kt with stsArea do begin Panels[1].Width := stsArea.Width - FFixedStatusWidth; FNextButtonL := Panels[0].Width + Panels[1].Width; FNextButtonR := FNextButtonL + Panels[2].Width; end; lstCIRNLocations.Left := FNextButtonL - ScrollBarWidth - 100; lstCIRNLocations.Width := ClientWidth - lstCIRNLocations.Left; Self.Repaint; end; procedure TfrmFrame.ChangeFont(NewFontSize: Integer); { Makes changes in all components whenever the font size is changed. This is hardcoded and based on MS Sans Serif for now, as only the font size may be selected. Courier New is used wherever non-proportional fonts are required. } const TAB_VOFFSET = 7; var OldFont: TFont; begin // Ho ho! ResizeAnchoredFormToFont(self) doesn't work here because the // Form size is aliased with MainFormSize. OldFont := TFont.Create; try DisableAlign; try OldFont.Assign(Font); with Self do Font.Size := NewFontSize; with lblPtName do Font.Size := NewFontSize; // must change BOLDED labels by hand with lblPtSSN do Font.Size := NewFontSize; with lblPtAge do Font.Size := NewFontSize; with lblPtLocation do Font.Size := NewFontSize; with lblPtProvider do Font.Size := NewFontSize; with lblPtPostings do Font.Size := NewFontSize; with lblPtCare do Font.Size := NewFontSize; with lblPtAttending do Font.Size := NewFontSize; with lblFlag do Font.Size := NewFontSize; with lblPtCWAD do Font.Size := NewFontSize; with lblCIRN do Font.Size := NewFontSize; with lblCIRNData do Font.Size := NewFontSize; with lstCIRNLocations do Font.Size := NewFontSize; with tabPage do Font.Size := NewFontSize; with laMHV do Font.Size := NewFontSize; //VAA with laVAA2 do Font.Size := NewFontSize; //VAA tabPage.Height := MainFontHeight + TAB_VOFFSET; // resize tab selector FitToolbar; // resize toolbar stsArea.Font.Size := NewFontSize; stsArea.Height := MainFontHeight + TAB_VOFFSET; stsArea.Panels[0].Width := ResizeWidth( OldFont, Font, stsArea.Panels[0].Width); stsArea.Panels[2].Width := ResizeWidth( OldFont, Font, stsArea.Panels[2].Width); //VAA CQ8271 if ((fCover.PtIsVAA and fCover.PtIsMHV)) then begin laMHV.Height := (pnlToolBar.Height div 2) -1; with laVAA2 do begin Top := laMHV.Top + laMHV.Height; Height := (pnlToolBar.Height div 2) -1; end; end; //end VAA RefreshFixedStatusWidth; FormResize( self ); finally EnableAlign; end; finally OldFont.Free; end; //remove CWAD color if using high-contrast colors if ColorToRGB(clWindowText) <> ColorToRGB(clBlack) then begin lblPtCWAD.Font.Color := clWindowText; lblFlag.Font.Color := clWindowText; end; case (NewFontSize) of 8: mnu8pt.Checked := true; 10: mnu10pt1.Checked := true; 12: mnu12pt1.Checked := true; 14: mnu14pt1.Checked := true; 18: mnu18pt1.Checked := true; 24: mnu24pt1.Checked := true; end; //Now that the form elements are resized, the pages will know what size to take. frmCover.SetFontSize(NewFontSize); // child pages lack a ParentFont property frmProblems.SetFontSize(NewFontSize); frmMeds.SetFontSize(NewFontSize); frmOrders.SetFontSize(NewFontSize); frmNotes.SetFontSize(NewFontSize); frmConsults.SetFontSize(NewFontSize); frmDCSumm.SetFontSize(NewFontSize); if Assigned(frmSurgery) then frmSurgery.SetFontSize(NewFontSize); frmLabs.SetFontSize(NewFontSize); frmReports.SetFontSize(NewFontSize); TfrmIconLegend.SetFontSize(NewFontSize); uOrders.SetFontSize(NewFontSize); if Assigned(frmRemDlg) then frmRemDlg.SetFontSize; if Assigned(frmReminderTree) then frmReminderTree.SetFontSize(NewFontSize); if Assigned(frmImages) then frmImages.SetFontSize(NewFontSize); //kt if GraphFloat <> nil then ResizeAnchoredFormToFont(GraphFloat); end; procedure TfrmFrame.FitToolBar; { resizes and repositions the panels & labels used in the toolbar } const PATIENT_WIDTH = 29; VISIT_WIDTH = 36; POSTING_WIDTH = 11.5; FLAG_WIDTH = 5; CIRN_WIDTH = 7; MHV_WIDTH = 6; LINES_HIGH = 2; M_HORIZ = 4; M_MIDDLE = 2; M_NVERT = 4; M_WVERT = 6; TINY_MARGIN = 2; //var //WidthNeeded: integer; begin pnlToolbar.Height := (LINES_HIGH * lblPtName.Height) + M_HORIZ + M_MIDDLE + M_HORIZ; pnlPatient.Width := HigherOf(PATIENT_WIDTH * MainFontWidth, lblPtName.Width + (M_WVERT * 2)); lblPtSSN.Top := M_HORIZ + lblPtName.Height + M_MIDDLE; lblPtAge.Top := lblPtSSN.Top; lblPtAge.Left := pnlPatient.Width - lblPtAge.Width - M_WVERT; pnlVisit.Width := HigherOf(LowerOf(VISIT_WIDTH * MainFontWidth, HigherOf(lblPtProvider.Width + (M_WVERT * 2), lblPtLocation.Width + (M_WVERT * 2))), PATIENT_WIDTH * MainFontWidth); lblPtProvider.Top := lblPtSSN.Top; lblPtAttending.Top := lblPtSSN.Top; lblCIRNData.Top := lblPtSSN.Top; pnlPostings.Width := Round(POSTING_WIDTH * MainFontWidth); pnlFlag.Width := Round(FLAG_WIDTH * MainFontWidth); pnlFlag.Width := Round(FLAG_WIDTH * MainFontWidth); pnlCIRN.Width := Round(CIRN_WIDTH * MainFontWidth) + M_WVERT; paVAA.Width := Round(MHV_WIDTH * MainFontWidth) + M_WVERT; with lblPtPostings do SetBounds(M_WVERT, M_HORIZ, pnlPostings.Width-M_WVERT-M_WVERT, lblPtName.Height); with lblPtCWAD do SetBounds(M_WVERT, lblPtSSN.Top, lblPtPostings.Width, lblPtName.Height); //Low resolution handling: First, try to fit everything on by shrinking fields if pnlPrimaryCare.Width < HigherOf( lblPtCare.Left + lblPtCare.Width, lblPtAttending.Left + lblPtAttending.Width) + TINY_MARGIN then begin lblPtAge.Left := lblPtAge.Left - (lblPtName.Left - TINY_MARGIN); lblPtName.Left := TINY_MARGIN; lblPTSSN.Left := TINY_MARGIN; pnlPatient.Width := HigherOf( lblPtName.Left + lblPtName.Width, lblPtAge.Left + lblPtAge.Width)+ TINY_MARGIN; lblPtLocation.Left := TINY_MARGIN; lblPtProvider.Left := TINY_MARGIN; pnlVisit.Width := HigherOf( lblPtLocation.Left + lblPtLocation.Width, lblPtProvider.Left + lblPtProvider.Width)+ TINY_MARGIN; end; //If that is not enough, add scroll bars to form {if pnlPrimaryCare.Width < HigherOf( lblPtCare.Left + lblPtCare.Width, lblPtAttending.Left + lblPtAttending.Width) + TINY_MARGIN then begin WidthNeeded := HigherOf( lblPtCare.Left + lblPtCare.Width, lblPtAttending.Left + lblPtAttending.Width) + TINY_MARGIN - pnlPrimaryCare.Width; HorzScrollBar.Range := ClientWidth + WidthNeeded; Width := Width + WidthNeeded; end else } // commented out - BA HorzScrollBar.Range := 0; end; { Temporary Calls -------------------------------------------------------------------------- } procedure TfrmFrame.ToggleMenuItemChecked(Sender: TObject); begin with (Sender as TMenuItem) do begin if not Checked then Checked := true else Checked := false; end; end; procedure TfrmFrame.mnuFontSizeClick(Sender: TObject); begin if (frmRemDlg <> nil) then // ShowMessage('Please close the reminder dialog before changing font sizes.') <-- original line. //kt 7/17/2007 ShowMessage(DKLangConstW('fFrame_Please_close_the_reminder_dialog_before_changing_font_sizesx')) //kt added 7/17/2007 else if (dlgProbs <> nil) then // ShowMessage('Font size cannot be changed while adding or editing a problem.') <-- original line. //kt 7/17/2007 ShowMessage(DKLangConstW('fFrame_Font_size_cannot_be_changed_while_adding_or_editing_a_problemx')) //kt added 7/17/2007 else begin with (Sender as TMenuItem) do begin ToggleMenuItemChecked(Sender); fMeds.oldFont := MainFontSize; //CQ9182 ChangeFont(Tag); end; end; end; procedure TfrmFrame.mnuEditClick(Sender: TObject); var IsReadOnly: Boolean; begin FEditCtrl := nil; if Screen.ActiveControl is TCustomEdit then FEditCtrl := TCustomEdit(Screen.ActiveControl); if FEditCtrl <> nil then begin if FEditCtrl is TMemo then IsReadOnly := TMemo(FEditCtrl).ReadOnly else if FEditCtrl is TEdit then IsReadOnly := TEdit(FEditCtrl).ReadOnly else if FEditCtrl is TRichEdit then IsReadOnly := TRichEdit(FEditCtrl).ReadOnly else IsReadOnly := True; mnuEditUndo.Enabled := FEditCtrl.Perform(EM_CANUNDO, 0, 0) <> 0; mnuEditCut.Enabled := FEditCtrl.SelLength > 0; mnuEditCopy.Enabled := mnuEditCut.Enabled; mnuEditPaste.Enabled := (IsReadOnly = False) and Clipboard.HasFormat(CF_TEXT); end else begin mnuEditUndo.Enabled := False; mnuEditCut.Enabled := False; mnuEditCopy.Enabled := False; mnuEditPaste.Enabled := False; end; end; procedure TfrmFrame.mnuEditUndoClick(Sender: TObject); begin FEditCtrl.Perform(EM_UNDO, 0, 0); end; procedure TfrmFrame.mnuEditCutClick(Sender: TObject); begin FEditCtrl.CutToClipboard; end; procedure TfrmFrame.mnuEditCopyClick(Sender: TObject); begin FEditCtrl.CopyToClipboard; end; procedure TfrmFrame.mnuEditPasteClick(Sender: TObject); begin FEditCtrl.SelText := Clipboard.AsText; //FEditCtrl.PasteFromClipboard; // use AsText to prevent formatting from being pasted end; procedure TfrmFrame.mnuFilePrintClick(Sender: TObject); begin case mnuFilePrint.Tag of CT_NOTES: frmNotes.RequestPrint; CT_CONSULTS: frmConsults.RequestPrint; CT_DCSUMM: frmDCSumm.RequestPrint; CT_REPORTS: frmReports.RequestPrint; CT_LABS: frmLabs.RequestPrint; CT_ORDERS: frmOrders.RequestPrint; CT_PROBLEMS: frmProblems.RequestPrint; CT_SURGERY: if Assigned(frmSurgery) then frmSurgery.RequestPrint; CT_WEBTAB1..CT_LAST_WEBTAB: begin tempFrmWebTab := TfrmWebTab(frmWebTabs[mnuFilePrint.Tag-CT_WEBTAB1]); if tempFrmWebTab <> nil then tempFrmWebTab.RequestPrint; end; end; end; function TfrmFrame.FormHelp(Command: Word; Data: Integer; var CallHelp: Boolean): Boolean; var ActiveForm: TForm; begin inherited; if Screen.ActiveForm <> nil then begin if Screen.ActiveForm.ActiveControl <> nil then begin if Screen.ActiveForm.ActiveControl is TForm then ActiveForm := TForm(Screen.ActiveForm.ActiveControl) else if Screen.ActiveForm.ActiveControl.Owner is TForm then ActiveForm := TForm(Screen.ActiveForm.ActiveControl.Owner) else ActiveForm := Screen.ActiveForm; end else ActiveForm := Screen.ActiveForm; HelpFile := ActiveForm.HelpFile; end ; Result := True; end; procedure TfrmFrame.WMSysCommand(var Message: TMessage); begin case TabToPageID(tabPage.TabIndex) of CT_NOTES: if Assigned(Screen.ActiveControl.Parent) and (Screen.ActiveControl.Parent.Name = 'cboCosigner') then with Message do begin SendMessage(frmNotes.Handle, Msg, WParam, LParam); Result := 0; end else inherited; CT_DCSUMM: if Assigned(Screen.ActiveControl.Parent) and (Screen.ActiveControl.Parent.Name = 'cboAttending') then with Message do begin SendMessage(frmDCSumm.Handle, Msg, WParam, lParam); Result := 0; end else inherited; CT_CONSULTS: if Assigned(Screen.ActiveControl.Parent) and (Screen.ActiveControl.Parent.Name = 'cboCosigner') then with Message do begin SendMessage(frmConsults.Handle, Msg, WParam, lParam); Result := 0; end else inherited; else inherited; end; if Message.WParam = SC_MAXIMIZE then begin // form becomes maximized; frmOrders.mnuOptimizeFieldsClick(self); frmProblems.mnuOptimizeFieldsClick(self); frmMeds.mnuOptimizeFieldsClick(self); end else if Message.WParam = SC_MINIMIZE then begin // form becomes maximized; end else if Message.WParam = SC_RESTORE then begin // form is restored (from maximized); frmOrders.mnuOptimizeFieldsClick(self); frmProblems.mnuOptimizeFieldsClick(self); frmMeds.mnuOptimizeFieldsClick(self); end; end; procedure TfrmFrame.RemindersChanged(Sender: TObject); var ImgName: string; begin pnlReminders.tag := HAVE_REMINDERS; //pnlReminders.Hint := 'Click to display reminders'; <-- original line. //kt 7/17/2007 pnlReminders.Hint := DKLangConstW('fFrame_Click_to_display_reminders'); //kt added 7/17/2007 case GetReminderStatus of rsUnknown: begin ImgName := 'BMP_REMINDERS_UNKNOWN'; // pnlReminders.Caption := 'Reminders'; <-- original line. //kt 7/17/2007 pnlReminders.Caption := DKLangConstW('fFrame_Reminders'); //kt added 7/17/2007 end; rsDue: begin ImgName := 'BMP_REMINDERS_DUE'; // pnlReminders.Caption := 'Due Reminders'; <-- original line. //kt 7/17/2007 pnlReminders.Caption := DKLangConstW('fFrame_Due_Reminders'); //kt added 7/17/2007 end; rsApplicable: begin ImgName := 'BMP_REMINDERS_APPLICABLE'; // pnlReminders.Caption := 'Applicable Reminders'; <-- original line. //kt 7/17/2007 pnlReminders.Caption := DKLangConstW('fFrame_Applicable_Reminders'); //kt added 7/17/2007 end; rsNotApplicable: begin ImgName := 'BMP_REMINDERS_OTHER'; // pnlReminders.Caption := 'Other Reminders'; <-- original line. //kt 7/17/2007 pnlReminders.Caption := DKLangConstW('fFrame_Other_Reminders'); //kt added 7/17/2007 end; else begin ImgName := 'BMP_REMINDERS_NONE'; // pnlReminders.Hint := 'There are currently no reminders available'; <-- original line. //kt 7/17/2007 pnlReminders.Hint := DKLangConstW('fFrame_There_are_currently_no_reminders_available'); //kt added 7/17/2007 pnlReminders.Caption := pnlReminders.Hint; pnlReminders.tag := NO_REMINDERS; end; end; if(RemindersEvaluatingInBackground) then begin if(anmtRemSearch.ResName = '') then begin TORExposedAnimate(anmtRemSearch).OnMouseDown := pnlRemindersMouseDown; TORExposedAnimate(anmtRemSearch).OnMouseUp := pnlRemindersMouseUp; anmtRemSearch.ResHandle := 0; anmtRemSearch.ResName := 'REMSEARCHAVI'; end; imgReminder.Visible := FALSE; anmtRemSearch.Active := TRUE; anmtRemSearch.Visible := TRUE; if(pnlReminders.Hint <> '') then pnlReminders.Hint := CRLF + pnlReminders.Hint + '.'; // pnlReminders.Hint := 'Evaluating Reminders... ' + pnlReminders.Hint; <-- original line. //kt 7/17/2007 pnlReminders.Hint := DKLangConstW('fFrame_Evaluating_Remindersxxx') + pnlReminders.Hint; //kt added 7/17/2007 pnlReminders.Caption := pnlReminders.Hint; end else begin anmtRemSearch.Visible := FALSE; imgReminder.Visible := TRUE; imgReminder.Picture.Bitmap.LoadFromResourceName(hInstance, ImgName); anmtRemSearch.Active := FALSE; end; mnuViewReminders.Enabled := (pnlReminders.tag = HAVE_REMINDERS); end; procedure TfrmFrame.pnlRemindersMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if(not InitialRemindersLoaded) then StartupReminders; if(pnlReminders.tag = HAVE_REMINDERS) then pnlReminders.BevelOuter := bvLowered; end; procedure TfrmFrame.pnlRemindersMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin pnlReminders.BevelOuter := bvRaised; if(pnlReminders.tag = HAVE_REMINDERS) then ViewInfo(mnuViewReminders); end; //--------------------- CIRN-related procedures -------------------------------- procedure TfrmFrame.SetUpCIRN; var i: integer; aAutoQuery: string; ASite: TRemoteSite; begin with RemoteSites do if UseVistaWeb then begin ChangePatient(Patient.DFN); lblCIRN.Caption := 'Remote'; //VistaWeb On lblCIRNData.Caption := 'Data*'; pnlCIRN.Caption := 'Remote Data'; lblCIRN.Width := 43; lblCIRNData.Width := 43; lblCIRNData.Alignment := taCenter; lblCIRN.Alignment := taCenter; lblCIRN.Enabled := True; lblCIRNData.Enabled := True; lblCIRNAvail.Enabled := True; pnlCIRN.TabStop := True; if RemoteDataExists and (RemoteSites.Count > 0) then begin lblCIRN.Enabled := True; lblCIRNData.Enabled := True; lblCIRNAvail.Enabled := True; pnlCIRN.TabStop := True; if ColorToRGB(clWindowText) = ColorToRGB(clBlack) then begin lblCIRN.Font.Color := clBlue; lblCIRNData.Font.Color := clBlue; lblCIRNAvail.Font.Color := clBlue; lstCIRNLocations.Font.Color := clBlue; lblCIRN.Caption := 'Remote'; lblCIRNData.Caption := 'Data*'; lblCIRNAvail.Caption := 'Available'; pnlCIRN.Caption := 'Remote Data Available'; end else begin lblCIRN.Font.Color := clWindowText; lblCIRNData.Font.Color := clWindowText; lblCIRNAvail.Font.Color := clWindowText; lstCIRNLocations.Font.Color := clWindowText; end; end else begin lblCIRN.Font.Color := clWindowText; lblCIRNData.Font.Color := clWindowText; lblCIRNAvail.Font.Color := clWindowText; lblCIRN.Enabled := False; lblCIRNData.Enabled := False; lblCIRNAvail.Enabled := False; pnlCIRN.TabStop := False; pnlCIRN.Hint := NoDataReason; end; // pnlCIRN.Hint := 'Click to open VistaWeb'; <-- original line. //kt 7/17/2007 pnlCIRN.Hint := DKLangConstW('fFrame_Click_to_open_VistaWeb'); //kt added 7/17/2007 end else begin ChangePatient(Patient.DFN); lblCIRN.Caption := ' Remote'; lblCIRNData.Caption := 'Data'; pnlCIRN.Caption := 'Remote Data'; lblCIRNAvail.Caption := ''; lblCIRN.Width := 43; lblCIRNData.Width := 43; lblCIRNData.Alignment := taCenter; lblCIRN.Alignment := taCenter; if RemoteDataExists and (RemoteSites.Count > 0) then begin lblCIRN.Enabled := True; lblCIRNData.Enabled := True; lblCIRNAvail.Enabled := True; pnlCIRN.TabStop := True; if ColorToRGB(clWindowText) = ColorToRGB(clBlack) then begin lblCIRN.Font.Color := clBlue; lblCIRNData.Font.Color := clBlue; lblCIRNAvail.Font.Color := clBlue; lstCIRNLocations.Font.Color := clBlue; lblCIRN.Caption := 'Remote'; lblCIRNData.Caption := 'Data'; lblCIRNAvail.Caption := 'Available'; pnlCIRN.Caption := 'Remote Data Available'; end else begin lblCIRN.Font.Color := clWindowText; lblCIRNData.Font.Color := clWindowText; lblCIRNAvail.Font.Color := clWindowText; lstCIRNLocations.Font.Color := clWindowText; lblCIRNAvail.Color := clWindowText; end; // pnlCIRN.Hint := 'Click to display other facilities having data for this patient.'; <-- original line. //kt 7/17/2007 pnlCIRN.Hint := DKLangConstW('fFrame_Click_to_display_other_facilities_having_data_for_this_patientx'); //kt added 7/17/2007 // lstCIRNLocations.Items.Add('-1' + U + 'Use VistaWeb from now on'); <-- original line. //kt 7/17/2007 lstCIRNLocations.Items.Add('-1' + U + DKLangConstW('fFrame_Use_VistaWeb_from_now_on')); //kt added 7/17/2007 if RemoteSites.Count > 0 then // lstCIRNLocations.Items.Add('0' + U + 'All Available Sites'); <-- original line. //kt 7/17/2007 lstCIRNLocations.Items.Add('0' + U + DKLangConstW('fFrame_All_Available_Sites')); //kt added 7/17/2007 for i := 0 to RemoteSites.Count - 1 do begin ASite := TRemoteSite(SiteList[i]); lstCIRNLocations.Items.Add(ASite.SiteID + U + ASite.SiteName + U + FormatFMDateTime('mmm dd yyyy hh:nn', ASite.LastDate)); end; end else begin lblCIRN.Font.Color := clWindowText; lblCIRNData.Font.Color := clWindowText; lblCIRNAvail.Font.Color := clWindowText; lblCIRN.Enabled := False; lblCIRNData.Enabled := False; lblCIRNAvail.Enabled := False; pnlCIRN.TabStop := False; pnlCIRN.Hint := NoDataReason; end; aAutoQuery := AutoRDV; //Check to see if Remote Queries should be used for all available sites if (aAutoQuery = '1') and (lstCIRNLocations.Count > 0) then begin lstCIRNLocations.ItemIndex := 1; lstCIRNLocations.Checked[1] := true; lstCIRNLocationsClick(self); end; end; end; procedure TfrmFrame.pnlCIRNClick(Sender: TObject); //var // aAddress: string; begin {if UseVistaWeb then begin pnlCIRN.BevelOuter := bvRaised; pnlCIRN.Hint := 'Click to open VistaWeb'; lblCIRN.Width := 43; lblCIRNData.Width := 43; lblCIRNData.Alignment := taCenter; lblCIRN.Alignment := taCenter; lstCIRNLocations.Visible := false; lstCIRNLocations.SendToBack; aAddress := GetVistaWebAddress(Patient.DFN); ShellExecute(Handle, 'open', PChar(aAddress), PChar(''), '', SW_NORMAL); Exit; end; if not RemoteSites.RemoteDataExists then Exit; if (not lstCIRNLocations.Visible) then begin pnlCIRN.BevelOuter := bvLowered; lstCIRNLocations.Visible := True; lstCIRNLocations.BringToFront; lstCIRNLocations.SetFocus; pnlCIRN.Hint := 'Click to close list.'; end else begin pnlCIRN.BevelOuter := bvRaised; lstCIRNLocations.Visible := False; lstCIRNLocations.SendToBack; pnlCIRN.Hint := 'Click to display other facilities having data for this patient.'; end } ViewInfo(mnuViewRemoteData); end; procedure TfrmFrame.lstCIRNLocationsClick(Sender: TObject); const DGSR_FAIL = -1; DGSR_NONE = 0; DGSR_SHOW = 1; DGSR_ASK = 2; DGSR_DENY = 3; var iIndex,j,iAll,iCur: integer; aMsg,s: string; AccessStatus: integer; begin iAll := 1; AccessStatus := 0; iIndex := lstCIRNLocations.ItemIndex; if iIndex = 0 then if (piece(lstCIRNLocations.Items[0],'^',1) = '-1') and (lstCIRNLocations.Checked[iIndex] = true) then begin // if MessageDlg('Are you sure you want to make VistaWeb your default for viewing Remote Data?', <-- original line. //kt 7/17/2007 if MessageDlg(DKLangConstW('fFrame_Are_you_sure_you_want_to_make_VistaWeb_your_default_for_viewing_Remote_Datax'), //kt added 7/17/2007 mtConfirmation, [mbYes, mbNo], 0) = mrYes then begin ChangeVistaWebParam('1'); lblCIRN.Caption := 'Remote'; //VistaWeb On lblCIRNData.Caption := 'Data*'; pnlCIRN.Caption := 'Remote Data'; lblCIRNAvail.Caption := ''; lblCIRN.Width := 43; lblCIRNData.Width := 43; lblCIRNData.Alignment := taCenter; lblCIRN.Alignment := taCenter; with RemoteSites do if RemoteDataExists and (RemoteSites.Count > 0) then begin lblCIRN.Enabled := True; lblCIRNData.Enabled := True; pnlCIRN.TabStop := True; if ColorToRGB(clWindowText) = ColorToRGB(clBlack) then begin lblCIRN.Font.Color := clBlue; lblCIRNData.Font.Color := clBlue; lstCIRNLocations.Font.Color := clBlue; lblCIRN.Caption := 'Remote'; lblCIRNData.Caption := 'Data*'; lblCIRNAvail.Caption := 'Available'; pnlCIRN.Caption := 'Remote Data Available'; end else begin lblCIRN.Font.Color := clWindowText; lblCIRNData.Font.Color := clWindowText; lstCIRNLocations.Font.Color := clWindowText; lblCIRNAvail.Font.Color := clWindowText; end; end; pnlCIRNClick(self); Exit; end else lstCIRNLocations.Checked[iIndex] := false; end else begin ChangeVistaWebParam('0'); lblCIRN.Caption := 'Remote'; lblCIRNData.Caption := 'Data'; pnlCIRN.Caption := 'Remote Data'; lblCIRN.Width := 43; lblCIRNData.Width := 43; lblCIRNData.Alignment := taCenter; lblCIRN.Alignment := taCenter; pnlCIRNClick(self); Exit; end; if not CheckHL7TCPLink then begin // InfoBox('Local HL7 TCP Link is down.' + CRLF + 'Unable to retrieve remote data.', TC_DGSR_ERR, MB_OK); <-- original line. //kt 7/17/2007 InfoBox(DKLangConstW('fFrame_Local_HL7_TCP_Link_is_downx') + CRLF + DKLangConstW('fFrame_Unable_to_retrieve_remote_datax'), TC_DGSR_ERR, MB_OK); //kt added 7/17/2007 lstCIRNLocations.Checked[iIndex] := false; Exit; end; if lstCIRNLocations.Items.Count > 1 then if piece(lstCIRNLocations.Items[1],'^',1) = '0' then iAll := 2; with frmReports do if piece(uRemoteType,'^',2) = 'V' then begin lvReports.Items.BeginUpdate; lvReports.Items.Clear; lvReports.Columns.Clear; lvReports.Items.EndUpdate; end; uReportInstruction := ''; frmReports.TabControl1.Tabs.Clear; frmLabs.TabControl1.Tabs.Clear; frmReports.TabControl1.Tabs.AddObject('Local',nil); frmLabs.TabControl1.Tabs.AddObject('Local',nil); //StatusText('Checking Remote Sites...'); <-- original line. //kt 7/17/2007 StatusText(DKLangConstW('fFrame_Checking_Remote_Sitesxxx')); //kt added 7/17/2007 if piece(lstCIRNLocations.Items[iIndex],'^',1) = '0' then // All sites have been clicked if lstCIRNLocations.Checked[iIndex] = false then // All selection is being turned off begin with RemoteSites.SiteList do for j := 0 to Count - 1 do if lstCIRNLocations.Checked[j+2] = true then begin lstCIRNLocations.Checked[j+2] := false; TRemoteSite(RemoteSites.SiteList[j]).Selected := false; TRemoteSite(RemoteSites.SiteList[j]).ReportClear; TRemoteSite(RemoteSites.SiteList[j]).LabClear; end; end else begin with RemoteSites.SiteList do for j := 0 to Count - 1 do begin Screen.Cursor := crAppStart; //kt crHourGlass; {CheckRemotePatient(aMsg, Patient.DFN + ';' + Patient.ICN,TRemoteSite(Items[j]).SiteID, AccessStatus);} Screen.Cursor := crDefault; // aMsg := aMsg + ' at site: ' + TRemoteSite(Items[j]).SiteName; <-- original line. //kt 7/17/2007 aMsg := aMsg + DKLangConstW('fFrame_at_sitex') + TRemoteSite(Items[j]).SiteName; //kt added 7/17/2007 s := lstCIRNLocations.Items[j+2]; lstCIRNLocations.Items[j+2] := pieces(s, '^', 1, 3); case AccessStatus of DGSR_FAIL: begin // if piece(aMsg,':',1) = 'RPC name not found at site' then //Allow for backward compatibility <-- original line. //kt 7/17/2007 if piece(aMsg,':',1) = DKLangConstW('fFrame_RPC_name_not_found_at_site') then //Allow for backward compatibility //kt added 7/17/2007 begin lstCIRNLocations.Checked[j+2] := true; TRemoteSite(RemoteSites.SiteList[j]).ReportClear; TRemoteSite(RemoteSites.SiteList[j]).LabClear; TRemoteSite(Items[j]).Selected := true; end else begin InfoBox(aMsg, TC_DGSR_ERR, MB_OK); lstCIRNLocations.Checked[j+2] := false; lstCIRNLocations.Items[j+2] := pieces(s, '^', 1, 3) + '^' + TC_DGSR_ERR; TRemoteSite(Items[j]).Selected := false; Continue; end; end; DGSR_NONE: begin lstCIRNLocations.Checked[j+2] := true; TRemoteSite(RemoteSites.SiteList[j]).ReportClear; TRemoteSite(RemoteSites.SiteList[j]).LabClear; TRemoteSite(Items[j]).Selected := true; end; DGSR_SHOW: begin InfoBox(AMsg, TC_DGSR_SHOW, MB_OK); lstCIRNLocations.Checked[j+2] := true; TRemoteSite(RemoteSites.SiteList[j]).ReportClear; TRemoteSite(RemoteSites.SiteList[j]).LabClear; TRemoteSite(Items[j]).Selected := true; end; DGSR_ASK: if InfoBox(AMsg + TX_DGSR_YESNO, TC_DGSR_SHOW, MB_YESNO or MB_ICONWARNING or MB_DEFBUTTON2) = IDYES then begin lstCIRNLocations.Checked[j+2] := true; TRemoteSite(RemoteSites.SiteList[j]).ReportClear; TRemoteSite(RemoteSites.SiteList[j]).LabClear; TRemoteSite(Items[j]).Selected := true; end else begin lstCIRNLocations.Checked[j+2] := false; lstCIRNLocations.Items[j+2] := pieces(s, '^', 1, 3) + '^' + TC_DGSR_SHOW; TRemoteSite(Items[j]).Selected := false; Continue; end; else begin InfoBox(AMsg, TC_DGSR_DENY, MB_OK); lstCIRNLocations.Checked[j+2] := false; lstCIRNLocations.Items[j+2] := pieces(s, '^', 1, 3) + '^' + TC_DGSR_DENY; TRemoteSite(Items[j]).Selected := false; Continue; end; end; end; end else begin if iIndex > 0 then begin iCur := iIndex - iAll; TRemoteSite(RemoteSites.SiteList[iCur]).Selected := lstCIRNLocations.Checked[iIndex]; if lstCIRNLocations.Checked[iIndex] = true then with RemoteSites.SiteList do begin Screen.Cursor := crAppStart; //kt crHourGlass; {CheckRemotePatient(aMsg, Patient.DFN + ';' + Patient.ICN,TRemoteSite(Items[iCur]).SiteID, AccessStatus);} Screen.Cursor := crDefault; // aMsg := aMsg + ' at site: ' + TRemoteSite(Items[iCur]).SiteName; <-- original line. //kt 7/17/2007 aMsg := aMsg + DKLangConstW('fFrame_at_sitex') + TRemoteSite(Items[iCur]).SiteName; //kt added 7/17/2007 s := lstCIRNLocations.Items[iIndex]; lstCIRNLocations.Items[iIndex] := pieces(s, '^', 1, 3); case AccessStatus of DGSR_FAIL: begin // if piece(aMsg,':',1) = 'RPC name not found at site' then //Allow for backward compatibility <-- original line. //kt 7/17/2007 if piece(aMsg,':',1) = DKLangConstW('fFrame_RPC_name_not_found_at_site') then //Allow for backward compatibility //kt added 7/17/2007 begin lstCIRNLocations.Checked[iIndex] := true; TRemoteSite(RemoteSites.SiteList[iCur]).ReportClear; TRemoteSite(RemoteSites.SiteList[iCur]).LabClear; TRemoteSite(Items[iCur]).Selected := true; end else begin InfoBox(aMsg, TC_DGSR_ERR, MB_OK); lstCIRNLocations.Checked[iIndex] := false; lstCIRNLocations.Items[iIndex] := pieces(s, '^', 1, 3) + '^' + TC_DGSR_ERR; TRemoteSite(Items[iCur]).Selected := false; end; end; DGSR_NONE: begin lstCIRNLocations.Checked[iIndex] := true; TRemoteSite(RemoteSites.SiteList[iCur]).ReportClear; TRemoteSite(RemoteSites.SiteList[iCur]).LabClear; TRemoteSite(Items[iCur]).Selected := true; end; DGSR_SHOW: begin InfoBox(AMsg, TC_DGSR_SHOW, MB_OK); lstCIRNLocations.Checked[iIndex] := true; TRemoteSite(RemoteSites.SiteList[iCur]).ReportClear; TRemoteSite(RemoteSites.SiteList[iCur]).LabClear; TRemoteSite(Items[iCur]).Selected := true; end; DGSR_ASK: if InfoBox(AMsg + TX_DGSR_YESNO, TC_DGSR_SHOW, MB_YESNO or MB_ICONWARNING or MB_DEFBUTTON2) = IDYES then begin lstCIRNLocations.Checked[iIndex] := true; TRemoteSite(RemoteSites.SiteList[iCur]).ReportClear; TRemoteSite(RemoteSites.SiteList[iCur]).LabClear; TRemoteSite(Items[iCur]).Selected := true; end else begin lstCIRNLocations.Checked[iIndex] := false; lstCIRNLocations.Items[iIndex] := pieces(s, '^', 1, 3) + '^' + TC_DGSR_SHOW; end; else begin InfoBox(AMsg, TC_DGSR_DENY, MB_OK); lstCIRNLocations.Checked[iIndex] := false; lstCIRNLocations.Items[iIndex] := pieces(s, '^', 1, 3) + '^' + TC_DGSR_DENY; TRemoteSite(Items[iCur]).Selected := false; end; end; with frmReports do if piece(uRemoteType,'^',1) = '1' then if not(piece(uRemoteType,'^',2) = 'V') then begin TabControl1.Visible := true; pnlRightTop.Height := lblTitle.Height + TabControl1.Height; end; with frmLabs do if lstReports.ItemIndex > -1 then if piece(lstReports.Items[lstReports.ItemIndex],'^',3) = '1' then if not(piece(lstReports.Items[lstReports.ItemIndex],'^',5) = 'V') then TabControl1.Visible := true; end; end; end; with RemoteSites.SiteList do for j := 0 to Count - 1 do if TRemoteSite(Items[j]).Selected then begin frmReports.TabControl1.Tabs.AddObject(TRemoteSite(Items[j]).SiteName, TRemoteSite(Items[j])); frmLabs.TabControl1.Tabs.AddObject(TRemoteSite(Items[j]).SiteName, TRemoteSite(Items[j])); end; //frmLabs.TabControl1.OnChange(nil); //frmReports.TabControl1.OnChange(nil); if frmReports.tvReports.SelectionCount > 0 then frmReports.tvReportsClick(self); if frmLabs.lstReports.ItemIndex > -1 then frmLabs.ExtlstReportsClick(self, true); StatusText(''); end; procedure TfrmFrame.popCIRNCloseClick(Sender: TObject); begin lstCIRNLocations.Visible := False; lstCirnLocations.SendToBack; pnlCIRN.BevelOuter := bvRaised; end; procedure TfrmFrame.popCIRNSelectAllClick(Sender: TObject); begin lstCIRNLocations.ItemIndex := 0; lstCIRNLocations.Checked[0] := true; lstCIRNLocations.OnClick(Self); end; procedure TfrmFrame.popCIRNSelectNoneClick(Sender: TObject); begin lstCIRNLocations.ItemIndex := 0; lstCIRNLocations.Checked[0] := false; lstCIRNLocations.OnClick(Self); end; procedure TfrmFrame.mnuFilePrintSetupClick(Sender: TObject); var CurrPrt: string; begin CurrPrt := SelectDevice(Self, Encounter.Location, True,''); User.CurrentPrinter := Piece(CurrPrt, U, 1); end; procedure TfrmFrame.lstCIRNLocationsChange(Sender: TObject); begin if lstCIRNLocations.ItemIndex > 0 then if (lstCIRNLocations.Selected[lstCIRNLocations.ItemIndex] = true) and (uUpdateStat = false) then if not (piece(lstCIRNLocations.Items[1],'^',1) = '0') then lstCIRNLocations.OnClick(nil); end; procedure TfrmFrame.LabInfo1Click(Sender: TObject); begin ExecuteLabInfo; end; procedure TfrmFrame.mnuFileNotifRemoveClick(Sender: TObject); //const //TC_REMOVE_ALERT = 'Remove Current Alert'; <-- original line. //kt 7/17/2007 //TX_REMOVE_ALERT1 = 'This action will delete the alert you are currently processing; the alert will ' + CRLF + <-- original line. //kt 7/17/2007 // 'disappear automatically when all orders have been acted on, but this action may' + CRLF + <-- original line. //kt 7/17/2007 // 'be used to remove the alert if some orders are to be left unchanged.' + CRLF + CRLF + <-- original line. //kt 7/17/2007 // 'Your '; <-- original line. //kt 7/17/2007 //TX_REMOVE_ALERT2 = ' alert for '; <-- original line. //kt 7/17/2007 //TX_REMOVE_ALERT3 = ' will be deleted!' + CRLF + CRLF + 'Are you sure?'; <-- original line. //kt 7/17/2007 var AlertMsg, AlertType: string; TC_REMOVE_ALERT : string; TX_REMOVE_ALERT1 : string; TX_REMOVE_ALERT2 : string; TX_REMOVE_ALERT3 : string; procedure StopProcessingNotifs; begin Notifications.Clear; FNextButtonActive := False; stsArea.Panels[2].Bevel := pbLowered; mnuFileNext.Enabled := False; mnuFileNotifRemove.Enabled := False; end; begin TC_REMOVE_ALERT := DKLangConstW('fFrame_Remove_Current_Alert'); //kt added 7/17/2007 TX_REMOVE_ALERT1 := DKLangConstW('fFrame_This_action_will_delete_the_alert_you_are_currently_processingx_the_alert_will') + CRLF + //kt added 7/17/2007 DKLangConstW('fFrame_disappear_automatically_when_all_orders_have_been_acted_onx_but_this_action_may') + CRLF + //kt added 7/17/2007 DKLangConstW('fFrame_be_used_to_remove_the_alert_if_some_orders_are_to_be_left_unchangedx') + CRLF + CRLF + //kt added 7/17/2007 DKLangConstW('fFrame_Your'); //kt added 7/17/2007 TX_REMOVE_ALERT2 := DKLangConstW('fFrame_alert_for'); //kt added 7/17/2007 TX_REMOVE_ALERT3 := DKLangConstW('fFrame_will_be_deletedx') + CRLF + CRLF + DKLangConstW('fFrame_Are_you_surex'); //kt added 7/17/2007 if not Notifications.Active then Exit; case Notifications.Followup of // NF_MEDICATIONS_EXPIRING_INPT : AlertType := 'Expiring Medications'; <-- original line. //kt 7/17/2007 NF_MEDICATIONS_EXPIRING_INPT : AlertType := DKLangConstW('fFrame_Expiring_Medications'); //kt added 7/17/2007 // NF_MEDICATIONS_EXPIRING_OUTPT : AlertType := 'Expiring Medications'; <-- original line. //kt 7/17/2007 NF_MEDICATIONS_EXPIRING_OUTPT : AlertType := DKLangConstW('fFrame_Expiring_Medications'); //kt added 7/17/2007 // NF_ORDER_REQUIRES_ELEC_SIGNATURE: AlertType := 'Unsigned Orders'; <-- original line. //kt 7/17/2007 NF_ORDER_REQUIRES_ELEC_SIGNATURE: AlertType := DKLangConstW('fFrame_Unsigned_Orders'); //kt added 7/17/2007 // NF_FLAGGED_ORDERS : AlertType := 'Flagged Orders (for clarification)'; <-- original line. //kt 7/17/2007 NF_FLAGGED_ORDERS : AlertType := DKLangConstW('fFrame_Flagged_Orders_xfor_clarificationx'); //kt added 7/17/2007 // NF_UNVERIFIED_MEDICATION_ORDER : AlertType := 'Unverified Medication Order'; <-- original line. //kt 7/17/2007 NF_UNVERIFIED_MEDICATION_ORDER : AlertType := DKLangConstW('fFrame_Unverified_Medication_Order'); //kt added 7/17/2007 // NF_UNVERIFIED_ORDER : AlertType := 'Unverified Order'; <-- original line. //kt 7/17/2007 NF_UNVERIFIED_ORDER : AlertType := DKLangConstW('fFrame_Unverified_Order'); //kt added 7/17/2007 // NF_FLAGGED_OI_EXP_INPT : AlertType := 'Flagged Orderable Item (INPT)'; <-- original line. //kt 7/17/2007 NF_FLAGGED_OI_EXP_INPT : AlertType := DKLangConstW('fFrame_Flagged_Orderable_Item_xINPTx'); //kt added 7/17/2007 // NF_FLAGGED_OI_EXP_OUTPT : AlertType := 'Flagged Orderable Item (OUTPT)'; <-- original line. //kt2 7/17/2007 NF_FLAGGED_OI_EXP_OUTPT : AlertType := DKLangConstW('fFrame_Flagged_Orderable_Item_xOUTPTx'); //kt2 added 7/17/2007 else Exit; end; AlertMsg := TX_REMOVE_ALERT1 + AlertType + TX_REMOVE_ALERT2 + Patient.Name + TX_REMOVE_ALERT3; if InfoBox(AlertMsg, TC_REMOVE_ALERT, MB_YESNO) = ID_YES then begin Notifications.DeleteForCurrentUser; Notifications.Next; // avoid prompt if no more alerts selected to process {v14a RV} if Notifications.Active then begin if (InfoBox(TX_NOTIF_STOP, TC_NOTIF_STOP, MB_YESNO) = ID_NO) then begin Notifications.Prior; mnuFileNextClick(Self); end else StopProcessingNotifs; end else StopProcessingNotifs; end; end; procedure TfrmFrame.mnuToolsOptionsClick(Sender: TObject); // personal preferences - changes may need to be applied to chart var i: integer; begin i := 0; DialogOptions(i); end; procedure TfrmFrame.LoadUserPreferences; begin LoadSizesForUser; // LoadUserVitalPreferences; GetUserTemplateDefaults(TRUE); end; procedure TfrmFrame.SaveUserPreferences; begin SaveSizesForUser; // position & size settings // SaveUserVitalPreferences; // save Vitals metric setting SaveUserTemplateDefaults; end; procedure TfrmFrame.mnuFileRefreshClick(Sender: TObject); begin FRefreshing := TRUE; try mnuFileOpenClick(Self); finally FRefreshing := FALSE; end; end; procedure TfrmFrame.AppActivated(Sender: TObject); begin if assigned(FOldActivate) then FOldActivate(Sender); SetActiveWindow(Application.Handle); end; // close Treatment Factor hint window if alt-tab pressed. procedure TfrmFrame.AppDeActivated(Sender: TObject); begin if FRVTFhintWindowActive then begin FRVTFHintWindow.ReleaseHandle; FRVTFHintWindowActive := False; end else if FOSTFHintWndActive then begin FOSTFhintWindow.ReleaseHandle; FOSTFHintWndActive := False ; end; if FHintWinActive then // graphing - hints on values begin FHintWin.ReleaseHandle; FHintWinActive := false; end; end; (*procedure TfrmFrame.CreateTab(var AnInstance: TObject; AClass: TClass; ATabID: integer; ALabel: string); begin AnInstance := TPage.Create(Self); TPage(AnInstance).Parent := pnlPage; TPage(AnInstance).Show; uTabList.Add(IntToStr(ATabID)); tabPage.Tabs.Add(ALabel); end;*) procedure TfrmFrame.CreateTab(ATabID: integer; ALabel: string); var TempFrmWebTab : TfrmWebTab; //kt added begin // old comment - try making owner self (instead of application) to see if solves TMenuItem.Insert bug case ATabID of CT_PROBLEMS : begin frmProblems := TfrmProblems.Create(Self); frmProblems.Parent := pnlPage; end; CT_MEDS : begin frmMeds := TfrmMeds.Create(Self); frmMeds.Parent := pnlPage; frmMeds.InitfMedsSize; end; CT_ORDERS : begin frmOrders := TfrmOrders.Create(Self); frmOrders.Parent := pnlPage; end; CT_HP : begin // not yet end; CT_NOTES : begin frmNotes := TfrmNotes.Create(Self); frmNotes.Parent := pnlPage; //kt Note: The following two lines must be done **AFTER** // the assigment of Parent to pnlPage. Otherwise // the ActiveX object looses its attachement point // or something and the document objects turns nil. frmNotes.HtmlViewer.Loaded; //kt 8/09 frmNotes.HtmlEditor.Loaded; //kt 8/09 end; CT_CONSULTS : begin frmConsults := TfrmConsults.Create(Self); frmConsults.Parent := pnlPage; end; CT_DCSUMM : begin frmDCSumm := TfrmDCSumm.Create(Self); frmDCSumm.Parent := pnlPage; end; CT_LABS : begin frmLabs := TfrmLabs.Create(Self); frmLabs.Parent := pnlPage; end; CT_REPORTS : begin frmReports := TfrmReports.Create(Self); frmReports.Parent := pnlPage; end; CT_SURGERY : begin frmSurgery := TfrmSurgery.Create(Self); frmSurgery.Parent := pnlPage; end; CT_COVER : begin frmCover := TfrmCover.Create(Self); frmCover.Parent := pnlPage; end; CT_WEBTAB1..CT_LAST_WEBTAB : begin //kt added 6/6/08 TempFrmWebTab := TfrmWebTab.Create(Self); //kt 6/6/08 TempFrmWebTab.WebBrowser.Navigate('about:blank'); TempFrmWebTab.Parent := pnlPage; //kt 6/6/08 frmWebTabs[ATabID-CT_WEBTAB1] := TempFrmWebTab end; //kt 6/6/08 CT_IMAGES : begin //kt 8/19/05, 3/8/10 frmImages := TfrmImages.Create(Self); //kt 8/19/05, 3/8/10 frmImages.Parent := pnlPage; //kt 8/19/05, 3/8/10 end; //kt 8/19/05, 3/8/10 else Exit; end; if ATabID = CT_COVER then begin uTabList.Insert(0, IntToStr(ATabID)); tabPage.Tabs.Insert(0, ALabel); tabPage.TabIndex := 0; end else begin uTabList.Add(IntToStr(ATabID)); tabPage.Tabs.Add(ALabel); end; TabColorsList.Add(IntToStr(ATabID)); //will put colors in later... //kt {if TabColorsList.IndexOf(ALabel) < 0 then //kt added 8/8/08 TabColorsList.Add(ALabel); //will put colors in later... //kt } end; procedure TfrmFrame.LoadTabColors(ColorsList : TStringList); //kt added 8/8/08 Entire function var i : integer; sValue : string; value : longword; DefColor : integer; const DEF_COLORS : array[0..11] of integer = (255, 33023, 16711935, 65280, 65535, 65535, 8388736, 16776960, 16512, 65535, 65535, 65535 ); begin value :=0; TabColorsEnabled := uTMGOptions.ReadBool('TAB_COLORS ENABLE',true); for i := 0 to ColorsList.Count-1 do begin if i <= 11 then DefColor := DEF_COLORS[i] else DefColor := ($00FFFF); sValue := uTMGOptions.ReadString('Tab '+IntToStr(i)+' Color',inttostr(DefColor)); try value := StrToInt(sValue) except on EConvertError do value := $00FFFF; end; ColorsList.Objects[i] := pointer(value); end; end; procedure TfrmFrame.SaveTabColors(ColorsList : TStringList); //kt added 8/8/08 Entire function var i : integer; begin for i := 0 to ColorsList.Count-1 do begin uTMGOptions.WriteInteger('Tab '+IntToStr(i)+' Color',longword(ColorsList.Objects[i])); end; uTMGOptions.WriteBool('TAB_COLORS ENABLE',TabColorsEnabled); //kt 8/09 end; procedure TfrmFrame.ShowHideChartTabMenus(AMenuItem: TMenuItem); var i: integer; begin for i := 0 to AMenuItem.Count - 1 do AMenuItem.Items[i].Visible := TabExists(AMenuItem.Items[i].Tag); end; function TfrmFrame.TabExists(ATabID: integer): boolean; begin Result := (uTabList.IndexOf(IntToStr(ATabID)) > -1) end; procedure TfrmFrame.ReportsOnlyDisplay; begin // Configure "Edit" menu: menuHideAllBut(mnuEdit, mnuEditPref); // Hide everything under Edit menu except Preferences. menuHideAllBut(mnuEditPref, Prefs1); // Hide everything under Preferences menu except Fonts. // Remaining pull-down menus: mnuView.visible := false; mnuFileRefresh.visible := false; mnuFileEncounter.visible := false; mnuFileReview.visible := false; mnuFileNext.visible := false; mnuFileNotifRemove.visible := false; mnuHelpBroker.visible := false; mnuHelpLists.visible := false; mnuHelpSymbols.visible := false; // Top panel components: //pnlVisit.visible := false; //pnlVisit.hint := 'Provider/Location'; <-- original line. //kt 7/17/2007 pnlVisit.hint := DKLangConstW('fFrame_ProviderxLocation'); //kt added 7/17/2007 pnlVisit.onMouseDown := nil; pnlVisit.onMouseUp := nil; //pnlPrimaryCare.visible := false; //pnlPostings.visible := false; //lblPtCWAD.visible := false; //lblPtPostings.visible := false; //pnlReminders.visible := false; //anmtRemSearch.visible := false; // Forms for other tabs: frmCover.visible := false; frmProblems.visible := false; frmMeds.visible := false; frmOrders.visible := false; frmNotes.visible := false; frmConsults.visible := false; frmDCSumm.visible := false; if Assigned(frmSurgery) then frmSurgery.visible := false; frmLabs.visible := false; // Other tabs (so to speak): tabPage.tabs.clear; tabPage.tabs.add('Reports'); end; procedure TfrmFrame.UpdatePtInfoOnRefresh; var tmpDFN: string; begin tmpDFN := Patient.DFN; Patient.Clear; Patient.DFN := tmpDFN; uCore.TempEncounterLoc := 0; //hds7591 Clinic/Ward movement. uCore.TempEncounterLocName := ''; //hds7591 Clinic/Ward movement. if (FPrevInPatient and Patient.Inpatient) then //transfering inside hospital Encounter.Location := Patient.Location else if (FPrevInPatient and (not Patient.Inpatient)) then //patient was discharged begin Encounter.Inpatient := False; Encounter.Location := 0; FPrevInPatient := False; end else if ((not FPrevInPatient) and Patient.Inpatient) then //patient was admitted begin Encounter.Inpatient := True; uCore.TempEncounterLoc := Encounter.Location; //hds7591 Clinic/Ward movement. uCore.TempEncounterLocName := Encounter.LocationName; //hds7591 Clinic/Ward movement. Encounter.Location := Patient.Location; Encounter.DateTime := Patient.AdmitTime; Encounter.VisitCategory := 'H'; FPrevInPatient := True; end; //if User.IsProvider then Encounter.Provider := ; DisplayEncounterText; end; procedure TfrmFrame.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); var NewTabIndex: integer; begin //CQ2844: Toggle Remote Data button using Alt+R case Key of 82,114: if (ssAlt in Shift) then frmFrame.pnlCIRNClick(Sender); end; if (Key = VK_TAB) then begin if (ssCtrl in Shift) then begin if not (ActiveControl is TCustomMemo) or not TMemo(ActiveControl).WantTabs then begin NewTabIndex := tabPage.TabIndex; if ssShift in Shift then dec(NewTabIndex) else inc(NewTabIndex); if NewTabIndex >= tabPage.Tabs.Count then dec(NewTabIndex,tabPage.Tabs.Count) else if NewTabIndex < 0 then inc(NewTabIndex,tabPage.Tabs.Count); tabPage.TabIndex := NewTabIndex; tabPageChange(tabPage); Key := 0; end; end; end; end; procedure TfrmFrame.FormActivate(Sender: TObject); begin if Assigned(FLastPage) then FLastPage.FocusFirstControl; end; procedure TfrmFrame.pnlPrimaryCareEnter(Sender: TObject); begin with Sender as TPanel do if (ControlCount > 0) and (Controls[0] is TSpeedButton) and (TSpeedButton(Controls[0]).Down) then BevelInner := bvLowered else BevelInner := bvRaised; end; procedure TfrmFrame.pnlPrimaryCareExit(Sender: TObject); var ShiftIsDown,TabIsDown : boolean; begin with Sender as TPanel do begin BevelInner := bvNone; //Make the lstCIRNLocations act as if between pnlCIRN & pnlReminders //in the Tab Order if (lstCIRNLocations.CanFocus) then begin ShiftIsDown := Boolean(Hi(GetKeyState(VK_SHIFT))); TabIsDown := Boolean(Hi(GetKeyState(VK_TAB))); if TabIsDown then if (ShiftIsDown) and (Name = 'pnlReminders') then lstCIRNLocations.SetFocus else if Not (ShiftIsDown) and (Name = 'pnlCIRN') then lstCIRNLocations.SetFocus; end; end; end; procedure TfrmFrame.pnlPatientClick(Sender: TObject); begin //ViewInfo(mnuViewDemo); mnuViewDemoClick(Self); end; procedure TfrmFrame.pnlVisitClick(Sender: TObject); begin //if (not User.IsReportsOnly) then // Reports Only tab. // mnuFileEncounterClick(Self); ViewInfo(mnuViewVisits); end; procedure TfrmFrame.pnlPrimaryCareClick(Sender: TObject); begin //ReportBox(DetailPrimaryCare(Patient.DFN), 'Primary Care', True); ViewInfo(mnuViewPrimaryCare); end; procedure TfrmFrame.pnlRemindersClick(Sender: TObject); begin if(pnlReminders.tag = HAVE_REMINDERS) then ViewInfo(mnuViewReminders); end; procedure TfrmFrame.pnlPostingsClick(Sender: TObject); begin ViewInfo(mnuViewPostings); end; //=========================== CCOW main changes ======================== procedure TfrmFrame.HandleCCOWError(AMessage: string); begin {$ifdef DEBUG} ShowMessage(AMessage); {$endif} InfoBox(TX_CCOW_ERROR, TC_CCOW_ERROR, MB_ICONERROR or MB_OK); FCCOWInstalled := False; imgCCOW.Picture.BitMap.LoadFromResourceName(hInstance, 'BMP_CCOW_BROKEN'); pnlCCOW.Hint := TX_CCOW_BROKEN; mnuFileResumeContext.Visible := True; mnuFileResumeContext.Enabled := False; mnuFileBreakContext.Visible := True; mnuFileBreakContext.Enabled := False; FCCOWError := True; end; function TfrmFrame.AllowCCOWContextChange(var CCOWResponse: UserResponse; NewDFN: string): boolean; var PtData : IContextItemCollection; PtDataItem2, PtDataItem3, PtDataItem4 : IContextItem; response : UserResponse; StationNumber: string; IsProdAcct: boolean; begin Result := False; response := 0; try // Start a context change transaction if FCCOWInstalled then begin FCCOWError := False; imgCCOW.Picture.BitMap.LoadFromResourceName(hInstance, 'BMP_CCOW_CHANGING'); pnlCCOW.Hint := TX_CCOW_CHANGING; try ctxContextor.StartContextChange(); except on E: Exception do HandleCCOWError(E.Message); end; if FCCOWError then begin Result := False; Exit; end; // Set the new proposed context data. PtData := CoContextItemCollection.Create(); StationNumber := User.StationNumber; IsProdAcct := User.IsProductionAccount; {$IFDEF CCOWBROKER} //IsProdAcct := RPCBrokerV.Login.IsProduction; //not yet {$ENDIF} PtDataItem2 := CoContextItem.Create(); PtDataItem2.Set_Name('Patient.co.PatientName'); // Patient.Name PtDataItem2.Set_Value(Piece(Patient.Name, ',', 1) + U + Piece(Patient.Name, ',', 2) + '^^^^'); PtData.Add(PtDataItem2); PtDataItem3 := CoContextItem.Create(); if not IsProdAcct then PtDataItem3.Set_Name('Patient.id.MRN.DFN_' + StationNumber + '_TEST') // Patient.DFN else PtDataItem3.Set_Name('Patient.id.MRN.DFN_' + StationNumber); // Patient.DFN PtDataItem3.Set_Value(Patient.DFN); PtData.Add(PtDataItem3); if Patient.ICN <> '' then begin PtDataItem4 := CoContextItem.Create(); if not IsProdAcct then PtDataItem4.Set_Name('Patient.id.MRN.NationalIDNumber_TEST') // Patient.ICN else PtDataItem4.Set_Name('Patient.id.MRN.NationalIDNumber'); // Patient.ICN PtDataItem4.Set_Value(Patient.ICN); PtData.Add(PtDataItem4); end; // End the context change transaction. FCCOWError := False; try response := ctxContextor.EndContextChange(true, PtData); except on E: Exception do HandleCCOWError(E.Message); end; if FCCOWError then begin HideEverything; Result := False; Exit; end; end else //response := urBreak; begin Result := True; Exit; end; CCOWResponse := response; if (response = UrCommit) then begin // New context is committed. //ShowMessage('Response was Commit'); mnuFileResumeContext.Enabled := False; mnuFileBreakContext.Enabled := True; FCCOWIconName := 'BMP_CCOW_LINKED'; pnlCCOW.Hint := TX_CCOW_LINKED; imgCCOW.Picture.BitMap.LoadFromResourceName(hInstance, FCCOWIconName); Result := True; end else if (response = UrCancel) then begin // Proposed context change is canceled. Return to the current context. PtData.RemoveAll; mnuFileResumeContext.Enabled := False; mnuFileBreakContext.Enabled := True; imgCCOW.Picture.BitMap.LoadFromResourceName(hInstance, FCCOWIconName); Result := False; end else if (response = UrBreak) then begin // The contextor has broken the link by suspending. This app should // update the Clinical Link icon, enable the Resume menu item, and // disable the Suspend menu item. PtData.RemoveAll; mnuFileResumeContext.Enabled := True; mnuFileBreakContext.Enabled := False; FCCOWIconName := 'BMP_CCOW_BROKEN'; pnlCCOW.Hint := TX_CCOW_BROKEN; imgCCOW.Picture.BitMap.LoadFromResourceName(hInstance, FCCOWIconName); if Patient.Inpatient then begin Encounter.Inpatient := True; Encounter.Location := Patient.Location; Encounter.DateTime := Patient.AdmitTime; Encounter.VisitCategory := 'H'; end; if User.IsProvider then Encounter.Provider := User.DUZ; SetupPatient; tabPage.TabIndex := PageIDToTab(User.InitialTab); tabPageChange(tabPage); Result := False; end; except on exc : EOleException do //ShowMessage('EOleException: ' + exc.Message + ' - ' + string(exc.ErrorCode) ); ShowMessage('EOleException: ' + exc.Message); end; end; procedure TfrmFrame.ctxContextorCanceled(Sender: TObject); begin // Application should maintain its state as the current (existing) context. imgCCOW.Picture.BitMap.LoadFromResourceName(hInstance, FCCOWIconName); end; procedure TfrmFrame.ctxContextorPending(Sender: TObject; const aContextItemCollection: IDispatch); var Reason, HyperLinkReason: string; PtChanged: boolean; {$IFDEF CCOWBROKER} UserChanged: boolean; {$ENDIF} begin // If the app would lose data, or have other problems changing context at // this time, it should return a message using SetSurveyReponse. Note that the // user may decide to commit the context change anyway. // // if (cannot-change-context-without-a-problem) then // contextor.SetSurveyResponse('Conditional accept reason...'); if FCCOWBusy then begin Sleep(10000); end; FCCOWError := False; try CheckForDifferentPatient(aContextItemCollection, PtChanged); {$IFDEF CCOWBROKER} CheckForDifferentUser(aContextItemCollection, UserChanged); {$ENDIF} except on E: Exception do HandleCCOWError(E.Message); end; if FCCOWError then begin HideEverything; Exit; end; {$IFDEF CCOWBROKER} if PtChanged or UserChanged then {$ELSE} if PtChanged then {$ENDIF} begin FCCOWContextChanging := True; imgCCOW.Picture.BitMap.LoadFromResourceName(hInstance, 'BMP_CCOW_CHANGING'); pnlCCOW.Hint := TX_CCOW_CHANGING; AllowContextChangeAll(Reason); end; CheckHyperlinkResponse(aContextItemCollection, HyperlinkReason); Reason := HyperlinkReason + Reason; if Pos('COM_OBJECT_ACTIVE', Reason) > 0 then Sleep(12000) else if Length(Reason) > 0 then ctxContextor.SetSurveyResponse(Reason); FCCOWContextChanging := False; end; procedure TfrmFrame.ctxContextorCommitted(Sender: TObject); var Reason: string; PtChanged: boolean; i: integer; begin // Application should now access the new context and update its state. FCCOWError := False; try {$IFDEF CCOWBROKER} with RPCBrokerV do if (WasUserDefined and IsUserCleared and (ctxContextor.CurrentContext.Present(CCOW_USER_NAME) = nil)) then // RV 05/11/04 begin Reason := 'COMMIT'; if AllowContextChangeAll(Reason) then begin Close; Exit; end; end; {$ENDIF} CheckForDifferentPatient(ctxContextor.CurrentContext, PtChanged); except on E: Exception do HandleCCOWError(E.Message); end; if FCCOWError then begin HideEverything; Exit; end; if not PtChanged then exit; FCCOWDrivedChange := True; i := 0; while Length(Screen.Forms[i].Name) > 0 do begin if fsModal in Screen.Forms[i].FormState then begin Screen.Forms[i].ModalResult := mrCancel; i := i + 1; end else // the fsModal forms always sequenced prior to the none-fsModal forms Break; end; Reason := 'COMMIT'; if AllowContextChangeAll(Reason) then UpdateCCOWContext; FCCOWIconName := 'BMP_CCOW_LINKED'; pnlCCOW.Hint := TX_CCOW_LINKED; imgCCOW.Picture.BitMap.LoadFromResourceName(hInstance, FCCOWIconName); end; //function TfrmFrame.FindBestCCOWDFN(var APatientName: string): string; function TfrmFrame.FindBestCCOWDFN: string; var data: IContextItemCollection; anItem: IContextItem; StationNumber, tempDFN: string; IsProdAcct: Boolean; procedure FindNextBestDFN; begin StationNumber := User.StationNumber; if IsProdAcct then anItem := data.Present('Patient.id.MRN.DFN_' + StationNumber) else anItem := data.Present('Patient.id.MRN.DFN_' + StationNumber + '_TEST'); if anItem <> nil then tempDFN := anItem.Get_Value(); end; begin if uCore.User = nil then begin Result := ''; exit; end; IsProdAcct := User.IsProductionAccount; {$IFDEF CCOWBROKER} //IsProdAcct := RPCBrokerV.Login.IsProduction; //not yet {$ENDIF} // Get an item collection of the current context FCCOWError := False; try data := ctxContextor.CurrentContext; except on E: Exception do HandleCCOWError(E.Message); end; if FCCOWError then begin HideEverything; Exit; end; // Retrieve the ContextItem name and value as strings if IsProdAcct then anItem := data.Present('Patient.id.MRN.NationalIDNumber') else anItem := data.Present('Patient.id.MRN.NationalIDNumber_TEST'); if anItem <> nil then begin tempDFN := GetDFNFromICN(anItem.Get_Value()); // "Public" RPC call if tempDFN = '-1' then FindNextBestDFN; end else FindNextBestDFN; Result := tempDFN; (* anItem := data.Present('Patient.co.PatientName'); if anItem <> nil then APatientName := anItem.Get_Value();*) data := nil; anItem := nil; end; procedure TfrmFrame.UpdateCCOWContext; var PtDFN(*, PtName*): string; begin if not FCCOWInstalled then exit; //PtDFN := FindBestCCOWDFN(PtName); PtDFN := FindBestCCOWDFN; if StrToInt64Def(PtDFN, 0) > 0 then begin // Select new patient based on context value if Patient.DFN = PtDFN then exit; Patient.DFN := PtDFN; //if (Patient.Name = '-1') or (PtName <> Piece(Patient.Name, ',', 1) + U + Piece(Patient.Name, ',', 2) + '^^^^') then if (Patient.Name = '-1') then begin HideEverything; exit; end else ShowEverything; Encounter.Clear; if Patient.Inpatient then begin Encounter.Inpatient := True; Encounter.Location := Patient.Location; Encounter.DateTime := Patient.AdmitTime; Encounter.VisitCategory := 'H'; end; if User.IsProvider then Encounter.Provider := User.DUZ; if not FFirstLoad then SetupPatient; frmCover.UpdateVAAButton; //VAA DetermineNextTab; tabPage.TabIndex := PageIDToTab(NextTab); tabPageChange(tabPage); end else HideEverything; end; procedure TfrmFrame.mnuFileBreakContextClick(Sender: TObject); begin FCCOWError := False; FCCOWIconName := 'BMP_CCOW_CHANGING'; pnlCCOW.Hint := TX_CCOW_CHANGING; imgCCOW.Picture.BitMap.LoadFromResourceName(hInstance, FCCOWIconName); try ctxContextor.Suspend; except on E: Exception do HandleCCOWError(E.Message); end; if FCCOWError then exit; FCCOWIconName := 'BMP_CCOW_BROKEN'; pnlCCOW.Hint := TX_CCOW_BROKEN; imgCCOW.Picture.BitMap.LoadFromResourceName(hInstance, FCCOWIconName); mnuFileResumeContext.Enabled := True; mnuFileBreakContext.Enabled := False; end; procedure TfrmFrame.mnuFileResumeContextGetClick(Sender: TObject); var Reason: string; begin Reason := ''; if not AllowContextChangeAll(Reason) then exit; FCCOWIconName := 'BMP_CCOW_CHANGING'; pnlCCOW.Hint := TX_CCOW_CHANGING; imgCCOW.Picture.BitMap.LoadFromResourceName(hInstance, FCCOWIconName); FCCOWError := False; try ctxContextor.Resume; except on E: Exception do HandleCCOWError(E.Message); end; if FCCOWError then exit; UpdateCCOWContext; FCCOWIconName := 'BMP_CCOW_LINKED'; pnlCCOW.Hint := TX_CCOW_LINKED; imgCCOW.Picture.BitMap.LoadFromResourceName(hInstance, FCCOWIconName); mnuFileResumeContext.Enabled := False; mnuFileBreakContext.Visible := True; mnuFileBreakContext.Enabled := True; end; procedure TfrmFrame.mnuFileResumeContextSetClick(Sender: TObject); var CCOWResponse: UserResponse; Reason: string; begin Reason := ''; if not AllowContextChangeAll(Reason) then exit; FCCOWIconName := 'BMP_CCOW_CHANGING'; pnlCCOW.Hint := TX_CCOW_CHANGING; imgCCOW.Picture.BitMap.LoadFromResourceName(hInstance, FCCOWIconName); FCCOWError := False; try ctxContextor.Resume; except on E: Exception do HandleCCOWError(E.Message); end; if FCCOWError then exit; if (AllowCCOWContextChange(CCOWResponse, Patient.DFN)) then begin mnuFileResumeContext.Enabled := False; mnuFileBreakContext.Visible := True; mnuFileBreakContext.Enabled := True; FCCOWIconName := 'BMP_CCOW_LINKED'; pnlCCOW.Hint := TX_CCOW_LINKED; imgCCOW.Picture.BitMap.LoadFromResourceName(hInstance, FCCOWIconName); end else begin mnuFileResumeContext.Enabled := True; mnuFileBreakContext.Enabled := False; FCCOWIconName := 'BMP_CCOW_BROKEN'; pnlCCOW.Hint := TX_CCOW_BROKEN; imgCCOW.Picture.BitMap.LoadFromResourceName(hInstance, FCCOWIconName); try if ctxContextor.State in [csParticipating] then ctxContextor.Suspend; except on E: Exception do HandleCCOWError(E.Message); end; end; SetupPatient; tabPage.TabIndex := PageIDToTab(User.InitialTab); tabPageChange(tabPage); end; procedure TfrmFrame.CheckForDifferentPatient(aContextItemCollection: IDispatch; var PtChanged: boolean); var data : IContextItemCollection; anItem: IContextItem; PtDFN, PtName: string; begin if uCore.Patient = nil then begin PtChanged := False; Exit; end; data := IContextItemCollection(aContextItemCollection) ; //PtDFN := FindBestCCOWDFN(PtName); PtDFN := FindBestCCOWDFN; // Retrieve the ContextItem name and value as strings anItem := data.Present('Patient.co.PatientName'); if anItem <> nil then PtName := anItem.Get_Value(); PtChanged := not ((PtDFN = Patient.DFN) and (PtName = Piece(Patient.Name, ',', 1) + U + Piece(Patient.Name, ',', 2) + '^^^^')); end; {$IFDEF CCOWBROKER} procedure TfrmFrame.CheckForDifferentUser(aContextItemCollection: IDispatch; var UserChanged: boolean); var data : IContextItemCollection; begin if uCore.User = nil then begin UserChanged := False; Exit; end; data := IContextItemCollection(aContextItemCollection) ; UserChanged := RPCBrokerV.IsUserContextPending(data); end; {$ENDIF} procedure TfrmFrame.CheckHyperlinkResponse(aContextItemCollection: IDispatch; var HyperlinkReason: string); var data : IContextItemCollection; anItem : IContextItem; itemvalue: string; PtSubject: string; begin data := IContextItemCollection(aContextItemCollection) ; anItem := data.Present('[hds_med_va.gov]request.id.name'); // Retrieve the ContextItem name and value as strings if anItem <> nil then begin itemValue := anItem.Get_Value(); if itemValue = 'GetWindowHandle' then begin PtSubject := 'patient.id.mrn.dfn_' + User.StationNumber; if not User.IsProductionAccount then PtSubject := PtSubject + '_test'; if data.Present(PtSubject) <> nil then HyperlinkReason := '!@#$' + IntToStr(Self.Handle) + ':0:' else HyperlinkReason := ''; end; end; end; procedure TfrmFrame.HideEverything; begin FNoPatientSelected := TRUE; pnlNoPatientSelected.Visible := True; pnlNoPatientSelected.BringToFront; mnuFileReview.Enabled := False; mnuFilePrint.Enabled := False; mnuFilePrintSelectedItems.Enabled := False; mnuFileEncounter.Enabled := False; mnuFileNext.Enabled := False; mnuFileRefresh.Enabled := False; mnuFilePrintSetup.Enabled := False; mnuFilePrintSelectedItems.Enabled := False; mnuFileNotifRemove.Enabled := False; mnuFileResumeContext.Enabled := False; mnuFileBreakContext.Enabled := False; mnuEdit.Enabled := False; mnuView.Enabled := False; mnuTools.Enabled := False; end; procedure TfrmFrame.ShowEverything; begin FNoPatientSelected := FALSE; pnlNoPatientSelected.Visible := False; pnlNoPatientSelected.SendToBack; mnuFileReview.Enabled := True; mnuFilePrint.Enabled := True; mnuFileEncounter.Enabled := True; mnuFileNext.Enabled := True; mnuFileRefresh.Enabled := True; mnuFilePrintSetup.Enabled := True; mnuFilePrintSelectedItems.Enabled := True; mnuFileNotifRemove.Enabled := True; if not FCCOWError then begin if FCCOWIconName= 'BMP_CCOW_BROKEN' then begin mnuFileResumeContext.Enabled := True; mnuFileBreakContext.Enabled := False; end else begin mnuFileResumeContext.Enabled := False; mnuFileBreakContext.Enabled := True; end; end; mnuEdit.Enabled := True; mnuView.Enabled := True; mnuTools.Enabled := True; end; procedure TfrmFrame.pnlFlagMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin pnlFlag.BevelOuter := bvLowered; end; procedure TfrmFrame.pnlFlagMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin pnlFlag.BevelOuter := bvRaised; end; procedure TfrmFrame.pnlFlagClick(Sender: TObject); begin //ShowFlags; ViewInfo(mnuViewFlags); end; procedure TfrmFrame.mnuFilePrintSelectedItemsClick(Sender: TObject); begin case TabToPageID(tabPage.TabIndex) of CT_NOTES: frmNotes.LstNotesToPrint; CT_CONSULTS: frmConsults.LstConsultsToPrint; CT_DCSUMM: frmDCSumm.LstSummsToPrint; end; {case} end; procedure TfrmFrame.mnuAlertRenewClick(Sender: TObject); var XQAID: string; begin XQAID := Piece(Notifications.RecordID, '^', 2); RenewAlert(XQAID); end; procedure TfrmFrame.mnuAlertForwardClick(Sender: TObject); var XQAID, AlertMsg: string; begin XQAID := Piece(Notifications.RecordID,'^', 2); AlertMsg := Piece(Notifications.RecordID, '^', 1); RenewAlert(XQAID); // must renew/restore an alert before it can be forwarded ForwardAlertTo(XQAID + '^' + AlertMsg); end; procedure TfrmFrame.mnuGECStatusClick(Sender: TObject); var ans, Result,str,str1,title: string; cnt,i: integer; fin: boolean; begin Result := sCallV('ORQQPXRM GEC STATUS PROMPT', [Patient.DFN]); if Piece(Result,U,1) <> '0' then begin title := Piece(Result,U,2); if pos('~',Piece(Result,U,1))>0 then begin str:=''; str1 := Piece(Result,U,1); cnt := DelimCount(str1, '~'); for i:=1 to cnt+1 do begin if i = 1 then str := Piece(str1,'~',i); if i > 1 then str :=str+CRLF+Piece(str1,'~',i); end; end else str := Piece(Result,U,1); if Piece(Result,U,3)='1' then begin fin := (InfoBox(str,title, MB_YESNO or MB_DEFBUTTON2)=IDYES); if fin = true then ans := '1'; if fin = false then ans := '0'; CallV('ORQQPXRM GEC FINISHED?',[Patient.DFN,ans]); end else InfoBox(str,title, MB_OK); end; end; procedure TfrmFrame.pnlFlagEnter(Sender: TObject); begin pnlFlag.BevelInner := bvRaised; pnlFlag.BevelOuter := bvNone; pnlFlag.BevelWidth := 4; end; procedure TfrmFrame.pnlFlagExit(Sender: TObject); begin pnlFlag.BevelWidth := 2; pnlFlag.BevelInner := bvNone; pnlFlag.BevelOuter := bvRaised; end; procedure TfrmFrame.tabPageMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin LastTab := TabToPageID((sender as TTabControl).TabIndex); end; procedure TfrmFrame.lstCIRNLocationsExit(Sender: TObject); begin //Make the lstCIRNLocations act as if between pnlCIRN & pnlReminders //in the Tab Order if Boolean(Hi(GetKeyState(VK_TAB))) then if Boolean(Hi(GetKeyState(VK_SHIFT))) then pnlCIRN.SetFocus else pnlReminders.SetFocus; end; procedure TfrmFrame.AppEventsActivate(Sender: TObject); begin FJustEnteredApp := True; end; procedure TfrmFrame.ScreenActiveFormChange(Sender: TObject); begin if(assigned(FOldActiveFormChange)) then FOldActiveFormChange(Sender); //Focus the Form that Stays on Top after the Application Regains focus. if FJustEnteredApp then FocusApplicationTopForm; FJustEnteredApp := false; end; procedure TfrmFrame.FocusApplicationTopForm; var I : integer; begin for I := (Screen.FormCount-1) downto 0 do //Set the last one opened last begin with Screen.Forms[I] do if (FormStyle = fsStayOnTop) and (Enabled) and (Visible) then SetFocus; end; end; procedure TfrmFrame.AppEventsShortCut(var Msg: TWMKey; var Handled: Boolean); begin if ((Boolean(Hi(GetKeyState(VK_MENU{ALT})))) and (Msg.CharCode = VK_F1)) then begin FocusApplicationTopForm; Handled := True; end; end; procedure TfrmFrame.mnuToolsGraphingClick(Sender: TObject); begin Screen.Cursor := crHourGlass; if GraphFloat = nil then // new graph begin GraphFloat := TfrmGraphs.Create(self); try with GraphFloat do begin if btnClose.Tag = 1 then Exit; Initialize; // Caption := 'CPRS Graphing - Patient: ' + MixedCase(Patient.Name); <-- original line. //kt 7/17/2007 Caption := DKLangConstW('fFrame_CPRS_Graphing_x_Patientx') + MixedCase(Patient.Name); //kt added 7/17/2007 BorderIcons := [biSystemMenu, biMaximize, biMinimize]; BorderStyle := bsSizeable; BorderWidth := 1; // context sensitive type (tabPage.TabIndex) & [item] ResizeAnchoredFormToFont(GraphFloat); Show; end; finally if GraphFloat.btnClose.Tag = 1 then begin GraphFloatActive := false; GraphFloat.Free; GraphFloat := nil; end else GraphFloatActive := true; end; end else if GraphFloat.btnClose.Tag = 1 then Exit else if GraphFloatActive and (GraphFloat.lstTypes.Hint = Patient.DFN) then GraphFloat.BringToFront // graph is active, same patient else if GraphFloat.lstTypes.Hint = Patient.DFN then begin // graph is not active, same patient // context sensitive GraphFloat.Show; GraphFloatActive := true; end else //with GraphFloat do // new patient begin GraphFloat.InitialRetain; GraphFloatActive := false; GraphFloat.Free; GraphFloat := nil; mnuToolsGraphingClick(self); // delete and recurse {//FormCreate(self); //**************** Initialize; DisplayData('top'); DisplayData('bottom'); lstCheck.Items.Clear; Caption := 'CPRS Graphing - Patient: ' + MixedCase(Patient.Name); // context sensitive Show; GraphFloatActive := true;} end; Screen.Cursor := crDefault; end; procedure TfrmFrame.pnlCIRNMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin pnlCIRN.BevelOuter := bvLowered; end; procedure TfrmFrame.pnlCIRNMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin pnlCIRN.BevelOuter := bvRaised; end; procedure TfrmFrame.laMHVClick(Sender: TObject); begin //if laMHV.Caption = 'MHV' then // ShellExecute(Handle, 'open', PChar('http://www.myhealth.va.gov/'), '', '', SW_NORMAL); ViewInfo(mnuViewMyHealtheVet); end; procedure TfrmFrame.laVAA2Click(Sender: TObject); {var InsuranceSubscriberName: string; ReportString: TStringList; //CQ7782 } begin {if fCover.VAAFlag[0] <> '0' then //'0' means subscriber not found begin InsuranceSubscriberName := fCover.VAAFlag[12]; //CQ7782 //ReportString := TStringList.Create; ReportString := VAAFlag; ReportString[0] := ''; ReportBox(ReportString, InsuranceSubscriberName, True); //end CQ7782 end;} ViewInfo(mnuInsurance); end; procedure TfrmFrame.ViewInfo(Sender: TObject); var SelectNew: Boolean; InsuranceSubscriberName: string; ReportString: TStringList; aAddress: string; begin case (Sender as TMenuItem).Tag of 1:begin { displays patient inquiry report (which optionally allows new patient to be selected) } StatusText(TX_PTINQ); PatientInquiry(SelectNew); if Assigned(FLastPage) then FLastPage.FocusFirstControl; StatusText(''); if SelectNew then mnuFileOpenClick(mnuViewDemo); end; 2:begin if (not User.IsReportsOnly) then // Reports Only tab. mnuFileEncounterClick(Self); end; 3:begin // ReportBox(DetailPrimaryCare(Patient.DFN), 'Primary Care', True); <-- original line. //kt 7/17/2007 ReportBox(DetailPrimaryCare(Patient.DFN), DKLangConstW('fFrame_Primary_Care'), True); //kt added 7/17/2007 end; 4:begin if laMHV.Caption = 'MHV' then ShellExecute(laMHV.Handle, 'open', PChar('http://www.myhealth.va.gov/'), '', '', SW_NORMAL); end; 5:begin if fCover.VAAFlag[0] <> '0' then //'0' means subscriber not found begin InsuranceSubscriberName := fCover.VAAFlag[12]; ReportString := VAAFlag; ReportString[0] := ''; ReportBox(ReportString, InsuranceSubscriberName, True); end; end; 6:begin ShowFlags; end; 7:begin if UseVistaWeb then begin pnlCIRN.BevelOuter := bvRaised; // pnlCIRN.Hint := 'Click to open VistaWeb'; <-- original line. //kt 7/17/2007 pnlCIRN.Hint := DKLangConstW('fFrame_Click_to_open_VistaWeb'); //kt added 7/17/2007 lblCIRN.Width := 43; lblCIRNData.Width := 43; lblCIRNData.Alignment := taCenter; lblCIRN.Alignment := taCenter; lstCIRNLocations.Visible := false; lstCIRNLocations.SendToBack; aAddress := GetVistaWebAddress(Patient.DFN); ShellExecute(pnlCirn.Handle, 'open', PChar(aAddress), PChar(''), '', SW_NORMAL); Exit; end; if not RemoteSites.RemoteDataExists then Exit; if (not lstCIRNLocations.Visible) then begin pnlCIRN.BevelOuter := bvLowered; lstCIRNLocations.Visible := True; lstCIRNLocations.BringToFront; lstCIRNLocations.SetFocus; // pnlCIRN.Hint := 'Click to close list.'; <-- original line. //kt 7/17/2007 pnlCIRN.Hint := DKLangConstW('fFrame_Click_to_close_listx'); //kt added 7/17/2007 end else begin pnlCIRN.BevelOuter := bvRaised; lstCIRNLocations.Visible := False; lstCIRNLocations.SendToBack; // pnlCIRN.Hint := 'Click to display other facilities having data for this patient.'; <-- original line. //kt 7/17/2007 pnlCIRN.Hint := DKLangConstW('fFrame_Click_to_display_other_facilities_having_data_for_this_patientx'); //kt added 7/17/2007 end; end; 8:begin ViewReminderTree; end; 9:begin { displays the window that shows crisis notes, warnings, allergies, & advance directives } ShowCWAD; end; end; end; procedure TfrmFrame.mnuViewInformationClick(Sender: TObject); begin mnuViewDemo.Enabled := frmFrame.pnlPatient.Enabled; mnuViewVisits.Enabled := frmFrame.pnlVisit.Enabled; mnuViewPrimaryCare.Enabled := frmFrame.pnlPrimaryCare.Enabled; mnuViewMyHealtheVet.Enabled := not (Copy(frmFrame.laMHV.Hint, 1, 2) = 'No'); mnuInsurance.Enabled := not (Copy(frmFrame.laVAA2.Hint, 1, 2) = 'No'); mnuViewFlags.Enabled := frmFrame.lblFlag.Enabled; mnuViewRemoteData.Enabled := frmFrame.lblCirn.Enabled; mnuViewReminders.Enabled := frmFrame.pnlReminders.Enabled; mnuViewPostings.Enabled := frmFrame.pnlPostings.Enabled; end; procedure TfrmFrame.CheckForTMGPatch; var //Added by ELH 6/20/08 RPCResult : AnsiString; i : integer; begin RPCBrokerV.remoteprocedure := 'XWB IS RPC AVAILABLE'; RPCBrokerV.Param[0].Value := 'TMG ADD PATIENT'; RPCBrokerV.Param[0].ptype := literal; RPCBrokerV.Param[1].Value := 'R'; RPCBrokerV.Param[1].ptype := literal; ///RPCResult := RPCBrokerV.StrCall; {returns 1 if available, 0 if not available} CallBroker; if RPCBrokerV.Results.Count>0 then begin RPCResult := RPCBrokerV.Results.Strings[0]; boolTMGPatchInstalled := (StrToInt(RPCResult) = 1); end else begin boolTMGPatchInstalled := False; end; end; procedure TfrmFrame.EditDemographicsClick(Sender: TObject); //kt added Function 12/15/07, 6/6/08 var EditResult: integer; begin EditResult := frmPtDemoEdit.ShowModal; if EditResult <> mrCancel then mnuFileRefreshClick(Sender); end; procedure TfrmFrame.tabPageDrawTab(Control: TCustomTabControl; TabIndex: Integer; const Rect: TRect; Active: Boolean); //kt added var ALabel : string; colorIndex : Integer; color : TColor; begin if TabColorsEnabled then begin ALabel := TTabControl(Control).Tabs[TabIndex]; { colorIndex := TabColorsList.IndexOf(ALabel); if colorIndex < 0 then color := clYellow else color := TColor(TabColorsList.Objects[colorIndex]); } color := TColor(TabColorsList.Objects[TabIndex]); DrawTab(Control,TabIndex,Rect,color,Active); end else begin //this isn't working... This is not what I want. Fix later... //For now, TabColorsEnabled should always be TRUE. //Control.Canvas.FillRect(Rect); //elh we will try to alter the OwnerDraw property here //TabPage.OwnerDraw := TabColorsEnabled; end; end; procedure TfrmFrame.DrawTab(Control: TCustomTabControl; TabIndex: Integer; const Rect: TRect; Color : TColor; Active: Boolean); var oRect : TRect; sCaption,temp : String; iTop : Integer; iLeft : Integer; i : integer; TabControl : TTabControl; lf : TLogFont; //Windows native font structure tf : TFont; Degrees : integer; inactiveColor : TColor; function DarkenRed(Color : TColor; Percent : byte) : TColor; var red : longWord; begin red := (Color and $0000FF); red := Round (red * (Percent/100)); Result := (Color and $FFFF00) or red; end; function DarkenGreen(Color : TColor; Percent : byte) : TColor; var green : longWord; begin green := (Color and $00FF00); green := green shr 8; green := Round(green * (Percent/100)); green := green shl 8; Result := (Color and $FF00FF) or green; end; function DarkenBlue(Color : TColor; Percent : byte) : TColor; var blue : longWord; begin blue := (Color and $FF0000); blue := blue shr 16; Blue := Round (blue * (Percent/100)); blue := blue shl 16; Result := (Color and $00FFFF) or blue; end; function Darken(Color : TColor; Percent : byte) : TColor; begin if Percent=0 then begin result := Color; exit; end; result:= DarkenRed(Color, Percent); result := DarkenBlue(result,Percent); result := DarkenGreen(result,Percent); end; begin oRect := Rect; inactiveColor := Darken(Color,75); //75% TabControl := TTabControl(Control); if TabControl.Tabs.Count=0 then exit; sCaption := TabControl.Tabs.Strings[TabIndex]; for i := 1 to length(temp) do begin if temp[i] <> '&' then sCaption := sCaption + temp[i]; end; Control.Canvas.Font.Name := 'Tahoma'; //Test4 if Active then begin Control.Canvas.Font.Style := Control.Canvas.Font.Style + [fsBold]; //Test3 Control.Canvas.Font.Color := clBlack //Test1 end else begin Control.Canvas.Font.Style := Control.Canvas.Font.Style - [fsBold]; //Test3 //Control.Canvas.Font.Color := clBlack Control.Canvas.Font.Color := clWhite; //Test1 end; if (TabControl.TabPosition = tpLeft) or (TabControl.TabPosition = tpRight) then begin if (TabControl.TabPosition = tpLeft) then begin iTop := Rect.Bottom-4; if Active then iTop := iTop - 2; iLeft := Rect.Left + 1; Degrees := 90; end else begin iTop := Rect.Top + 4; if Active then iTop := iTop + 2; iLeft := Rect.Right - 2; Degrees := 270; end; tf := TFont.Create; try tf.Assign(Control.Canvas.Font); GetObject(tf.Handle, sizeof(lf), @lf); lf.lfEscapement := 10 * Degrees; //degrees of desired rotation lf.lfHeight := Control.Canvas.Font.Height - 2; tf.Handle := CreateFontIndirect(lf); Control.Canvas.Font.Assign(tf); finally tf.Free; end; end else begin iTop := Rect.Top + ((Rect.Bottom - Rect.Top - Control.Canvas.TextHeight(sCaption)) div 2) + 1; iLeft := Rect.Left + ((Rect.Right - Rect.Left - Control.Canvas.TextWidth (sCaption)) div 2) + 1; end; if (TabControl.TabPosition = tpBottom) and (not Active) then begin iTop := iTop - 2; end; if Active then begin Control.Canvas.Brush.Color := Color; //Test2 end else begin Control.Canvas.Brush.Color := inactiveColor; //Test2 end; Control.Canvas.FillRect(Rect); Control.Canvas.TextOut(iLeft,iTop,sCaption); end; procedure TfrmFrame.PrintLabels1Click(Sender: TObject); begin if frmPtLabelPrint <> nil then begin frmPtLabelPrint.PrepDialog(Patient); frmPtLabelPrint.ShowModal; end; end; procedure TfrmFrame.mnuViewDemoClick(Sender: TObject); { displays patient inquiry report (which optionally allows new patient to be selected) } var SelectNew: Boolean; begin StatusText(TX_PTINQ); PatientInquiry(SelectNew); if Assigned(FLastPage) then FLastPage.FocusFirstControl; StatusText(''); if SelectNew then mnuFileOpenClick(mnuViewDemo); end; initialization finalization end.