unit uCore; { The core objects- patient, user, and encounter are defined here. All other clinical objects in the GUI assume that these core objects exist. } {$OPTIMIZATION OFF} // REMOVE AFTER UNIT IS DEBUGGED interface uses SysUtils, Windows, Classes, Forms, ORFn, rCore, uConst, ORClasses; type TUser = class(TObject) private FDUZ: Int64; // User DUZ (IEN in New Person file) FName: string; // User Name (mixed case) FUserClass: Integer; // User Class (based on OR keys for now) FCanSignOrders: Boolean; // Has ORES key FIsProvider: Boolean; // Has VA Provider key FOrderRole: Integer; FNoOrdering: Boolean; FEnableVerify: Boolean; FDTIME: Integer; FCountDown: Integer; FCurrentPrinter: string; FNotifyAppsWM: Boolean; FDomain: string; FPtMsgHang: Integer; FService: Integer; FAutoSave: Integer; FInitialTab: Integer; FUseLastTab: Boolean; FWebAccess: Boolean; FIsRPL: string; FRPLList: string; FHasCorTabs: Boolean; FHasRptTab: Boolean; FIsReportsOnly: Boolean; FToolsRptEdit: Boolean; FDisableHold: Boolean; FGECStatus: Boolean; FStationNumber: string; FIsProductionAccount: boolean; public constructor Create; function HasKey(const KeyName: string): Boolean; procedure SetCurrentPrinter(Value: string); property DUZ: Int64 read FDUZ; property Name: string read FName; property UserClass: Integer read FUserClass; property CanSignOrders: Boolean read FCanSignOrders; property IsProvider: Boolean read FIsProvider; property OrderRole: Integer read FOrderRole; property NoOrdering: Boolean read FNoOrdering; property EnableVerify: Boolean read FEnableVerify; property DTIME: Integer read FDTIME; property CountDown: Integer read FCountDown; property PtMsgHang: Integer read FPtMsgHang; property Service: Integer read FService; property AutoSave: Integer read FAutoSave; property InitialTab: Integer read FInitialTab; property UseLastTab: Boolean read FUseLastTab; property WebAccess: Boolean read FWebAccess; property DisableHold: Boolean read FDisableHold; property IsRPL: string read FIsRPL; property RPLList: string read FRPLList; property HasCorTabs: Boolean read FHasCorTabs; property HasRptTab: Boolean read FHasRptTab; property IsReportsOnly: Boolean read FIsReportsOnly; property ToolsRptEdit: Boolean read FToolsRptEdit; property CurrentPrinter: string read FCurrentPrinter write SetCurrentPrinter; property GECStatus: Boolean read FGECStatus; property StationNumber: string read FStationNumber; property IsProductionAccount: boolean read FIsProductionAccount; end; TPatient = class(TObject) private FDFN: string; // Internal Entry Number in Patient file //*DFN* FICN: string; // Integration Control Number from MPI FName: string; // Patient Name (mixed case) FSSN: string; // Patient Identifier (generally SSN) FDOB: TFMDateTime; // Date of Birth in Fileman format FAge: Integer; // Patient Age FSex: Char; // Male, Female, Unknown FCWAD: string; // chars identify if pt has CWAD warnings FRestricted: Boolean; // True if this is a restricted record FInpatient: Boolean; // True if that patient is an inpatient FLocation: Integer; // IEN in Hosp Loc if inpatient FWardService: string; FSpecialty: Integer; // IEN of the treating specialty if inpatient FAdmitTime: TFMDateTime; // Admit date/time if inpatient FSrvConn: Boolean; // True if patient is service connected FSCPercent: Integer; // Per Cent Service Connection FPrimTeam: string; // name of primary care team FPrimProv: string; // name of primary care provider FAttending: string; // if inpatient, name of attending FDateDied: TFMDateTime; // Date of Patient Death (<=0 or still alive) FDateDiedLoaded: boolean; // Used to determine of DateDied has been loaded procedure SetDFN(const Value: string); function GetDateDied: TFMDateTime; // *DFN* public procedure Clear; property DFN: string read FDFN write SetDFN; //*DFN* property ICN: string read FICN; property Name: string read FName; property SSN: string read FSSN; property DOB: TFMDateTime read FDOB; property Age: Integer read FAge; property Sex: Char read FSex; property CWAD: string read FCWAD; property Inpatient: Boolean read FInpatient; property Location: Integer read FLocation; property WardService: string read FWardService; property Specialty: Integer read FSpecialty; property AdmitTime: TFMDateTime read FAdmitTime; property DateDied: TFMDateTime read GetDateDied; property ServiceConnected: Boolean read FSrvConn; property SCPercent: Integer read FSCPercent; property PrimaryTeam: string read FPrimTeam; property PrimaryProvider: string read FPrimProv; property Attending: string read FAttending; end; TEncounter = class(TObject, IORNotifier) private FChanged: Boolean; // one or more visit fields have changed FDateTime: TFMDateTime; // date/time of encounter (appt, admission) FInpatient: Boolean; // true if this is an inpatient encounter FLocation: Integer; // IEN in Hospital Location file FLocationName: string; // Name in Hospital Location file FLocationText: string; // Name + Date/Time or Name + RoomBed FProvider: Int64 ; // IEN in New Person file FProviderName: string; // Name in New Person file FVisitCategory: Char; // A=ambulatory,T=Telephone,H=inpt,E=historic FStandAlone: Boolean; // true if visit not related to appointment FNotifier: IORNotifier; // Event handlers for location changes function GetLocationName: string; function GetLocationText: string; function GetProviderName: string; function GetVisitCategory: Char; function GetVisitStr: string; procedure SetDateTime(Value: TFMDateTime); procedure SetInpatient(Value: Boolean); procedure SetLocation(Value: Integer); procedure SetProvider(Value: Int64); procedure SetStandAlone(Value: Boolean); procedure SetVisitCategory(Value: Char); procedure UpdateText; public constructor Create; destructor Destroy; override; procedure Clear; function NeedVisit: Boolean; property DateTime: TFMDateTime read FDateTime write SetDateTime; property Inpatient: Boolean read FInpatient write SetInpatient; property Location: Integer read FLocation write SetLocation; property LocationName: string read GetLocationName; property LocationText: string read GetLocationText; property Provider: Int64 read FProvider write SetProvider; property ProviderName: string read GetProviderName; property StandAlone: Boolean read FStandAlone write SetStandAlone; property VisitCategory: Char read GetVisitCategory write SetVisitCategory; property VisitStr: string read GetVisitStr; property Notifier: IORNotifier read FNotifier implements IORNotifier; end; TChangeItem = class private FItemType: Integer; FID: string; FText: string; FGroupName: string; FSignState: Integer; FParentID : string; constructor Create(AnItemType: Integer; const AnID, AText, AGroupName: string; ASignState: Integer; AParentID: string = ''); public property ItemType: Integer read FItemType; property ID: string read FID; property Text: string read FText; property GroupName: string read FGroupName; property SignState: Integer read FSignState write FSignState; property ParentID : string read FParentID; end; TORRemoveChangesEvent = procedure(Sender: TObject; ChangeItem: TChangeItem) of object; {**RV**} TChanges = class private FCount: Integer; FDocuments: TList; FOrders: TList; FOrderGrp: TStringList; FPCE: TList; FPCEGrp: TStringList; FOnRemove: TORRemoveChangesEvent; {**RV**} private procedure AddUnsignedToChanges; public constructor Create; destructor Destroy; override; procedure Add(ItemType: Integer; const AnID, ItemText, GroupName: string; SignState: Integer; AParentID: string = ''); procedure Clear; function CanSign: Boolean; function Exist(ItemType: Integer; const AnID: string): Boolean; function ExistForOrder(const AnID: string): Boolean; function Locate(ItemType: Integer; const AnID: string): TChangeItem; procedure Remove(ItemType: Integer; const AnID: string); procedure ReplaceID(ItemType: Integer; const OldID, NewID: string); procedure ReplaceSignState(ItemType: Integer; const AnID: string; NewState: Integer); procedure ReplaceText(ItemType: Integer; const AnID, NewText: string); procedure ReplaceODGrpName(const AnODID, NewGrp: string); procedure ChangeOrderGrp(const oldGrpName,newGrpName: string); function RequireReview: Boolean; property Count: Integer read FCount; property Documents: TList read FDocuments; property OnRemove: TORRemoveChangesEvent read FOnRemove write FOnRemove; {**RV**} property Orders: TList read FOrders; property PCE: TList read FPCE; property OrderGrp: TStringList read FOrderGrp; property PCEGrp: TStringList read FPCEGrp; end; TNotifyItem = class private DFN: string; FollowUp: Integer; //AlertData: string; RecordID: string; end; TNotifications = class private FActive: Boolean; FList: TList; FCurrentIndex: Integer; FNotifyItem: TNotifyItem; function GetDFN: string; //*DFN* function GetFollowUp: Integer; function GetAlertData: string; function GetRecordID: string; function GetText: string; public constructor Create; destructor Destroy; override; procedure Add(const ADFN: string; AFollowUp: Integer; const ARecordID: string); //*DFN* procedure Clear; procedure Next; procedure Prior; procedure Delete; procedure DeleteForCurrentUser; property Active: Boolean read FActive; property DFN: string read GetDFN; //*DFN* property FollowUp: Integer read GetFollowUp; property AlertData: string read GetAlertData; property RecordID: string read GetRecordID; property Text: string read GetText; end; TRemoteSite = class private FSiteID: string; FSiteName: string; FLastDate: TFMDateTime; FSelected: Boolean; FRemoteHandle: string; FLabRemoteHandle: string; FQueryStatus: string; FLabQueryStatus: string; FData: TStringList; FLabData: TStringList; FCurrentLabQuery: string; FCurrentReportQuery: string; procedure SetSelected(Value: Boolean); public destructor Destroy; override; constructor Create(ASite: string); procedure ReportClear; procedure LabClear; property SiteID : string read FSiteID; property SiteName: string read FSiteName; property LastDate: TFMDateTime read FLastDate; property Selected: boolean read FSelected write SetSelected; property RemoteHandle: string read FRemoteHandle write FRemoteHandle; property QueryStatus: string read FQueryStatus write FQueryStatus; property Data: TStringList read FData write FData; property LabRemoteHandle: string read FLabRemoteHandle write FLabRemoteHandle; property LabQueryStatus: string read FLabQueryStatus write FLabQueryStatus; property LabData: TStringList read FLabData write FLabData; property CurrentLabQuery: string read FCurrentLabQuery write FCurrentLabQuery; property CurrentReportQuery: string read FCurrentReportQuery write FCurrentReportQuery; end; TRemoteSiteList = class private FCount: integer; FSiteList: TList; FRemoteDataExists: Boolean; FNoDataReason: string; public constructor Create; destructor Destroy; override; procedure Add(ASite: string); procedure ChangePatient(const DFN: string); procedure Clear; property Count : integer read FCount; property SiteList : TList read FSiteList; property RemoteDataExists: Boolean read FRemoteDataExists; property NoDataReason : string read FNoDataReason; end; TRemoteReport = class private FReport: string; FHandle: string; public constructor Create(AReport: string); destructor Destroy; override; property Handle :string read FHandle write FHandle; property Report :string read FReport write FReport; end; TRemoteReportList = class private FCount: integer; FReportList: TList; public constructor Create; destructor Destroy; override; procedure Add(AReportList, AHandle: string); procedure Clear; property Count :integer read FCount; property ReportList :TList read FReportList; end; PReportTreeObject = ^TReportTreeObject; TReportTreeObject = Record ID : String; //Report ID Heading : String; //Report Heading Remote : String; //Remote Data Capable RptType : String; //Report Type Category : String; //Report Category RPCName : String; //Associated RPC IFN : String; //IFN of report in file 101.24 HDR : String; //HDR is source of data if = 1 end; var User: TUser; Patient: TPatient; Encounter: TEncounter = nil; Changes: TChanges; RemoteSites: TRemoteSiteList; RemoteReports: TRemoteReportList; Notifications: TNotifications; HasFlag: boolean; FlagList: TStringList; //hds7591 Clinic/Ward movement. TempEncounterLoc: Integer; // used to Save Encounter Location when user selected "Review Sign Changes" from "File" TempEncounterLocName: string; // since in the path PatientRefresh is done prior to checking if patient has been admitted while entering OPT orders. procedure NotifyOtherApps(const AppEvent, AppData: string); procedure FlushNotifierBuffer; procedure TerminateOtherAppNotification; procedure GotoWebPage(const URL: WideString); implementation uses rTIU, rOrders, rConsults, uOrders; type HlinkNavProc = function(pUnk: IUnknown; szTarget: PWideChar): HResult; stdcall; var uVistaMsg, uVistaDomMsg: UINT; URLMonHandle: THandle = 0; HlinkNav: HlinkNavProc; type TNotifyAppsThread = class(TThread) private FRunning: boolean; public constructor CreateThread; procedure ResumeIfIdle; procedure ResumeAndTerminate; procedure Execute; override; property Running: boolean read FRunning; end; TMsgType = (mtVistaMessage, mtVistaDomainMessage); var uSynchronizer: TMultiReadExclusiveWriteSynchronizer = nil; uNotifyAppsThread: TNotifyAppsThread = nil; uNotifyAppsQueue: TStringList = nil; uNotifyAppsActive: boolean = TRUE; AnAtom: ATOM = 0; const LONG_BROADCAST_TIMEOUT = 30000; // 30 seconds SHORT_BROADCAST_TIMEOUT = 2000; // 2 seconds MSG_TYPE: array[TMsgType] of String = ('V','D'); function QueuePending: boolean; begin uSynchronizer.BeginRead; try Result := (uNotifyAppsQueue.Count > 0); finally uSynchronizer.EndRead; end; end; procedure ProcessQueue(ShortTimout: boolean); var msg: String; process: boolean; AResult: LPDWORD; MsgCode, timeout: UINT; TypeCode: String; begin if(not QueuePending) then exit; uSynchronizer.BeginWrite; try process := (uNotifyAppsQueue.Count > 0); if(process) then begin msg := uNotifyAppsQueue.Strings[0]; uNotifyAppsQueue.Delete(0); end; finally uSynchronizer.EndWrite; end; if(process) then begin TypeCode := copy(msg,1,1); delete(msg,1,1); if(TypeCode = MSG_TYPE[mtVistaMessage]) then MsgCode := uVistaMsg else MsgCode := uVistaDomMsg; if(ShortTimout) then timeout := SHORT_BROADCAST_TIMEOUT else timeout := LONG_BROADCAST_TIMEOUT; // put text in the global atom table AnAtom := GlobalAddAtom(PChar(msg)); if (AnAtom <> 0) then begin try // broadcast 'VistA Domain Event - Clinical' to all main windows //SendMessage(HWND_BROADCAST, uVistaDomMsg, WPARAM(Application.MainForm.Handle), LPARAM(AnAtom)); // //Changed to SendMessageTimeout to prevent hang when other app unresponsive (RV) AResult := nil; SendMessageTimeout(HWND_BROADCAST, MsgCode, WPARAM(Application.MainForm.Handle), LPARAM(AnAtom), SMTO_ABORTIFHUNG or SMTO_BLOCK, timeout, AResult^); finally // after all windows have processed the message, remove the text from the table GlobalDeleteAtom(AnAtom); AnAtom := 0; end; end; end; end; constructor TNotifyAppsThread.CreateThread; begin inherited Create(TRUE); FRunning := TRUE; end; procedure TNotifyAppsThread.ResumeIfIdle; begin if(Suspended) then Resume; end; procedure TNotifyAppsThread.ResumeAndTerminate; begin Terminate; if(Suspended) then Resume; end; procedure TNotifyAppsThread.Execute; begin while(not Terminated) do begin if(QueuePending) then ProcessQueue(FALSE) else if(not Terminated) then Suspend; end; FRunning := FALSE; end; function AppNotificationEnabled: boolean; begin Result := FALSE; if(not uNotifyAppsActive) then exit; if Application.MainForm = nil then Exit; if User = nil then exit; if not User.FNotifyAppsWM then Exit; // register the message with windows to get a unique message number (if not already registered) if uVistaMsg = 0 then uVistaMsg := RegisterWindowMessage('VistA Event - Clinical'); if uVistaDomMsg = 0 then uVistaDomMsg := RegisterWindowMessage('VistA Domain Event - Clinical'); if (uVistaMsg = 0) or (uVistaDomMsg = 0) then Exit; if(not assigned(uNotifyAppsQueue)) then uNotifyAppsQueue := TStringList.Create; if(not assigned(uSynchronizer)) then uSynchronizer := TMultiReadExclusiveWriteSynchronizer.Create; if(not assigned(uNotifyAppsThread)) then uNotifyAppsThread := TNotifyAppsThread.CreateThread; Result := TRUE; end; procedure ReleaseAppNotification; var waitState: DWORD; begin uNotifyAppsActive := FALSE; if(assigned(uNotifyAppsThread)) then begin uNotifyAppsThread.ResumeAndTerminate; sleep(10); if(uNotifyAppsThread.Running) then begin waitState := WaitForSingleObject(uNotifyAppsThread.Handle, SHORT_BROADCAST_TIMEOUT); if((waitState = WAIT_TIMEOUT) or (waitState = WAIT_FAILED) or (waitState = WAIT_ABANDONED)) then begin TerminateThread(uNotifyAppsThread.Handle, 0); if(AnAtom <> 0) then begin GlobalDeleteAtom(AnAtom); AnAtom := 0; end; end; end; FreeAndNil(uNotifyAppsThread); end; if(assigned(uSynchronizer)) and (assigned(uNotifyAppsQueue)) then begin while(QueuePending) do ProcessQueue(TRUE); end; FreeAndNil(uSynchronizer); FreeAndNil(uNotifyAppsQueue); end; procedure NotifyOtherApps(const AppEvent, AppData: string); var m1: string; m2: string; begin if(AppNotificationEnabled) then begin // first send the domain version of the message m1 := MSG_TYPE[mtVistaDomainMessage] + AppEvent + U + 'CPRS;' + User.FDomain + U + Patient.DFN + U + AppData; // for backward compatibility, send the message without the domain m2 := MSG_TYPE[mtVistaMessage] + AppEvent + U + 'CPRS' + U + Patient.DFN + U + AppData; uSynchronizer.BeginWrite; try uNotifyAppsQueue.Add(m1); uNotifyAppsQueue.Add(m2); finally uSynchronizer.EndWrite; end; uNotifyAppsThread.ResumeIfIdle; end; end; procedure FlushNotifierBuffer; begin if(AppNotificationEnabled) then begin uSynchronizer.BeginWrite; try uNotifyAppsQueue.Clear; finally uSynchronizer.EndWrite; end; end; end; procedure TerminateOtherAppNotification; begin ReleaseAppNotification; end; { TUser methods ---------------------------------------------------------------------------- } constructor TUser.Create; { create the User object for the currently logged in user } var UserInfo: TUserInfo; begin UserInfo := GetUserInfo; FDUZ := UserInfo.DUZ; FName := UserInfo.Name; FUserClass := UserInfo.UserClass; FCanSignOrders := UserInfo.CanSignOrders; FIsProvider := UserInfo.IsProvider; FOrderRole := UserInfo.OrderRole; FNoOrdering := UserInfo.NoOrdering; FEnableVerify := UserInfo.EnableVerify; FDTIME := UserInfo.DTIME; FCountDown := UserInfo.CountDown; FNotifyAppsWM := UserInfo.NotifyAppsWM; FDomain := UserInfo.Domain; FPtMsgHang := UserInfo.PtMsgHang; FService := UserInfo.Service; FAutoSave := UserInfo.AutoSave; FInitialTab := UserInfo.InitialTab; FUseLastTab := UserInfo.UseLastTab; if(URLMonHandle = 0) then FWebAccess := FALSE else FWebAccess := UserInfo.WebAccess; FDisableHold := UserInfo.DisableHold; FIsRPL := UserInfo.IsRPL; FRPLList := UserInfo.RPLList; FHasCorTabs := UserInfo.HasCorTabs; FHasRptTab := UserInfo.HasRptTab; FIsReportsOnly := UserInfo.IsReportsOnly; FToolsRptEdit := UserInfo.ToolsRptEdit; FCurrentPrinter := GetDefaultPrinter(DUZ, 0); FGECStatus := UserInfo.GECStatusCheck; FStationNumber := UserInfo.StationNumber; FIsProductionAccount := UserInfo.IsProductionAccount; end; function TUser.HasKey(const KeyName: string): Boolean; { returns true if the current user has the given security key } begin Result := HasSecurityKey(KeyName); end; { TPatient methods ------------------------------------------------------------------------- } procedure TPatient.Clear; { clears all fields in the Patient object } begin FDFN := ''; FName := ''; FSSN := ''; FDOB := 0; FAge := 0; FSex := 'U'; FCWAD := ''; FRestricted := False; FInpatient := False; FLocation := 0; FWardService := ''; FSpecialty := 0; FAdmitTime := 0; FSrvConn := False; FSCPercent := 0; FPrimTeam := ''; FPrimProv := ''; FAttending := ''; end; function TPatient.GetDateDied: TFMDateTime; begin if(not FDateDiedLoaded) then begin FDateDied := DateOfDeath(FDFN); FDateDiedLoaded := TRUE; end; Result := FDateDied; end; procedure TPatient.SetDFN(const Value: string); //*DFN* { selects a patient and sets up the Patient object for the patient } var PtSelect: TPtSelect; begin if (Value = '') or (Value = FDFN) then Exit; //*DFN* Clear; SelectPatient(Value, PtSelect); FDFN := Value; FName := PtSelect.Name; FICN := PtSelect.ICN; FSSN := PtSelect.SSN; FDOB := PtSelect.DOB; FAge := PtSelect.Age; FSex := PtSelect.Sex; FCWAD := PtSelect.CWAD; FRestricted := PtSelect.Restricted; FInpatient := Length(PtSelect.Location) > 0; FWardService :=PtSelect.WardService; FLocation := PtSelect.LocationIEN; FSpecialty := PtSelect.SpecialtyIEN; FAdmitTime := PtSelect.AdmitTime; FSrvConn := PtSelect.ServiceConnected; FSCPercent := PtSelect.SCPercent; FPrimTeam := PtSelect.PrimaryTeam; FPrimProv := PtSelect.PrimaryProvider; FAttending := PtSelect.Attending; end; { TEncounter ------------------------------------------------------------------------------- } constructor TEncounter.Create; begin inherited; FNotifier := TORNotifier.Create(Self, TRUE); end; destructor TEncounter.Destroy; begin FNotifier := nil; // Frees instance inherited; end; procedure TEncounter.Clear; { clears all the fields of an Encounter (usually done upon patient selection } begin FChanged := False; FDateTime := 0; FInpatient := False; FLocationName := ''; FLocationText := ''; FProvider := 0; FProviderName := ''; FStandAlone := False; FVisitCategory := #0; SetLocation(0); // Used to call Notifications - do it last so everything else is set end; function TEncounter.GetLocationText: string; { returns abbreviated hospital location + room/bed (or date/time for appt) } begin if FChanged then UpdateText; Result := FLocationText; end; function TEncounter.GetLocationName: string; { returns external text value for hospital location } begin if FChanged then UpdateText; Result := FLocationName; end; function TEncounter.GetProviderName: string; { returns external text value for provider name } begin if FChanged then UpdateText; Result := FProviderName; end; function TEncounter.GetVisitCategory: Char; begin Result := FVisitCategory; if Result = #0 then Result := 'A'; end; function TEncounter.GetVisitStr: string; begin Result := IntToStr(FLocation) + ';' + FloatToStr(FDateTime) + ';' + VisitCategory; // use VisitCategory property to insure non-null character end; function TEncounter.NeedVisit: Boolean; { returns true if required fields for visit creation are present } begin // added "<" to FDateTime check to trap "-1" visit dates - v23.12 (RV) if (FDateTime <= 0) or (FLocation = 0) then Result := True else Result := False; end; procedure TEncounter.SetDateTime(Value: TFMDateTime); { sets the date/time for the encounter - causes the visit to be reset } begin if Value <> FDateTime then begin FDateTime := Value; FChanged := True; end; end; procedure TEncounter.SetInpatient(Value: Boolean); { sets the inpatient flag for the encounter - causes the visit to be reset } begin if Value <> FInpatient then begin FInpatient := Value; FChanged := True; end; end; procedure TEncounter.SetLocation(Value: Integer); { sets the location for the encounter - causes the visit to be reset } begin if Value <> FLocation then begin FLocation := Value; FChanged := True; FNotifier.Notify(Self); end; end; procedure TEncounter.SetProvider(Value: Int64); { sets the provider for the encounter - causes the visit to be reset } begin if Value <> FProvider then begin FProvider := Value; FChanged := True; end; end; procedure TEncounter.SetStandAlone(Value: Boolean); { StandAlone should be true if this encounter isn't related to an appointment } begin if Value <> FStandAlone then begin FStandAlone := Value; FChanged := True; end; end; procedure TEncounter.SetVisitCategory(Value: Char); { sets the visit type for this encounter - causes to visit to be reset } begin if Value <> FVisitCategory then begin FVisitCategory := Value; FChanged := True; end; end; procedure TEncounter.UpdateText; { retrieve external values for provider name, hospital location } var EncounterText: TEncounterText; begin { this references the Patient object which is assumed to be created } EncounterText := GetEncounterText(Patient.DFN, FLocation, FProvider); with EncounterText do begin FLocationName := LocationName; if Length(LocationAbbr) > 0 then FLocationText := LocationAbbr else FLocationText := LocationName; if Length(LocationName) > 0 then begin if (FVisitCategory = 'H') //FInpatient then FLocationText := FLocationText + ' ' + RoomBed else FLocationText := FLocationText + ' ' + FormatFMDateTime('mmm dd,yy hh:nn', FDateTime); end else FLocationText := ''; if Length(ProviderName) > 0 // ProviderName is the field in EncounterText then FProviderName := ProviderName else FProviderName := ''; end; FChanged := False; end; { TChangeItem ------------------------------------------------------------------------------ } constructor TChangeItem.Create(AnItemType: Integer; const AnID, AText, AGroupName: string; ASignState: Integer; AParentID: string); begin FItemType := AnItemType; FID := AnID; FText := AText; FGroupName := AGroupName; FSignState := ASignState; FParentID := AParentID; end; { TChanges --------------------------------------------------------------------------------- } constructor TChanges.Create; begin FDocuments := TList.Create; FOrders := TList.Create; FPCE := TList.Create; FOrderGrp := TStringList.Create; FPCEGrp := TStringList.Create; FCount := 0; end; destructor TChanges.Destroy; begin Clear; FDocuments.Free; FOrders.Free; FPCE.Free; FOrderGrp.Free; FPCEGrp.Free; inherited Destroy; end; procedure TChanges.Add(ItemType: Integer; const AnID, ItemText, GroupName: string; SignState: Integer; AParentID: string); var i: Integer; Found: Boolean; ChangeList: TList; NewChangeItem: TChangeItem; begin ChangeList := nil; case ItemType of CH_DOC: ChangeList := FDocuments; CH_SUM: ChangeList := FDocuments; {*REV*} CH_CON: ChangeList := FDocuments; CH_SUR: ChangeList := FDocuments; CH_ORD: ChangeList := FOrders; CH_PCE: ChangeList := FPCE; end; Found := False; if ChangeList <> nil then with ChangeList do for i := 0 to Count - 1 do with TChangeItem(Items[i]) do if ID = AnID then begin Found := True; // can't change ItemType, ID, or GroupName, must call Remove first FText := ItemText; FSignState := SignState; end; if not Found then begin NewChangeItem := TChangeItem.Create(ItemType, AnID, ItemText, GroupName, SignState, AParentID); case ItemType of CH_DOC: begin FDocuments.Add(NewChangeItem); end; CH_SUM: begin {*REV*} FDocuments.Add(NewChangeItem); end; CH_CON: begin FDocuments.Add(NewChangeItem); end; CH_SUR: begin FDocuments.Add(NewChangeItem); end; CH_ORD: begin FOrders.Add(NewChangeItem); with FOrderGrp do if IndexOf(GroupName) < 0 then Add(GroupName); end; CH_PCE: begin FPCE.Add(NewChangeItem); with FPCEGrp do if IndexOf(GroupName) < 0 then Add(GroupName); end; end; Inc(FCount); end; end; function TChanges.CanSign: Boolean; { returns true if any items in the changes list can be signed by the user } var i: Integer; begin Result := False; with FDocuments do for i := 0 to Count - 1 do with TChangeItem(Items[i]) do if FSignState <> CH_SIGN_NA then begin Result := True; Exit; end; with FOrders do for i := 0 to Count - 1 do with TChangeItem(Items[i]) do if FSignState <> CH_SIGN_NA then begin Result := True; Exit; end; // don't have to worry about FPCE - it never requires signatures end; procedure TChanges.Clear; var i, ConsultIEN: Integer; DocIEN: Int64; OrderID: string; begin with FDocuments do for i := 0 to Count - 1 do begin DocIEN := StrToInt64Def(TChangeItem(Items[i]).ID, 0); UnlockDocument(DocIEN); ConsultIEN := GetConsultIENforNote(DocIEN); if ConsultIEN > -1 then begin OrderID := GetConsultOrderIEN(ConsultIEN); UnlockOrderIfAble(OrderID); end; TChangeItem(Items[i]).Free; end; with FOrders do for i := 0 to Count - 1 do TChangeItem(Items[i]).Free; with FPCE do for i := 0 to Count - 1 do TChangeItem(Items[i]).Free; FDocuments.Clear; FOrders.Clear; FPCE.Clear; FOrderGrp.Clear; FPCEGrp.Clear; FCount := 0; end; function TChanges.Exist(ItemType: Integer; const AnID: string): Boolean; var ChangeList: TList; i: Integer; begin Result := False; ChangeList := nil; case ItemType of CH_DOC: ChangeList := FDocuments; CH_SUM: ChangeList := FDocuments; {*REV*} CH_CON: ChangeList := FDocuments; CH_SUR: ChangeList := FDocuments; CH_ORD: ChangeList := FOrders; CH_PCE: ChangeList := FPCE; end; if ChangeList <> nil then with ChangeList do for i := 0 to Count - 1 do if TChangeItem(Items[i]).ID = AnID then begin Result := True; Break; end; end; function TChanges.ExistForOrder(const AnID: string): Boolean; { returns TRUE if any item in the list of orders has matching order number (ignores action) } var i: Integer; begin Result := False; if FOrders <> nil then with FOrders do for i := 0 to Count - 1 do if Piece(TChangeItem(Items[i]).ID, ';', 1) = Piece(AnID, ';', 1) then begin Result := True; Break; end; end; function TChanges.Locate(ItemType: Integer; const AnID: string): TChangeItem; var ChangeList: TList; i: Integer; begin Result := nil; ChangeList := nil; case ItemType of CH_DOC: ChangeList := FDocuments; CH_SUM: ChangeList := FDocuments; {*REV*} CH_CON: ChangeList := FDocuments; CH_SUR: ChangeList := FDocuments; CH_ORD: ChangeList := FOrders; CH_PCE: ChangeList := FPCE; end; if ChangeList <> nil then with ChangeList do for i := 0 to Count - 1 do if TChangeItem(Items[i]).ID = AnID then begin Result := TChangeItem(Items[i]); Break; end; end; procedure TChanges.Remove(ItemType: Integer; const AnID: string); { remove a change item from the appropriate list of changes (depending on type) this doesn't check groupnames, may leave a groupname without any associated items } var ChangeList: TList; i,j: Integer; needRemove: boolean; begin ChangeList := nil; case ItemType of CH_DOC: ChangeList := FDocuments; CH_SUM: ChangeList := FDocuments; CH_CON: ChangeList := FDocuments; CH_SUR: ChangeList := FDocuments; CH_ORD: ChangeList := FOrders; CH_PCE: ChangeList := FPCE; end; if ChangeList <> nil then with ChangeList do for i := Count - 1 downto 0 do if TChangeItem(Items[i]).ID = AnID then begin if Assigned(FOnRemove) then FOnRemove(Self, TChangeItem(Items[i])) {**RV**} else TChangeItem(Items[i]).Free; {**RV**} //TChangeItem(Items[i]).Free; {**RV**} // set TChangeItem(Items[i]) = nil? Delete(i); Dec(FCount); end; if ItemType = CH_ORD then begin for i := OrderGrp.Count - 1 downto 0 do begin needRemove := True; for j := 0 to FOrders.Count - 1 do if (AnsiCompareText(TChangeItem(FOrders[j]).GroupName,OrderGrp[i]) = 0 ) then needRemove := False; if needRemove then OrderGrp.Delete(i); end; end; if ItemType = CH_ORD then UnlockOrder(AnID); if ItemType = CH_DOC then UnlockDocument(StrToIntDef(AnID, 0)); if ItemType = CH_CON then UnlockDocument(StrToIntDef(AnID, 0)); if ItemType = CH_SUM then UnlockDocument(StrToIntDef(AnID, 0)); if ItemType = CH_SUR then UnlockDocument(StrToIntDef(AnID, 0)); end; procedure TChanges.ReplaceID(ItemType: Integer; const OldID, NewID: string); var ChangeList: TList; i: Integer; begin ChangeList := nil; case ItemType of CH_DOC: ChangeList := FDocuments; CH_SUM: ChangeList := FDocuments; {*REV*} CH_CON: ChangeList := FDocuments; CH_SUR: ChangeList := FDocuments; CH_ORD: ChangeList := FOrders; CH_PCE: ChangeList := FPCE; end; if ChangeList <> nil then with ChangeList do for i := 0 to Count - 1 do if TChangeItem(Items[i]).ID = OldID then begin TChangeItem(Items[i]).FID := NewID; end; end; procedure TChanges.ReplaceSignState(ItemType: Integer; const AnID: string; NewState: Integer); var ChangeList: TList; i: Integer; begin ChangeList := nil; case ItemType of CH_DOC: ChangeList := FDocuments; CH_SUM: ChangeList := FDocuments; {*REV*} CH_CON: ChangeList := FDocuments; CH_SUR: ChangeList := FDocuments; CH_ORD: ChangeList := FOrders; CH_PCE: ChangeList := FPCE; end; if ChangeList <> nil then with ChangeList do for i := 0 to Count - 1 do if TChangeItem(Items[i]).ID = AnID then begin TChangeItem(Items[i]).FSignState := NewState; end; end; procedure TChanges.ReplaceText(ItemType: Integer; const AnID, NewText: string); var ChangeList: TList; i: Integer; begin ChangeList := nil; case ItemType of CH_DOC: ChangeList := FDocuments; CH_SUM: ChangeList := FDocuments; {*REV*} CH_CON: ChangeList := FDocuments; CH_SUR: ChangeList := FDocuments; CH_ORD: ChangeList := FOrders; CH_PCE: ChangeList := FPCE; end; if ChangeList <> nil then with ChangeList do for i := 0 to Count - 1 do if TChangeItem(Items[i]).ID = AnID then begin TChangeItem(Items[i]).FText := NewText; end; end; function TChanges.RequireReview: Boolean; { returns true if documents can be signed or if any orders exist in Changes } var i: Integer; begin Result := False; AddUnsignedToChanges; if FOrders.Count > 0 then Result := True; if Result = False then with FDocuments do for i := 0 to Count - 1 do with TChangeItem(Items[i]) do if FSignState <> CH_SIGN_NA then begin Result := True; Break; end; end; procedure TChanges.AddUnsignedToChanges; { retrieves unsigned orders outside this session based on OR UNSIGNED ORDERS ON EXIT } var i, CanSign: Integer; AnID: string; HaveOrders, OtherOrders: TStringList; AChangeItem: TChangeItem; begin if Patient.DFN = '' then Exit; // exit if there is already an 'Other Unsigned' group? HaveOrders := TStringList.Create; OtherOrders := TStringList.Create; try StatusText('Looking for unsigned orders...'); for i := 0 to Pred(FOrders.Count) do begin AChangeItem := FOrders[i]; HaveOrders.Add(AChangeItem.ID); end; LoadUnsignedOrders(OtherOrders, HaveOrders); if (Encounter.Provider = User.DUZ) and User.CanSignOrders then CanSign := CH_SIGN_YES else CanSign := CH_SIGN_NA; for i := 0 to Pred(OtherOrders.Count) do begin AnID := OtherOrders[i]; Add(CH_ORD, AnID, TextForOrder(AnID), 'Other Unsigned', CanSign); end; finally StatusText(''); HaveOrders.Free; OtherOrders.Free; end; end; { TNotifications ---------------------------------------------------------------------------- } constructor TNotifications.Create; begin FList := TList.Create; FCurrentIndex := -1; FActive := False; end; destructor TNotifications.Destroy; begin Clear; FList.Free; inherited Destroy; end; procedure TNotifications.Add(const ADFN: string; AFollowUp: Integer; const ARecordID: string); //*DFN* var NotifyItem: TNotifyItem; begin NotifyItem := TNotifyItem.Create; NotifyItem.DFN := ADFN; NotifyItem.FollowUp := AFollowUp; NotifyItem.RecordID := ARecordId; FList.Add(NotifyItem); FActive := True; end; procedure TNotifications.Clear; var i: Integer; begin with FList do for i := 0 to Count - 1 do with TNotifyItem(Items[i]) do Free; FList.Clear; FActive := False; FCurrentIndex := -1; FNotifyItem := nil; end; function TNotifications.GetDFN: string; //*DFN* begin if FNotifyItem <> nil then Result := FNotifyItem.DFN else Result := ''; //*DFN* end; function TNotifications.GetFollowUp: Integer; begin if FNotifyItem <> nil then Result := FNotifyItem.FollowUp else Result := 0; end; function TNotifications.GetAlertData: string; begin if FNotifyItem <> nil then Result := GetXQAData(Piece(FNotifyItem.RecordID, U, 2)) else Result := ''; end; function TNotifications.GetRecordID: string; begin if FNotifyItem <> nil then Result := FNotifyItem.RecordID else Result := ''; end; function TNotifications.GetText: string; begin if FNotifyItem <> nil then Result := Piece(Piece(FNotifyItem.RecordID, U, 1 ), ':', 2) else Result := ''; end; procedure TNotifications.Next; begin Inc(FCurrentIndex); if FCurrentIndex < FList.Count then FNotifyItem := TNotifyItem(FList[FCurrentIndex]) else begin FActive := False; FNotifyItem := nil; end; end; procedure TNotifications.Prior; begin Dec(FCurrentIndex); if FCurrentIndex < 0 then FNotifyItem := nil else FNotifyItem := TNotifyItem(FList[FCurrentIndex]); if FList.Count > 0 then FActive := True; end; procedure TNotifications.Delete; begin if FNotifyItem <> nil then DeleteAlert(Piece(FNotifyItem.RecordID, U, 2)); end; procedure TNotifications.DeleteForCurrentUser; begin if FNotifyItem <> nil then DeleteAlertForUser(Piece(FNotifyItem.RecordID, U, 2)); end; { TRemoteSite methods ---------------------------------------------------------------------------- } constructor TRemoteSite.Create(ASite: string); begin FSiteID := Piece(ASite, U, 1); FSiteName := MixedCase(Piece(ASite, U, 2)); FLastDate := StrToFMDateTime(Piece(ASite, U, 3)); FSelected := False; FQueryStatus := ''; FData := TStringList.Create; FLabQueryStatus := ''; FLabData := TStringList.Create; FCurrentLabQuery := ''; FCurrentReportQuery := ''; end; destructor TRemoteSite.Destroy; begin LabClear; ReportClear; FData.Free; FLabData.Free; inherited Destroy; end; procedure TRemoteSite.ReportClear; begin FData.Clear; FQueryStatus := ''; end; procedure TRemoteSite.LabClear; begin FLabData.Clear; FLabQueryStatus := ''; end; procedure TRemoteSite.SetSelected(Value: boolean); begin FSelected := Value; end; constructor TRemoteReport.Create(AReport: string); begin FReport := AReport; FHandle := ''; end; destructor TRemoteReport.Destroy; begin inherited Destroy; end; constructor TRemoteReportList.Create; begin FReportList := TList.Create; FCount := 0; end; destructor TRemoteReportList.Destroy; begin //Clear; FReportList.Free; inherited Destroy; end; procedure TRemoteReportList.Add(AReportList, AHandle: string); var ARemoteReport: TRemoteReport; begin ARemoteReport := TRemoteReport.Create(AReportList); ARemoteReport.Handle := AHandle; ARemoteReport.Report := AReportList; FReportList.Add(ARemoteReport); FCount := FReportList.Count; end; procedure TRemoteReportList.Clear; var i: Integer; begin with FReportList do for i := 0 to Count - 1 do with TRemoteReport(Items[i]) do Free; FReportList.Clear; FCount := 0; end; constructor TRemoteSiteList.Create; begin FSiteList := TList.Create; FCount := 0; end; destructor TRemoteSiteList.Destroy; begin Clear; FSiteList.Free; inherited Destroy; end; procedure TRemoteSiteList.Add(ASite: string); var ARemoteSite: TRemoteSite; begin ARemoteSite := TRemoteSite.Create(ASite); FSiteList.Add(ARemoteSite); FCount := FSiteList.Count; end; procedure TRemoteSiteList.Clear; var i: Integer; begin with FSiteList do for i := 0 to Count - 1 do with TRemoteSite(Items[i]) do Free; FSiteList.Clear; FCount := 0; end; procedure TRemoteSiteList.ChangePatient(const DFN: string); var ALocations: TStringList; i: integer; begin Clear; ALocations := TStringList.Create; try FRemoteDataExists := HasRemoteData(DFN, ALocations); if FRemoteDataExists then begin SortByPiece(ALocations, '^', 2); for i := 0 to ALocations.Count - 1 do if piece(ALocations[i],'^',5) = '1' then Add(ALocations.Strings[i]); FNoDataReason := ''; end else FNoDataReason := Piece(ALocations[0], U, 2); FCount := FSiteList.Count; finally ALocations.Free; end; end; procedure TUser.SetCurrentPrinter(Value: string); begin FCurrentPrinter := Value; end; procedure GotoWebPage(const URL: WideString); begin if(URLMonHandle <> 0) then HlinkNav(nil, PWideChar(URL)); end; procedure LoadURLMon; const UrlMonLib = 'URLMON.DLL'; HlinkName = 'HlinkNavigateString'; begin URLMonHandle := LoadLibrary(PChar(UrlMonLib)); if URLMonHandle <= HINSTANCE_ERROR then URLMonHandle := 0 else begin HlinkNav := GetProcAddress(URLMonHandle, HlinkName); if(not assigned(HlinkNav)) then begin FreeLibrary(URLMonHandle); URLMonHandle := 0; end; end; end; procedure ReleaseURLMon; begin if(URLMonHandle <> 0) then begin FreeLibrary(URLMonHandle); URLMonHandle := 0; end; end; procedure TChanges.ReplaceODGrpName(const AnODID, NewGrp: string); var ChangeList: TList; i: Integer; begin ChangeList := FOrders; if ChangeList <> nil then with ChangeList do for i := 0 to Count - 1 do if TChangeItem(Items[i]).ID = AnODID then TChangeItem(Items[i]).FGroupName := NewGrp; end; procedure TChanges.ChangeOrderGrp(const oldGrpName,newGrpName: string); var i : integer; begin for i := 0 to FOrderGrp.Count - 1 do begin if AnsiCompareText(FOrderGrp[i],oldGrpName)= 0 then FOrderGrp[i] := newGrpName; end; end; initialization uVistaMsg := 0; LoadURLMon; finalization ReleaseURLMon; ReleaseAppNotification; end.