iSharkFly-Open
/
VistA-cprs
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Initial Upload of Official WV CPRS 1.0.26.76

This commit is contained in:
kdtop3 2008-07-06 21:36:37 +00:00
parent 969bb312d5
commit a37fcb43fa
774 changed files with 341078 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
CPRS-Chart/Accessibility_TLB.dcr Normal file
View File

Binary file not shown.

286
CPRS-Chart/Accessibility_TLB.pas Normal file
View File

@ -0,0 +1,286 @@
unit Accessibility_TLB;
// ************************************************************************ //
// WARNING
// -------
// The types declared in this file were generated from data read from a
// Type Library. If this type library is explicitly or indirectly (via
// another type library referring to this type library) re-imported, or the
// 'Refresh' command of the Type Library Editor activated while editing the
// Type Library, the contents of this file will be regenerated and all
// manual modifications will be lost.
// ************************************************************************ //
// PASTLWTR : 1.2
// File generated on 2/4/2008 6:51:03 PM from Type Library described below.
// ************************************************************************ //
// Type Lib: C:\WINDOWS\system32\oleacc.dll (1)
// LIBID: {1EA4DBF0-3C3B-11CF-810C-00AA00389B71}
// LCID: 0
// Helpfile:
// HelpString:
// DepndLst:
// (1) v2.0 stdole, (C:\WINDOWS\system32\stdole2.tlb)
// Parent TypeLibrary:
// (0) v1.0 CPRSChart, (C:\Program Files\Borland\Delphi7\Projects\OR_SRC_CREATION FILE 12 06 06 OR_3_270\WV_Release_CPRS_OFFICIAL\CPRS-Chart\CPRSChart.tlb)
// Errors:
// Hint: Parameter 'var' of IAccPropServices.SetPropValue changed to 'var_'
// Hint: Parameter 'var' of IAccPropServices.SetHwndProp changed to 'var_'
// Hint: Parameter 'var' of IAccPropServices.SetHmenuProp changed to 'var_'
// ************************************************************************ //
{$TYPEDADDRESS OFF} // Unit must be compiled without type-checked pointers.
{$WARN SYMBOL_PLATFORM OFF}
{$WRITEABLECONST ON}
{$VARPROPSETTER ON}
interface
uses Windows, ActiveX, Classes, Graphics, StdVCL, Variants;
// *********************************************************************//
// GUIDS declared in the TypeLibrary. Following prefixes are used:
// Type Libraries : LIBID_xxxx
// CoClasses : CLASS_xxxx
// DISPInterfaces : DIID_xxxx
// Non-DISP interfaces: IID_xxxx
// *********************************************************************//
const
// TypeLibrary Major and minor versions
AccessibilityMajorVersion = 1;
AccessibilityMinorVersion = 1;
LIBID_Accessibility: TGUID = '{1EA4DBF0-3C3B-11CF-810C-00AA00389B71}';
IID_IAccessible: TGUID = '{618736E0-3C3D-11CF-810C-00AA00389B71}';
IID_IAccessibleHandler: TGUID = '{03022430-ABC4-11D0-BDE2-00AA001A1953}';
IID_IAccIdentity: TGUID = '{7852B78D-1CFD-41C1-A615-9C0C85960B5F}';
IID_IAccPropServer: TGUID = '{76C0DBBB-15E0-4E7B-B61B-20EEEA2001E0}';
IID_IAccPropServices: TGUID = '{6E26E776-04F0-495D-80E4-3330352E3169}';
CLASS_CAccPropServices: TGUID = '{B5F8350B-0548-48B1-A6EE-88BD00B4A5E7}';
// *********************************************************************//
// Declaration of Enumerations defined in Type Library
// *********************************************************************//
// Constants for enum AnnoScope
type
AnnoScope = TOleEnum;
const
ANNO_THIS = $00000000;
ANNO_CONTAINER = $00000001;
type
// *********************************************************************//
// Forward declaration of types defined in TypeLibrary
// *********************************************************************//
IAccessible = interface;
IAccessibleDisp = dispinterface;
IAccessibleHandler = interface;
IAccIdentity = interface;
IAccPropServer = interface;
IAccPropServices = interface;
// *********************************************************************//
// Declaration of CoClasses defined in Type Library
// (NOTE: Here we map each CoClass to its Default Interface)
// *********************************************************************//
CAccPropServices = IAccPropServices;
// *********************************************************************//
// Declaration of structures, unions and aliases.
// *********************************************************************//
wireHWND = ^_RemotableHandle;
wireHMENU = ^_RemotableHandle;
PByte1 = ^Byte; {*}
PUserType1 = ^TGUID; {*}
__MIDL_IWinTypes_0009 = record
case Integer of
0: (hInproc: Integer);
1: (hRemote: Integer);
end;
_RemotableHandle = packed record
fContext: Integer;
u: __MIDL_IWinTypes_0009;
end;
// *********************************************************************//
// Interface: IAccessible
// Flags: (4432) Hidden Dual OleAutomation Dispatchable
// GUID: {618736E0-3C3D-11CF-810C-00AA00389B71}
// *********************************************************************//
IAccessible = interface(IDispatch)
['{618736E0-3C3D-11CF-810C-00AA00389B71}']
function Get_accParent: IDispatch; safecall;
function Get_accChildCount: Integer; safecall;
function Get_accChild(varChild: OleVariant): IDispatch; safecall;
function Get_accName(varChild: OleVariant): WideString; safecall;
function Get_accValue(varChild: OleVariant): WideString; safecall;
function Get_accDescription(varChild: OleVariant): WideString; safecall;
function Get_accRole(varChild: OleVariant): OleVariant; safecall;
function Get_accState(varChild: OleVariant): OleVariant; safecall;
function Get_accHelp(varChild: OleVariant): WideString; safecall;
function Get_accHelpTopic(out pszHelpFile: WideString; varChild: OleVariant): Integer; safecall;
function Get_accKeyboardShortcut(varChild: OleVariant): WideString; safecall;
function Get_accFocus: OleVariant; safecall;
function Get_accSelection: OleVariant; safecall;
function Get_accDefaultAction(varChild: OleVariant): WideString; safecall;
procedure accSelect(flagsSelect: Integer; varChild: OleVariant); safecall;
procedure accLocation(out pxLeft: Integer; out pyTop: Integer; out pcxWidth: Integer;
out pcyHeight: Integer; varChild: OleVariant); safecall;
function accNavigate(navDir: Integer; varStart: OleVariant): OleVariant; safecall;
function accHitTest(xLeft: Integer; yTop: Integer): OleVariant; safecall;
procedure accDoDefaultAction(varChild: OleVariant); safecall;
procedure Set_accName(varChild: OleVariant; const pszName: WideString); safecall;
procedure Set_accValue(varChild: OleVariant; const pszValue: WideString); safecall;
property accParent: IDispatch read Get_accParent;
property accChildCount: Integer read Get_accChildCount;
property accChild[varChild: OleVariant]: IDispatch read Get_accChild;
property accName[varChild: OleVariant]: WideString read Get_accName write Set_accName;
property accValue[varChild: OleVariant]: WideString read Get_accValue write Set_accValue;
property accDescription[varChild: OleVariant]: WideString read Get_accDescription;
property accRole[varChild: OleVariant]: OleVariant read Get_accRole;
property accState[varChild: OleVariant]: OleVariant read Get_accState;
property accHelp[varChild: OleVariant]: WideString read Get_accHelp;
property accHelpTopic[out pszHelpFile: WideString; varChild: OleVariant]: Integer read Get_accHelpTopic;
property accKeyboardShortcut[varChild: OleVariant]: WideString read Get_accKeyboardShortcut;
property accFocus: OleVariant read Get_accFocus;
property accSelection: OleVariant read Get_accSelection;
property accDefaultAction[varChild: OleVariant]: WideString read Get_accDefaultAction;
end;
// *********************************************************************//
// DispIntf: IAccessibleDisp
// Flags: (4432) Hidden Dual OleAutomation Dispatchable
// GUID: {618736E0-3C3D-11CF-810C-00AA00389B71}
// *********************************************************************//
IAccessibleDisp = dispinterface
['{618736E0-3C3D-11CF-810C-00AA00389B71}']
property accParent: IDispatch readonly dispid -5000;
property accChildCount: Integer readonly dispid -5001;
property accChild[varChild: OleVariant]: IDispatch readonly dispid -5002;
property accName[varChild: OleVariant]: WideString dispid -5003;
property accValue[varChild: OleVariant]: WideString dispid -5004;
property accDescription[varChild: OleVariant]: WideString readonly dispid -5005;
property accRole[varChild: OleVariant]: OleVariant readonly dispid -5006;
property accState[varChild: OleVariant]: OleVariant readonly dispid -5007;
property accHelp[varChild: OleVariant]: WideString readonly dispid -5008;
property accHelpTopic[out pszHelpFile: WideString; varChild: OleVariant]: Integer readonly dispid -5009;
property accKeyboardShortcut[varChild: OleVariant]: WideString readonly dispid -5010;
property accFocus: OleVariant readonly dispid -5011;
property accSelection: OleVariant readonly dispid -5012;
property accDefaultAction[varChild: OleVariant]: WideString readonly dispid -5013;
procedure accSelect(flagsSelect: Integer; varChild: OleVariant); dispid -5014;
procedure accLocation(out pxLeft: Integer; out pyTop: Integer; out pcxWidth: Integer;
out pcyHeight: Integer; varChild: OleVariant); dispid -5015;
function accNavigate(navDir: Integer; varStart: OleVariant): OleVariant; dispid -5016;
function accHitTest(xLeft: Integer; yTop: Integer): OleVariant; dispid -5017;
procedure accDoDefaultAction(varChild: OleVariant); dispid -5018;
end;
// *********************************************************************//
// Interface: IAccessibleHandler
// Flags: (272) Hidden OleAutomation
// GUID: {03022430-ABC4-11D0-BDE2-00AA001A1953}
// *********************************************************************//
IAccessibleHandler = interface(IUnknown)
['{03022430-ABC4-11D0-BDE2-00AA001A1953}']
function AccessibleObjectFromID(hwnd: Integer; lObjectID: Integer; out pIAccessible: IAccessible): HResult; stdcall;
end;
// *********************************************************************//
// Interface: IAccIdentity
// Flags: (0)
// GUID: {7852B78D-1CFD-41C1-A615-9C0C85960B5F}
// *********************************************************************//
IAccIdentity = interface(IUnknown)
['{7852B78D-1CFD-41C1-A615-9C0C85960B5F}']
function GetIdentityString(dwIDChild: LongWord; out ppIDString: PByte1;
out pdwIDStringLen: LongWord): HResult; stdcall;
end;
// *********************************************************************//
// Interface: IAccPropServer
// Flags: (0)
// GUID: {76C0DBBB-15E0-4E7B-B61B-20EEEA2001E0}
// *********************************************************************//
IAccPropServer = interface(IUnknown)
['{76C0DBBB-15E0-4E7B-B61B-20EEEA2001E0}']
function GetPropValue(var pIDString: Byte; dwIDStringLen: LongWord; idProp: TGUID;
out pvarValue: OleVariant; out pfHasProp: Integer): HResult; stdcall;
end;
// *********************************************************************//
// Interface: IAccPropServices
// Flags: (0)
// GUID: {6E26E776-04F0-495D-80E4-3330352E3169}
// *********************************************************************//
IAccPropServices = interface(IUnknown)
['{6E26E776-04F0-495D-80E4-3330352E3169}']
function SetPropValue(var pIDString: Byte; dwIDStringLen: LongWord; idProp: TGUID;
var_: OleVariant): HResult; stdcall;
function SetPropServer(var pIDString: Byte; dwIDStringLen: LongWord; var paProps: TGUID;
cProps: SYSINT; const pServer: IAccPropServer; AnnoScope: AnnoScope): HResult; stdcall;
function ClearProps(var pIDString: Byte; dwIDStringLen: LongWord; var paProps: TGUID;
cProps: SYSINT): HResult; stdcall;
function SetHwndProp(var hwnd: _RemotableHandle; idObject: LongWord; idChild: LongWord;
idProp: TGUID; var_: OleVariant): HResult; stdcall;
function SetHwndPropStr(var hwnd: _RemotableHandle; idObject: LongWord; idChild: LongWord;
idProp: TGUID; str: PWideChar): HResult; stdcall;
function SetHwndPropServer(var hwnd: _RemotableHandle; idObject: LongWord; idChild: LongWord;
var paProps: TGUID; cProps: SYSINT; const pServer: IAccPropServer;
AnnoScope: AnnoScope): HResult; stdcall;
function ClearHwndProps(var hwnd: _RemotableHandle; idObject: LongWord; idChild: LongWord;
var paProps: TGUID; cProps: SYSINT): HResult; stdcall;
function ComposeHwndIdentityString(var hwnd: _RemotableHandle; idObject: LongWord;
idChild: LongWord; out ppIDString: PByte1;
out pdwIDStringLen: LongWord): HResult; stdcall;
function DecomposeHwndIdentityString(var pIDString: Byte; dwIDStringLen: LongWord;
out phwnd: wireHWND; out pidObject: LongWord;
out pidChild: LongWord): HResult; stdcall;
function SetHmenuProp(var hmenu: _RemotableHandle; idChild: LongWord; idProp: TGUID;
var_: OleVariant): HResult; stdcall;
function SetHmenuPropStr(var hmenu: _RemotableHandle; idChild: LongWord; idProp: TGUID;
str: PWideChar): HResult; stdcall;
function SetHmenuPropServer(var hmenu: _RemotableHandle; idChild: LongWord; var paProps: TGUID;
cProps: SYSINT; const pServer: IAccPropServer; AnnoScope: AnnoScope): HResult; stdcall;
function ClearHmenuProps(var hmenu: _RemotableHandle; idChild: LongWord; var paProps: TGUID;
cProps: SYSINT): HResult; stdcall;
function ComposeHmenuIdentityString(var hmenu: _RemotableHandle; idChild: LongWord;
out ppIDString: PByte1; out pdwIDStringLen: LongWord): HResult; stdcall;
function DecomposeHmenuIdentityString(var pIDString: Byte; dwIDStringLen: LongWord;
out phmenu: wireHMENU; out pidChild: LongWord): HResult; stdcall;
end;
// *********************************************************************//
// The Class CoCAccPropServices provides a Create and CreateRemote method to
// create instances of the default interface IAccPropServices exposed by
// the CoClass CAccPropServices. The functions are intended to be used by
// clients wishing to automate the CoClass objects exposed by the
// server of this typelibrary.
// *********************************************************************//
CoCAccPropServices = class
class function Create: IAccPropServices;
class function CreateRemote(const MachineName: string): IAccPropServices;
end;
implementation
uses ComObj;
class function CoCAccPropServices.Create: IAccPropServices;
begin
Result := CreateComObject(CLASS_CAccPropServices) as IAccPropServices;
end;
class function CoCAccPropServices.CreateRemote(const MachineName: string): IAccPropServices;
begin
Result := CreateRemoteComObject(MachineName, CLASS_CAccPropServices) as IAccPropServices;
end;
end.

61
CPRS-Chart/BA/UBAConst.pas Normal file
View File

@ -0,0 +1,61 @@
unit UBAConst;
{$OPTIMIZATION OFF}
interface
const
BUFFER_ORDER_ID = '9999999999';
CARET = '^';
NOT_APPLICABLE = 'N/A';
ENCOUNTER_TODAYS_DX = '^Diagnoses from Today''s Orders'; //BAPHII 1.3.10
ENCOUNTER_PERSONAL_DX = '^Personal Diagnoses List Items';
DX_PROBLEM_LIST_TXT = 'Problem List Items';
DX_PERSONAL_LIST_TXT = 'Personal Diagnoses List Items';
DX_ENCOUNTER_LIST_TXT = 'Encounter Form Diagnoses';
DX_TODAYS_DX_LIST_TXT = 'Diagnoses from Today''s Orders';
MIN_SC_CONDITION = 0;
MAX_SC_CONDITION = 0;
BILLABLE_ORDER = '1';
SERVICE_CONNECTED = 'SC';
NOT_SERVICE_CONNECTED = 'NSC';
AGENT_ORANGE = 'AO';
IONIZING_RADIATION = 'IR';
ENVIRONMENTAL_CONTAM = 'EC';
HEAD_NECK_CANCER = 'HNC';
MILITARY_SEXUAL_TRAUMA = 'MST';
COMBAT_VETERAN = 'CV';
MAX_DX = 4;
DXREC_INIT_FIELD_VAL = '';
UNSIGNED_REC_INIT_FIELD_VAL = '';
PRIMARY_DX = 'Primary';
SECONDARY_DX = 'Secondary';
//Form identifiers
F_ORDERS_SIGN = 1;
F_REVIEW = 2;
F_CONSULTS = 3;
// Order Status
BAOK2SIGN = 1;
DISCONTINUED = 5;
MIN_RECT = 0;
MAX_RECT = 199;
ADD_TO_PROBLEM_LIST = 'PL';
ADD_TO_PERSONAL_DX_LIST = 'PD';
BA_INACTIVE_CODE = '#';
implementation
end.

1480
CPRS-Chart/BA/UBACore.pas Normal file
View File

File diff suppressed because it is too large Load Diff

1182
CPRS-Chart/BA/UBAGlobals.pas Normal file
View File

File diff suppressed because it is too large Load Diff

43
CPRS-Chart/BA/UBAMessages.pas Normal file
View File

@ -0,0 +1,43 @@
unit UBAMessages;
{$OPTIMIZATION OFF}
{.$define debug}
interface
const
{$ifdef debug}
BA_ASSRTF = 'Assertion failed' + #13;
{$endif}
//CPRS User Messages
BA_MAX_DX_ALLOWED = 'Can Not Add Diagnosis' + #13 +
'Reason: Maximum (4) diagnoses have already been applied to this order.' + #13 +
'You may use the ''Diagnosis Editor'' to manage diagnoses for order(s).';
BA_NO_ORDERS_SELECTED = 'No orders have been selected. Select one or more orders to be signed.';
BA_CONFIRM_DX_OVERWRITE = '''Lookup Diagnoses'' action will overwrite any existing diagnoses for selected orders.'+#13+'Do you wish to proceed?';
BA_MAX_DX = 'A maximum of 4 diagnosis can be selected';
BA_BILLING_DATA_SAVE_FAILED = 'Error: Billing data was not saved';
BA_NA_COPY_DISALLOWED = 'Can''t copy ''N/A'' orders. Select non-''N/A'' order(s), and retry the copy.';
BA_NA_PASTE_DISALLOWED = 'Selected Diagnoses will not be pasted to orders flagged with N/A.';
BA_ONE_ORDER_ONLY = 'Only 1 order at a time may be selected for copying';
BA_PERSONAL_LIST_UPDATED = 'Personal Diagnoses List Updated.';
BA_NO_BILLABLE_ORDERS = 'No billable orders have been selected.';
BA_INACTIVE_CODE = 'Inactive Code';
BA_INACTIVE_ICD9_CODE_1 = 'The diagnosis code (';
BA_INACTIVE_ICD9_CODE_2 = ') is not active as of today''s date,' + #13#10+
'Please select another.';
BA_DATA_NOT_REQD = '9';
BA_DUP_DX = 'Duplicate Diagnosis.';
BA_DUP_DX_DISALLOWED_1 = 'Diagnosis (';
BA_DUP_DX_DISALLOWED_2 = ') has already been selected.';
implementation
end.

270
CPRS-Chart/BA/fBALocalDiagnoses.dfm Normal file
View File

@ -0,0 +1,270 @@
object frmBALocalDiagnoses: TfrmBALocalDiagnoses
Left = 192
Top = 61
Width = 620
Height = 544
Caption = 'Assign Diagnoses to Order(s)'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
KeyPreview = True
OldCreateOrder = False
Position = poScreenCenter
ShowHint = True
OnActivate = FormActivate
OnCreate = FormCreate
OnDestroy = FormDestroy
OnShow = FormShow
PixelsPerInch = 96
TextHeight = 13
object pnlTop: TPanel
Left = 0
Top = 0
Width = 612
Height = 96
Align = alTop
Caption = 'pnlTop'
TabOrder = 0
DesignSize = (
612
96)
object lbOrders: TListBox
Left = 7
Top = 25
Width = 599
Height = 69
Anchors = [akLeft, akTop, akRight, akBottom]
IntegralHeight = True
ItemHeight = 13
TabOrder = 2
OnMouseMove = lbOrdersMouseMove
end
object ORStaticText1: TORStaticText
Left = 216
Top = 8
Width = 169
Height = 14
AutoSize = False
Caption = 'Selected Orders'
TabOrder = 1
TabStop = True
OnEnter = ORStaticText1Enter
OnExit = ORStaticText1Exit
end
object lblPatientName: TStaticText
Left = 11
Top = 9
Width = 76
Height = 17
Caption = 'PatientName'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = [fsBold]
ParentFont = False
TabOrder = 0
TabStop = True
end
end
object pnlMain: TPanel
Left = 0
Top = 96
Width = 612
Height = 259
Align = alClient
TabOrder = 1
object lbSections: TORListBox
Left = 9
Top = 16
Width = 238
Height = 201
Style = lbOwnerDrawVariable
IntegralHeight = True
ItemHeight = 13
ParentShowHint = False
ShowHint = True
TabOrder = 1
OnClick = lbSectionsClick
OnDrawItem = lbSectionsDrawItem
Caption = 'Diagnosis Section'
ItemTipColor = clWindow
LongList = False
Pieces = '3'
CheckEntireLine = True
end
object btnOther: TButton
Left = 155
Top = 219
Width = 92
Height = 20
Caption = 'Other &Diagnosis'
TabOrder = 2
OnClick = btnOtherClick
end
object lbDiagnosis: TORListBox
Left = 248
Top = 16
Width = 353
Height = 225
IntegralHeight = True
ItemHeight = 13
ParentShowHint = False
ShowHint = True
TabOrder = 4
OnClick = lbDiagnosisClick
Caption = 'Diagnosis Section'
ItemTipColor = clWindow
LongList = False
Pieces = '1,2,3'
end
object ORStaticText2: TORStaticText
Left = 8
Top = 1
Width = 241
Height = 17
AutoSize = False
BevelKind = bkFlat
Caption = 'Diagnosis Section'
TabOrder = 0
TabStop = True
OnEnter = ORStaticText1Enter
OnExit = ORStaticText1Exit
end
object ORStaticText3: TORStaticText
Left = 248
Top = 1
Width = 353
Height = 17
AutoSize = False
BevelKind = bkFlat
Caption = 'Diagnosis Codes'
TabOrder = 3
TabStop = True
OnEnter = ORStaticText1Enter
OnExit = ORStaticText1Exit
end
end
object pnlBottom: TORAutoPanel
Left = 0
Top = 355
Width = 612
Height = 162
Align = alBottom
TabOrder = 2
DesignSize = (
612
162)
object lvDxGrid: TListView
Left = 12
Top = 19
Width = 445
Height = 85
Color = clInfoBk
Columns = <
item
Caption = 'Add To PL/PD'
Width = 85
end
item
Caption = 'Primary'
MinWidth = 65
Width = 65
end
item
Caption = 'Diagnosis for Selected Orders'
MinWidth = 275
Width = 290
end>
Ctl3D = False
HideSelection = False
MultiSelect = True
ReadOnly = True
RowSelect = True
TabOrder = 1
ViewStyle = vsReport
OnClick = lvDxGridClick
OnKeyDown = lvDxGridKeyDown
OnKeyUp = lvDxGridKeyUp
end
object cbAddToPDList: TCheckBox
Left = 459
Top = 33
Width = 129
Height = 17
Caption = 'Add to Personal Dx List'
TabOrder = 3
OnClick = cbAddToPDListClick
end
object cbAddToPL: TCheckBox
Left = 459
Top = 17
Width = 149
Height = 16
Anchors = [akLeft, akTop, akRight, akBottom]
Caption = 'Add To Problem List'
TabOrder = 2
OnClick = cbAddToPLClick
end
object btnPrimary: TButton
Left = 480
Top = 57
Width = 72
Height = 19
Caption = '&Primary'
TabOrder = 4
OnClick = btnPrimaryClick
end
object btnRemove: TButton
Left = 480
Top = 81
Width = 72
Height = 19
Caption = '&Remove'
TabOrder = 5
OnClick = btnRemoveClick
end
object btnSelectAll: TButton
Left = 385
Top = 108
Width = 72
Height = 18
Caption = '&Select All'
TabOrder = 6
OnClick = btnSelectAllClick
end
object buOK: TButton
Left = 384
Top = 136
Width = 72
Height = 21
Caption = '&OK'
TabOrder = 7
OnClick = buOKClick
end
object buCancel: TButton
Left = 482
Top = 136
Width = 72
Height = 21
Caption = '&Cancel'
TabOrder = 8
OnClick = buCancelClick
end
object ORStaticText4: TORStaticText
Left = 14
Top = 3
Width = 219
Height = 14
AutoSize = False
Caption = 'Provisional Diagnosis'
TabOrder = 0
TabStop = True
OnEnter = ORStaticText1Enter
OnExit = ORStaticText1Exit
end
end
end

1576
CPRS-Chart/BA/fBALocalDiagnoses.pas Normal file
View File

File diff suppressed because it is too large Load Diff

312
CPRS-Chart/BA/fBAOptionsDiagnoses.dfm Normal file
View File

@ -0,0 +1,312 @@
inherited frmBAOptionsDiagnoses: TfrmBAOptionsDiagnoses
Left = 231
Top = 183
Width = 747
Height = 557
Caption = 'Personal Diagnoses List'
Constraints.MinHeight = 100
Constraints.MinWidth = 200
OnActivate = FormActivate
OnCreate = FormCreate
OnShow = FormShow
PixelsPerInch = 96
TextHeight = 13
object Panel1: TPanel
Left = 0
Top = 0
Width = 739
Height = 530
Align = alClient
Caption = 'Panel1'
Constraints.MinHeight = 344
Constraints.MinWidth = 576
TabOrder = 0
object Panel2: TPanel
Left = 16
Top = 10
Width = 713
Height = 519
Caption = 'Panel1'
TabOrder = 0
object Splitter1: TSplitter
Left = 458
Top = 26
Width = -3
Height = 463
Cursor = crHSplit
end
object Splitter2: TSplitter
Left = 169
Top = 26
Width = 7
Height = 463
Cursor = crHSplit
end
object Splitter3: TSplitter
Left = 457
Top = 26
Width = 1
Height = 463
Cursor = crHSplit
end
object Splitter5: TSplitter
Left = 455
Top = 26
Width = 2
Height = 463
Cursor = crHSplit
end
object pnlBottom: TPanel
Left = 1
Top = 489
Width = 711
Height = 29
Align = alBottom
BevelOuter = bvNone
Caption = ' '
TabOrder = 0
DesignSize = (
711
29)
object btnOther: TButton
Left = 13
Top = 3
Width = 129
Height = 23
Anchors = [akLeft, akBottom]
Caption = 'Other &Diagnoses'
Constraints.MinHeight = 23
Constraints.MinWidth = 115
TabOrder = 0
OnClick = btnOtherClick
end
object btnOK: TButton
Left = 523
Top = 3
Width = 75
Height = 23
Anchors = [akRight, akBottom]
Caption = '&OK'
TabOrder = 1
OnClick = btnOKClick
end
object Button1: TButton
Left = 632
Top = 4
Width = 75
Height = 21
Anchors = [akRight, akBottom]
Caption = '&Cancel'
TabOrder = 2
OnClick = Button1Click
end
end
object Panel3: TPanel
Left = 1
Top = 26
Width = 168
Height = 463
Align = alLeft
BevelOuter = bvNone
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
ParentFont = False
TabOrder = 1
object lbSections: TORListBox
Left = 0
Top = 17
Width = 161
Height = 446
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
ItemHeight = 13
ParentFont = False
ParentShowHint = False
ShowHint = True
TabOrder = 0
OnClick = lbSectionsClick
OnEnter = lbSectionsEnter
ItemTipColor = clWindow
LongList = False
Pieces = '3'
end
object hdrCntlDxSections: THeaderControl
Left = 0
Top = 0
Width = 168
Height = 17
DragReorder = False
Sections = <
item
Alignment = taCenter
ImageIndex = -1
Text = 'Diagnoses Sections'
Width = 50
end>
end
end
object Panel4: TPanel
Left = 176
Top = 26
Width = 201
Height = 463
Align = alLeft
BevelOuter = bvNone
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
ParentFont = False
TabOrder = 2
object lbDiagnosis: TORListBox
Left = 0
Top = 17
Width = 201
Height = 446
Align = alClient
ItemHeight = 13
MultiSelect = True
ParentShowHint = False
ShowHint = True
Sorted = True
TabOrder = 0
OnClick = lbDiagnosisChange
OnEnter = lbDiagnosisEnter
ItemTipColor = clWindow
LongList = False
Pieces = '1,2,3'
OnChange = lbDiagnosisChange
end
object hdrCntlDxAdd: THeaderControl
Left = 0
Top = 0
Width = 201
Height = 17
DragReorder = False
Sections = <
item
Alignment = taCenter
ImageIndex = -1
Text = 'Diagnoses to add'
Width = 50
end>
end
end
object Panel5: TPanel
Left = 455
Top = 26
Width = 257
Height = 463
Align = alClient
BevelOuter = bvNone
Caption = 'Panel5'
TabOrder = 3
object lbPersonalDx: TORListBox
Left = 0
Top = 17
Width = 257
Height = 446
Align = alClient
Anchors = [akRight]
Color = clInfoBk
ItemHeight = 13
MultiSelect = True
ParentShowHint = False
ShowHint = True
Sorted = True
TabOrder = 0
OnClick = lbPersonalDxClick
ItemTipColor = clWindow
LongList = False
Pieces = '2,1,3'
end
object hdrCntlDx: THeaderControl
Left = 0
Top = 0
Width = 257
Height = 17
DragReorder = False
Sections = <
item
Alignment = taCenter
ImageIndex = -1
MinWidth = 150
Text = 'Diagnoses Codes'
Width = 150
end>
OnSectionClick = hdrCntlDxSectionClick
end
end
object pnlTop: TPanel
Left = 1
Top = 1
Width = 711
Height = 25
Align = alTop
BevelOuter = bvNone
TabOrder = 4
object StaticText3: TStaticText
Left = 472
Top = 8
Width = 140
Height = 17
Caption = 'Personal Diagnoses List'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = [fsBold]
ParentFont = False
TabOrder = 0
TabStop = True
end
end
object Panel7: TPanel
Left = 377
Top = 26
Width = 78
Height = 463
Align = alLeft
BevelOuter = bvNone
TabOrder = 5
DesignSize = (
78
463)
object btnAdd: TBitBtn
Left = 1
Top = 88
Width = 75
Height = 25
Anchors = [akLeft, akTop, akRight]
Caption = '&Add'
Constraints.MinHeight = 25
Constraints.MinWidth = 70
Enabled = False
TabOrder = 0
OnClick = btnAddClick
NumGlyphs = 2
end
object btnDelete: TBitBtn
Left = 2
Top = 136
Width = 75
Height = 25
Caption = '&Remove'
Constraints.MinHeight = 25
Constraints.MinWidth = 70
Enabled = False
TabOrder = 1
OnClick = btnDeleteClick
NumGlyphs = 2
end
end
end
end
end

652
CPRS-Chart/BA/fBAOptionsDiagnoses.pas Normal file
View File

@ -0,0 +1,652 @@
unit fBAOptionsDiagnoses;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, fAutoSz, StdCtrls, ORCtrls, ExtCtrls, ORFn, UCore, RCore, ORNet,
UBAGlobals, fPCELex, rPCE, Buttons, UBACore, UBAMessages, UBAConst,
ComCtrls;
type
TfrmBAOptionsDiagnoses = class(TfrmAutoSz)
Panel1: TPanel;
Panel2: TPanel;
Splitter1: TSplitter;
Splitter2: TSplitter;
Splitter3: TSplitter;
pnlBottom: TPanel;
btnOther: TButton;
btnOK: TButton;
Panel3: TPanel;
lbSections: TORListBox;
Panel4: TPanel;
lbDiagnosis: TORListBox;
Panel5: TPanel;
lbPersonalDx: TORListBox;
pnlTop: TPanel;
Panel7: TPanel;
btnAdd: TBitBtn;
btnDelete: TBitBtn;
Splitter5: TSplitter;
Button1: TButton;
StaticText3: TStaticText;
hdrCntlDx: THeaderControl;
hdrCntlDxSections: THeaderControl;
hdrCntlDxAdd: THeaderControl;
procedure FormCreate(Sender: TObject);
procedure btnOtherClick(Sender: TObject);
procedure lbSectionsClick(Sender: TObject);
procedure lbSectionsEnter(Sender: TObject);
procedure lbDiagnosisClick(Sender: TObject);
procedure btnCancelClick(Sender: TObject);
procedure btnOKClick(Sender: TObject);
procedure btnAddClick(Sender: TObject);
procedure btnDeleteClick(Sender: TObject);
procedure lbDiagnosisChange(Sender: TObject);
procedure lbPersonalDxClick(Sender: TObject);
procedure lbDiagnosisEnter(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure FormActivate(Sender: TObject);
function IsDXInList(ADXCode: string):boolean;
procedure LoadPersonalDxList;
procedure btnRemoveAllClick(Sender: TObject);
procedure btnAddAllClick(Sender: TObject);
procedure hdrCntlDxSectionClick(HeaderControl: THeaderControl;
Section: THeaderSection);
procedure FormResize(Sender: TObject);
private
{ Private declarations }
procedure LoadEncounterDx;
procedure ListDiagnosesSections(Dest: TStrings);
procedure AddProblemsToDxList;
procedure ListDiagnosesCodes(Section: String);
procedure InactiveICDNotification;
procedure SyncDxDeleteList;
procedure SyncDxNewList;
public
{ Public declarations }
end;
var
uAddToP : integer;
uDeleteFromPDL: integer;
uNewDxList : TStringList;
Problems : TStringList;
DxList : TStringList;
ECFDiagnoses : TStringList;
tmplst : TStringList;
newDxLst : TStringList;
delDxLst : TStringList;
inactiveCodes : integer;
procedure DialogOptionsDiagnoses(topvalue, leftvalue, fontsize: integer; var actiontype: Integer);
implementation
{$R *.dfm}
var
LastDFN : string;
LastLocation : integer;
FDxSection: string;
BADxCode: String;
procedure DialogOptionsDiagnoses(topvalue, leftvalue, fontsize: integer; var actiontype: Integer);
var
frmBAOptionsDiagnoses: TfrmBAOptionsDiagnoses;
begin
frmBAOptionsDiagnoses := TfrmBAOptionsDiagnoses.Create(Application);
actiontype := 0;
with frmBAOptionsDiagnoses do
begin
if (topvalue < 0) or (leftvalue < 0) then
Position := poScreenCenter
else
begin
Position := poDesigned;
Top := topvalue;
Left := leftvalue;
end;
ResizeAnchoredFormToFont(frmBAOptionsDiagnoses);
ShowModal;
end;
end;
procedure TfrmBAOptionsDiagnoses.FormCreate(Sender: TObject);
begin
inactiveCodes := 0;
LoadEncounterDx;
ListDiagnosesSections(lbSections.Items);
// lbPersonalDx.Items := rpcGetPersonalDxList(User.DUZ);
LoadPersonalDxList;
btnOK.Enabled := False;
hdrCntlDx.Sections[0].Width := lbPersonalDX.Width;
hdrCntlDxSections.Sections[0].Width := lbSections.Width;
hdrCntlDxAdd.Sections[0].Width := lbDiagnosis.Width;
// lbPersonalDx.Sorted := false;
// lbPersonalDx.Sorted := True;
lbPersonalDX.Repaint;
end;
procedure TfrmBAOptionsDiagnoses.LoadEncounterDx;
{ load the major coding lists that are used by the encounter form for a given location }
var
i: integer;
TempList: TStringList;
EncDt: TFMDateTime;
begin
Caption := 'Personal Diagnoses List for ' + User.Name;
LastLocation := Encounter.Location;
EncDt := Trunc(FMToday);
//add problems to the top of diagnoses.
TempList := TstringList.Create;
DxList.clear;
tCallV(TempList,'ORWPCE DIAG', [LastLocation, EncDt]);
DxList.add(templist.strings[0]);
AddProblemsToDxList;
for i := 1 to (TempList.Count-1) do
begin
DxList.add(Templist.strings[i]);
end;
end;
procedure TfrmBAOptionsDiagnoses.ListDiagnosesSections(Dest: TStrings);
var
i: Integer;
x: string;
begin
for i := 0 to DxList.Count - 1 do if CharAt(DxList[i], 1) = U then
begin
x := Piece(DxList[i], U, 2);
if Length(x) = 0 then x := '<No Section Name>';
Dest.Add(IntToStr(i) + U + Piece(DxList[i], U, 2) + U + x);
end;
end;
procedure TfrmBAOptionsDiagnoses.ListDiagnosesCodes(Section: String);
var
i,j: integer;
a: string;
begin
lbDiagnosis.Clear;
a := '';
for i := 0 to DxList.Count-1 do
begin
a := DxList.Strings[i];
if Piece(DxList[i], U, 2) = (Piece(Section,U,2)) then
break;
end;
inc(i);
for j := i to DxList.Count-1 do
begin
if Piece(DxList[j], U, 0) = '' then
break
else
begin
a := Piece(DxList[j], U, 2) + '^' + Piece(DxList[j], U, 1);
if not UBACore.IsICD9CodeActive(Piece(a,U,2),'ICD',Encounter.DateTime) then
begin
a := a + ' ' + UBAConst.BA_INACTIVE_CODE;
inc(inactiveCodes);
end;
lbDiagnosis.Items.Add(a);
end;
end;
end;
procedure TfrmBAOptionsDiagnoses.AddProblemsToDxList;
var
i : integer;
EncDt: TFMDateTime;
x : String;
begin
//Get problem list
EncDt := Trunc(FMToday);
LastDFN := Patient.DFN;
tCallV(Problems, 'ORWPCE ACTPROB', [Patient.DFN, EncDT]);
if Problems.Count > 0 then
begin
DxList.add('^Problem List Items');
for i := 1 to (Problems.count-1) do
begin
x :=(Piece(Problems.Strings[i],U,3) + U +
Piece(Problems.Strings[i],U,2));
// if (Piece(Problems.Strings[i],U,3) = '799.9') then continue; // DON'T INCLUDE 799.9 CODES
if (Piece(problems.Strings[i], U, 11) = '#') then
DxList.add(Piece(Problems.Strings[i],U,3) + U + // PL code inactive
Piece(Problems.Strings[i],U,2) + U + '#')
else if (Piece(problems.Strings[i], U, 10) = '') then // no inactive date for code
DxList.add(Piece(Problems.Strings[i],U,3) + U +
Piece(Problems.Strings[i],U,2))
else if (Trunc(StrToFloat(Piece(Problems.Strings[i], U, 10))) > EncDT) then // code active as of EncDt
DxList.add(Piece(Problems.Strings[i],U,3) + U +
Piece(Problems.Strings[i],U,2))
else
DxList.add(Piece(Problems.Strings[i],U,3) + U + // PL code inactive
Piece(Problems.Strings[i],U,2) + U + '#');
end;
end;
end;
procedure TfrmBAOptionsDiagnoses.btnOtherClick(Sender: TObject);
var
Match: string;
SelectedList : TStringList;
lexIEN: string;
begin
inherited;
BAPersonalDX := True;
SelectedList := TStringList.Create;
if Assigned (SelectedList) then SelectedList.Clear;
BADxCode := ''; //init
//Execute LEXICON
LexiconLookup(Match, LX_ICD);
if Match = '' then Exit;
if strLen(PChar(Piece(Match, U, 3)))> 0 then
lexIEN := Piece(Match, U, 3);
BADxCode := Piece(Match,U,2) + ' ' + Piece(Match, U, 1);
if IsDXInList(Piece(Match,U,1) ) then Exit; // eliminate duplicates
if UBACore.IsICD9CodeActive(Piece(Match,U,1),'ICD',Encounter.DateTime) then
begin
lbPersonalDx.Items.Add(BADxCode);
if strLen(PChar(lexIEN)) > 0 then
newDxLst.Add(Piece(Match,U,1) + U + lexIEN)
else
newDxLst.Add(Piece(Match,U,1));
end
else
InfoBox(BA_INACTIVE_ICD9_CODE_1 + BADxCode + BA_INACTIVE_ICD9_CODE_2 , BA_INACTIVE_CODE, MB_ICONWARNING or MB_OK);
lexIEN := '';
BAPersonalDX := False;
if newDxLst.Count > 0 then btnOK.Enabled := True;
end;
procedure TfrmBAOptionsDiagnoses.lbSectionsClick(Sender: TObject);
var i: integer;
begin
inherited;
for i := 0 to lbSections.Items.Count-1 do
begin
if(lbSections.Selected[i]) then
begin
ListDiagnosesCodes(lbSections.Items[i]);
FDXSection := lbSections.Items[i];
Break;
end;
end;
end;
procedure TfrmBAOptionsDiagnoses.lbSectionsEnter(Sender: TObject);
begin
inherited;
lbSections.Selected[0] := true;
end;
procedure TfrmBAOptionsDiagnoses.lbDiagnosisClick(Sender: TObject);
var
i : integer;
newDxCodes: TStringList;
selectedCode: String;
begin
inherited;
newDxCodes := TStringList.Create;
newDxCodes.Clear;
for i := 0 to lbDiagnosis.Items.Count-1 do
begin
if(lbDiagnosis.Selected[i]) then
begin
selectedCode := Piece(lbDiagnosis.Items[i],U,2);
newDxCodes.Add(selectedCode);
end;
if newDxCodes.Count > 0 then
begin
rpcAddToPersonalDxList(User.DUZ,NewDxCodes);
NewDxCodes.Clear;
lbPersonalDx.Items := rpcGetPersonalDxList(User.DUZ);
end;
end;
end;
procedure TfrmBAOptionsDiagnoses.btnCancelClick(Sender: TObject);
begin
inherited;
Close;
end;
procedure TfrmBAOptionsDiagnoses.btnOKClick(Sender: TObject);
begin
inherited;
if delDxLst.Count > 0 then
begin
// delete selected dx's
rpcDeleteFromPersonalDxList(User.DUZ,delDxLst);
delDxLst.Clear;
end;
if newDxLst.Count > 0 then
begin
newDxLst.Sort;
newDxLst.Duplicates := dupIgnore;
// add selected dx's
rpcAddToPersonalDxList(User.DUZ,newDxLst);
newDxLst.Clear;
end;
Close;
end;
procedure TfrmBAOptionsDiagnoses.btnAddClick(Sender: TObject);
var
i : integer;
newDxCode: string;
begin
inherited;
for i := 0 to lbDiagnosis.Items.Count-1 do
begin
if(lbDiagnosis.Selected[i]) then
begin
newDxCode := Piece(lbDiagnosis.Items[i],U,2);
if (not IsDxInList(newDxCode) ) then
begin
if UBACore.IsICD9CodeActive(newDxCode,'ICD',Encounter.DateTime) then
begin
newDxLst.Add(newDxCode);
lbPersonalDx.Items.Add(Piece(lbDiagnosis.Items[i],U,2) + U + Piece(lbDiagnosis.Items[i],U,1) )
end
else
InfoBox(BA_INACTIVE_ICD9_CODE_1 + Trim(Piece(newDxCode,'#',1)) + BA_INACTIVE_ICD9_CODE_2 , BA_INACTIVE_CODE, MB_ICONWARNING or MB_OK);
end;
end;
end;
btnAdd.Enabled := False;
lbDiagnosis.ClearSelection;
if newDxLst.Count > 0 then btnOK.Enabled := True;
end;
procedure TfrmBAOptionsDiagnoses.btnDeleteClick(Sender: TObject);
var
i, c: integer;
begin
inherited;
SyncDxDeleteList;
SyncDxNewList;
// delete selected dx from listbox.
with lbPersonalDX do
begin
i := Items.Count - 1;
c := SelCount;
Items.BeginUpdate;
while (i >= 0) and (c > 0) do
begin
if Selected[i] = true then
begin
Dec(c);
Items.Delete(i);
end;
Dec(i);
end;
Items.EndUpdate;
end;
btnDelete.Enabled := False;
lbDiagnosis.ClearSelection;
if delDxLst.Count > 0 then btnOK.Enabled := True;
end;
procedure TfrmBAOptionsDiagnoses.lbDiagnosisChange(Sender: TObject);
begin
inherited;
if lbDiagnosis.Count = 0 then
btnAdd.Enabled := False
else
begin
if (lbDiagnosis.SelCount > 0) then
btnAdd.Enabled := True
else
btnAdd.Enabled := False;
end;
end;
procedure TfrmBAOptionsDiagnoses.lbPersonalDxClick(Sender: TObject);
var i : integer;
begin
inherited;
for i := 0 to lbPersonalDX.Count-1 do
begin
if(lbPersonalDX.Selected[i]) then
begin
btnDelete.Enabled := True;
break;
end
else
btnDelete.Enabled := False;
end;
end;
procedure TfrmBAOptionsDiagnoses.lbDiagnosisEnter(Sender: TObject);
begin
inherited;
if lbDiagnosis.Count > 0 then
lbDiagnosis.Selected[0] := true;
end;
procedure TfrmBAOptionsDiagnoses.FormShow(Sender: TObject);
begin
inherited;
if lbSections.Count > 0 then
ListDiagnosesCodes(lbSections.Items[0]);
lbSections.SetFocus;
end;
procedure TfrmBAOptionsDiagnoses.Button1Click(Sender: TObject);
begin
inherited;
newDxLst.Clear;
Close;
end;
procedure TfrmBAOptionsDiagnoses.InactiveICDNotification;
begin
if inactiveCodes > 0 then
begin
if (not BAFWarningShown) and (inactiveCodes > 0) then
begin
InfoBox('There are ' + IntToStr(inactiveCodes) + ' active problem(s) flagged with a "#" as having' + #13#10 +
'inactive ICD codes as of today''s date. Please correct these' + #13#10 +
'problems via the Problems Tab - Change" option.', 'Inactive ICD Codes Found', MB_ICONWARNING or MB_OK);
BAFWarningShown := True;
end;
end;
end;
procedure TfrmBAOptionsDiagnoses.FormActivate(Sender: TObject);
begin
inherited;
InactiveICDNotification;
end;
function TfrmBAOptionsDiagnoses.IsDXInList(ADXCode: string):boolean;
var
i: integer;
//x,y: string;
begin
Result := False;
for i := 0 to lbPersonalDx.Count-1 do
if ADXCode = Piece(lbPersonalDx.Items[i],U,1) then
begin
Result := True;
Break;
end;
end;
procedure TfrmBAOptionsDiagnoses.LoadPersonalDxList;
var
i: integer;
dxList: TStringList;
inActiveDx: string;
begin
dxList := TStringList.Create;
dxList.Clear;
dxList := rpcGetPersonalDxList(User.DUZ);
if dxList.Count > 0 then
begin
for i := 0 to dxList.Count -1 do
begin
if not UBACore.IsICD9CodeActive(Piece(dxList.Strings[i],U,1),'ICD',Encounter.DateTime ) then
begin
inActiveDx := Piece(dxList.Strings[i],U,1) + ' ' + BA_INACTIVE_CODE + U + Piece(DxList.Strings[i],U,2);
lbPersonalDx.Items.Add(inActiveDx);
end
else
lbPersonalDx.Items.Add(dxList.Strings[i]);
end;
end;
end;
procedure TfrmBAOptionsDiagnoses.btnRemoveAllClick(Sender: TObject);
var
i: integer;
delDxCode: string;
begin
inherited;
// save dx seleted for deletion, update file when ok is pressed
for i := 0 to lbPersonalDX.Count-1 do
begin
delDxCode := Piece(lbPersonalDX.Items[i],U,1);
delDxLst.Add(delDxCode);
end;
// delete selected dx from listbox.
with lbPersonalDX do
begin
i := Items.Count - 1;
Items.BeginUpdate;
while (i >= 0) do
begin
Items.Delete(i);
Dec(i);
end;
Items.EndUpdate;
end;
btnDelete.Enabled := False;
lbDiagnosis.ClearSelection;
if delDxLst.Count > 0 then btnOK.Enabled := True;
end;
procedure TfrmBAOptionsDiagnoses.btnAddAllClick(Sender: TObject);
var
i : integer;
newDxCode: string;
begin
inherited;
for i := 0 to lbDiagnosis.Items.Count-1 do
begin
newDxCode := Piece(lbDiagnosis.Items[i],U,2);
if (not IsDxInList(newDxCode) ) then
begin
if UBACore.IsICD9CodeActive(newDxCode,'ICD',Encounter.DateTime) then
begin
newDxLst.Add(newDxCode);
lbPersonalDx.Items.Add(Piece(lbDiagnosis.Items[i],U,2) + U + Piece(lbDiagnosis.Items[i],U,1) )
end
else
InfoBox(BA_INACTIVE_ICD9_CODE_1 + Trim(Piece(newDxCode,'#',1)) + BA_INACTIVE_ICD9_CODE_2 , BA_INACTIVE_CODE, MB_ICONWARNING or MB_OK);
end;
end;
btnAdd.Enabled := False;
lbDiagnosis.ClearSelection;
if newDxLst.Count > 0 then btnOK.Enabled := True;
end;
procedure TfrmBAOptionsDiagnoses.hdrCntlDxSectionClick(
HeaderControl: THeaderControl; Section: THeaderSection);
begin
inherited;
lbPersonalDx.Sorted := false;
lbPersonalDx.Sorted := True;
lbPersonalDX.Repaint;
end;
procedure TfrmBAOptionsDiagnoses.FormResize(Sender: TObject);
begin
inherited;
hdrCntlDxSections.Sections[0].Width := lbSections.Width;
hdrCntlDxAdd.Sections[0].Width := lbDiagnosis.Width;
hdrCntlDx.Sections[0].Width := lbPersonalDx.Width;
end;
procedure TfrmBAOptionsDiagnoses.SyncDxDeleteList;
var
i: integer;
delDxCode: string;
begin
// save dx selected for deletion, update file when ok is pressed
for i := 0 to lbPersonalDX.Count-1 do
begin
if(lbPersonalDX.Selected[i]) then
begin
delDxCode := Piece(lbPersonalDX.Items[i],U,1);
delDxLst.Add(delDxCode);
end;
end;
end;
procedure TfrmBAOptionsDiagnoses.SyncDxNewList;
var
i,j :integer;
begin
// remove diagnoses selected for deletion from newdxList;
for i := 0 to lbPersonalDX.Count-1 do
begin
if lbPersonalDX.Selected[i] then
begin
for j := 0 to newDxLst.Count-1 do
begin
if (Piece(lbPersonalDX.Items[i],U,1)) = (newDxLst.Strings[j]) then
begin
newDxLst.Delete(j);
Break;
end;
end;
end;
end;
end;
initialization
uAddToPDL := 0;
uDeleteFromPDL := 0;
Problems := TStringList.Create;
DxList := TStringList.Create;
ECFDiagnoses := TStringList.Create;
uNewDxList := TStringList.Create;
tmplst := TStringList.Create;
newDxLst := TStringList.Create;
delDxLst := TStringList.Create;
Problems.Clear;
DxList.Clear;
ECFDiagnoses.Clear;
uNewDxList.Clear;
tmplst.Clear;
newDxLst.Clear;
delDxLst.Clear;
end.

32
CPRS-Chart/CPRS.vpw Normal file
View File

@ -0,0 +1,32 @@
[ProjectDates]
[State]
SCREEN: 800 600 22 22 600 432 0 0 N 0 0 0 0 588 233
CWD: D:\vista\cprs\main\CPRS-Chart
BUFFER: BN="D:\ejb\book\chap09\timetracker\Employee.java"
BI: MA=1 74 1 TABS=1 9 WWS=1 IWT=0 ST=0 IN=2 BW=0 US=32000 RO=1 SE=1 SN=0 BIN=0 MN=Java HM=0 MF=0 TL=0 MLL=0 ASE=0 LNL=6 LCF=0 CAPS=0
VIEW: LN=.0 CL=1 LE=0 CX=0 CY=1 WI=5 BI=12 HT=0 HN=0 HF=0 HC=4
BUFFER: BN="D:\ejb\book\chap09\timetracker\EmployeePK.java"
BI: MA=1 74 1 TABS=1 9 WWS=1 IWT=0 ST=0 IN=2 BW=0 US=32000 RO=1 SE=1 SN=0 BIN=0 MN=Java HM=0 MF=0 TL=0 MLL=0 ASE=0 LNL=6 LCF=0 CAPS=0
VIEW: LN=.0 CL=1 LE=0 CX=0 CY=1 WI=5 BI=14 HT=0 HN=0 HF=0 HC=4
BUFFER: BN="D:\ejb\book\chap09\timetracker\EmployeeBean.java"
BI: MA=1 74 1 TABS=1 9 WWS=1 IWT=0 ST=0 IN=2 BW=0 US=32000 RO=1 SE=1 SN=0 BIN=0 MN=Java HM=0 MF=608 TL=0 MLL=0 ASE=0 LNL=6 LCF=0 CAPS=0
VIEW: LN=.0 CL=1 LE=0 CX=0 CY=1 WI=5 BI=15 HT=0 HN=0 HF=0 HC=4
WINDOW: 0 0 522 167 -1 -1 N WF=0 WT=2 "Courier New,9,0,1"
BUFFER: BN="D:\ejb\book\chap09\timetracker\Employee.java"
VIEW: LN=.0 CL=1 LE=0 CX=0 CY=1 WI=121 BI=12 HT=0 HN=0 HF=0 HC=4
WINDOW: 22 22 522 167 -1 -1 N WF=0 WT=3 "Courier New,9,0,1"
BUFFER: BN="D:\ejb\book\chap09\timetracker\EmployeePK.java"
VIEW: LN=.0 CL=1 LE=0 CX=0 CY=1 WI=122 BI=14 HT=0 HN=0 HF=0 HC=4
WINDOW: 44 44 522 167 -1 -1 N WF=0 WT=1 "Courier New,9,0,1"
BUFFER: BN="D:\ejb\book\chap09\timetracker\EmployeeBean.java"
VIEW: LN=.6777 CL=1 LE=0 CX=0 CY=6 WI=123 BI=15 HT=0 HN=0 HF=0 HC=4
FILEHIST: 9
c:\temp\p4win\ReadOnly-0-Rev-12-fReview.pas
D:\dev\AppExHandler\AppExHandler.pas
D:\vista\cprs\OR_3_190V24\CPRS-Chart\fmeds.dfm
D:\vista\cprs\OR_3_190V24\CPRS-Chart\Orders\fODMedNVA.pas
D:\vista\cprs\OR_3_215V26\CPRS-Chart\dcu\Trpcb.dcu
D:\vista\cprs\OR_3_215V26\CPRS-Chart\Accessibility_TLB.~pas
D:\ejb\book\chap09\timetracker\Employee.java
D:\ejb\book\chap09\timetracker\EmployeePK.java
D:\ejb\book\chap09\timetracker\EmployeeBean.java

BIN
CPRS-Chart/CPRSChart SHORTCUT.lnk Normal file
View File

Binary file not shown.

42
CPRS-Chart/CPRSChart.cfg Normal file
View File

@ -0,0 +1,42 @@
-$A8
-$B-
-$C+
-$D+
-$E-
-$F-
-$G+
-$H+
-$I+
-$J+
-$K-
-$L+
-$M-
-$N+
-$O+
-$P+
-$Q-
-$R-
-$S-
-$T-
-$U-
-$V+
-$W-
-$X+
-$YD
-$Z1
-GD
-cg
-AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;
-H+
-W+
-M
-$M32768,1048576
-K$00400000
-E"C:\Program Files\Borland\Delphi7\Projects\OR_SRC_CREATION FILE 12 06 06 OR_3_270\WV_Release_CPRS_OFFICIAL\CPRS-Chart"
-N"C:\Program Files\Borland\Delphi7\Projects\OR_SRC_CREATION FILE 12 06 06 OR_3_270\WV_Release_CPRS_OFFICIAL\CPRS-Chart"
-LE"C:\Program Files\Borland\Delphi7\Projects\OR_SRC_CREATION FILE 12 06 06 OR_3_270\WV_Release_CPRS_OFFICIAL\Packages"
-LN"C:\Program Files\Borland\Delphi7\Projects\OR_SRC_CREATION FILE 12 06 06 OR_3_270\WV_Release_CPRS_OFFICIAL\Packages"
-U"c:\program files\borland\delphi7\Lib\Debug;C:\Program Files\Borland\Delphi7\Projects\OR_SRC_CREATION FILE 12 06 06 OR_3_270\WV_Release_CPRS_OFFICIAL\CPRS-Lib"
-O"c:\program files\borland\delphi7\Lib\Debug;C:\Program Files\Borland\Delphi7\Projects\OR_SRC_CREATION FILE 12 06 06 OR_3_270\WV_Release_CPRS_OFFICIAL\CPRS-Lib"
-I"c:\program files\borland\delphi7\Lib\Debug;C:\Program Files\Borland\Delphi7\Projects\OR_SRC_CREATION FILE 12 06 06 OR_3_270\WV_Release_CPRS_OFFICIAL\CPRS-Lib"
-R"c:\program files\borland\delphi7\Lib\Debug;C:\Program Files\Borland\Delphi7\Projects\OR_SRC_CREATION FILE 12 06 06 OR_3_270\WV_Release_CPRS_OFFICIAL\CPRS-Lib"

170
CPRS-Chart/CPRSChart.dof Normal file
View File

@ -0,0 +1,170 @@
[FileVersion]
Version=7.0
[Compiler]
A=8
B=0
C=1
D=1
E=0
F=0
G=1
H=1
I=1
J=1
K=0
L=1
M=0
N=1
O=1
P=1
Q=0
R=0
S=0
T=0
U=0
V=1
W=0
X=1
Y=1
Z=1
ShowHints=1
ShowWarnings=1
UnitAliases=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;
NamespacePrefix=
SymbolDeprecated=1
SymbolLibrary=1
SymbolPlatform=1
UnitLibrary=1
UnitPlatform=1
UnitDeprecated=1
HResultCompat=1
HidingMember=1
HiddenVirtual=1
Garbage=1
BoundsError=1
ZeroNilCompat=1
StringConstTruncated=1
ForLoopVarVarPar=1
TypedConstVarPar=1
AsgToTypedConst=1
CaseLabelRange=1
ForVariable=1
ConstructingAbstract=1
ComparisonFalse=1
ComparisonTrue=1
ComparingSignedUnsigned=1
CombiningSignedUnsigned=1
UnsupportedConstruct=1
FileOpen=1
FileOpenUnitSrc=1
BadGlobalSymbol=1
DuplicateConstructorDestructor=1
InvalidDirective=1
PackageNoLink=1
PackageThreadVar=1
ImplicitImport=1
HPPEMITIgnored=1
NoRetVal=1
UseBeforeDef=1
ForLoopVarUndef=1
UnitNameMismatch=1
NoCFGFileFound=1
MessageDirective=1
ImplicitVariants=1
UnicodeToLocale=1
LocaleToUnicode=1
ImagebaseMultiple=1
SuspiciousTypecast=1
PrivatePropAccessor=1
UnsafeType=1
UnsafeCode=1
UnsafeCast=1
[Linker]
MapFile=3
OutputObjs=0
ConsoleApp=1
DebugInfo=0
RemoteSymbols=0
MinStackSize=32768
MaxStackSize=1048576
ImageBase=4194304
ExeDescription=
[Directories]
OutputDir=C:\Program Files\Borland\Delphi7\Projects\OR_SRC_CREATION FILE 12 06 06 OR_3_270\WV_Release_CPRS_OFFICIAL\CPRS-Chart
UnitOutputDir=C:\Program Files\Borland\Delphi7\Projects\OR_SRC_CREATION FILE 12 06 06 OR_3_270\WV_Release_CPRS_OFFICIAL\CPRS-Chart
PackageDLLOutputDir=C:\Program Files\Borland\Delphi7\Projects\OR_SRC_CREATION FILE 12 06 06 OR_3_270\WV_Release_CPRS_OFFICIAL\Packages
PackageDCPOutputDir=C:\Program Files\Borland\Delphi7\Projects\OR_SRC_CREATION FILE 12 06 06 OR_3_270\WV_Release_CPRS_OFFICIAL\Packages
SearchPath=$(DELPHI)\Lib\Debug;C:\Program Files\Borland\Delphi7\Projects\OR_SRC_CREATION FILE 12 06 06 OR_3_270\WV_Release_CPRS_OFFICIAL\CPRS-Lib
Packages=vcl;rtl;vclx;VclSmp;vclshlctrls;dbrtl;adortl;vcldb;qrpt;bdertl;vcldbx;dsnap;cds;bdecds;teeui;teedb;tee;teeqr;ibxpress;visualclx;visualdbclx;vclie;xmlrtl;inet;inetdbbde;inetdbxpress;inetdb;nmfast;dbexpress;dbxcds;indy;dclOffice2k;soaprtl;XWB_R60
Conditionals=
DebugSourceDirs=
UsePackages=0
[Parameters]
RunParams=s=127.0.0.1 p=9211 CCOW=disable
HostApplication=
Launcher=
UseLauncher=0
DebugCWD=
[Language]
ActiveLang=
ProjectLang=
RootDir=C:\Program Files\Borland\Delphi6\Bin\
[Version Info]
IncludeVerInfo=1
AutoIncBuild=0
MajorVer=1
MinorVer=0
Release=26
Build=76
Debug=0
PreRelease=0
Special=0
Private=0
DLL=0
Locale=1033
CodePage=1252
[Version Info Keys]
CompanyName=Department of Veterans Affairs
FileDescription=1/21/2006
FileVersion=1.0.26.76
InternalName=1.0.26.76 server required
LegalCopyright=Unauthorized access or misuse of this system and/or its data is a federal crime. Use of all data shall be in accordance with VA policy on security and privacy.
LegalTrademarks=
OriginalFilename=Patch 215
ProductName=Computerized Patient Record System
ProductVersion=1.0.0.0
Comments=Version 1.0.26.76
[HistoryLists\hlUnitAliases]
Count=1
Item0=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;
[HistoryLists\hlSearchPath]
Count=5
Item0=$(DELPHI)\Lib\Debug;C:\Program Files\Borland\Delphi7\Projects\OR_SRC_CREATION FILE 12 06 06 OR_3_270\WV_Release_CPRS_OFFICIAL\CPRS-Lib
Item1=$(DELPHI)\Lib\Debug;C:\Vista\cprs\OR_3_270V26_69\CPRS-Lib;C:\Program Files\Borland\Delphi7\Projects\OR_SRC_CREATION FILE 12 06 06 OR_3_270\WV_OR_SRC_CREATION\CPRS-Lib
Item2=$(DELPHI)\Lib\Debug;C:\Vista\cprs\OR_3_270V26_69\CPRS-Lib;C:\Program Files\Borland\Delphi7\Projects\OR_SRC_CREATION FILE 12 06 06 OR_3_270\OR_SRC_CREATION\CPRS-Lib
Item3=$(DELPHI)\Lib\Debug;C:\Vista\cprs\OR_3_270V26_69\CPRS-Lib
Item4=C:\Vista\cprs\OR_3_215V26_69\CPRS-Lib
[HistoryLists\hlUnitOutputDirectory]
Count=4
Item0=C:\Program Files\Borland\Delphi7\Projects\OR_SRC_CREATION FILE 12 06 06 OR_3_270\WV_Release_CPRS_OFFICIAL\CPRS-Chart
Item1=C:\Vista\cprs\WV_OR_3_270V26_69\CPRS-Chart\DCU
Item2=C:\Vista\cprs\OR_3_270V26_69\CPRS-Chart\DCU
Item3=C:\Vista\cprs\OR_3_215V26_69\CPRS-Chart\DCU
[HistoryLists\hlOutputDirectorry]
Count=4
Item0=C:\Program Files\Borland\Delphi7\Projects\OR_SRC_CREATION FILE 12 06 06 OR_3_270\WV_Release_CPRS_OFFICIAL\CPRS-Chart
Item1=C:\Vista\cprs\WV_OR_3_270V26_69\CPRS-Chart
Item2=C:\Vista\cprs\OR_3_270V26_69\CPRS-Chart
Item3=C:\Vista\cprs\OR_3_215V26_69\CPRS-Chart
[HistoryLists\hlBPLOutput]
Count=4
Item0=C:\Program Files\Borland\Delphi7\Projects\OR_SRC_CREATION FILE 12 06 06 OR_3_270\WV_Release_CPRS_OFFICIAL\Packages
Item1=C:\Vista\cprs\WV_OR_3_270V26_69\Packages
Item2=C:\Vista\cprs\OR_3_270V26_69\Packages
Item3=C:\Vista\cprs\OR_3_215V26_69\Packages
[HistoryLists\hlDCPOutput]
Count=4
Item0=C:\Program Files\Borland\Delphi7\Projects\OR_SRC_CREATION FILE 12 06 06 OR_3_270\WV_Release_CPRS_OFFICIAL\Packages
Item1=C:\Vista\cprs\WV_OR_3_270V26_69\Packages
Item2=C:\Vista\cprs\OR_3_270V26_69\Packages
Item3=C:\Vista\cprs\OR_3_215V26_69\Packages

327
CPRS-Chart/CPRSChart.dpr Normal file
View File

@ -0,0 +1,327 @@
program CPRSChart;
uses
ShareMem,
Forms,
ORSystem,
fPage in 'fPage.pas' {frmPage},
fHSplit in 'fHSplit.pas' {frmHSplit},
fHP in 'fHP.pas' {frmHP},
fCover in 'fCover.pas' {frmCover},
fMeds in 'fMeds.pas' {frmMeds},
fNotes in 'fNotes.pas' {frmNotes},
fDCSumm in 'fDCSumm.pas' {frmDCSumm},
fLabs in 'fLabs.pas' {frmLabs},
fReports in 'fReports.pas' {frmReports},
uCore in 'uCore.pas',
fPtSel in 'fPtSel.pas' {frmPtSel},
fPtSens in 'fPtSens.pas' {frmPtSens},
rCore in 'rCore.pas',
fEncnt in 'fEncnt.pas' {frmEncounter},
fVisit in 'fVisit.pas' {frmVisit},
fPtDemo in 'fPtDemo.pas' {frmPtDemo},
rTIU in 'rTIU.pas',
fxBroker in 'fxBroker.pas' {frmBroker},
fNoteBA in 'fNoteBA.pas' {frmNotesByAuthor},
fNoteBD in 'fNoteBD.pas' {frmNotesByDate},
fLabTest in 'fLabTest.pas' {frmLabTest},
fLabTestGroups in 'fLabTestGroups.pas' {frmLabTestGroups},
fLabTests in 'fLabTests.pas' {frmLabTests},
rLabs in 'rLabs.pas',
fSignItem in 'fSignItem.pas' {frmSignItem},
rCover in 'rCover.pas',
fRptBox in 'fRptBox.pas' {frmReportBox},
rReports in 'rReports.pas',
fAbout in 'fAbout.pas' {frmAbout},
fxLists in 'fxLists.pas' {frmDbgList},
fProbs in 'fProbs.pas' {frmProblems},
fAutoSz in 'fAutoSz.pas' {frmAutoSz},
rMisc in 'rMisc.pas',
fxServer in 'fxServer.pas' {frmDbgServer},
fPtCWAD in 'fPtCWAD.pas' {frmPtCWAD},
rMeds in 'rMeds.pas',
fVitals in 'fVitals.pas' {frmVitals},
uProbs in 'uProbs.pas',
fProbEdt in 'fProbEdt.pas' {frmdlgProb},
fProbflt in 'fProbFlt.pas' {frmPlVuFilt},
fProbCmt in 'fProbCmt.pas' {frmProbCmt},
fNoteCslt in 'fNoteCslt.pas' {frmNoteConsult},
fNotePrt in 'fNotePrt.pas' {frmNotePrint},
uConst in 'uConst.pas',
fConsults in 'Consults\fConsults.pas' {frmConsults},
fLkUpLocation in 'fLkUpLocation.pas' {frmLkUpLocation},
fRename in 'fRename.pas' {frmRename},
fDateRange in 'fDateRange.pas' {frmDateRange},
fRenewOutMed in 'fRenewOutMed.pas' {frmRenewOutMed},
fConsult513Prt in 'Consults\fConsult513Prt.pas' {frm513Print},
fConsultAct in 'Consults\fConsultAct.pas' {frmConsultAction},
fConsultAlertTo in 'Consults\fConsultAlertTo.pas' {frmConsultAlertsTo},
fConsultBD in 'Consults\fConsultBD.pas' {frmConsultsByDate},
fConsultBS in 'Consults\fConsultBS.pas' {frmConsultsByService},
fConsultBSt in 'Consults\fConsultBSt.pas' {frmConsultsByStatus},
fConsultsView in 'Consults\fConsultsView.pas' {frmConsultsView},
rConsults in 'Consults\rConsults.pas',
uConsults in 'Consults\uConsults.pas',
fTimeout in 'fTimeout.pas' {frmTimeout},
fNoteDR in 'fNoteDR.pas' {frmNoteDelReason},
rDCSumm in 'rDCSumm.pas',
fSplash in 'fSplash.pas' {frmSplash},
fCsltNote in 'Consults\fCsltNote.pas' {frmCsltNote},
rProbs in 'rProbs.pas',
fEditConsult in 'Consults\fEditConsult.pas' {frmEditCslt},
fEditProc in 'Consults\fEditProc.pas' {frmEditProc},
fAllgyFind in 'fAllgyFind.pas' {frmAllgyFind},
fAddlSigners in 'fAddlSigners.pas' {frmAddlSigners},
fLabPrint in 'fLabPrint.pas' {frmLabPrint},
fReportsPrint in 'fReportsPrint.pas' {frmReportPrt},
fvit in 'fvit.pas' {frmVit},
uPCE in 'Encounter\uPCE.pas',
fEncounterFrame in 'Encounter\fEncounterFrame.pas' {frmEncounterFrame},
fPCEBase in 'Encounter\fPCEBase.pas' {frmPCEBase},
fPCELex in 'Encounter\fPCELex.pas' {frmPCELex},
fPCEOther in 'Encounter\fPCEOther.pas' {frmPCEOther},
fProcedure in 'Encounter\fProcedure.pas' {frmProcedures},
fSkinTest in 'Encounter\fSkinTest.pas' {frmSkinTests},
fVisitType in 'Encounter\fVisitType.pas' {frmVisitType},
rPCE in 'Encounter\rPCE.pas',
fDiagnoses in 'Encounter\fDiagnoses.pas' {frmDiagnoses},
fPatientEd in 'Encounter\fPatientEd.pas' {frmPatientEd},
fExam in 'Encounter\fExam.pas' {frmExams},
fHealthFactor in 'Encounter\fHealthFactor.pas' {frmHealthFactors},
fImmunization in 'Encounter\fImmunization.pas' {frmImmunizations},
fEncVitals in 'Encounter\fEncVitals.pas' {frmEncVitals},
fEffectDate in 'fEffectDate.pas' {frmEffectDate},
fPtSelDemog in 'fPtSelDemog.pas' {frmPtSelDemog},
fPtSelOptns in 'fPtSelOptns.pas' {frmPtSelOptns},
uInit in 'uInit.pas',
uSpell in 'uSpell.pas',
dShared in 'dShared.pas' {dmodShared: TDataModule},
fDrawers in 'fDrawers.pas' {frmDrawers},
fMedCopy in 'fMedCopy.pas' {frmMedCopy},
uReminders in 'uReminders.pas',
rReminders in 'rReminders.pas',
fReminderTree in 'fReminderTree.pas' {frmReminderTree},
fReminderDialog in 'fReminderDialog.pas' {frmRemDlg},
fReportsAdhocSubItem1 in 'fReportsAdhocSubItem1.pas' {frmReportsAdhocSubItem1},
fReportsAdhocComponent1 in 'fReportsAdhocComponent1.pas' {frmReportsAdhocComponent1},
fPtSelMsg in 'fPtSelMsg.pas' {frmPtSelMsg},
fMHTest in 'fMHTest.pas' {frmMHTest},
fGAF in 'Encounter\fGAF.pas' {frmGAF},
fPCEProvider in 'Encounter\fPCEProvider.pas' {frmPCEProvider},
fPCEBaseGrid in 'Encounter\fPCEBaseGrid.pas' {frmPCEBaseGrid},
fPCEBaseMain in 'Encounter\fPCEBaseMain.pas' {frmPCEBaseMain},
fNoteProps in 'fNoteProps.pas' {frmNoteProperties},
fNotesBP in 'fNotesBP.pas' {frmNotesBP},
fLabInfo in 'fLabInfo.pas' {frmLabInfo},
fPreReq in 'Consults\fPreReq.pas' {frmPrerequisites},
fDCSummProps in 'fDCSummProps.pas' {frmDCSummProperties},
fHFSearch in 'Encounter\fHFSearch.pas' {frmHFSearch},
fConsMedRslt in 'Consults\fConsMedRslt.pas' {frmConsMedRslt},
mVitMetric in 'Vitals\mVitMetric.pas' {fraVitMetric: TFrame},
mVitAll in 'Vitals\mVitAll.pas' {fraVitAll: TFrame},
mVitBase in 'Vitals\mVitBase.pas' {fraVitBase: TFrame},
uVitals in 'Vitals\uVitals.pas',
rVitals in 'Vitals\rVitals.pas',
mVitPulse in 'Vitals\mVitPulse.pas' {fraVitPulse: TFrame},
mVitResp in 'Vitals\mVitResp.pas' {fraVitResp: TFrame},
mVitBP in 'Vitals\mVitBP.pas' {fraVitPB: TFrame},
mVitTemp in 'Vitals\mVitTemp.pas' {fraVitTemp: TFrame},
mVitHeight in 'Vitals\mVitHeight.pas' {fraVitHeight: TFrame},
mVitWeight in 'Vitals\mVitWeight.pas' {fraVitWeight: TFrame},
mVitPain in 'Vitals\mVitPain.pas' {fraVitPain: TFrame},
mVitPO2 in 'Vitals\mVitPO2.pas' {fraVitPO2: TFrame},
mVitCVP in 'Vitals\mVitCVP.pas' {fraVitCVP: TFrame},
mVitCirGirth in 'Vitals\mVitCirGirth.pas' {fraVitCircum: TFrame},
uDCSumm in 'uDCSumm.pas',
uDocTree in 'uDocTree.pas',
fVitalsDate in 'Vitals\fVitalsDate.pas' {frmVitalsDate},
uTemplates in 'Templates\uTemplates.pas',
fTemplateDialog in 'Templates\fTemplateDialog.pas' {frmTemplateDialog},
fTemplateEditor in 'Templates\fTemplateEditor.pas' {frmTemplateEditor},
fTemplateFieldEditor in 'Templates\fTemplateFieldEditor.pas' {frmTemplateFieldEditor},
fTemplateFields in 'Templates\fTemplateFields.pas' {frmTemplateFields},
fTemplateObjects in 'Templates\fTemplateObjects.pas' {frmTemplateObjects},
fTemplateView in 'Templates\fTemplateView.pas' {frmTemplateView},
mTemplateFieldButton in 'Templates\mTemplateFieldButton.pas' {fraTemplateFieldButton: TFrame},
rTemplates in 'Templates\rTemplates.pas',
uTemplateFields in 'Templates\uTemplateFields.pas',
fTemplateAutoGen in 'Templates\fTemplateAutoGen.pas' {frmTemplateAutoGen},
mVisitRelated in 'Encounter\mVisitRelated.pas' {fraVisitRelated: TFrame},
fRemVisitInfo in 'fRemVisitInfo.pas' {frmRemVisitInfo},
fIconLegend in 'fIconLegend.pas' {frmIconLegend},
mImgText in 'mImgText.pas' {fraImgText: TFrame},
fTemplateImport in 'Templates\fTemplateImport.pas' {frmTemplateImport},
fRemCoverSheet in 'fRemCoverSheet.pas' {frmRemCoverSheet},
uTIU in 'uTIU.pas',
fRemCoverPreview in 'fRemCoverPreview.pas' {frmRemCoverPreview},
fPCEEdit in 'Encounter\fPCEEdit.pas' {frmPCEEdit},
uSurgery in 'uSurgery.pas',
fSurgeryView in 'fSurgeryView.pas' {frmSurgeryView},
rSurgery in 'rSurgery.pas',
uCaseTree in 'uCaseTree.pas',
fSurgery in 'fSurgery.pas' {frmSurgery},
fNoteIDParents in 'fNoteIDParents.pas' {frmNoteIDParents},
uReports in 'uReports.pas',
fNoteCPFields in 'fNoteCPFields.pas' {frmNoteCPFields},
CPRSChart_TLB in 'CPRSChart_TLB.pas',
uEventHooks in 'uEventHooks.pas',
rEventHooks in 'rEventHooks.pas',
fPtSelOptSave in 'fPtSelOptSave.pas' {frmPtSelOptSave},
uOrders in 'Orders\uOrders.pas',
fOCSession in 'Orders\fOCSession.pas' {frmOCSession},
fODAuto in 'Orders\fODAuto.pas',
fODBase in 'Orders\fODBase.pas' {frmODBase},
fODDiet in 'Orders\fODDiet.pas' {frmODDiet},
fODDietLT in 'Orders\fODDietLT.pas' {frmODDietLT},
fODGen in 'Orders\fODGen.pas' {frmODGen},
fODLab in 'Orders\fODLab.pas' {frmODLab},
fODLabImmedColl in 'Orders\fODLabImmedColl.pas' {frmODLabImmedColl},
fODLabOthCollSamp in 'Orders\fODLabOthCollSamp.pas' {frmODLabOthCollSamp},
fODLabOthSpec in 'Orders\fODLabOthSpec.pas' {frmODLabOthSpec},
fODMedComplex in 'Orders\fODMedComplex.pas' {frmODMedComplex},
fODMedFA in 'Orders\fODMedFA.pas' {frmODMedFA},
fODMedIn in 'Orders\fODMedIn.pas' {frmODMedIn},
fODMedIV in 'Orders\fODMedIV.pas' {frmODMedIV},
fODMedOIFA in 'Orders\fODMedOIFA.pas' {frmODMedOIFA},
fODMedOut in 'Orders\fODMedOut.pas' {frmODMedOut},
fODMeds in 'Orders\fODMeds.pas' {frmODMeds},
fODMessage in 'Orders\fODMessage.pas' {frmODMessage},
fODMisc in 'Orders\fODMisc.pas' {frmODMisc},
fODRad in 'Orders\fODRad.pas' {frmODRad},
fODRadApproval in 'Orders\fODRadApproval.pas' {frmODRadApproval},
fODRadConShRes in 'Orders\fODRadConShRes.pas' {frmODRadConShRes},
fODRadImType in 'Orders\fODRadImType.pas' {frmODRadImType},
fODSaveQuick in 'Orders\fODSaveQuick.pas' {frmODQuick},
fODText in 'Orders\fODText.pas' {frmODText},
fODVitals in 'Orders\fODVitals.pas' {frmODVitals},
fOMAction in 'Orders\fOMAction.pas' {frmOMAction},
fOMHTML in 'Orders\fOMHTML.pas' {frmOMHTML},
fOMNavA in 'Orders\fOMNavA.pas' {frmOMNavA},
fOMProgress in 'Orders\fOMProgress.pas' {frmOMProgress},
fOMSet in 'Orders\fOMSet.pas' {frmOMSet},
fOMVerify in 'Orders\fOMVerify.pas' {frmOMVerify},
fOrderComment in 'Orders\fOrderComment.pas' {frmWardComments},
fOrderFlag in 'Orders\fOrderFlag.pas' {frmFlagOrder},
fOrders in 'Orders\fOrders.pas' {frmOrders},
fOrdersAlert in 'Orders\fOrdersAlert.pas' {frmAlertOrders},
fOrderSaveQuick in 'Orders\fOrderSaveQuick.pas' {frmSaveQuickOrder},
fOrdersComplete in 'Orders\fOrdersComplete.pas' {frmCompleteOrders},
fOrdersCopy in 'Orders\fOrdersCopy.pas' {frmCopyOrders},
fOrdersDC in 'Orders\fOrdersDC.pas' {frmDCOrders},
fOrdersHold in 'Orders\fOrdersHold.pas' {frmHoldOrders},
fOrdersOnChart in 'Orders\fOrdersOnChart.pas' {frmOnChartOrders},
fOrdersPrint in 'Orders\fOrdersPrint.pas' {frmOrdersPrint},
fOrdersRefill in 'Orders\fOrdersRefill.pas' {frmRefillOrders},
fOrdersRelease in 'Orders\fOrdersRelease.pas' {frmReleaseOrders},
fOrdersRenew in 'Orders\fOrdersRenew.pas' {frmRenewOrders},
fOrdersSign in 'Orders\fOrdersSign.pas' {frmSignOrders},
fOrdersTS in 'Orders\fOrdersTS.pas' {frmOrdersTS},
fOrdersUnhold in 'Orders\fOrdersUnhold.pas' {frmUnholdOrders},
fOrdersVerify in 'Orders\fOrdersVerify.pas' {frmVerifyOrders},
fOrderUnflag in 'Orders\fOrderUnflag.pas' {frmUnflagOrder},
fOrderVw in 'Orders\fOrderVw.pas' {frmOrderView},
rODAllergy in 'Orders\rODAllergy.pas',
rODBase in 'Orders\rODBase.pas',
rODDiet in 'Orders\rODDiet.pas',
rODLab in 'Orders\rODLab.pas',
rODMeds in 'Orders\rODMeds.pas',
rODRad in 'Orders\rODRad.pas',
rOrders in 'Orders\rOrders.pas',
uODBase in 'Orders\uODBase.pas',
fOCAccept in 'Orders\fOCAccept.pas' {frmOCAccept},
fODConsult in 'Consults\fODConsult.pas' {frmODCslt},
fODProc in 'Consults\fODProc.pas' {frmODProc},
uOptions in 'Options\uOptions.pas',
fOptionsCombinations in 'Options\fOptionsCombinations.pas' {frmOptionsCombinations},
fOptionsDays in 'Options\fOptionsDays.pas' {frmOptionsDays},
fOptionsLists in 'Options\fOptionsLists.pas' {frmOptionsLists},
fOptionsNewList in 'Options\fOptionsNewList.pas' {frmOptionsNewList},
fOptionsNotes in 'Options\fOptionsNotes.pas' {frmOptionsNotes},
fOptionsOther in 'Options\fOptionsOther.pas' {frmOptionsOther},
fOptionsPatientSelection in 'Options\fOptionsPatientSelection.pas' {frmOptionsPatientSelection},
fOptionsPrimaryList in 'Options\fOptionsPrimaryList.pas' {frmOptionsPrimaryList},
fOptionsReminders in 'Options\fOptionsReminders.pas' {frmOptionsReminders},
fOptionsReportsCustom in 'Options\fOptionsReportsCustom.pas' {frmOptionsReportsCustom},
fOptionsReportsDefault in 'Options\fOptionsReportsDefault.pas' {frmOptionsReportsDefault},
fOptionsSubscribe in 'Options\fOptionsSubscribe.pas' {frmOptionsSubscribe},
fOptionsSurrogate in 'Options\fOptionsSurrogate.pas' {frmOptionsSurrogate},
fOptionsTeams in 'Options\fOptionsTeams.pas' {frmOptionsTeams},
fOptionsTitles in 'Options\fOptionsTitles.pas' {frmOptionsTitles},
rOptions in 'Options\rOptions.pas',
fOptions in 'Options\fOptions.pas' {frmOptions},
uSignItems in 'uSignItems.pas',
mCoPayDesc in 'mCoPayDesc.pas' {fraCoPayDesc: TFrame},
XuDigSigSC_TLB in 'XuDigSigSC_TLB.pas',
fOrdersCV in 'Orders\fOrdersCV.pas' {frmChgEvent},
fODReleaseEvent in 'Orders\fODReleaseEvent.pas' {frmOrdersReleaseEvent},
fODActive in 'Orders\fODActive.pas' {frmODActive},
fDefaultEvent in 'fDefaultEvent.pas' {frmDefaultEvent},
mEvntDelay in 'mEvntDelay.pas' {fraEvntDelayList: TFrame},
fOrdersEvntRelease in 'Orders\fOrdersEvntRelease.pas' {frmOrdersEvntRelease},
rECS in 'rECS.pas',
fODChangeEvtDisp in 'Orders\fODChangeEvtDisp.pas' {frmChangeEventDisp},
fODValidateAction in 'Orders\fODValidateAction.pas' {frmInvalidActionList},
fODChild in 'Orders\fODChild.pas' {frmODChild},
uAccessibleStringGrid in 'uAccessibleStringGrid.pas' {AccessibleStringGrid: CoClass},
Accessibility_TLB in 'Accessibility_TLB.pas',
uAccessibleListBox in 'uAccessibleListBox.pas' {AccessibleListBox: CoClass},
uAccessibleTreeNode in 'uAccessibleTreeNode.pas' {IAccessibleTreeNode: CoClass},
uAccessibleTreeView in 'uAccessibleTreeView.pas' {AccessibleTreeView: CoClass},
fDupPts in 'fDupPts.pas' {frmDupPts},
VERGENCECONTEXTORLib_TLB in 'VERGENCECONTEXTORLib_TLB.pas',
uOrPtf in 'uOrPtf.pas',
fPatientFlagMulti in 'fPatientFlagMulti.pas' {frmFlags},
fFrame in 'fFrame.pas' {frmFrame},
fAlertForward in 'fAlertForward.pas' {frmAlertForward},
fODMedNVA in 'Orders\fODMedNVA.pas' {frmODMedNVA},
uAccessibleRichEdit in 'uAccessibleRichEdit.pas' {AccessibleRichEdit: CoClass},
fPrintList in 'fPrintList.pas' {frmPrintList},
fODChangeUnreleasedRenew in 'Orders\fODChangeUnreleasedRenew.pas' {frmODChangeUnreleasedRenew},
UBAMessages in 'BA\UBAMessages.pas',
UBAConst in 'BA\UBAConst.pas',
UBAGlobals in 'BA\UBAGlobals.pas',
fBALocalDiagnoses in 'BA\fBALocalDiagnoses.pas' {frmBALocalDiagnoses},
fReview in 'fReview.pas' {frmReview},
fARTFreeTextMsg in 'fARTFreeTextMsg.pas' {frmARTFreeTextMsg},
fAllgyBox in 'fAllgyBox.pas' {frmAllgyBox},
fARTAllgy in 'fARTAllgy.pas' {frmARTAllergy},
UBACore in 'BA\UBACore.pas',
fBAOptionsDiagnoses in 'BA\fBAOptionsDiagnoses.pas' {frmBAOptionsDiagnoses},
fOtherSchedule in 'Orders\fOtherSchedule.pas' {frmOtherSchedule},
fODBBank in 'Orders\fODBBank.pas' {frmODBBank},
fNoteST in 'fNoteST.pas' {frmNotesSearchText},
fNoteSTStop in 'fNoteSTStop.pas' {frmSearchStop},
rGraphs in 'rGraphs.pas',
fGraphs in 'fGraphs.pas' {frmGraphs},
fGraphSettings in 'fGraphSettings.pas' {frmGraphSettings},
fGraphProfiles in 'fGraphProfiles.pas' {frmGraphProfiles},
uGraphs in 'uGraphs.pas',
fClinicWardMeds in 'fClinicWardMeds.pas' {frmClinicWardMeds},
fActivateDeactivate in 'fActivateDeactivate.pas' {frmActivateDeactive},
uFormMonitor in 'uFormMonitor.pas';
{$R *.TLB}
{$R *.RES}
begin
if not UpdateSelf then // only start if not copying new version
begin
RegisterCPRSTypeLibrary; // will halt program if /regserver or /unregserver param
Application.Initialize;
frmSplash := nil;
if ParamSearch('SPLASH') <> 'OFF' then
begin
frmSplash := TfrmSplash.Create(Application); // show splash screen
frmSplash.Show; // "
frmSplash.Refresh; // "
end;
Application.Title := 'CPRS - Patient Chart';
Application.HelpFile := 'cprs.hlp';
Application.CreateForm(TdmodShared, dmodShared);
Application.CreateForm(TfrmFrame, frmFrame);
Application.CreateForm(TfrmSearchStop, frmSearchStop);
frmSplash.Free; // close & free splash screen
Application.Run;
end;
end.

976
CPRS-Chart/CPRSChart.drc Normal file
View File

@ -0,0 +1,976 @@
/* VER150
Generated by the Borland Delphi Pascal Compiler
because -GD or --drc was supplied to the compiler.
This file contains compiler-generated resources that
were bound to the executable.
If this file is empty, then no compiler-generated
resources were bound to the produced executable.
*/
#define IdResourceStrings_RSStackHOST_NOT_FOUND 65040
#define IdResourceStrings_RSStackENETUNREACH 65056
#define IdResourceStrings_RSStackENETRESET 65057
#define IdResourceStrings_RSStackECONNABORTED 65058
#define IdResourceStrings_RSStackECONNRESET 65059
#define IdResourceStrings_RSStackENOBUFS 65060
#define IdResourceStrings_RSStackEISCONN 65061
#define IdResourceStrings_RSStackENOTCONN 65062
#define IdResourceStrings_RSStackESHUTDOWN 65063
#define IdResourceStrings_RSStackETOOMANYREFS 65064
#define IdResourceStrings_RSStackETIMEDOUT 65065
#define IdResourceStrings_RSStackECONNREFUSED 65066
#define IdResourceStrings_RSStackELOOP 65067
#define IdResourceStrings_RSStackENAMETOOLONG 65068
#define IdResourceStrings_RSStackEHOSTDOWN 65069
#define IdResourceStrings_RSStackEHOSTUNREACH 65070
#define IdResourceStrings_RSStackENOTEMPTY 65071
#define IdResourceStrings_RSStackEWOULDBLOCK 65072
#define IdResourceStrings_RSStackEINPROGRESS 65073
#define IdResourceStrings_RSStackEALREADY 65074
#define IdResourceStrings_RSStackENOTSOCK 65075
#define IdResourceStrings_RSStackEDESTADDRREQ 65076
#define IdResourceStrings_RSStackEMSGSIZE 65077
#define IdResourceStrings_RSStackEPROTOTYPE 65078
#define IdResourceStrings_RSStackENOPROTOOPT 65079
#define IdResourceStrings_RSStackEPROTONOSUPPORT 65080
#define IdResourceStrings_RSStackESOCKTNOSUPPORT 65081
#define IdResourceStrings_RSStackEOPNOTSUPP 65082
#define IdResourceStrings_RSStackEPFNOSUPPORT 65083
#define IdResourceStrings_RSStackEAFNOSUPPORT 65084
#define IdResourceStrings_RSStackEADDRINUSE 65085
#define IdResourceStrings_RSStackEADDRNOTAVAIL 65086
#define IdResourceStrings_RSStackENETDOWN 65087
#define VDBConsts_SPostEdit 65088
#define VDBConsts_SCancelEdit 65089
#define VDBConsts_SRefreshRecord 65090
#define VDBConsts_SRemoteLogin 65091
#define IdResourceStrings_RSWinsockInitializationError 65092
#define IdResourceStrings_RSSetSizeExceeded 65093
#define IdResourceStrings_RSWS2CallError 65094
#define IdResourceStrings_RSWS2LoadError 65095
#define IdResourceStrings_RSInvalidServiceName 65096
#define IdResourceStrings_RSStackError 65097
#define IdResourceStrings_RSStackEINTR 65098
#define IdResourceStrings_RSStackEBADF 65099
#define IdResourceStrings_RSStackEACCES 65100
#define IdResourceStrings_RSStackEFAULT 65101
#define IdResourceStrings_RSStackEINVAL 65102
#define IdResourceStrings_RSStackEMFILE 65103
#define OleConst_SCannotActivate 65104
#define OleConst_SNoWindowHandle 65105
#define OleConst_SInvalidLicense 65106
#define OleConst_SNotLicensed 65107
#define OleConst_sNoRunningObject 65108
#define DBConsts_SBcdOverflow 65109
#define DBConsts_SInvalidBcdValue 65110
#define DBConsts_SCouldNotParseTimeStamp 65111
#define DBConsts_SInvalidSqlTimeStamp 65112
#define VDBConsts_SFirstRecord 65113
#define VDBConsts_SPriorRecord 65114
#define VDBConsts_SNextRecord 65115
#define VDBConsts_SLastRecord 65116
#define VDBConsts_SInsertRecord 65117
#define VDBConsts_SDeleteRecord 65118
#define VDBConsts_SEditRecord 65119
#define TeeConst_TeeMsg_ValuesArrowEndX 65120
#define TeeConst_TeeMsg_ValuesArrowEndY 65121
#define ComConst_SCreateRegKeyError 65122
#define ComConst_SOleError 65123
#define ComConst_SObjectFactoryMissing 65124
#define ComConst_STypeInfoMissing 65125
#define ComConst_SBadTypeInfo 65126
#define ComConst_SDispIntfMissing 65127
#define ComConst_SNoMethod 65128
#define ComConst_SVarNotObject 65129
#define ComConst_STooManyParams 65130
#define ComConst_SDCOMNotInstalled 65131
#define ComConst_SDAXError 65132
#define ComConst_SAutomationWarning 65133
#define ComConst_SNoCloseActiveServer1 65134
#define ComConst_SNoCloseActiveServer2 65135
#define TeeConst_TeeMsg_FunctionDivide 65136
#define TeeConst_TeeMsg_FunctionHigh 65137
#define TeeConst_TeeMsg_FunctionLow 65138
#define TeeConst_TeeMsg_FunctionAverage 65139
#define TeeConst_TeeMsg_DefaultFontName 65140
#define TeeConst_TeeMsg_CheckPointerSize 65141
#define TeeConst_TeeMsg_FunctionPeriod 65142
#define TeeConst_TeeMsg_PieOther 65143
#define TeeConst_TeeMsg_ValuesX 65144
#define TeeConst_TeeMsg_ValuesY 65145
#define TeeConst_TeeMsg_ValuesPie 65146
#define TeeConst_TeeMsg_ValuesBar 65147
#define TeeConst_TeeMsg_ValuesAngle 65148
#define TeeConst_TeeMsg_ValuesGanttStart 65149
#define TeeConst_TeeMsg_ValuesGanttEnd 65150
#define TeeConst_TeeMsg_ValuesGanttNextTask 65151
#define TeeConst_TeeMsg_GalleryArrow 65152
#define TeeConst_TeeMsg_GalleryGantt 65153
#define TeeConst_TeeMsg_GanttSample1 65154
#define TeeConst_TeeMsg_GanttSample2 65155
#define TeeConst_TeeMsg_GanttSample3 65156
#define TeeConst_TeeMsg_GanttSample4 65157
#define TeeConst_TeeMsg_GanttSample5 65158
#define TeeConst_TeeMsg_GanttSample6 65159
#define TeeConst_TeeMsg_GanttSample7 65160
#define TeeConst_TeeMsg_GanttSample8 65161
#define TeeConst_TeeMsg_GanttSample9 65162
#define TeeConst_TeeMsg_GanttSample10 65163
#define TeeConst_TeeMsg_DefaultFontSize 65164
#define TeeConst_TeeMsg_FunctionAdd 65165
#define TeeConst_TeeMsg_FunctionSubtract 65166
#define TeeConst_TeeMsg_FunctionMultiply 65167
#define TeeConst_TeeMsg_GalleryArea 65168
#define TeeConst_TeeMsg_GalleryBar 65169
#define TeeConst_TeeMsg_GalleryHorizBar 65170
#define TeeConst_TeeMsg_GalleryPie 65171
#define TeeConst_TeeMsg_GalleryFastLine 65172
#define TeeConst_TeeMsg_Rotation 65173
#define TeeConst_TeeMsg_PieSample1 65174
#define TeeConst_TeeMsg_PieSample2 65175
#define TeeConst_TeeMsg_PieSample3 65176
#define TeeConst_TeeMsg_PieSample4 65177
#define TeeConst_TeeMsg_PieSample5 65178
#define TeeConst_TeeMsg_PieSample6 65179
#define TeeConst_TeeMsg_PieSample7 65180
#define TeeConst_TeeMsg_PieSample8 65181
#define TeeConst_TeeMsg_GalleryStandard 65182
#define TeeConst_TeeMsg_GalleryFunctions 65183
#define TeeConst_TeeMsg_AxisIncrementNeg 65184
#define TeeConst_TeeMsg_AxisMinMax 65185
#define TeeConst_TeeMsg_AxisMaxMin 65186
#define TeeConst_TeeMsg_AxisLogBase 65187
#define TeeConst_TeeMsg_MaxPointsPerPage 65188
#define TeeConst_TeeMsg_3dPercent 65189
#define TeeConst_TeeMsg_CircularSeries 65190
#define TeeConst_TeeMsg_BarWidthPercent 65191
#define TeeConst_TeeMsg_BarOffsetPercent 65192
#define TeeConst_TeeMsg_DefaultPercentOf 65193
#define TeeConst_TeeMsg_DefPercentFormat 65194
#define TeeConst_TeeMsg_DefValueFormat 65195
#define TeeConst_TeeMsg_AxisTitle 65196
#define TeeConst_TeeMsg_AxisLabels 65197
#define TeeConst_TeeMsg_GalleryLine 65198
#define TeeConst_TeeMsg_GalleryPoint 65199
#define ComStrs_sDateTimeMin 65200
#define ComStrs_sFailSetCalDateTime 65201
#define ComStrs_sFailSetCalMaxSelRange 65202
#define ComStrs_sFailSetCalMinMaxRange 65203
#define ComStrs_sFailsetCalSelRange 65204
#define WinHelpViewer_hNoKeyword 65205
#define TeeConst_TeeMsg_LegendTopPos 65206
#define TeeConst_TeeMsg_LegendFirstValue 65207
#define TeeConst_TeeMsg_LegendColorWidth 65208
#define TeeConst_TeeMsg_SeriesSetDataSource 65209
#define TeeConst_TeeMsg_SeriesInvDataSource 65210
#define TeeConst_TeeMsg_FillSample 65211
#define TeeConst_TeeMsg_Angle 65212
#define TeeConst_TeeMsg_AxisLogDateTime 65213
#define TeeConst_TeeMsg_AxisLogNotPositive 65214
#define TeeConst_TeeMsg_AxisLabelSep 65215
#define ComStrs_sTabFailDelete 65216
#define ComStrs_sTabFailRetrieve 65217
#define ComStrs_sTabFailGetObject 65218
#define ComStrs_sTabFailSet 65219
#define ComStrs_sTabFailSetObject 65220
#define ComStrs_sTabMustBeMultiLine 65221
#define ComStrs_sInvalidIndex 65222
#define ComStrs_sInsertError 65223
#define ComStrs_sInvalidOwner 65224
#define ComStrs_sRichEditInsertError 65225
#define ComStrs_sRichEditLoadFail 65226
#define ComStrs_sRichEditSaveFail 65227
#define ComStrs_sUDAssociated 65228
#define ComStrs_sPageIndexError 65229
#define ComStrs_sInvalidComCtl32 65230
#define ComStrs_sDateTimeMax 65231
#define ExtCtrls_clNameHighlightText 65232
#define ExtCtrls_clNameInactiveBorder 65233
#define ExtCtrls_clNameInactiveCaption 65234
#define ExtCtrls_clNameInactiveCaptionText 65235
#define ExtCtrls_clNameInfoBk 65236
#define ExtCtrls_clNameInfoText 65237
#define ExtCtrls_clNameMenu 65238
#define ExtCtrls_clNameMenuText 65239
#define ExtCtrls_clNameNone 65240
#define ExtCtrls_clNameScrollBar 65241
#define ExtCtrls_clName3DDkShadow 65242
#define ExtCtrls_clName3DLight 65243
#define ExtCtrls_clNameWindow 65244
#define ExtCtrls_clNameWindowFrame 65245
#define ExtCtrls_clNameWindowText 65246
#define ComStrs_sTabFailClear 65247
#define ExtCtrls_clNameMoneyGreen 65248
#define ExtCtrls_clNameSkyBlue 65249
#define ExtCtrls_clNameCream 65250
#define ExtCtrls_clNameMedGray 65251
#define ExtCtrls_clNameActiveBorder 65252
#define ExtCtrls_clNameActiveCaption 65253
#define ExtCtrls_clNameAppWorkSpace 65254
#define ExtCtrls_clNameBackground 65255
#define ExtCtrls_clNameBtnFace 65256
#define ExtCtrls_clNameBtnHighlight 65257
#define ExtCtrls_clNameBtnShadow 65258
#define ExtCtrls_clNameBtnText 65259
#define ExtCtrls_clNameCaptionText 65260
#define ExtCtrls_clNameDefault 65261
#define ExtCtrls_clNameGrayText 65262
#define ExtCtrls_clNameHighlight 65263
#define ExtCtrls_clNameBlack 65264
#define ExtCtrls_clNameMaroon 65265
#define ExtCtrls_clNameGreen 65266
#define ExtCtrls_clNameOlive 65267
#define ExtCtrls_clNameNavy 65268
#define ExtCtrls_clNamePurple 65269
#define ExtCtrls_clNameTeal 65270
#define ExtCtrls_clNameGray 65271
#define ExtCtrls_clNameSilver 65272
#define ExtCtrls_clNameRed 65273
#define ExtCtrls_clNameLime 65274
#define ExtCtrls_clNameYellow 65275
#define ExtCtrls_clNameBlue 65276
#define ExtCtrls_clNameFuchsia 65277
#define ExtCtrls_clNameAqua 65278
#define ExtCtrls_clNameWhite 65279
#define Consts_SNoDefaultPrinter 65280
#define Consts_SDuplicateMenus 65281
#define Consts_SCannotOpenAVI 65282
#define Consts_SDockedCtlNeedsName 65283
#define Consts_SDockTreeRemoveError 65284
#define Consts_SDockZoneNotFound 65285
#define Consts_SDockZoneHasNoCtl 65286
#define Consts_SMultiSelectRequired 65287
#define Consts_SSeparator 65288
#define Consts_SErrorSettingCount 65289
#define Consts_SListBoxMustBeVirtual 65290
#define Consts_SNoGetItemEventHandler 65291
#define HelpIntfs_hNoTableOfContents 65292
#define HelpIntfs_hNothingFound 65293
#define HelpIntfs_hNoContext 65294
#define HelpIntfs_hNoTopics 65295
#define Consts_SmkcLeft 65296
#define Consts_SmkcUp 65297
#define Consts_SmkcRight 65298
#define Consts_SmkcDown 65299
#define Consts_SmkcIns 65300
#define Consts_SmkcDel 65301
#define Consts_SmkcShift 65302
#define Consts_SmkcCtrl 65303
#define Consts_SmkcAlt 65304
#define Consts_SOutOfRange 65305
#define Consts_SInsertLineError 65306
#define Consts_SInvalidClipFmt 65307
#define Consts_SIconToClipboard 65308
#define Consts_SCannotOpenClipboard 65309
#define Consts_SInvalidMemoSize 65310
#define Consts_SInvalidPrinterOp 65311
#define Consts_SMsgDlgHelp 65312
#define Consts_SMsgDlgAbort 65313
#define Consts_SMsgDlgRetry 65314
#define Consts_SMsgDlgIgnore 65315
#define Consts_SMsgDlgAll 65316
#define Consts_SMsgDlgNoToAll 65317
#define Consts_SMsgDlgYesToAll 65318
#define Consts_SmkcBkSp 65319
#define Consts_SmkcTab 65320
#define Consts_SmkcEsc 65321
#define Consts_SmkcEnter 65322
#define Consts_SmkcSpace 65323
#define Consts_SmkcPgUp 65324
#define Consts_SmkcPgDn 65325
#define Consts_SmkcEnd 65326
#define Consts_SmkcHome 65327
#define Consts_SAllButton 65328
#define Consts_SCannotDragForm 65329
#define Consts_SVMetafiles 65330
#define Consts_SVEnhMetafiles 65331
#define Consts_SVIcons 65332
#define Consts_SVBitmaps 65333
#define Consts_SMaskErr 65334
#define Consts_SMaskEditErr 65335
#define Consts_SMsgDlgWarning 65336
#define Consts_SMsgDlgError 65337
#define Consts_SMsgDlgInformation 65338
#define Consts_SMsgDlgConfirm 65339
#define Consts_SMsgDlgYes 65340
#define Consts_SMsgDlgNo 65341
#define Consts_SMsgDlgOK 65342
#define Consts_SMsgDlgCancel 65343
#define Consts_SNotPrinting 65344
#define Consts_SPrinting 65345
#define Consts_SInvalidPrinter 65346
#define Consts_SDeviceOnPort 65347
#define Consts_SGroupIndexTooLow 65348
#define Consts_SNoMDIForm 65349
#define Consts_SControlParentSetToSelf 65350
#define Consts_SOKButton 65351
#define Consts_SCancelButton 65352
#define Consts_SYesButton 65353
#define Consts_SNoButton 65354
#define Consts_SHelpButton 65355
#define Consts_SCloseButton 65356
#define Consts_SIgnoreButton 65357
#define Consts_SRetryButton 65358
#define Consts_SAbortButton 65359
#define Consts_SImageReadFail 65360
#define Consts_SImageWriteFail 65361
#define Consts_SWindowDCError 65362
#define Consts_SWindowClass 65363
#define Consts_SCannotFocus 65364
#define Consts_SParentRequired 65365
#define Consts_SParentGivenNotAParent 65366
#define Consts_SMDIChildNotVisible 65367
#define Consts_SVisibleChanged 65368
#define Consts_SCannotShowModal 65369
#define Consts_SScrollBarRange 65370
#define Consts_SPropertyOutOfRange 65371
#define Consts_SMenuIndexError 65372
#define Consts_SMenuReinserted 65373
#define Consts_SMenuNotFound 65374
#define Consts_SNoTimers 65375
#define RTLConsts_SThreadCreateError 65376
#define RTLConsts_SThreadError 65377
#define Consts_SInvalidTabPosition 65378
#define Consts_SInvalidTabStyle 65379
#define Consts_SInvalidBitmap 65380
#define Consts_SInvalidIcon 65381
#define Consts_SInvalidMetafile 65382
#define Consts_SChangeIconSize 65383
#define Consts_SOleGraphic 65384
#define Consts_SUnknownClipboardFormat 65385
#define Consts_SOutOfResources 65386
#define Consts_SNoCanvasHandle 65387
#define Consts_SInvalidImageSize 65388
#define Consts_SInvalidImageList 65389
#define Consts_SReplaceImage 65390
#define Consts_SImageIndexError 65391
#define RTLConsts_SListCapacityError 65392
#define RTLConsts_SListCountError 65393
#define RTLConsts_SListIndexError 65394
#define RTLConsts_SMemoryStreamError 65395
#define RTLConsts_SPropertyException 65396
#define RTLConsts_SReadError 65397
#define RTLConsts_SReadOnlyProperty 65398
#define RTLConsts_SRegGetDataFailed 65399
#define RTLConsts_SRegSetDataFailed 65400
#define RTLConsts_SResNotFound 65401
#define RTLConsts_SSeekNotImplemented 65402
#define RTLConsts_SSortedListError 65403
#define RTLConsts_STooManyDeleted 65404
#define RTLConsts_SUnknownGroup 65405
#define RTLConsts_SUnknownProperty 65406
#define RTLConsts_SWriteError 65407
#define RTLConsts_SDuplicateString 65408
#define RTLConsts_SFCreateErrorEx 65409
#define RTLConsts_SFixedColTooBig 65410
#define RTLConsts_SFixedRowTooBig 65411
#define RTLConsts_SFOpenErrorEx 65412
#define RTLConsts_SGridTooLarge 65413
#define RTLConsts_SIndexOutOfRange 65414
#define RTLConsts_SInvalidImage 65415
#define RTLConsts_SInvalidName 65416
#define RTLConsts_SInvalidProperty 65417
#define RTLConsts_SInvalidPropertyElement 65418
#define RTLConsts_SInvalidPropertyPath 65419
#define RTLConsts_SInvalidPropertyType 65420
#define RTLConsts_SInvalidPropertyValue 65421
#define RTLConsts_SInvalidRegType 65422
#define RTLConsts_SInvalidStringGridOp 65423
#define SysConst_SLongDayNameSun 65424
#define SysConst_SLongDayNameMon 65425
#define SysConst_SLongDayNameTue 65426
#define SysConst_SLongDayNameWed 65427
#define SysConst_SLongDayNameThu 65428
#define SysConst_SLongDayNameFri 65429
#define SysConst_SLongDayNameSat 65430
#define RTLConsts_SAncestorNotFound 65431
#define RTLConsts_SAssignError 65432
#define RTLConsts_SBitsIndexError 65433
#define RTLConsts_SCantWriteResourceStreamError 65434
#define RTLConsts_SCheckSynchronizeError 65435
#define RTLConsts_SClassNotFound 65436
#define RTLConsts_SDuplicateClass 65437
#define RTLConsts_SDuplicateItem 65438
#define RTLConsts_SDuplicateName 65439
#define SysConst_SLongMonthNameApr 65440
#define SysConst_SLongMonthNameMay 65441
#define SysConst_SLongMonthNameJun 65442
#define SysConst_SLongMonthNameJul 65443
#define SysConst_SLongMonthNameAug 65444
#define SysConst_SLongMonthNameSep 65445
#define SysConst_SLongMonthNameOct 65446
#define SysConst_SLongMonthNameNov 65447
#define SysConst_SLongMonthNameDec 65448
#define SysConst_SShortDayNameSun 65449
#define SysConst_SShortDayNameMon 65450
#define SysConst_SShortDayNameTue 65451
#define SysConst_SShortDayNameWed 65452
#define SysConst_SShortDayNameThu 65453
#define SysConst_SShortDayNameFri 65454
#define SysConst_SShortDayNameSat 65455
#define SysConst_SUnkOSError 65456
#define SysConst_SShortMonthNameJan 65457
#define SysConst_SShortMonthNameFeb 65458
#define SysConst_SShortMonthNameMar 65459
#define SysConst_SShortMonthNameApr 65460
#define SysConst_SShortMonthNameMay 65461
#define SysConst_SShortMonthNameJun 65462
#define SysConst_SShortMonthNameJul 65463
#define SysConst_SShortMonthNameAug 65464
#define SysConst_SShortMonthNameSep 65465
#define SysConst_SShortMonthNameOct 65466
#define SysConst_SShortMonthNameNov 65467
#define SysConst_SShortMonthNameDec 65468
#define SysConst_SLongMonthNameJan 65469
#define SysConst_SLongMonthNameFeb 65470
#define SysConst_SLongMonthNameMar 65471
#define SysConst_SVarTypeTooManyCustom 65472
#define SysConst_SVarTypeCouldNotConvert 65473
#define SysConst_SVarTypeConvertOverflow 65474
#define SysConst_SVarOverflow 65475
#define SysConst_SVarInvalid 65476
#define SysConst_SVarBadType 65477
#define SysConst_SVarNotImplemented 65478
#define SysConst_SVarUnexpected 65479
#define SysConst_SExternalException 65480
#define SysConst_SAssertionFailed 65481
#define SysConst_SIntfCastError 65482
#define SysConst_SSafecallException 65483
#define SysConst_SAssertError 65484
#define SysConst_SAbstractError 65485
#define SysConst_SModuleAccessViolation 65486
#define SysConst_SOSError 65487
#define SysConst_SInvalidFormat 65488
#define SysConst_SArgumentMissing 65489
#define SysConst_SDispatchError 65490
#define SysConst_SReadAccess 65491
#define SysConst_SWriteAccess 65492
#define SysConst_SFormatTooLong 65493
#define SysConst_SVarArrayCreate 65494
#define SysConst_SVarArrayBounds 65495
#define SysConst_SVarArrayLocked 65496
#define SysConst_SInvalidVarCast 65497
#define SysConst_SInvalidVarOp 65498
#define SysConst_SInvalidVarNullOp 65499
#define SysConst_SInvalidVarOpWithHResultWithPrefix 65500
#define SysConst_SVarTypeOutOfRangeWithPrefix 65501
#define SysConst_SVarTypeAlreadyUsedWithPrefix 65502
#define SysConst_SVarTypeNotUsableWithPrefix 65503
#define SysConst_SRangeError 65504
#define SysConst_SIntOverflow 65505
#define SysConst_SInvalidOp 65506
#define SysConst_SZeroDivide 65507
#define SysConst_SOverflow 65508
#define SysConst_SUnderflow 65509
#define SysConst_SInvalidPointer 65510
#define SysConst_SInvalidCast 65511
#define SysConst_SAccessViolationArg3 65512
#define SysConst_SAccessViolationNoArg 65513
#define SysConst_SStackOverflow 65514
#define SysConst_SControlC 65515
#define SysConst_SPrivilege 65516
#define SysConst_SOperationAborted 65517
#define SysConst_SException 65518
#define SysConst_SExceptTitle 65519
#define SysConst_SInvalidInteger 65520
#define SysConst_SInvalidFloat 65521
#define SysConst_SInvalidTime 65522
#define SysConst_SInvalidDateTime 65523
#define SysConst_STimeEncodeError 65524
#define SysConst_SDateEncodeError 65525
#define SysConst_SOutOfMemory 65526
#define SysConst_SInOutError 65527
#define SysConst_SFileNotFound 65528
#define SysConst_SInvalidFilename 65529
#define SysConst_STooManyOpenFiles 65530
#define SysConst_SAccessDenied 65531
#define SysConst_SEndOfFile 65532
#define SysConst_SDiskFull 65533
#define SysConst_SInvalidInput 65534
#define SysConst_SDivByZero 65535
STRINGTABLE
BEGIN
IdResourceStrings_RSStackHOST_NOT_FOUND, "Host not found."
IdResourceStrings_RSStackENETUNREACH, "Network is unreachable."
IdResourceStrings_RSStackENETRESET, "Net dropped connection or reset."
IdResourceStrings_RSStackECONNABORTED, "Software caused connection abort."
IdResourceStrings_RSStackECONNRESET, "Connection reset by peer."
IdResourceStrings_RSStackENOBUFS, "No buffer space available."
IdResourceStrings_RSStackEISCONN, "Socket is already connected."
IdResourceStrings_RSStackENOTCONN, "Socket is not connected."
IdResourceStrings_RSStackESHUTDOWN, "Cannot send or receive after socket is closed."
IdResourceStrings_RSStackETOOMANYREFS, "Too many references, cannot splice."
IdResourceStrings_RSStackETIMEDOUT, "Connection timed out."
IdResourceStrings_RSStackECONNREFUSED, "Connection refused."
IdResourceStrings_RSStackELOOP, "Too many levels of symbolic links."
IdResourceStrings_RSStackENAMETOOLONG, "File name too long."
IdResourceStrings_RSStackEHOSTDOWN, "Host is down."
IdResourceStrings_RSStackEHOSTUNREACH, "No route to host."
IdResourceStrings_RSStackENOTEMPTY, "Directory not empty"
IdResourceStrings_RSStackEWOULDBLOCK, "Operation would block. "
IdResourceStrings_RSStackEINPROGRESS, "Operation now in progress."
IdResourceStrings_RSStackEALREADY, "Operation already in progress."
IdResourceStrings_RSStackENOTSOCK, "Socket operation on non-socket."
IdResourceStrings_RSStackEDESTADDRREQ, "Destination address required."
IdResourceStrings_RSStackEMSGSIZE, "Message too long."
IdResourceStrings_RSStackEPROTOTYPE, "Protocol wrong type for socket."
IdResourceStrings_RSStackENOPROTOOPT, "Bad protocol option."
IdResourceStrings_RSStackEPROTONOSUPPORT, "Protocol not supported."
IdResourceStrings_RSStackESOCKTNOSUPPORT, "Socket type not supported."
IdResourceStrings_RSStackEOPNOTSUPP, "Operation not supported on socket."
IdResourceStrings_RSStackEPFNOSUPPORT, "Protocol family not supported."
IdResourceStrings_RSStackEAFNOSUPPORT, "Address family not supported by protocol family."
IdResourceStrings_RSStackEADDRINUSE, "Address already in use."
IdResourceStrings_RSStackEADDRNOTAVAIL, "Cannot assign requested address."
IdResourceStrings_RSStackENETDOWN, "Network is down."
VDBConsts_SPostEdit, "Post edit"
VDBConsts_SCancelEdit, "Cancel edit"
VDBConsts_SRefreshRecord, "Refresh data"
VDBConsts_SRemoteLogin, "Remote Login"
IdResourceStrings_RSWinsockInitializationError, "Winsock Initialization Error."
IdResourceStrings_RSSetSizeExceeded, "Set Size Exceeded."
IdResourceStrings_RSWS2CallError, "Error on call Winsock2 library function %s"
IdResourceStrings_RSWS2LoadError, "Error on loading Winsock2 library (%s)"
IdResourceStrings_RSInvalidServiceName, "%s is not a valid service."
IdResourceStrings_RSStackError, "Socket Error # %d\r\n%s"
IdResourceStrings_RSStackEINTR, "Interrupted system call."
IdResourceStrings_RSStackEBADF, "Bad file number."
IdResourceStrings_RSStackEACCES, "Access denied."
IdResourceStrings_RSStackEFAULT, "Bad address."
IdResourceStrings_RSStackEINVAL, "Invalid argument."
IdResourceStrings_RSStackEMFILE, "Too many open files."
OleConst_SCannotActivate, "OLE control activation failed"
OleConst_SNoWindowHandle, "Could not obtain OLE control window handle"
OleConst_SInvalidLicense, "License information for %s is invalid"
OleConst_SNotLicensed, "License information for %s not found. You cannot use this control in design mode"
OleConst_sNoRunningObject, "Unable to retrieve a pointer to a running object registered with OLE for %s/%s"
DBConsts_SBcdOverflow, "BCD overflow"
DBConsts_SInvalidBcdValue, "%s is not a valid BCD value"
DBConsts_SCouldNotParseTimeStamp, "Could not parse SQL TimeStamp string"
DBConsts_SInvalidSqlTimeStamp, "Invalid SQL date/time values"
VDBConsts_SFirstRecord, "First record"
VDBConsts_SPriorRecord, "Prior record"
VDBConsts_SNextRecord, "Next record"
VDBConsts_SLastRecord, "Last record"
VDBConsts_SInsertRecord, "Insert record"
VDBConsts_SDeleteRecord, "Delete record"
VDBConsts_SEditRecord, "Edit record"
TeeConst_TeeMsg_ValuesArrowEndX, "EndX"
TeeConst_TeeMsg_ValuesArrowEndY, "EndY"
ComConst_SCreateRegKeyError, "Error creating system registry entry"
ComConst_SOleError, "OLE error %.8x"
ComConst_SObjectFactoryMissing, "Object factory for class %s missing"
ComConst_STypeInfoMissing, "Type information missing for class %s"
ComConst_SBadTypeInfo, "Incorrect type information for class %s"
ComConst_SDispIntfMissing, "Dispatch interface missing from class %s"
ComConst_SNoMethod, "Method '%s' not supported by automation object"
ComConst_SVarNotObject, "Variant does not reference an automation object"
ComConst_STooManyParams, "Dispatch methods do not support more than 64 parameters"
ComConst_SDCOMNotInstalled, "DCOM not installed"
ComConst_SDAXError, "DAX Error"
ComConst_SAutomationWarning, "COM Server Warning"
ComConst_SNoCloseActiveServer1, "There are still active COM objects in this application. One or more clients may have references to these objects, so manually closing "
ComConst_SNoCloseActiveServer2, "this application may cause those client application(s) to fail.\r\n\r\nAre you sure you want to close this application?"
TeeConst_TeeMsg_FunctionDivide, "Divide"
TeeConst_TeeMsg_FunctionHigh, "High"
TeeConst_TeeMsg_FunctionLow, "Low"
TeeConst_TeeMsg_FunctionAverage, "Average"
TeeConst_TeeMsg_DefaultFontName, "Arial"
TeeConst_TeeMsg_CheckPointerSize, "Pointer size must be greater than zero"
TeeConst_TeeMsg_FunctionPeriod, "Function Period should be >= 0"
TeeConst_TeeMsg_PieOther, "Other"
TeeConst_TeeMsg_ValuesX, "X"
TeeConst_TeeMsg_ValuesY, "Y"
TeeConst_TeeMsg_ValuesPie, "Pie"
TeeConst_TeeMsg_ValuesBar, "Bar"
TeeConst_TeeMsg_ValuesAngle, "Angle"
TeeConst_TeeMsg_ValuesGanttStart, "Start"
TeeConst_TeeMsg_ValuesGanttEnd, "End"
TeeConst_TeeMsg_ValuesGanttNextTask, "NextTask"
TeeConst_TeeMsg_GalleryArrow, "Arrow"
TeeConst_TeeMsg_GalleryGantt, "Gantt"
TeeConst_TeeMsg_GanttSample1, "Design"
TeeConst_TeeMsg_GanttSample2, "Prototyping"
TeeConst_TeeMsg_GanttSample3, "Development"
TeeConst_TeeMsg_GanttSample4, "Sales"
TeeConst_TeeMsg_GanttSample5, "Marketing"
TeeConst_TeeMsg_GanttSample6, "Testing"
TeeConst_TeeMsg_GanttSample7, "Manufac."
TeeConst_TeeMsg_GanttSample8, "Debugging"
TeeConst_TeeMsg_GanttSample9, "New Version"
TeeConst_TeeMsg_GanttSample10, "Banking"
TeeConst_TeeMsg_DefaultFontSize, "8"
TeeConst_TeeMsg_FunctionAdd, "Add"
TeeConst_TeeMsg_FunctionSubtract, "Subtract"
TeeConst_TeeMsg_FunctionMultiply, "Multiply"
TeeConst_TeeMsg_GalleryArea, "Area"
TeeConst_TeeMsg_GalleryBar, "Bar"
TeeConst_TeeMsg_GalleryHorizBar, "Horiz. Bar"
TeeConst_TeeMsg_GalleryPie, "Pie"
TeeConst_TeeMsg_GalleryFastLine, "Fast Line"
TeeConst_TeeMsg_Rotation, "Rotation"
TeeConst_TeeMsg_PieSample1, "Cars"
TeeConst_TeeMsg_PieSample2, "Phones"
TeeConst_TeeMsg_PieSample3, "Tables"
TeeConst_TeeMsg_PieSample4, "Monitors"
TeeConst_TeeMsg_PieSample5, "Lamps"
TeeConst_TeeMsg_PieSample6, "Keyboards"
TeeConst_TeeMsg_PieSample7, "Bikes"
TeeConst_TeeMsg_PieSample8, "Chairs"
TeeConst_TeeMsg_GalleryStandard, "Standard"
TeeConst_TeeMsg_GalleryFunctions, "Functions"
TeeConst_TeeMsg_AxisIncrementNeg, "Axis increment must be >= 0"
TeeConst_TeeMsg_AxisMinMax, "Axis Minimum Value must be <= Maximum"
TeeConst_TeeMsg_AxisMaxMin, "Axis Maximum Value must be >= Minimum"
TeeConst_TeeMsg_AxisLogBase, "Axis Logarithmic Base should be >= 2"
TeeConst_TeeMsg_MaxPointsPerPage, "MaxPointsPerPage must be >= 0"
TeeConst_TeeMsg_3dPercent, "3D effect percent must be between %d and %d"
TeeConst_TeeMsg_CircularSeries, "Circular Series dependences are not allowed"
TeeConst_TeeMsg_BarWidthPercent, "Bar Width Percent must be between 1 and 100"
TeeConst_TeeMsg_BarOffsetPercent, "Bar Offset Percent must be between -100% and 100%"
TeeConst_TeeMsg_DefaultPercentOf, "%s of %s"
TeeConst_TeeMsg_DefPercentFormat, "##0.## %"
TeeConst_TeeMsg_DefValueFormat, "#,##0.###"
TeeConst_TeeMsg_AxisTitle, "Axis Title"
TeeConst_TeeMsg_AxisLabels, "Axis Labels"
TeeConst_TeeMsg_GalleryLine, "Line"
TeeConst_TeeMsg_GalleryPoint, "Point"
ComStrs_sDateTimeMin, "Date is less than minimum of %s"
ComStrs_sFailSetCalDateTime, "Failed to set calendar date or time"
ComStrs_sFailSetCalMaxSelRange, "Failed to set maximum selection range"
ComStrs_sFailSetCalMinMaxRange, "Failed to set calendar min/max range"
ComStrs_sFailsetCalSelRange, "Failed to set calendar selected range"
WinHelpViewer_hNoKeyword, "No help keyword specified."
TeeConst_TeeMsg_LegendTopPos, "Top Legend Position must be between 0 and 100 %"
TeeConst_TeeMsg_LegendFirstValue, "First Legend Value must be > 0"
TeeConst_TeeMsg_LegendColorWidth, "Legend Color Width must be between 0 and 100 %"
TeeConst_TeeMsg_SeriesSetDataSource, "No ParentChart to validate DataSource"
TeeConst_TeeMsg_SeriesInvDataSource, "No valid DataSource: %s"
TeeConst_TeeMsg_FillSample, "FillSampleValues NumValues must be > 0"
TeeConst_TeeMsg_Angle, "%s Angle must be between 0 and 359 degrees"
TeeConst_TeeMsg_AxisLogDateTime, "DateTime Axis cannot be Logarithmic"
TeeConst_TeeMsg_AxisLogNotPositive, "Logarithmic Axis Min and Max values should be >= 0"
TeeConst_TeeMsg_AxisLabelSep, "Labels Separation % must be greater than 0"
ComStrs_sTabFailDelete, "Failed to delete tab at index %d"
ComStrs_sTabFailRetrieve, "Failed to retrieve tab at index %d"
ComStrs_sTabFailGetObject, "Failed to get object at index %d"
ComStrs_sTabFailSet, "Failed to set tab \"%s\" at index %d"
ComStrs_sTabFailSetObject, "Failed to set object at index %d"
ComStrs_sTabMustBeMultiLine, "MultiLine must be True when TabPosition is tpLeft or tpRight"
ComStrs_sInvalidIndex, "Invalid index"
ComStrs_sInsertError, "Unable to insert an item"
ComStrs_sInvalidOwner, "Invalid owner"
ComStrs_sRichEditInsertError, "RichEdit line insertion error"
ComStrs_sRichEditLoadFail, "Failed to Load Stream"
ComStrs_sRichEditSaveFail, "Failed to Save Stream"
ComStrs_sUDAssociated, "%s is already associated with %s"
ComStrs_sPageIndexError, "%d is an invalid PageIndex value. PageIndex must be between 0 and %d"
ComStrs_sInvalidComCtl32, "This control requires version 4.70 or greater of COMCTL32.DLL"
ComStrs_sDateTimeMax, "Date exceeds maximum of %s"
ExtCtrls_clNameHighlightText, "Highlight Text"
ExtCtrls_clNameInactiveBorder, "Inactive Border"
ExtCtrls_clNameInactiveCaption, "Inactive Caption"
ExtCtrls_clNameInactiveCaptionText, "Inactive Caption Text"
ExtCtrls_clNameInfoBk, "Info Background"
ExtCtrls_clNameInfoText, "Info Text"
ExtCtrls_clNameMenu, "Menu Background"
ExtCtrls_clNameMenuText, "Menu Text"
ExtCtrls_clNameNone, "None"
ExtCtrls_clNameScrollBar, "Scroll Bar"
ExtCtrls_clName3DDkShadow, "3D Dark Shadow"
ExtCtrls_clName3DLight, "3D Light"
ExtCtrls_clNameWindow, "Window Background"
ExtCtrls_clNameWindowFrame, "Window Frame"
ExtCtrls_clNameWindowText, "Window Text"
ComStrs_sTabFailClear, "Failed to clear tab control"
ExtCtrls_clNameMoneyGreen, "Money Green"
ExtCtrls_clNameSkyBlue, "Sky Blue"
ExtCtrls_clNameCream, "Cream"
ExtCtrls_clNameMedGray, "Medium Gray"
ExtCtrls_clNameActiveBorder, "Active Border"
ExtCtrls_clNameActiveCaption, "Active Caption"
ExtCtrls_clNameAppWorkSpace, "Application Workspace"
ExtCtrls_clNameBackground, "Background"
ExtCtrls_clNameBtnFace, "Button Face"
ExtCtrls_clNameBtnHighlight, "Button Highlight"
ExtCtrls_clNameBtnShadow, "Button Shadow"
ExtCtrls_clNameBtnText, "Button Text"
ExtCtrls_clNameCaptionText, "Caption Text"
ExtCtrls_clNameDefault, "Default"
ExtCtrls_clNameGrayText, "Gray Text"
ExtCtrls_clNameHighlight, "Highlight Background"
ExtCtrls_clNameBlack, "Black"
ExtCtrls_clNameMaroon, "Maroon"
ExtCtrls_clNameGreen, "Green"
ExtCtrls_clNameOlive, "Olive"
ExtCtrls_clNameNavy, "Navy"
ExtCtrls_clNamePurple, "Purple"
ExtCtrls_clNameTeal, "Teal"
ExtCtrls_clNameGray, "Gray"
ExtCtrls_clNameSilver, "Silver"
ExtCtrls_clNameRed, "Red"
ExtCtrls_clNameLime, "Lime"
ExtCtrls_clNameYellow, "Yellow"
ExtCtrls_clNameBlue, "Blue"
ExtCtrls_clNameFuchsia, "Fuchsia"
ExtCtrls_clNameAqua, "Aqua"
ExtCtrls_clNameWhite, "White"
Consts_SNoDefaultPrinter, "There is no default printer currently selected"
Consts_SDuplicateMenus, "Menu '%s' is already being used by another form"
Consts_SCannotOpenAVI, "Cannot open AVI"
Consts_SDockedCtlNeedsName, "Docked control must have a name"
Consts_SDockTreeRemoveError, "Error removing control from dock tree"
Consts_SDockZoneNotFound, " - Dock zone not found"
Consts_SDockZoneHasNoCtl, " - Dock zone has no control"
Consts_SMultiSelectRequired, "Multiselect mode must be on for this feature"
Consts_SSeparator, "Separator"
Consts_SErrorSettingCount, "Error setting %s.Count"
Consts_SListBoxMustBeVirtual, "Listbox (%s) style must be virtual in order to set Count"
Consts_SNoGetItemEventHandler, "No OnGetItem event handler assigned"
HelpIntfs_hNoTableOfContents, "Unable to find a Table of Contents"
HelpIntfs_hNothingFound, "No help found for %s"
HelpIntfs_hNoContext, "No context-sensitive help installed"
HelpIntfs_hNoTopics, "No topic-based help system installed"
Consts_SmkcLeft, "Left"
Consts_SmkcUp, "Up"
Consts_SmkcRight, "Right"
Consts_SmkcDown, "Down"
Consts_SmkcIns, "Ins"
Consts_SmkcDel, "Del"
Consts_SmkcShift, "Shift+"
Consts_SmkcCtrl, "Ctrl+"
Consts_SmkcAlt, "Alt+"
Consts_SOutOfRange, "Value must be between %d and %d"
Consts_SInsertLineError, "Unable to insert a line"
Consts_SInvalidClipFmt, "Invalid clipboard format"
Consts_SIconToClipboard, "Clipboard does not support Icons"
Consts_SCannotOpenClipboard, "Cannot open clipboard"
Consts_SInvalidMemoSize, "Text exceeds memo capacity"
Consts_SInvalidPrinterOp, "Operation not supported on selected printer"
Consts_SMsgDlgHelp, "&Help"
Consts_SMsgDlgAbort, "&Abort"
Consts_SMsgDlgRetry, "&Retry"
Consts_SMsgDlgIgnore, "&Ignore"
Consts_SMsgDlgAll, "&All"
Consts_SMsgDlgNoToAll, "N&o to All"
Consts_SMsgDlgYesToAll, "Yes to &All"
Consts_SmkcBkSp, "BkSp"
Consts_SmkcTab, "Tab"
Consts_SmkcEsc, "Esc"
Consts_SmkcEnter, "Enter"
Consts_SmkcSpace, "Space"
Consts_SmkcPgUp, "PgUp"
Consts_SmkcPgDn, "PgDn"
Consts_SmkcEnd, "End"
Consts_SmkcHome, "Home"
Consts_SAllButton, "&All"
Consts_SCannotDragForm, "Cannot drag a form"
Consts_SVMetafiles, "Metafiles"
Consts_SVEnhMetafiles, "Enhanced Metafiles"
Consts_SVIcons, "Icons"
Consts_SVBitmaps, "Bitmaps"
Consts_SMaskErr, "Invalid input value"
Consts_SMaskEditErr, "Invalid input value. Use escape key to abandon changes"
Consts_SMsgDlgWarning, "Warning"
Consts_SMsgDlgError, "Error"
Consts_SMsgDlgInformation, "Information"
Consts_SMsgDlgConfirm, "Confirm"
Consts_SMsgDlgYes, "&Yes"
Consts_SMsgDlgNo, "&No"
Consts_SMsgDlgOK, "OK"
Consts_SMsgDlgCancel, "Cancel"
Consts_SNotPrinting, "Printer is not currently printing"
Consts_SPrinting, "Printing in progress"
Consts_SInvalidPrinter, "Printer selected is not valid"
Consts_SDeviceOnPort, "%s on %s"
Consts_SGroupIndexTooLow, "GroupIndex cannot be less than a previous menu item's GroupIndex"
Consts_SNoMDIForm, "Cannot create form. No MDI forms are currently active"
Consts_SControlParentSetToSelf, "A control cannot have itself as its parent"
Consts_SOKButton, "OK"
Consts_SCancelButton, "Cancel"
Consts_SYesButton, "&Yes"
Consts_SNoButton, "&No"
Consts_SHelpButton, "&Help"
Consts_SCloseButton, "&Close"
Consts_SIgnoreButton, "&Ignore"
Consts_SRetryButton, "&Retry"
Consts_SAbortButton, "Abort"
Consts_SImageReadFail, "Failed to read ImageList data from stream"
Consts_SImageWriteFail, "Failed to write ImageList data to stream"
Consts_SWindowDCError, "Error creating window device context"
Consts_SWindowClass, "Error creating window class"
Consts_SCannotFocus, "Cannot focus a disabled or invisible window"
Consts_SParentRequired, "Control '%s' has no parent window"
Consts_SParentGivenNotAParent, "Parent given is not a parent of '%s'"
Consts_SMDIChildNotVisible, "Cannot hide an MDI Child Form"
Consts_SVisibleChanged, "Cannot change Visible in OnShow or OnHide"
Consts_SCannotShowModal, "Cannot make a visible window modal"
Consts_SScrollBarRange, "Scrollbar property out of range"
Consts_SPropertyOutOfRange, "%s property out of range"
Consts_SMenuIndexError, "Menu index out of range"
Consts_SMenuReinserted, "Menu inserted twice"
Consts_SMenuNotFound, "Sub-menu is not in menu"
Consts_SNoTimers, "Not enough timers available"
RTLConsts_SThreadCreateError, "Thread creation error: %s"
RTLConsts_SThreadError, "Thread Error: %s (%d)"
Consts_SInvalidTabPosition, "Tab position incompatible with current tab style"
Consts_SInvalidTabStyle, "Tab style incompatible with current tab position"
Consts_SInvalidBitmap, "Bitmap image is not valid"
Consts_SInvalidIcon, "Icon image is not valid"
Consts_SInvalidMetafile, "Metafile is not valid"
Consts_SChangeIconSize, "Cannot change the size of an icon"
Consts_SOleGraphic, "Invalid operation on TOleGraphic"
Consts_SUnknownClipboardFormat, "Unsupported clipboard format"
Consts_SOutOfResources, "Out of system resources"
Consts_SNoCanvasHandle, "Canvas does not allow drawing"
Consts_SInvalidImageSize, "Invalid image size"
Consts_SInvalidImageList, "Invalid ImageList"
Consts_SReplaceImage, "Unable to Replace Image"
Consts_SImageIndexError, "Invalid ImageList Index"
RTLConsts_SListCapacityError, "List capacity out of bounds (%d)"
RTLConsts_SListCountError, "List count out of bounds (%d)"
RTLConsts_SListIndexError, "List index out of bounds (%d)"
RTLConsts_SMemoryStreamError, "Out of memory while expanding memory stream"
RTLConsts_SPropertyException, "Error reading %s%s%s: %s"
RTLConsts_SReadError, "Stream read error"
RTLConsts_SReadOnlyProperty, "Property is read-only"
RTLConsts_SRegGetDataFailed, "Failed to get data for '%s'"
RTLConsts_SRegSetDataFailed, "Failed to set data for '%s'"
RTLConsts_SResNotFound, "Resource %s not found"
RTLConsts_SSeekNotImplemented, "%s.Seek not implemented"
RTLConsts_SSortedListError, "Operation not allowed on sorted list"
RTLConsts_STooManyDeleted, "Too many rows or columns deleted"
RTLConsts_SUnknownGroup, "%s not in a class registration group"
RTLConsts_SUnknownProperty, "Property %s does not exist"
RTLConsts_SWriteError, "Stream write error"
RTLConsts_SDuplicateString, "String list does not allow duplicates"
RTLConsts_SFCreateErrorEx, "Cannot create file \"%s\". %s"
RTLConsts_SFixedColTooBig, "Fixed column count must be less than column count"
RTLConsts_SFixedRowTooBig, "Fixed row count must be less than row count"
RTLConsts_SFOpenErrorEx, "Cannot open file \"%s\". %s"
RTLConsts_SGridTooLarge, "Grid too large for operation"
RTLConsts_SIndexOutOfRange, "Grid index out of range"
RTLConsts_SInvalidImage, "Invalid stream format"
RTLConsts_SInvalidName, "''%s'' is not a valid component name"
RTLConsts_SInvalidProperty, "Invalid property value"
RTLConsts_SInvalidPropertyElement, "Invalid property element: %s"
RTLConsts_SInvalidPropertyPath, "Invalid property path"
RTLConsts_SInvalidPropertyType, "Invalid property type: %s"
RTLConsts_SInvalidPropertyValue, "Invalid property value"
RTLConsts_SInvalidRegType, "Invalid data type for '%s'"
RTLConsts_SInvalidStringGridOp, "Cannot insert or delete rows from grid"
SysConst_SLongDayNameSun, "Sunday"
SysConst_SLongDayNameMon, "Monday"
SysConst_SLongDayNameTue, "Tuesday"
SysConst_SLongDayNameWed, "Wednesday"
SysConst_SLongDayNameThu, "Thursday"
SysConst_SLongDayNameFri, "Friday"
SysConst_SLongDayNameSat, "Saturday"
RTLConsts_SAncestorNotFound, "Ancestor for '%s' not found"
RTLConsts_SAssignError, "Cannot assign a %s to a %s"
RTLConsts_SBitsIndexError, "Bits index out of range"
RTLConsts_SCantWriteResourceStreamError, "Can't write to a read-only resource stream"
RTLConsts_SCheckSynchronizeError, "CheckSynchronize called from thread $%x, which is NOT the main thread"
RTLConsts_SClassNotFound, "Class %s not found"
RTLConsts_SDuplicateClass, "A class named %s already exists"
RTLConsts_SDuplicateItem, "List does not allow duplicates ($0%x)"
RTLConsts_SDuplicateName, "A component named %s already exists"
SysConst_SLongMonthNameApr, "April"
SysConst_SLongMonthNameMay, "May"
SysConst_SLongMonthNameJun, "June"
SysConst_SLongMonthNameJul, "July"
SysConst_SLongMonthNameAug, "August"
SysConst_SLongMonthNameSep, "September"
SysConst_SLongMonthNameOct, "October"
SysConst_SLongMonthNameNov, "November"
SysConst_SLongMonthNameDec, "December"
SysConst_SShortDayNameSun, "Sun"
SysConst_SShortDayNameMon, "Mon"
SysConst_SShortDayNameTue, "Tue"
SysConst_SShortDayNameWed, "Wed"
SysConst_SShortDayNameThu, "Thu"
SysConst_SShortDayNameFri, "Fri"
SysConst_SShortDayNameSat, "Sat"
SysConst_SUnkOSError, "A call to an OS function failed"
SysConst_SShortMonthNameJan, "Jan"
SysConst_SShortMonthNameFeb, "Feb"
SysConst_SShortMonthNameMar, "Mar"
SysConst_SShortMonthNameApr, "Apr"
SysConst_SShortMonthNameMay, "May"
SysConst_SShortMonthNameJun, "Jun"
SysConst_SShortMonthNameJul, "Jul"
SysConst_SShortMonthNameAug, "Aug"
SysConst_SShortMonthNameSep, "Sep"
SysConst_SShortMonthNameOct, "Oct"
SysConst_SShortMonthNameNov, "Nov"
SysConst_SShortMonthNameDec, "Dec"
SysConst_SLongMonthNameJan, "January"
SysConst_SLongMonthNameFeb, "February"
SysConst_SLongMonthNameMar, "March"
SysConst_SVarTypeTooManyCustom, "Too many custom variant types have been registered"
SysConst_SVarTypeCouldNotConvert, "Could not convert variant of type (%s) into type (%s)"
SysConst_SVarTypeConvertOverflow, "Overflow while converting variant of type (%s) into type (%s)"
SysConst_SVarOverflow, "Variant overflow"
SysConst_SVarInvalid, "Invalid argument"
SysConst_SVarBadType, "Invalid variant type"
SysConst_SVarNotImplemented, "Operation not supported"
SysConst_SVarUnexpected, "Unexpected variant error"
SysConst_SExternalException, "External exception %x"
SysConst_SAssertionFailed, "Assertion failed"
SysConst_SIntfCastError, "Interface not supported"
SysConst_SSafecallException, "Exception in safecall method"
SysConst_SAssertError, "%s (%s, line %d)"
SysConst_SAbstractError, "Abstract Error"
SysConst_SModuleAccessViolation, "Access violation at address %p in module '%s'. %s of address %p"
SysConst_SOSError, "System Error. Code: %d.\r\n%s"
SysConst_SInvalidFormat, "Format '%s' invalid or incompatible with argument"
SysConst_SArgumentMissing, "No argument for format '%s'"
SysConst_SDispatchError, "Variant method calls not supported"
SysConst_SReadAccess, "Read"
SysConst_SWriteAccess, "Write"
SysConst_SFormatTooLong, "Format string too long"
SysConst_SVarArrayCreate, "Error creating variant or safe array"
SysConst_SVarArrayBounds, "Variant or safe array index out of bounds"
SysConst_SVarArrayLocked, "Variant or safe array is locked"
SysConst_SInvalidVarCast, "Invalid variant type conversion"
SysConst_SInvalidVarOp, "Invalid variant operation"
SysConst_SInvalidVarNullOp, "Invalid NULL variant operation"
SysConst_SInvalidVarOpWithHResultWithPrefix, "Invalid variant operation (%s%.8x)\n%s"
SysConst_SVarTypeOutOfRangeWithPrefix, "Custom variant type (%s%.4x) is out of range"
SysConst_SVarTypeAlreadyUsedWithPrefix, "Custom variant type (%s%.4x) already used by %s"
SysConst_SVarTypeNotUsableWithPrefix, "Custom variant type (%s%.4x) is not usable"
SysConst_SRangeError, "Range check error"
SysConst_SIntOverflow, "Integer overflow"
SysConst_SInvalidOp, "Invalid floating point operation"
SysConst_SZeroDivide, "Floating point division by zero"
SysConst_SOverflow, "Floating point overflow"
SysConst_SUnderflow, "Floating point underflow"
SysConst_SInvalidPointer, "Invalid pointer operation"
SysConst_SInvalidCast, "Invalid class typecast"
SysConst_SAccessViolationArg3, "Access violation at address %p. %s of address %p"
SysConst_SAccessViolationNoArg, "Access violation"
SysConst_SStackOverflow, "Stack overflow"
SysConst_SControlC, "Control-C hit"
SysConst_SPrivilege, "Privileged instruction"
SysConst_SOperationAborted, "Operation aborted"
SysConst_SException, "Exception %s in module %s at %p.\r\n%s%s\r\n"
SysConst_SExceptTitle, "Application Error"
SysConst_SInvalidInteger, "'%s' is not a valid integer value"
SysConst_SInvalidFloat, "'%s' is not a valid floating point value"
SysConst_SInvalidTime, "'%s' is not a valid time"
SysConst_SInvalidDateTime, "'%s' is not a valid date and time"
SysConst_STimeEncodeError, "Invalid argument to time encode"
SysConst_SDateEncodeError, "Invalid argument to date encode"
SysConst_SOutOfMemory, "Out of memory"
SysConst_SInOutError, "I/O error %d"
SysConst_SFileNotFound, "File not found"
SysConst_SInvalidFilename, "Invalid filename"
SysConst_STooManyOpenFiles, "Too many open files"
SysConst_SAccessDenied, "File access denied"
SysConst_SEndOfFile, "Read beyond end of file"
SysConst_SDiskFull, "Disk full"
SysConst_SInvalidInput, "Invalid numeric input"
SysConst_SDivByZero, "Division by zero"
END

397
CPRS-Chart/CPRSChart.dsk Normal file
View File

@ -0,0 +1,397 @@
[Closed Files]
File_0=SourceModule,'C:\Program Files\Borland\Delphi7\Projects\OR_SRC_CREATION FILE 12 06 06 OR_3_270\WV_Release_CPRS_OFFICIAL\CPRS-Lib\ORSystem.pas',0,1,1,1,332,0,0
File_1=SourceModule,'C:\Shared\CPRSfromGeorgeWelch\OR_30_270_SRC_VOE_MODIFIED\Program Files\Borland\Delphi7\Projects\OR_SRC_CREATION FILE 12 06 06 OR_3_270\OR_SRC_CREATION\CPRS-Chart\CPRSChart.dpr',0,1,1,1,1,0,0
File_2=SourceModule,'C:\Shared\CPRSfromGeorgeWelch\OR_30_270_SRC_VOE_MODIFIED\Program Files\Borland\Delphi7\Projects\OR_SRC_CREATION FILE 12 06 06 OR_3_270\OR_SRC_CREATION\CPRS-Chart\fLabs.pas',0,1,1116,59,1127,0,0
File_3=SourceModule,'C:\Shared\CPRSfromGeorgeWelch\OR_30_270_SRC_VOE_MODIFIED\Program Files\Borland\Delphi7\Projects\OR_SRC_CREATION FILE 12 06 06 OR_3_270\OR_SRC_CREATION\CPRS-Chart\fReview.pas',0,1,928,47,939,0,0
File_4=SourceModule,'C:\Shared\CPRSfromGeorgeWelch\OR_30_270_SRC_VOE_MODIFIED\Program Files\Borland\Delphi7\Projects\OR_SRC_CREATION FILE 12 06 06 OR_3_270\OR_SRC_CREATION\CPRS-Chart\rTIU.pas',0,1,1033,28,1044,0,0
File_5=SourceModule,'C:\Shared\CPRSfromGeorgeWelch\OR_30_270_SRC_VOE_MODIFIED\Program Files\Borland\Delphi7\Projects\OR_SRC_CREATION FILE 12 06 06 OR_3_270\OR_SRC_CREATION\CPRS-Chart\fAbout.pas',0,35,56,105,67,0,0
File_6=SourceModule,'C:\Shared\CPRSfromGeorgeWelch\OR_30_270_SRC_VOE_MODIFIED\Program Files\Borland\Delphi7\Projects\OR_SRC_CREATION FILE 12 06 06 OR_3_270\OR_SRC_CREATION\CPRS-Chart\rMisc.pas',0,1,114,26,125,0,0
File_7=SourceModule,'C:\Shared\CPRSfromGeorgeWelch\OR_30_270_SRC_VOE_MODIFIED\Program Files\Borland\Delphi7\Projects\OR_SRC_CREATION FILE 12 06 06 OR_3_270\OR_SRC_CREATION\CPRS-Chart\uSpell.pas',0,1,103,48,114,0,0
File_8=SourceModule,'C:\Shared\CPRSfromGeorgeWelch\OR_30_270_SRC_VOE_MODIFIED\Program Files\Borland\Delphi7\Projects\OR_SRC_CREATION FILE 12 06 06 OR_3_270\OR_SRC_CREATION\CPRS-Chart\uSignItems.pas',0,1,645,37,664,0,0
[Modules]
Module0=C:\Program Files\Borland\Delphi7\Projects\OR_SRC_CREATION FILE 12 06 06 OR_3_270\WV_Release_CPRS_OFFICIAL\CPRS-Chart\fPtSelOptns.pas
Module1=C:\Program Files\Borland\Delphi7\Projects\OR_SRC_CREATION FILE 12 06 06 OR_3_270\WV_Release_CPRS_OFFICIAL\CPRS-Chart\fPtSel.pas
Module2=C:\Program Files\Borland\Delphi7\Projects\OR_SRC_CREATION FILE 12 06 06 OR_3_270\WV_Release_CPRS_OFFICIAL\CPRS-Chart\fFrame.pas
Module3=C:\Program Files\Borland\Delphi7\Projects\OR_SRC_CREATION FILE 12 06 06 OR_3_270\WV_Release_CPRS_OFFICIAL\CPRS-Chart\VERGENCECONTEXTORLib_TLB.pas
Module4=C:\PROGRA~1\BORLAND\DELPHI7\LIB\BDK32\Source\wsockc.pas
Module5=c:\program files\borland\delphi7\source\rtl\Sys\system.pas
Count=6
EditWindowCount=1
TypeLibWindowCount=1
[C:\Program Files\Borland\Delphi7\Projects\OR_SRC_CREATION FILE 12 06 06 OR_3_270\WV_Release_CPRS_OFFICIAL\CPRS-Chart\fPtSelOptns.pas]
ModuleType=SourceModule
FormState=1
FormOnTop=1
[C:\Program Files\Borland\Delphi7\Projects\OR_SRC_CREATION FILE 12 06 06 OR_3_270\WV_Release_CPRS_OFFICIAL\CPRS-Chart\fPtSel.pas]
ModuleType=SourceModule
FormState=1
FormOnTop=1
[C:\Program Files\Borland\Delphi7\Projects\OR_SRC_CREATION FILE 12 06 06 OR_3_270\WV_Release_CPRS_OFFICIAL\CPRS-Chart\fFrame.pas]
ModuleType=SourceModule
FormState=0
FormOnTop=0
[C:\Program Files\Borland\Delphi7\Projects\OR_SRC_CREATION FILE 12 06 06 OR_3_270\WV_Release_CPRS_OFFICIAL\CPRS-Chart\VERGENCECONTEXTORLib_TLB.pas]
ModuleType=SourceModule
FormState=0
FormOnTop=0
[C:\PROGRA~1\BORLAND\DELPHI7\LIB\BDK32\Source\wsockc.pas]
ModuleType=SourceModule
FormState=0
FormOnTop=0
[c:\program files\borland\delphi7\source\rtl\Sys\system.pas]
ModuleType=SourceModule
FormState=0
FormOnTop=0
[C:\Program Files\Borland\Delphi7\Projects\ProjectGroup1.bpg]
FormState=0
FormOnTop=0
[C:\Program Files\Borland\Delphi7\Projects\OR_SRC_CREATION FILE 12 06 06 OR_3_270\WV_Release_CPRS_OFFICIAL\CPRS-Chart\CPRSChart.dpr]
FormState=0
FormOnTop=0
SymbolFile=C:\Program Files\Borland\Delphi7\Projects\OR_SRC_CREATION FILE 12 06 06 OR_3_270\WV_Release_CPRS_OFFICIAL\CPRS-Chart\CPRSChart.dsm
ModSinceCompile=1
[C:\Program Files\Borland\Delphi7\Projects\OR_SRC_CREATION FILE 12 06 06 OR_3_270\WV_Release_CPRS_OFFICIAL\CPRS-Chart\CPRSChart.tlb]
FormState=0
FormOnTop=0
[EditWindow0]
ViewCount=6
CurrentView=3
View0=0
View1=1
View2=2
View3=3
View4=4
View5=5
CodeExplorer=CodeExplorer@EditWindow0
MessageView=MessageView@EditWindow0
Create=1
Visible=1
State=0
Left=35
Top=116
Width=957
Height=594
MaxLeft=-1
MaxTop=-1
ClientWidth=949
ClientHeight=560
LeftPanelSize=0
RightPanelSize=0
BottomPanelSize=0
[View0]
Module=c:\program files\borland\delphi7\source\rtl\Sys\system.pas
CursorX=1
CursorY=11674
TopLine=11660
LeftCol=1
[View1]
Module=C:\Program Files\Borland\Delphi7\Projects\OR_SRC_CREATION FILE 12 06 06 OR_3_270\WV_Release_CPRS_OFFICIAL\CPRS-Chart\fPtSel.pas
CursorX=80
CursorY=1310
TopLine=1291
LeftCol=1
[View2]
Module=C:\PROGRA~1\BORLAND\DELPHI7\LIB\BDK32\Source\wsockc.pas
CursorX=1
CursorY=1479
TopLine=1465
LeftCol=1
[View3]
Module=C:\Program Files\Borland\Delphi7\Projects\OR_SRC_CREATION FILE 12 06 06 OR_3_270\WV_Release_CPRS_OFFICIAL\CPRS-Chart\fPtSelOptns.pas
CursorX=1
CursorY=202
TopLine=185
LeftCol=1
[View4]
Module=C:\Program Files\Borland\Delphi7\Projects\OR_SRC_CREATION FILE 12 06 06 OR_3_270\WV_Release_CPRS_OFFICIAL\CPRS-Chart\VERGENCECONTEXTORLib_TLB.pas
CursorX=1
CursorY=1145
TopLine=1134
LeftCol=1
[View5]
Module=C:\Program Files\Borland\Delphi7\Projects\OR_SRC_CREATION FILE 12 06 06 OR_3_270\WV_Release_CPRS_OFFICIAL\CPRS-Chart\fFrame.pas
CursorX=10
CursorY=624
TopLine=610
LeftCol=1
[TypeLibEditWindow0]
Create=1
Visible=0
State=0
Left=200
Top=110
Width=639
Height=453
MaxLeft=-1
MaxTop=-1
ClientWidth=631
ClientHeight=419
Module=C:\Program Files\Borland\Delphi7\Projects\OR_SRC_CREATION FILE 12 06 06 OR_3_270\WV_Release_CPRS_OFFICIAL\CPRS-Chart\CPRSChart.tlb
[Watches]
Count=1
Watch0='paramstr(2)',256,0,18,1,1,'Watches'
[WatchWindow]
WatchColumnWidth=100
WatchShowColumnHeaders=1
Create=1
Visible=0
State=0
Left=4
Top=410
Width=739
Height=172
MaxLeft=-1
MaxTop=-1
ClientWidth=731
ClientHeight=146
TBDockHeight=146
LRDockWidth=426
Dockable=1
[Breakpoints]
Count=0
[AddressBreakpoints]
Count=0
[Main Window]
Create=1
Visible=1
State=0
Left=0
Top=0
Width=1024
Height=112
MaxLeft=-1
MaxTop=-1
ClientWidth=1016
ClientHeight=78
[ProjectManager]
Create=1
Visible=0
State=0
Left=-43
Top=189
Width=1036
Height=462
MaxLeft=-1
MaxTop=-1
ClientWidth=1028
ClientHeight=436
TBDockHeight=489
LRDockWidth=719
Dockable=1
[Components]
Left=240
Top=237
Width=183
Height=235
Create=1
Visible=0
State=0
MaxLeft=-1
MaxTop=-1
ClientWidth=175
ClientHeight=209
TBDockHeight=235
LRDockWidth=183
Dockable=1
[CPUWindow]
Create=1
Visible=0
State=0
Left=166
Top=114
Width=634
Height=565
MaxLeft=-1
MaxTop=-1
ClientWidth=626
ClientHeight=531
DumpPane=79
DisassemblyPane=187
RegisterPane=231
FlagPane=64
[AlignmentPalette]
Create=1
Visible=0
State=0
Left=200
Top=114
Width=156
Height=84
MaxLeft=-1
MaxTop=-1
ClientWidth=150
ClientHeight=60
[PropertyInspector]
Create=1
Visible=1
State=0
Left=0
Top=394
Width=246
Height=335
MaxLeft=-1
MaxTop=-1
ClientWidth=238
ClientHeight=309
TBDockHeight=367
LRDockWidth=190
Dockable=1
SplitPos=85
ArrangeBy=Name
SelectedItem=Visible
ExpandedItems=
HiddenCategories=
[BreakpointWindow]
Create=1
Visible=0
State=0
Left=143
Top=285
Width=737
Height=197
MaxLeft=-1
MaxTop=-1
ClientWidth=729
ClientHeight=171
TBDockHeight=197
LRDockWidth=737
Dockable=1
Column0Width=100
Column1Width=75
Column2Width=200
Column3Width=200
Column4Width=75
Column5Width=75
[CallStackWindow]
Create=1
Visible=0
State=0
Left=282
Top=543
Width=469
Height=294
MaxLeft=-1
MaxTop=-1
ClientWidth=461
ClientHeight=268
TBDockHeight=294
LRDockWidth=469
Dockable=1
[ObjectTree]
Create=1
Visible=1
State=0
Left=0
Top=114
Width=250
Height=274
MaxLeft=-1
MaxTop=-1
ClientWidth=242
ClientHeight=248
TBDockHeight=248
LRDockWidth=190
Dockable=1
[DebugLogView]
Create=1
Visible=0
State=0
Left=431
Top=254
Width=417
Height=291
MaxLeft=-1
MaxTop=-1
ClientWidth=409
ClientHeight=265
TBDockHeight=291
LRDockWidth=417
Dockable=1
[CodeExplorer@EditWindow0]
Create=1
Visible=1
State=0
Left=0
Top=0
Width=1008
Height=419
MaxLeft=-1
MaxTop=-1
ClientWidth=1008
ClientHeight=419
TBDockHeight=305
LRDockWidth=140
Dockable=1
[MessageView@EditWindow0]
Create=1
Visible=0
State=0
Left=0
Top=0
Width=1008
Height=419
MaxLeft=-1
MaxTop=-1
ClientWidth=1008
ClientHeight=419
TBDockHeight=85
LRDockWidth=443
Dockable=1
[DockHosts]
DockHostCount=1
[DockSite0]
DockSiteType=1
Create=1
Visible=0
State=0
Left=4
Top=195
Width=1024
Height=474
MaxLeft=-1
MaxTop=-1
ClientWidth=1016
ClientHeight=448
TBDockHeight=474
LRDockWidth=283
Dockable=1
TabPosition=0
ActiveTab=Exploring fPtSelOptns.pas
TabDockClients=CodeExplorer@EditWindow0,MessageView@EditWindow0

BIN
CPRS-Chart/CPRSChart.dsm Normal file
View File

Binary file not shown.

BIN
CPRS-Chart/CPRSChart.exe Normal file
View File

Binary file not shown.

77282
CPRS-Chart/CPRSChart.map Normal file
View File

File diff suppressed because it is too large Load Diff

BIN
CPRS-Chart/CPRSChart.res Normal file
View File

Binary file not shown.

BIN
CPRS-Chart/CPRSChart.tlb Normal file
View File

Binary file not shown.

433
CPRS-Chart/CPRSChart_TLB.pas Normal file
View File

@ -0,0 +1,433 @@
unit CPRSChart_TLB;
// ************************************************************************ //
// WARNING
// -------
// The types declared in this file were generated from data read from a
// Type Library. If this type library is explicitly or indirectly (via
// another type library referring to this type library) re-imported, or the
// 'Refresh' command of the Type Library Editor activated while editing the
// Type Library, the contents of this file will be regenerated and all
// manual modifications will be lost.
// ************************************************************************ //
// PASTLWTR : 1.2
// File generated on 2/4/2008 6:51:03 PM from Type Library described below.
// ************************************************************************ //
// Type Lib: C:\Program Files\Borland\Delphi7\Projects\OR_SRC_CREATION FILE 12 06 06 OR_3_270\WV_Release_CPRS_OFFICIAL\CPRS-Chart\CPRSChart.tlb (1)
// LIBID: {0A4A6086-6504-11D5-82DE-00C04F72C274}
// LCID: 0
// Helpfile:
// HelpString: CPRSChart Library
// DepndLst:
// (1) v2.0 stdole, (C:\WINDOWS\system32\stdole2.tlb)
// (2) v1.1 Accessibility, (C:\WINDOWS\system32\oleacc.dll)
// ************************************************************************ //
{$TYPEDADDRESS OFF} // Unit must be compiled without type-checked pointers.
{$WARN SYMBOL_PLATFORM OFF}
{$WRITEABLECONST ON}
{$VARPROPSETTER ON}
interface
uses Windows, Accessibility_TLB, ActiveX, Classes, Graphics, StdVCL, Variants;
// *********************************************************************//
// GUIDS declared in the TypeLibrary. Following prefixes are used:
// Type Libraries : LIBID_xxxx
// CoClasses : CLASS_xxxx
// DISPInterfaces : DIID_xxxx
// Non-DISP interfaces: IID_xxxx
// *********************************************************************//
const
// TypeLibrary Major and minor versions
CPRSChartMajorVersion = 1;
CPRSChartMinorVersion = 0;
LIBID_CPRSChart: TGUID = '{0A4A6086-6504-11D5-82DE-00C04F72C274}';
IID_ICPRSBroker: TGUID = '{63DC619B-6BE0-11D5-82E6-00C04F72C274}';
IID_ICPRSState: TGUID = '{63DC619E-6BE0-11D5-82E6-00C04F72C274}';
IID_ICPRSExtension: TGUID = '{63DC61C4-6BE0-11D5-82E6-00C04F72C274}';
IID_IAccessibleStringGrid: TGUID = '{EFD768F7-59C0-48D9-889E-49EDF75488A6}';
CLASS_AccessibleStringGrid: TGUID = '{25CDBD92-C72E-47B0-9E75-9457B603000C}';
IID_IAccessibleListBox: TGUID = '{4B6A88F7-DCFE-4992-B5FC-565FDCB3829B}';
CLASS_AccessibleListBox: TGUID = '{758002E7-7012-4FAB-BD84-40D372694719}';
IID_IAccessibleTreeNode: TGUID = '{5974D1D8-0F49-45E5-AEFE-674A61F8771A}';
CLASS_AccessibleTreeNode: TGUID = '{3AD21DCA-2298-487A-8197-59B8D586C244}';
IID_IAccessibleTreeView: TGUID = '{06AA97AB-6D67-425C-B794-15FB8C62F870}';
CLASS_AccessibleTreeView: TGUID = '{507AD9F0-9ED6-4BCD-A3AB-DBA72153F14D}';
IID_IAccessibleRichEdit: TGUID = '{F2C380A5-C3DD-4AE8-81ED-C08C59E92962}';
CLASS_AccessibleRichEdit: TGUID = '{DC61493C-51FE-49A4-8749-8464A00D5CFC}';
// *********************************************************************//
// Declaration of Enumerations defined in Type Library
// *********************************************************************//
// Constants for enum BrokerParamType
type
BrokerParamType = TOleEnum;
const
bptLiteral = $00000000;
bptReference = $00000001;
bptList = $00000002;
bptUndefined = $00000003;
type
// *********************************************************************//
// Forward declaration of types defined in TypeLibrary
// *********************************************************************//
ICPRSBroker = interface;
ICPRSBrokerDisp = dispinterface;
ICPRSState = interface;
ICPRSStateDisp = dispinterface;
ICPRSExtension = interface;
ICPRSExtensionDisp = dispinterface;
IAccessibleStringGrid = interface;
IAccessibleStringGridDisp = dispinterface;
IAccessibleListBox = interface;
IAccessibleListBoxDisp = dispinterface;
IAccessibleTreeNode = interface;
IAccessibleTreeNodeDisp = dispinterface;
IAccessibleTreeView = interface;
IAccessibleTreeViewDisp = dispinterface;
IAccessibleRichEdit = interface;
IAccessibleRichEditDisp = dispinterface;
// *********************************************************************//
// Declaration of CoClasses defined in Type Library
// (NOTE: Here we map each CoClass to its Default Interface)
// *********************************************************************//
AccessibleStringGrid = IAccessibleStringGrid;
AccessibleListBox = IAccessibleListBox;
AccessibleTreeNode = IAccessibleTreeNode;
AccessibleTreeView = IAccessibleTreeView;
AccessibleRichEdit = IAccessibleRichEdit;
// *********************************************************************//
// Interface: ICPRSBroker
// Flags: (4416) Dual OleAutomation Dispatchable
// GUID: {63DC619B-6BE0-11D5-82E6-00C04F72C274}
// *********************************************************************//
ICPRSBroker = interface(IDispatch)
['{63DC619B-6BE0-11D5-82E6-00C04F72C274}']
function SetContext(const Context: WideString): WordBool; safecall;
function Server: WideString; safecall;
function Port: Integer; safecall;
function DebugMode: WordBool; safecall;
function Get_RPCVersion: WideString; safecall;
procedure Set_RPCVersion(const Value: WideString); safecall;
function Get_ClearParameters: WordBool; safecall;
procedure Set_ClearParameters(Value: WordBool); safecall;
function Get_ClearResults: WordBool; safecall;
procedure Set_ClearResults(Value: WordBool); safecall;
procedure CallRPC(const RPCName: WideString); safecall;
function Get_Results: WideString; safecall;
procedure Set_Results(const Value: WideString); safecall;
function Get_Param(Index: Integer): WideString; safecall;
procedure Set_Param(Index: Integer; const Value: WideString); safecall;
function Get_ParamType(Index: Integer): BrokerParamType; safecall;
procedure Set_ParamType(Index: Integer; Value: BrokerParamType); safecall;
function Get_ParamList(Index: Integer; const Node: WideString): WideString; safecall;
procedure Set_ParamList(Index: Integer; const Node: WideString; const Value: WideString); safecall;
function ParamCount: Integer; safecall;
function ParamListCount(Index: Integer): Integer; safecall;
property RPCVersion: WideString read Get_RPCVersion write Set_RPCVersion;
property ClearParameters: WordBool read Get_ClearParameters write Set_ClearParameters;
property ClearResults: WordBool read Get_ClearResults write Set_ClearResults;
property Results: WideString read Get_Results write Set_Results;
property Param[Index: Integer]: WideString read Get_Param write Set_Param;
property ParamType[Index: Integer]: BrokerParamType read Get_ParamType write Set_ParamType;
property ParamList[Index: Integer; const Node: WideString]: WideString read Get_ParamList write Set_ParamList;
end;
// *********************************************************************//
// DispIntf: ICPRSBrokerDisp
// Flags: (4416) Dual OleAutomation Dispatchable
// GUID: {63DC619B-6BE0-11D5-82E6-00C04F72C274}
// *********************************************************************//
ICPRSBrokerDisp = dispinterface
['{63DC619B-6BE0-11D5-82E6-00C04F72C274}']
function SetContext(const Context: WideString): WordBool; dispid 1;
function Server: WideString; dispid 2;
function Port: Integer; dispid 3;
function DebugMode: WordBool; dispid 4;
property RPCVersion: WideString dispid 5;
property ClearParameters: WordBool dispid 6;
property ClearResults: WordBool dispid 7;
procedure CallRPC(const RPCName: WideString); dispid 8;
property Results: WideString dispid 9;
property Param[Index: Integer]: WideString dispid 10;
property ParamType[Index: Integer]: BrokerParamType dispid 11;
property ParamList[Index: Integer; const Node: WideString]: WideString dispid 12;
function ParamCount: Integer; dispid 13;
function ParamListCount(Index: Integer): Integer; dispid 14;
end;
// *********************************************************************//
// Interface: ICPRSState
// Flags: (4416) Dual OleAutomation Dispatchable
// GUID: {63DC619E-6BE0-11D5-82E6-00C04F72C274}
// *********************************************************************//
ICPRSState = interface(IDispatch)
['{63DC619E-6BE0-11D5-82E6-00C04F72C274}']
function Handle: WideString; safecall;
function UserDUZ: WideString; safecall;
function UserName: WideString; safecall;
function PatientDFN: WideString; safecall;
function PatientName: WideString; safecall;
function PatientDOB: WideString; safecall;
function PatientSSN: WideString; safecall;
function LocationIEN: Integer; safecall;
function LocationName: WideString; safecall;
end;
// *********************************************************************//
// DispIntf: ICPRSStateDisp
// Flags: (4416) Dual OleAutomation Dispatchable
// GUID: {63DC619E-6BE0-11D5-82E6-00C04F72C274}
// *********************************************************************//
ICPRSStateDisp = dispinterface
['{63DC619E-6BE0-11D5-82E6-00C04F72C274}']
function Handle: WideString; dispid 1;
function UserDUZ: WideString; dispid 2;
function UserName: WideString; dispid 3;
function PatientDFN: WideString; dispid 4;
function PatientName: WideString; dispid 5;
function PatientDOB: WideString; dispid 6;
function PatientSSN: WideString; dispid 7;
function LocationIEN: Integer; dispid 8;
function LocationName: WideString; dispid 9;
end;
// *********************************************************************//
// Interface: ICPRSExtension
// Flags: (4416) Dual OleAutomation Dispatchable
// GUID: {63DC61C4-6BE0-11D5-82E6-00C04F72C274}
// *********************************************************************//
ICPRSExtension = interface(IDispatch)
['{63DC61C4-6BE0-11D5-82E6-00C04F72C274}']
function Execute(const CPRSBroker: ICPRSBroker; const CPRSState: ICPRSState;
const Param1: WideString; const Param2: WideString; const Param3: WideString;
var Data1: WideString; var Data2: WideString): WordBool; safecall;
end;
// *********************************************************************//
// DispIntf: ICPRSExtensionDisp
// Flags: (4416) Dual OleAutomation Dispatchable
// GUID: {63DC61C4-6BE0-11D5-82E6-00C04F72C274}
// *********************************************************************//
ICPRSExtensionDisp = dispinterface
['{63DC61C4-6BE0-11D5-82E6-00C04F72C274}']
function Execute(const CPRSBroker: ICPRSBroker; const CPRSState: ICPRSState;
const Param1: WideString; const Param2: WideString; const Param3: WideString;
var Data1: WideString; var Data2: WideString): WordBool; dispid 1;
end;
// *********************************************************************//
// Interface: IAccessibleStringGrid
// Flags: (4416) Dual OleAutomation Dispatchable
// GUID: {EFD768F7-59C0-48D9-889E-49EDF75488A6}
// *********************************************************************//
IAccessibleStringGrid = interface(IDispatch)
['{EFD768F7-59C0-48D9-889E-49EDF75488A6}']
end;
// *********************************************************************//
// DispIntf: IAccessibleStringGridDisp
// Flags: (4416) Dual OleAutomation Dispatchable
// GUID: {EFD768F7-59C0-48D9-889E-49EDF75488A6}
// *********************************************************************//
IAccessibleStringGridDisp = dispinterface
['{EFD768F7-59C0-48D9-889E-49EDF75488A6}']
end;
// *********************************************************************//
// Interface: IAccessibleListBox
// Flags: (4416) Dual OleAutomation Dispatchable
// GUID: {4B6A88F7-DCFE-4992-B5FC-565FDCB3829B}
// *********************************************************************//
IAccessibleListBox = interface(IDispatch)
['{4B6A88F7-DCFE-4992-B5FC-565FDCB3829B}']
end;
// *********************************************************************//
// DispIntf: IAccessibleListBoxDisp
// Flags: (4416) Dual OleAutomation Dispatchable
// GUID: {4B6A88F7-DCFE-4992-B5FC-565FDCB3829B}
// *********************************************************************//
IAccessibleListBoxDisp = dispinterface
['{4B6A88F7-DCFE-4992-B5FC-565FDCB3829B}']
end;
// *********************************************************************//
// Interface: IAccessibleTreeNode
// Flags: (4416) Dual OleAutomation Dispatchable
// GUID: {5974D1D8-0F49-45E5-AEFE-674A61F8771A}
// *********************************************************************//
IAccessibleTreeNode = interface(IDispatch)
['{5974D1D8-0F49-45E5-AEFE-674A61F8771A}']
end;
// *********************************************************************//
// DispIntf: IAccessibleTreeNodeDisp
// Flags: (4416) Dual OleAutomation Dispatchable
// GUID: {5974D1D8-0F49-45E5-AEFE-674A61F8771A}
// *********************************************************************//
IAccessibleTreeNodeDisp = dispinterface
['{5974D1D8-0F49-45E5-AEFE-674A61F8771A}']
end;
// *********************************************************************//
// Interface: IAccessibleTreeView
// Flags: (4416) Dual OleAutomation Dispatchable
// GUID: {06AA97AB-6D67-425C-B794-15FB8C62F870}
// *********************************************************************//
IAccessibleTreeView = interface(IDispatch)
['{06AA97AB-6D67-425C-B794-15FB8C62F870}']
end;
// *********************************************************************//
// DispIntf: IAccessibleTreeViewDisp
// Flags: (4416) Dual OleAutomation Dispatchable
// GUID: {06AA97AB-6D67-425C-B794-15FB8C62F870}
// *********************************************************************//
IAccessibleTreeViewDisp = dispinterface
['{06AA97AB-6D67-425C-B794-15FB8C62F870}']
end;
// *********************************************************************//
// Interface: IAccessibleRichEdit
// Flags: (4416) Dual OleAutomation Dispatchable
// GUID: {F2C380A5-C3DD-4AE8-81ED-C08C59E92962}
// *********************************************************************//
IAccessibleRichEdit = interface(IDispatch)
['{F2C380A5-C3DD-4AE8-81ED-C08C59E92962}']
end;
// *********************************************************************//
// DispIntf: IAccessibleRichEditDisp
// Flags: (4416) Dual OleAutomation Dispatchable
// GUID: {F2C380A5-C3DD-4AE8-81ED-C08C59E92962}
// *********************************************************************//
IAccessibleRichEditDisp = dispinterface
['{F2C380A5-C3DD-4AE8-81ED-C08C59E92962}']
end;
// *********************************************************************//
// The Class CoAccessibleStringGrid provides a Create and CreateRemote method to
// create instances of the default interface IAccessibleStringGrid exposed by
// the CoClass AccessibleStringGrid. The functions are intended to be used by
// clients wishing to automate the CoClass objects exposed by the
// server of this typelibrary.
// *********************************************************************//
CoAccessibleStringGrid = class
class function Create: IAccessibleStringGrid;
class function CreateRemote(const MachineName: string): IAccessibleStringGrid;
end;
// *********************************************************************//
// The Class CoAccessibleListBox provides a Create and CreateRemote method to
// create instances of the default interface IAccessibleListBox exposed by
// the CoClass AccessibleListBox. The functions are intended to be used by
// clients wishing to automate the CoClass objects exposed by the
// server of this typelibrary.
// *********************************************************************//
CoAccessibleListBox = class
class function Create: IAccessibleListBox;
class function CreateRemote(const MachineName: string): IAccessibleListBox;
end;
// *********************************************************************//
// The Class CoAccessibleTreeNode provides a Create and CreateRemote method to
// create instances of the default interface IAccessibleTreeNode exposed by
// the CoClass AccessibleTreeNode. The functions are intended to be used by
// clients wishing to automate the CoClass objects exposed by the
// server of this typelibrary.
// *********************************************************************//
CoAccessibleTreeNode = class
class function Create: IAccessibleTreeNode;
class function CreateRemote(const MachineName: string): IAccessibleTreeNode;
end;
// *********************************************************************//
// The Class CoAccessibleTreeView provides a Create and CreateRemote method to
// create instances of the default interface IAccessibleTreeView exposed by
// the CoClass AccessibleTreeView. The functions are intended to be used by
// clients wishing to automate the CoClass objects exposed by the
// server of this typelibrary.
// *********************************************************************//
CoAccessibleTreeView = class
class function Create: IAccessibleTreeView;
class function CreateRemote(const MachineName: string): IAccessibleTreeView;
end;
// *********************************************************************//
// The Class CoAccessibleRichEdit provides a Create and CreateRemote method to
// create instances of the default interface IAccessibleRichEdit exposed by
// the CoClass AccessibleRichEdit. The functions are intended to be used by
// clients wishing to automate the CoClass objects exposed by the
// server of this typelibrary.
// *********************************************************************//
CoAccessibleRichEdit = class
class function Create: IAccessibleRichEdit;
class function CreateRemote(const MachineName: string): IAccessibleRichEdit;
end;
implementation
uses ComObj;
class function CoAccessibleStringGrid.Create: IAccessibleStringGrid;
begin
Result := CreateComObject(CLASS_AccessibleStringGrid) as IAccessibleStringGrid;
end;
class function CoAccessibleStringGrid.CreateRemote(const MachineName: string): IAccessibleStringGrid;
begin
Result := CreateRemoteComObject(MachineName, CLASS_AccessibleStringGrid) as IAccessibleStringGrid;
end;
class function CoAccessibleListBox.Create: IAccessibleListBox;
begin
Result := CreateComObject(CLASS_AccessibleListBox) as IAccessibleListBox;
end;
class function CoAccessibleListBox.CreateRemote(const MachineName: string): IAccessibleListBox;
begin
Result := CreateRemoteComObject(MachineName, CLASS_AccessibleListBox) as IAccessibleListBox;
end;
class function CoAccessibleTreeNode.Create: IAccessibleTreeNode;
begin
Result := CreateComObject(CLASS_AccessibleTreeNode) as IAccessibleTreeNode;
end;
class function CoAccessibleTreeNode.CreateRemote(const MachineName: string): IAccessibleTreeNode;
begin
Result := CreateRemoteComObject(MachineName, CLASS_AccessibleTreeNode) as IAccessibleTreeNode;
end;
class function CoAccessibleTreeView.Create: IAccessibleTreeView;
begin
Result := CreateComObject(CLASS_AccessibleTreeView) as IAccessibleTreeView;
end;
class function CoAccessibleTreeView.CreateRemote(const MachineName: string): IAccessibleTreeView;
begin
Result := CreateRemoteComObject(MachineName, CLASS_AccessibleTreeView) as IAccessibleTreeView;
end;
class function CoAccessibleRichEdit.Create: IAccessibleRichEdit;
begin
Result := CreateComObject(CLASS_AccessibleRichEdit) as IAccessibleRichEdit;
end;
class function CoAccessibleRichEdit.CreateRemote(const MachineName: string): IAccessibleRichEdit;
begin
Result := CreateRemoteComObject(MachineName, CLASS_AccessibleRichEdit) as IAccessibleRichEdit;
end;
end.

8
CPRS-Chart/Consults/FormResize.txt Normal file
View File

@ -0,0 +1,8 @@
procedure TfrmODCslt.FormResize(Sender: TObject);
begin
inherited;
memOrder.Top := pnlReason.Top + pnlReason.Height + 2;
pnlMessage.Top := memOrder.Top + 2;
cmdAccept.Top := pnlMessage.Top;
cmdQuit.Top := cmdAccept.Top;
end;

182
CPRS-Chart/Consults/fConsMedRslt.dfm Normal file
View File

@ -0,0 +1,182 @@
object frmConsMedRslt: TfrmConsMedRslt
Left = 468
Top = 172
BorderStyle = bsDialog
Caption = 'Select Medicine Result'
ClientHeight = 242
ClientWidth = 505
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = True
Position = poScreenCenter
OnDestroy = FormDestroy
PixelsPerInch = 96
TextHeight = 13
object pnlBase: TORAutoPanel
Left = 0
Top = 0
Width = 505
Height = 242
Align = alClient
BevelOuter = bvNone
TabOrder = 0
object SrcLabel: TLabel
Left = 12
Top = 6
Width = 145
Height = 16
AutoSize = False
Caption = 'Select medicine result:'
end
object lblDateofAction: TOROffsetLabel
Left = 133
Top = 159
Width = 112
Height = 19
Caption = 'Date/time of this action'
HorzOffset = 2
Transparent = False
VertOffset = 6
WordWrap = False
end
object lblActionBy: TOROffsetLabel
Left = 266
Top = 159
Width = 215
Height = 19
Caption = 'Action by'
HorzOffset = 2
Transparent = False
VertOffset = 6
WordWrap = False
end
object lblResultName: TOROffsetLabel
Left = 27
Top = 29
Width = 90
Height = 15
Caption = 'Type of Result'
HorzOffset = 2
Transparent = False
VertOffset = 2
WordWrap = False
end
object lblResultDate: TOROffsetLabel
Left = 255
Top = 29
Width = 74
Height = 15
Caption = 'Date of Result'
HorzOffset = 2
Transparent = False
VertOffset = 2
WordWrap = False
end
object lblSummary: TOROffsetLabel
Left = 375
Top = 29
Width = 45
Height = 15
Caption = 'Summary'
HorzOffset = 2
Transparent = False
VertOffset = 2
WordWrap = False
end
object cmdOK: TButton
Left = 332
Top = 211
Width = 75
Height = 21
Caption = 'OK'
Default = True
TabOrder = 5
OnClick = cmdOKClick
end
object cmdCancel: TButton
Left = 412
Top = 211
Width = 75
Height = 21
Cancel = True
Caption = 'Cancel'
TabOrder = 6
OnClick = cmdCancelClick
end
object lstMedResults: TORListBox
Left = 15
Top = 45
Width = 476
Height = 114
Style = lbOwnerDrawFixed
ItemHeight = 13
ParentShowHint = False
ShowHint = True
Sorted = True
TabOrder = 0
OnDrawItem = lstMedResultsDrawItem
Caption = 'Select medicine result'
ItemTipColor = clWindow
LongList = False
Pieces = '2,3,4'
TabPositions = '40,60'
end
object cmdDetails: TButton
Left = 15
Top = 179
Width = 75
Height = 21
Caption = 'Show Details'
TabOrder = 1
OnClick = cmdDetailsClick
end
object ckAlert: TCheckBox
Left = 131
Top = 211
Width = 79
Height = 17
Caption = 'Send alert'
TabOrder = 4
OnClick = ckAlertClick
end
object calDateofAction: TORDateBox
Left = 133
Top = 179
Width = 116
Height = 21
TabStop = False
TabOrder = 2
Text = 'Now'
DateOnly = False
RequireTime = False
Caption = 'Date/time of this action'
end
object cboPerson: TORComboBox
Left = 265
Top = 179
Width = 220
Height = 21
Style = orcsDropDown
AutoSelect = True
Caption = 'Action by'
Color = clWindow
DropDownCount = 8
ItemHeight = 13
ItemTipColor = clWindow
ItemTipEnable = True
ListItemsOnly = True
LongList = True
LookupPiece = 2
MaxLength = 0
Pieces = '2,3'
Sorted = False
SynonymChars = '<>'
TabOrder = 3
OnNeedData = NewPersonNeedData
end
end
end

212
CPRS-Chart/Consults/fConsMedRslt.pas Normal file
View File

@ -0,0 +1,212 @@
unit fConsMedRslt;
interface
uses Windows, SysUtils, Classes, Graphics, Forms, Controls, StdCtrls,
Buttons, ORCtrls, ORfn, ExtCtrls, fAutoSz, ORDtTm, fConsultAlertTo, fRptBox;
type
TMedResultRec = record
Action: string;
ResultPtr: string;
DateTimeofAction: TFMDateTime;
ResponsiblePerson: Int64;
AlertsTo: TRecipientList;
end;
TfrmConsMedRslt = class(TfrmAutoSz)
cmdOK: TButton;
cmdCancel: TButton;
lstMedResults: TORListBox;
SrcLabel: TLabel;
pnlBase: TORAutoPanel;
cmdDetails: TButton;
ckAlert: TCheckBox;
lblDateofAction: TOROffsetLabel;
calDateofAction: TORDateBox;
lblActionBy: TOROffsetLabel;
cboPerson: TORComboBox;
lblResultName: TOROffsetLabel;
lblResultDate: TOROffsetLabel;
lblSummary: TOROffsetLabel;
procedure cmdOKClick(Sender: TObject);
procedure cmdCancelClick(Sender: TObject);
procedure cmdDetailsClick(Sender: TObject);
procedure ckAlertClick(Sender: TObject);
procedure NewPersonNeedData(Sender: TObject; const StartFrom: String;
Direction, InsertAt: Integer);
procedure FormDestroy(Sender: TObject);
procedure lstMedResultsDrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
protected
procedure ShowDetailsDestroyed(Sender: TObject);
private
FShowDetails: TfrmReportBox;
FOldShowDetailsOnDestroy: TNotifyEvent;
FMedResult: TMedResultRec ;
FChanged: Boolean;
end;
function SelectMedicineResult(ConsultIEN: integer; FormTitle: string; var MedResult: TMedResultRec): boolean ;
implementation
{$R *.DFM}
uses rConsults, rCore, uCore, uConst;
const
TX_MEDRSLT_TEXT = 'Select medicine result or press Cancel.';
TX_MEDRSLT_CAP = 'No Result Selected';
var
RecipientList: TRecipientList ;
function SelectMedicineResult(ConsultIEN: integer; FormTitle: string; var MedResult: TMedResultRec): boolean ;
{ displays Medicine Result selection form and returns a record of the selection }
var
frmConsMedRslt: TfrmConsMedRslt;
begin
frmConsMedRslt := TfrmConsMedRslt.Create(Application);
try
with frmConsMedRslt do
begin
FChanged := False;
FillChar(RecipientList, SizeOf(RecipientList), 0);
FillChar(FMedResult, SizeOf(FMedResult), 0);
Caption := FormTitle;
cboPerson.InitLongList(User.Name);
cboPerson.SelectByIEN(User.DUZ);
ResizeFormToFont(TForm(frmConsMedRslt));
if MedResult.Action = 'ATTACH' then
begin
lstMedResults.Items.Assign(GetAssignableMedResults(ConsultIEN));
ckAlert.Visible := True;
end
else if MedResult.Action = 'REMOVE' then
begin
lstMedResults.Items.Assign(GetRemovableMedResults(ConsultIEN));
ckAlert.Visible := False;
end;
if lstMedResults.Items.Count > 0 then
ShowModal
else
FChanged := True;
Result := FChanged;
MedResult := FMedResult;
end; {with frmODConsMedRslt}
finally
frmConsMedRslt.Release;
end;
end;
procedure TfrmConsMedRslt.cmdCancelClick(Sender: TObject);
begin
FillChar(FMedResult, SizeOf(FMedResult), 0);
FChanged := False;
Close;
end;
procedure TfrmConsMedRslt.cmdOKClick(Sender: TObject);
begin
FillChar(FMedResult, SizeOf(FMedResult), 0);
if lstMedResults.ItemIndex = -1 then
begin
InfoBox(TX_MEDRSLT_TEXT, TX_MEDRSLT_CAP, MB_OK or MB_ICONWARNING);
FChanged := False ;
Exit;
end;
FChanged := True;
with FMedResult do
begin
ResultPtr := lstMedResults.ItemID ;
DateTimeofAction := calDateOfAction.FMDateTime;
ResponsiblePerson := cboPerson.ItemIEN;
AlertsTo := RecipientList;
end;
Close;
end;
procedure TfrmConsMedRslt.cmdDetailsClick(Sender: TObject);
const
TX_RESULTS_CAP = 'Detailed Results Display';
var
x: string;
begin
inherited;
if lstMedResults.ItemIndex = -1 then exit;
x := Piece(Piece(Piece(lstMedResults.ItemID, ';', 2), '(', 2), ',', 1) + ';' + Piece(lstMedResults.ItemID, ';', 1);
NotifyOtherApps(NAE_REPORT, 'MED^' + x);
if(not assigned(FShowDetails)) then
begin
FShowDetails := ModelessReportBox(GetDetailedMedicineResults(lstMedResults.ItemID), TX_RESULTS_CAP, True);
FOldShowDetailsOnDestroy := FShowDetails.OnDestroy;
FShowDetails.OnDestroy := ShowDetailsDestroyed;
cmdDetails.Enabled := (not assigned(FShowDetails));
lstMedResults.Enabled := (not assigned(FShowDetails));
end;
end;
procedure TfrmConsMedRslt.ShowDetailsDestroyed(Sender: TObject);
begin
if(assigned(FOldShowDetailsOnDestroy)) then
FOldShowDetailsOnDestroy(Sender);
FShowDetails := nil;
cmdDetails.Enabled := (not assigned(FShowDetails));
lstMedResults.Enabled := (not assigned(FShowDetails));
end;
procedure TfrmConsMedRslt.ckAlertClick(Sender: TObject);
begin
FillChar(RecipientList, SizeOf(RecipientList), 0);
if ckAlert.Checked then SelectRecipients(Font.Size, 0, RecipientList) ;
end;
procedure TfrmConsMedRslt.NewPersonNeedData(Sender: TObject; const StartFrom: string;
Direction, InsertAt: Integer);
begin
inherited;
(Sender as TORComboBox).ForDataUse(SubSetOfPersons(StartFrom, Direction));
end;
procedure TfrmConsMedRslt.FormDestroy(Sender: TObject);
begin
inherited;
KillObj(@FShowDetails);
end;
procedure TfrmConsMedRslt.lstMedResultsDrawItem(Control: TWinControl;
Index: Integer; Rect: TRect; State: TOwnerDrawState);
var
x: string;
AnImage: TBitMap;
const
STD_PROC_TEXT = 'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX';
STD_DATE = 'MMM DD,YY@HH:NNXX';
begin
inherited;
AnImage := TBitMap.Create;
try
with (Control as TORListBox).Canvas do { draw on control canvas, not on the form }
begin
x := (Control as TORListBox).Items[Index];
FillRect(Rect); { clear the rectangle }
AnImage.LoadFromResourceName(hInstance, 'BMP_IMAGEFLAG_1');
(Control as TORListBox).ItemHeight := HigherOf(TextHeight(x), AnImage.Height);
if StrToIntDef(Piece(x, U, 5), 0) > 0 then
begin
BrushCopy(Bounds(Rect.Left, Rect.Top, AnImage.Width, AnImage.Height),
AnImage, Bounds(0, 0, AnImage.Width, AnImage.Height), clRed); {render ImageFlag}
end;
TextOut(Rect.Left + AnImage.Width, Rect.Top, Piece(x, U, 2));
TextOut(Rect.Left + AnImage.Width + TextWidth(STD_PROC_TEXT), Rect.Top, Piece(x, U, 3));
TextOut(Rect.Left + AnImage.Width + TextWidth(STD_PROC_TEXT) + TextWidth(STD_DATE), Rect.Top, Piece(x, U, 4));
end;
finally
AnImage.Free;
end;
end;
end.

167
CPRS-Chart/Consults/fConsult513Prt.dfm Normal file
View File

@ -0,0 +1,167 @@
object frm513Print: Tfrm513Print
Left = 116
Top = 375
AutoScroll = False
Caption = 'Print SF 513'
ClientHeight = 308
ClientWidth = 427
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = True
Position = poScreenCenter
OnCreate = FormCreate
OnDestroy = FormDestroy
PixelsPerInch = 96
TextHeight = 13
object lblPrintTo: TLabel
Left = 7
Top = 265
Width = 3
Height = 13
end
object lblConsultTitle: TMemo
Left = 10
Top = 8
Width = 301
Height = 53
BorderStyle = bsNone
Color = clBtnFace
Lines.Strings = (
'Consult Title, Date/Time of Consult, Location')
ReadOnly = True
TabOrder = 0
end
object grpChooseCopy: TGroupBox
Left = 321
Top = 4
Width = 98
Height = 61
Caption = 'Print'
TabOrder = 1
object radChartCopy: TRadioButton
Left = 8
Top = 16
Width = 81
Height = 17
Caption = '&Chart Copy'
Checked = True
TabOrder = 0
TabStop = True
OnClick = radChartCopyClick
end
object radWorkCopy: TRadioButton
Left = 8
Top = 36
Width = 81
Height = 17
Caption = '&Work Copy'
TabOrder = 1
OnClick = radWorkCopyClick
end
end
object grpDevice: TGroupBox
Left = 8
Top = 69
Width = 411
Height = 192
Caption = 'Device'
TabOrder = 2
object lblMargin: TLabel
Left = 8
Top = 166
Width = 60
Height = 13
Caption = 'Right Margin'
end
object lblLength: TLabel
Left = 120
Top = 166
Width = 61
Height = 13
Caption = 'Page Length'
end
object txtRightMargin: TMaskEdit
Left = 72
Top = 164
Width = 34
Height = 19
AutoSize = False
EditMask = '99999;0; '
MaxLength = 5
TabOrder = 1
end
object txtPageLength: TMaskEdit
Left = 184
Top = 164
Width = 34
Height = 19
AutoSize = False
EditMask = '99999;0; '
MaxLength = 5
TabOrder = 2
end
object cboDevice: TORComboBox
Left = 8
Top = 16
Width = 395
Height = 140
Style = orcsSimple
AutoSelect = True
Caption = 'Device'
Color = clWindow
DropDownCount = 8
ItemHeight = 13
ItemTipColor = clWindow
ItemTipEnable = True
ListItemsOnly = True
LongList = True
LookupPiece = 0
MaxLength = 0
ParentShowHint = False
Pieces = '2,4'
ShowHint = True
Sorted = False
SynonymChars = '<>'
TabPositions = '30'
TabOrder = 0
OnChange = cboDeviceChange
OnNeedData = cboDeviceNeedData
end
end
object cmdOK: TButton
Left = 267
Top = 272
Width = 72
Height = 22
Caption = 'OK'
Default = True
TabOrder = 4
OnClick = cmdOKClick
end
object cmdCancel: TButton
Left = 347
Top = 272
Width = 72
Height = 22
Cancel = True
Caption = 'Cancel'
TabOrder = 5
OnClick = cmdCancelClick
end
object chkDefault: TCheckBox
Left = 7
Top = 288
Width = 166
Height = 17
Caption = 'Save as user'#39's default printer'
TabOrder = 3
end
object dlgWinPrinter: TPrintDialog
Left = 268
Top = 26
end
end

200
CPRS-Chart/Consults/fConsult513Prt.pas Normal file
View File

@ -0,0 +1,200 @@
unit fConsult513Prt;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
fAutoSz, ORCtrls, StdCtrls, Mask, ORNet, ORFn, ComCtrls;
type
Tfrm513Print = class(TfrmAutoSz)
grpChooseCopy: TGroupBox;
radChartCopy: TRadioButton;
radWorkCopy: TRadioButton;
grpDevice: TGroupBox;
lblMargin: TLabel;
lblLength: TLabel;
txtRightMargin: TMaskEdit;
txtPageLength: TMaskEdit;
cmdOK: TButton;
cmdCancel: TButton;
lblConsultTitle: TMemo;
cboDevice: TORComboBox;
lblPrintTo: TLabel;
dlgWinPrinter: TPrintDialog;
chkDefault: TCheckBox;
procedure cboDeviceNeedData(Sender: TObject; const StartFrom: String;
Direction, InsertAt: Integer);
procedure FormCreate(Sender: TObject);
procedure cboDeviceChange(Sender: TObject);
procedure radChartCopyClick(Sender: TObject);
procedure radWorkCopyClick(Sender: TObject);
procedure cmdOKClick(Sender: TObject);
procedure cmdCancelClick(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
{ Private declarations }
FConsult: Integer;
FReportText: TRichEdit;
procedure DisplaySelectDevice;
public
{ Public declarations }
end;
procedure PrintSF513(AConsult: Longint; AConsultTitle: string);
implementation
{$R *.DFM}
uses rCore, rConsults, Printers, rReports, uCore;
const
TX_NODEVICE = 'A device must be selected to print, or press ''Cancel'' to not print.';
TX_NODEVICE_CAP = 'Device Not Selected';
TX_ERR_CAP = 'Print Error';
TX_QUEUED_CAP = 'Printing Report' ;
PAGE_BREAK = '**PAGE BREAK**';
procedure PrintSF513(AConsult: Longint; AConsultTitle: string);
{ displays a form that prompts for a device and then prints the SF513 }
var
frm513Print: Tfrm513Print;
DefPrt: string;
begin
frm513Print := Tfrm513Print.Create(Application);
try
ResizeFormToFont(TForm(frm513Print));
with frm513Print do
begin
lblConsultTitle.Text := AConsultTitle;
FConsult := AConsult;
DefPrt := GetDefaultPrinter(User.Duz, Encounter.Location);
if User.CurrentPrinter = '' then User.CurrentPrinter := DefPrt;
with cboDevice do
begin
if Printer.Printers.Count > 0 then
begin
Items.Add('WIN;Windows Printer^Windows Printer');
Items.Add('^--------------------VistA Printers----------------------');
end;
if User.CurrentPrinter <> '' then
begin
InitLongList(Piece(User.CurrentPrinter, ';', 2));
SelectByID(User.CurrentPrinter);
end
else
InitLongList('');
end;
if (DefPrt = 'WIN;Windows Printer') and
(User.CurrentPrinter = DefPrt) then
cmdOKClick(frm513Print)
else
ShowModal;
end;
finally
frm513Print.Release;
end;
end;
procedure Tfrm513Print.FormCreate(Sender: TObject);
begin
inherited;
FReportText := TRichEdit.Create(Self);
with FReportText do
begin
Parent := Self;
Visible := False;
Width := 600;
end;
end;
procedure Tfrm513Print.DisplaySelectDevice;
begin
with cboDevice, lblPrintTo do
begin
if radChartCopy.Checked then Caption := 'Print Chart Copy on: ' + Piece(ItemID, ';', 2);
if radWorkCopy.Checked then Caption := 'Print Work Copy on: ' + Piece(ItemID, ';', 2);
end;
end;
procedure Tfrm513Print.cboDeviceNeedData(Sender: TObject; const StartFrom: string;
Direction, InsertAt: Integer);
begin
inherited;
cboDevice.ForDataUse(SubsetOfDevices(StartFrom, Direction));
end;
procedure Tfrm513Print.cboDeviceChange(Sender: TObject);
begin
inherited;
with cboDevice do if ItemIndex > -1 then
begin
txtRightMargin.Text := Piece(Items[ItemIndex], '^', 4);
txtPageLength.Text := Piece(Items[ItemIndex], '^', 5);
DisplaySelectDevice;
end;
end;
procedure Tfrm513Print.radChartCopyClick(Sender: TObject);
begin
inherited;
DisplaySelectDevice;
end;
procedure Tfrm513Print.radWorkCopyClick(Sender: TObject);
begin
inherited;
DisplaySelectDevice;
end;
procedure Tfrm513Print.cmdOKClick(Sender: TObject);
var
ADevice, ErrMsg: string;
ChartCopy: string;
RemoteSiteID: string; //for Remote site printing
RemoteQuery: string; //for Remote site printing
begin
inherited;
RemoteSiteID := '';
RemoteQuery := '';
if cboDevice.ItemID = '' then
begin
InfoBox(TX_NODEVICE, TX_NODEVICE_CAP, MB_OK);
Exit;
end;
if radChartCopy.Checked then ChartCopy := 'C' else ChartCopy := 'W';
if Piece(cboDevice.ItemID, ';', 1) = 'WIN' then
begin
if dlgWinPrinter.Execute then with FReportText do
begin
FReportText.Lines.Assign(GetFormattedSF513(FConsult, ChartCopy));
PrintWindowsReport(FReportText, PAGE_BREAK, Self.Caption, ErrMsg);
if Length(ErrMsg) > 0 then InfoBox(ErrMsg, TX_ERR_CAP, MB_OK);
end;
end
else
begin
ADevice := Piece(cboDevice.ItemID, ';', 2);
PrintSF513ToDevice(FConsult, ADevice, ChartCopy, ErrMsg);
ErrMsg := Piece(FReportText.Lines[0], U, 2);
if Length(ErrMsg) > 0 then InfoBox(ErrMsg, TX_ERR_CAP, MB_OK);
end;
if chkDefault.Checked then SaveDefaultPrinter(Piece(cboDevice.ItemID, ';', 1));
User.CurrentPrinter := cboDevice.ItemID;
Close;
end;
procedure Tfrm513Print.cmdCancelClick(Sender: TObject);
begin
inherited;
Close;
end;
procedure Tfrm513Print.FormDestroy(Sender: TObject);
begin
FReportText.Free;
inherited;
end;
end.

362
CPRS-Chart/Consults/fConsultAct.dfm Normal file
View File

@ -0,0 +1,362 @@
object frmConsultAction: TfrmConsultAction
Left = 277
Top = 217
Width = 600
Height = 406
BorderIcons = []
Caption = 'frmConsultAction'
Color = clBtnFace
Constraints.MinHeight = 406
Constraints.MinWidth = 600
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = True
Position = poScreenCenter
PixelsPerInch = 96
TextHeight = 13
object pnlBase: TPanel
Left = 0
Top = 0
Width = 592
Height = 379
Align = alClient
BevelOuter = bvNone
TabOrder = 0
object pnlForward: TPanel
Left = 0
Top = 0
Width = 224
Height = 379
Align = alLeft
BevelOuter = bvNone
TabOrder = 0
object lblToService: TOROffsetLabel
Left = 2
Top = 0
Width = 120
Height = 19
Caption = 'To service'
HorzOffset = 2
Transparent = False
VertOffset = 6
WordWrap = False
end
object lblAttentionOf: TOROffsetLabel
Left = 2
Top = 325
Width = 44
Height = 19
Caption = 'Attention'
HorzOffset = 2
Transparent = False
VertOffset = 6
WordWrap = False
end
object lblUrgency: TOROffsetLabel
Left = 2
Top = 277
Width = 42
Height = 19
Caption = 'Urgency'
HorzOffset = 2
Transparent = False
VertOffset = 6
WordWrap = False
end
object Label1: TMemo
Left = 18
Top = 123
Width = 185
Height = 65
TabStop = False
Alignment = taCenter
BorderStyle = bsNone
Color = clBtnFace
Lines.Strings = (
'A procedure can only be forwarded to '
'other services defined as being able to '
'perform that procedure. Valid '
'selections for this procedure are listed '
'in the drop-down box above.')
ReadOnly = True
TabOrder = 4
end
object cboAttentionOf: TORComboBox
Left = 2
Top = 344
Width = 212
Height = 21
Style = orcsDropDown
AutoSelect = True
Caption = 'Attention'
Color = clWindow
DropDownCount = 8
ItemHeight = 13
ItemTipColor = clWindow
ItemTipEnable = True
ListItemsOnly = True
LongList = True
LookupPiece = 2
MaxLength = 0
Pieces = '2,3'
Sorted = False
SynonymChars = '<>'
TabOrder = 3
OnNeedData = NewPersonNeedData
CharsNeedMatch = 1
end
object cboUrgency: TORComboBox
Left = 2
Top = 297
Width = 212
Height = 21
Style = orcsDropDown
AutoSelect = True
Caption = 'Urgency'
Color = clWindow
DropDownCount = 8
ItemHeight = 13
ItemTipColor = clWindow
ItemTipEnable = True
ListItemsOnly = True
LongList = False
LookupPiece = 0
MaxLength = 0
Pieces = '2'
Sorted = False
SynonymChars = '<>'
TabOrder = 2
CharsNeedMatch = 1
end
object treService: TORTreeView
Left = 2
Top = 100
Width = 212
Height = 182
HideSelection = False
Indent = 19
ReadOnly = True
TabOrder = 1
OnChange = treServiceChange
OnExit = treServiceExit
Caption = 'To service'
NodePiece = 0
end
object cboService: TORComboBox
Left = 2
Top = 23
Width = 212
Height = 75
Style = orcsSimple
AutoSelect = True
Caption = 'To service'
Color = clWindow
DropDownCount = 8
ItemHeight = 13
ItemTipColor = clWindow
ItemTipEnable = True
ListItemsOnly = True
LongList = False
LookupPiece = 0
MaxLength = 0
Pieces = '2'
Sorted = True
SynonymChars = '<>'
TabOrder = 0
OnKeyPause = cboServiceSelect
OnMouseClick = cboServiceSelect
CharsNeedMatch = 1
end
end
object pnlOther: TPanel
Left = 224
Top = 0
Width = 368
Height = 379
Align = alClient
BevelOuter = bvNone
TabOrder = 1
object pnlSigFind: TPanel
Left = 0
Top = 0
Width = 368
Height = 57
Align = alTop
BevelOuter = bvNone
TabOrder = 0
object grpSigFindings: TRadioGroup
Left = 9
Top = 7
Width = 350
Height = 41
Caption = 'Significant Findings - Current status: '
Columns = 3
Ctl3D = True
Items.Strings = (
'&Yes'
'&No'
'&Unknown')
ParentCtl3D = False
TabOrder = 0
end
end
object pnlComments: TPanel
Left = 0
Top = 57
Width = 368
Height = 224
Align = alClient
Alignment = taLeftJustify
BevelOuter = bvNone
TabOrder = 1
object lblComments: TOROffsetLabel
Left = 0
Top = 0
Width = 368
Height = 19
Align = alTop
Caption = 'Comments'
HorzOffset = 2
Transparent = False
VertOffset = 6
WordWrap = False
end
object memComments: TCaptionMemo
Left = 0
Top = 19
Width = 368
Height = 170
Align = alClient
Font.Charset = ANSI_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Courier New'
Font.Style = []
ParentFont = False
ScrollBars = ssVertical
TabOrder = 0
Caption = 'Comments'
end
object pnlAlert: TPanel
Left = 0
Top = 189
Width = 368
Height = 35
Align = alBottom
BevelOuter = bvNone
TabOrder = 1
object lblAutoAlerts: TStaticText
Left = 6
Top = 1
Width = 4
Height = 4
TabOrder = 1
end
object ckAlert: TCheckBox
Left = 6
Top = 17
Width = 129
Height = 17
Caption = 'Send additional alerts'
TabOrder = 0
OnClick = ckAlertClick
end
end
end
object pnlAllActions: TPanel
Left = 0
Top = 281
Width = 368
Height = 98
Align = alBottom
BevelOuter = bvNone
TabOrder = 2
DesignSize = (
368
98)
object lblActionBy: TOROffsetLabel
Left = 138
Top = -4
Width = 215
Height = 19
Caption = 'Action by'
HorzOffset = 2
Transparent = False
VertOffset = 6
WordWrap = False
end
object lblDateofAction: TOROffsetLabel
Left = 5
Top = -4
Width = 112
Height = 19
Caption = 'Date/time of this action'
HorzOffset = 2
Transparent = False
VertOffset = 6
WordWrap = False
end
object calDateofAction: TORDateBox
Left = 5
Top = 15
Width = 116
Height = 21
TabOrder = 0
Text = 'Now'
DateOnly = False
RequireTime = False
Caption = 'Date/time of this action'
end
object cmdOK: TORAlignButton
Left = 201
Top = 62
Width = 75
Height = 22
Anchors = [akRight, akBottom]
Caption = 'OK'
TabOrder = 2
OnClick = cmdOKClick
end
object cmdCancel: TORAlignButton
Left = 286
Top = 62
Width = 75
Height = 22
Anchors = [akRight, akBottom]
Cancel = True
Caption = 'Cancel'
TabOrder = 3
OnClick = cmdCancelClick
end
object cboPerson: TORComboBox
Left = 137
Top = 15
Width = 220
Height = 21
Style = orcsDropDown
AutoSelect = True
Caption = 'Action by'
Color = clWindow
DropDownCount = 8
ItemHeight = 13
ItemTipColor = clWindow
ItemTipEnable = True
ListItemsOnly = True
LongList = True
LookupPiece = 2
MaxLength = 0
Pieces = '2,3'
Sorted = False
SynonymChars = '<>'
TabOrder = 1
TabStop = True
OnNeedData = NewPersonNeedData
CharsNeedMatch = 1
end
end
end
end
end

599
CPRS-Chart/Consults/fConsultAct.pas Normal file
View File

@ -0,0 +1,599 @@
unit fConsultAct;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ORFN,
StdCtrls, ExtCtrls, ORCtrls, uCore, ComCtrls, ORDtTm;
type
TfrmConsultAction = class(TForm)
lblActionBy: TOROffsetLabel;
calDateofAction: TORDateBox;
lblDateofAction: TOROffsetLabel;
cboPerson: TORComboBox;
memComments: TCaptionMemo;
lblComments: TOROffsetLabel;
lblToService: TOROffsetLabel;
cboAttentionOf: TORComboBox;
lblAttentionOf: TOROffsetLabel;
lblUrgency: TOROffsetLabel;
cmdOK: TORAlignButton;
cmdCancel: TORAlignButton;
cboUrgency: TORComboBox;
pnlBase: TPanel;
pnlForward: TPanel;
pnlOther: TPanel;
treService: TORTreeView;
pnlComments: TPanel;
pnlAllActions: TPanel;
grpSigFindings: TRadioGroup;
pnlSigFind: TPanel;
cboService: TORComboBox;
pnlAlert: TPanel;
ckAlert: TCheckBox;
Label1: TMemo;
lblAutoAlerts: TStaticText;
procedure cmdCancelClick(Sender: TObject);
procedure cmdOKClick(Sender: TObject);
procedure NewPersonNeedData(Sender: TObject; const StartFrom: string;
Direction, InsertAt: Integer);
procedure ProviderNeedData(Sender: TObject; const StartFrom: string;
Direction, InsertAt: Integer);
procedure ckAlertClick(Sender: TObject);
procedure treServiceChange(Sender: TObject; Node: TTreeNode);
procedure treServiceExit(Sender: TObject);
procedure cboServiceSelect(Sender: TObject); {**REV**}
private
FActionType: integer ;
FChanged: boolean ;
FActionBy: Int64;
FActionDate: TFMDateTime;
FToService: integer ;
FAttentionOf: int64 ;
FUrgency: integer ;
FSigFind: string;
FComments: TStrings ;
FAlert: integer ;
FAlertTo: string ;
FIsProcedure: boolean;
FProcIEN: integer;
FUserLevel: integer;
FUserIsRequester: boolean;
function SetupForward(IsProcedure: boolean; ProcIEN: integer): boolean;
procedure SetupAddComment;
procedure SetupAdminComplete;
procedure SetupSigFindings;
procedure SigFindPanelShow;
procedure SetupReceive;
procedure SetupSchedule;
procedure SetupOther;
procedure ShowAutoAlertText;
end;
function SetActionContext(FontSize: Integer; ActionCode: integer; IsProcedure: boolean; ProcID: string; UserLevel: integer): boolean;
var
frmConsultAction: TfrmConsultAction;
SvcList: TStrings ;
uChanging: Boolean;
const
TX_FWD_NO_CSLT_SVCS_TEXT = 'There are no services that you can forward this consult to' ;
TX_FWD_NO_PROC_SVCS_TEXT = 'There are no additional services that can perform this procedure.' ;
TX_NOTTHISSVC_TEXT = 'Consults cannot be forwarded to this service. Please select a subspecialty' ;
TX_NOFORWARD_TEXT = 'Service must be specified.' ;
TX_NOFORWARD_SELF = 'A consult cannot be forwarded to the same service already responsible.';
TX_NOFORWARD_CAP = 'Unable to forward' ;
TX_NOURGENCY_TEXT = 'Urgency must be specified';
TX_PERSON_TEXT = 'Select a person to perform this action or press Cancel.';
TX_PERSON_CAP = 'Missing person';
TX_DATE_TEXT = 'Enter a valid date for this action.' ;
TX_DATE_CAP = 'Invalid date' ;
TX_FUTDATE_TEXT = 'Dates or times in the future are not allowed.';
TX_COMMENTS_TEXT = 'Comments are required for this action.' ;
TX_COMMENTS_CAP = 'No comments entered' ;
TX_SIGFIND_TEXT = 'A significant findings selection is required.' ;
TX_SIGFIND_CAP = 'No significant findings status entered' ;
implementation
{$R *.DFM}
uses rCore, rConsults, uConsults, fConsults, fConsultAlertTo, rOrders;
var
RecipientList: TRecipientList ;
function SetActionContext(FontSize: Integer; ActionCode: integer; IsProcedure: boolean; ProcID: string; UserLevel: integer): boolean;
{ displays action input form for consults and sets up broker calls }
begin
Result := False;
frmConsultAction := TfrmConsultAction.Create(Application);
try
ResizeAnchoredFormToFont(frmConsultAction);
with frmConsultAction do
begin
//I wish I knew why the resize wasn't working on the buttons
cmdCancel.Left := pnlAllActions.ClientWidth - cmdCancel.Width -7;
cmdOK.Left := cmdCancel.Left - cmdOK.Width - 10;
FChanged := False;
FActionType := ActionCode ;
FIsProcedure := IsProcedure;
FProcIEN := StrToIntDef(Piece(ProcID, ';', 1), 0);
FUserLevel := UserLevel;
FUserIsRequester := (User.DUZ = ConsultRec.SendingProvider);
Caption := ActionType[ActionCode] ;
RecipientList.Recipients := '' ;
RecipientList.Changed := False ;
case FActionType of
CN_ACT_FORWARD: if not SetupForward(FIsProcedure, FProcIEN) then exit;
CN_ACT_ADD_CMT: SetupAddComment;
CN_ACT_ADMIN_COMPLETE: SetupAdminComplete;
CN_ACT_SIGFIND: SetupSigFindings;
CN_ACT_RECEIVE: SetupReceive;
CN_ACT_SCHEDULE: SetupSchedule;
else SetupOther;
end;
ShowModal ;
Result := FChanged ;
end ;
finally
frmConsultAction.Release;
end;
end;
//=================== Setup form for different actions ===========================
function TfrmConsultAction.SetupForward(IsProcedure: boolean; ProcIEN: integer): boolean;
var
i: integer;
OrdItmIEN: integer;
begin
pnlSigFind.Visible := False;
with frmConsultAction do Height := Height - pnlSigFind.Height;
pnlComments.Visible := True;
memComments.Clear;
if IsProcedure then
begin
OrdItmIEN := GetOrderableIEN(IntToStr(ConsultRec.ORFileNumber));
SvcList.Assign(GetProcedureServices(OrdItmIEN));
//SvcList.Assign(GetProcedureServices(ProcIEN)); RPC expects pointer to 101.43, NOT 123.3 (RV)
i := SvcList.IndexOf(IntToStr(ConsultRec.ToService) + U + Trim(ExternalName(ConsultRec.ToService, 123.5)));
if i > -1 then SvcList.Delete(i);
treService.Visible := False;
end
else
SvcList.Assign(LoadServiceListWithSynonyms(CN_SVC_LIST_FWD, ConsultRec.IEN)); {RV}
if (IsProcedure and (SvcList.Count <= 0)) then
begin
InfoBox(TX_FWD_NO_PROC_SVCS_TEXT, TX_NOFORWARD_CAP, MB_OK or MB_ICONWARNING);
Result := False ;
Exit ;
end
else if ((not IsProcedure) and (Piece(SvcList.Strings[0],U,1) = '-1')) then
begin
InfoBox(TX_FWD_NO_CSLT_SVCS_TEXT, TX_NOFORWARD_CAP, MB_OK or MB_ICONWARNING);
Result := False ;
Exit ;
end
else
begin
SortByPiece(TStringList(SvcList), U, 2); {RV}
for i := 0 to SvcList.Count - 1 do
if (cboService.Items.IndexOf(Trim(Piece(SvcList.Strings[i], U, 2))) = -1) and {RV}
(Piece(SvcList.Strings[i], U, 5) <> '1') then
cboService.Items.Add(SvcList.Strings[i]);
if not IsProcedure then
begin
BuildServiceTree(treService, SvcList, '0', nil) ;
with treService do
for i:=0 to Items.Count-1 do
begin
if Items[i].Level > 0 then Items[i].Expanded := False
else Items[i].Expanded := True;
TopItem := Items[0] ;
Selected := Items[0] ;
end ;
end;
pnlForward.Visible := True ;
end ;
if cboService.Items.Count = 1 then cboService.ItemIndex := 0;
FToService := cboService.ItemIEN;
cboAttentionOf.InitLongList('') ;
with cboUrgency do
begin
Items.Assign(SubsetofUrgencies(ConsultRec.IEN)) ;
MixedCaseList(Items) ;
SelectByIEN(ConsultRec.Urgency);
if ItemIndex = -1 then
begin
for i := 0 to Items.Count-1 do
if DisplayText[i] = 'Routine' then break ;
ItemIndex := i ;
end;
end ;
FUrgency := cboUrgency.ItemIEN;
//lblActionBy.Caption := 'Responsible Clinician'; // v20.1 RV
//cboPerson.OnNeedData := ProviderNeedData; //
lblActionBy.Caption := 'Responsible Person'; //
cboPerson.Caption := lblActionBy.Caption;
cboPerson.OnNeedData := NewPersonNeedData; //
cboPerson.InitLongList(User.Name) ;
cboPerson.SelectByIEN(User.DUZ);
ckAlert.Visible := False ;
lblAutoAlerts.Visible := False;
Result := True;
end;
procedure TfrmConsultAction.SetupAddComment;
begin
pnlForward.Visible := False ;
//with frmConsultAction do Width := Width - pnlForward.Width ;
pnlSigFind.Visible := False;
with frmConsultAction do Height := Height - pnlSigFind.Height;
ckAlert.Visible := True ;
lblAutoAlerts.Visible := True;
ShowAutoAlertText;
(* RecipientList.Recipients := '' ;
RecipientList.Changed := False ;*)
lblActionBy.Visible := False ;
cboPerson.Visible := False ;
pnlComments.Visible := True;
memComments.Clear;
ActiveControl := memComments ;
end;
procedure TfrmConsultAction.SetupSchedule;
begin
pnlForward.Visible := False ;
//with frmConsultAction do Width := Width - pnlForward.Width ;
pnlSigFind.Visible := False;
with frmConsultAction do Height := Height - pnlSigFind.Height;
ckAlert.Visible := True ;
lblAutoAlerts.Visible := True;
ShowAutoAlertText;
(* RecipientList.Recipients := '' ;
RecipientList.Changed := False ;*)
lblActionBy.Visible := True ;
cboPerson.Visible := True ;
lblActionBy.Caption := 'Responsible Person';
cboPerson.Caption := lblActionBy.Caption;
cboPerson.OnNeedData := NewPersonNeedData;
cboPerson.InitLongList(User.Name) ;
cboPerson.SelectByIEN(User.DUZ);
pnlComments.Visible := True;
memComments.Clear;
ActiveControl := memComments ;
end;
procedure TfrmConsultAction.SetupAdminComplete;
begin
SigFindPanelShow ;
pnlForward.Visible := False ;
//with frmConsultAction do Width := Width - pnlForward.Width ;
ckAlert.Visible := False ;
lblAutoAlerts.Visible := False;
//lblActionBy.Caption := 'Responsible Provider';
//cboPerson.OnNeedData := ProviderNeedData; //RIC-0100-21228 - need ALL users here
//cboPerson.InitLongList('') ;
//cboPerson.ItemIndex := -1;
lblActionBy.Caption := 'Responsible Person';
cboPerson.Caption := lblActionBy.Caption;
cboPerson.OnNeedData := NewPersonNeedData;
cboPerson.InitLongList(User.Name) ;
cboPerson.SelectByIEN(User.DUZ);
pnlComments.Visible := True;
memComments.Clear;
(* if not FUserIsRequester then RecipientList.Recipients := IntToStr(ConsultRec.SendingProvider);
RecipientList.Changed := not FUserIsRequester;*)
ActiveControl := memComments ;
end;
procedure TfrmConsultAction.SetupSigFindings;
begin
SigFindPanelShow ;
pnlForward.Visible := False ;
//with frmConsultAction do Width := Width - pnlForward.Width ;
ckAlert.Visible := True ;
lblAutoAlerts.Visible := True;
ShowAutoAlertText;
(* RecipientList.Recipients := '' ;
RecipientList.Changed := False ;*)
lblActionBy.Visible := False ;
cboPerson.Visible := False ;
pnlComments.Visible := True;
memComments.Clear;
ActiveControl := memComments ;
end;
procedure TfrmConsultAction.SigFindPanelShow;
var
i: integer;
begin
pnlSigFind.Visible := True;
with grpSigFindings do
begin
for i := 0 to 2 do if Copy(Items[i],1,1)=ConsultRec.Findings then ItemIndex := i ;
if ItemIndex = -1 then
begin
ItemIndex := 2;
Caption := Caption + 'Not yet entered';
end
else
Caption := Caption + Items[ItemIndex];
end;
end ;
procedure TfrmConsultAction.SetupReceive;
begin
pnlForward.Visible := False ;
//with frmConsultAction do Width := Width - pnlForward.Width ;
pnlComments.Visible := True; // V14?
ckAlert.Visible := False ;
lblAutoAlerts.Visible := False;
pnlSigFind.Visible := False;
with frmConsultAction do Height := Height - pnlSigFind.Height;// - pnlComments.Height ; // V14?
cboPerson.OnNeedData := NewPersonNeedData;
cboPerson.InitLongList(User.Name) ;
cboPerson.SelectByIEN(User.DUZ);
ActiveControl := calDateOfAction;
end;
procedure TfrmConsultAction.SetupOther;
begin
pnlForward.Visible := False ;
//with frmConsultAction do Width := Width - pnlForward.Width ;
pnlSigFind.Visible := False;
with frmConsultAction do Height := Height - pnlSigFind.Height;
lblActionBy.Caption := 'Action by';
cboPerson.Caption := lblActionBy.Caption;
cboPerson.OnNeedData := NewPersonNeedData;
cboPerson.InitLongList(User.Name) ;
cboPerson.SelectByIEN(User.DUZ);
ckAlert.Visible := False ;
lblAutoAlerts.Visible := False;
pnlComments.Visible := True;
memComments.Clear;
ActiveControl := memComments ;
end;
// ============================= Control events ================================
procedure TfrmConsultAction.NewPersonNeedData(Sender: TObject; const StartFrom: string;
Direction, InsertAt: Integer);
begin
inherited;
(Sender as TORComboBox).ForDataUse(SubSetOfPersons(StartFrom, Direction));
end;
procedure TfrmConsultAction.ProviderNeedData(Sender: TObject; const StartFrom: string;
Direction, InsertAt: Integer);
begin
inherited;
(Sender as TORComboBox).ForDataUse(SubSetOfProviders(StartFrom, Direction));
end;
procedure TfrmConsultAction.cmdCancelClick(Sender: TObject);
begin
FChanged := False ;
Close ;
end;
procedure TfrmConsultAction.cmdOKClick(Sender: TObject);
var
Alist: TStringList;
begin
Alist := TStringList.Create ;
try
if (cboPerson.ItemIEN = 0)
and (FActionType <> CN_ACT_ADD_CMT)
and (FActionType <> CN_ACT_SIGFIND) then
begin
InfoBox(TX_PERSON_TEXT, TX_PERSON_CAP, MB_OK or MB_ICONWARNING);
Exit;
end;
if ((FActionType = CN_ACT_SIGFIND) or (FActionType = CN_ACT_ADMIN_COMPLETE))
and (grpSigFindings.ItemIndex < 0) then
begin
InfoBox(TX_SIGFIND_TEXT, TX_SIGFIND_CAP, MB_OK or MB_ICONWARNING);
Exit;
end;
if ((FActionType = CN_ACT_DENY)
or (FActionType = CN_ACT_DISCONTINUE)
or (FActionType = CN_ACT_ADD_CMT)
or (FActionType = CN_ACT_ADMIN_COMPLETE))
and (memComments.Lines.Count = 0) then
begin
InfoBox(TX_COMMENTS_TEXT, TX_COMMENTS_CAP, MB_OK or MB_ICONWARNING);
Exit;
end;
if (FActionType = CN_ACT_FORWARD) then
begin
if (FIsProcedure and (cboService.ItemIndex = -1) and (FToService = 0 )) or
((not FIsProcedure) and (treService.Selected = nil) and (FToService = 0 )) then
begin
InfoBox(TX_NOFORWARD_TEXT, TX_NOFORWARD_CAP, MB_OK or MB_ICONWARNING);
Exit;
end;
if (not FIsProcedure) and (cboService.ItemIEN = ConsultRec.ToService) then
begin
InfoBox(TX_NOFORWARD_SELF, TX_NOFORWARD_CAP, MB_OK or MB_ICONWARNING);
Exit;
end;
if cboUrgency.ItemIEN = 0 then
begin
InfoBox(TX_NOURGENCY_TEXT, TX_NOFORWARD_CAP, MB_OK or MB_ICONWARNING);
Exit;
end;
if (FIsProcedure and (Piece(cboService.Items[cboService.ItemIndex], U, 5) = '1')) or
((not FIsProcedure) and (Piece(TORTreeNode(treService.Selected).StringData, U, 5) = '1')) then
begin
InfoBox(TX_NOTTHISSVC_TEXT, TX_NOFORWARD_CAP, MB_OK or MB_ICONWARNING);
Exit;
end;
end ;
if calDateofAction.Text <> '' then
begin
FActionDate := StrToFMDateTime(calDateofAction.Text) ;
if FActionDate = -1 then
begin
InfoBox(TX_DATE_TEXT, TX_DATE_CAP, MB_OK or MB_ICONWARNING);
calDateofAction.SetFocus ;
exit ;
end
else if FActionDate > FMNow then
begin
InfoBox(TX_FUTDATE_TEXT, TX_DATE_CAP, MB_OK or MB_ICONWARNING);
calDateofAction.SetFocus ;
exit ;
end;
end
else
FActionDate := FMNow ;
FActionBy := cboPerson.ItemIEN;
FAttentionOf := cboAttentionOf.ItemIEN ;
FUrgency := cboUrgency.ItemIEN ;
if (FActionType = CN_ACT_SIGFIND) or (FActionType = CN_ACT_ADMIN_COMPLETE) then
FSigFind := Copy(grpSigFindings.Items[grpSigFindings.ItemIndex],2,1);
LimitEditWidth(memComments, 74);
FComments := memComments.Lines ;
if ((ckAlert.Checked) (*or (FActionType = CN_ACT_ADMIN_COMPLETE)*))
and RecipientList.Changed then
begin
FAlert := 1 ;
FAlertTo := RecipientList.Recipients ;
end
else
begin
FAlert := 0;
FAlertTo := '';
end ;
case FActionType of
CN_ACT_RECEIVE :
ReceiveConsult(Alist, ConsultRec.IEN, FActionBy, FActionDate, FComments) ;
CN_ACT_SCHEDULE :
ScheduleConsult(Alist, ConsultRec.IEN, FActionBy, FActionDate, FAlert, FAlertTo, FComments) ;
CN_ACT_DENY :
DenyConsult(Alist, ConsultRec.IEN, FActionBy, FActionDate, FComments) ;
CN_ACT_DISCONTINUE:
DiscontinueConsult(Alist, ConsultRec.IEN, FActionBy, FActionDate, FComments) ;
CN_ACT_FORWARD :
ForwardConsult(Alist, ConsultRec.IEN, FToService, FActionBy, FAttentionOf, FUrgency, FActionDate, FComments);
CN_ACT_ADD_CMT :
AddComment(Alist, ConsultRec.IEN, FComments, FActionDate, FAlert, FAlertTo) ;
CN_ACT_SIGFIND :
SigFindings(Alist, ConsultRec.IEN, FSigFind, FComments, FActionDate, FAlert, FAlertTo) ;
CN_ACT_ADMIN_COMPLETE :
AdminComplete(Alist,ConsultRec.IEN, FSigFind, FComments, FActionBy, FActionDate, FAlert, FAlertTo);
end ;
if AList.Count > 0 then
begin
if StrToInt(Piece(Alist[0],u,1)) > 0 then
begin
InfoBox(Piece(Alist[0],u,2), 'Unable to '+ActionType[FActionType], MB_OK or MB_ICONWARNING);
FChanged := False ;
end
else
FChanged := True;
end
else
FChanged := True ;
finally
Alist.Free ;
end ;
Close ;
end ;
procedure TfrmConsultAction.ckAlertClick(Sender: TObject);
begin
if ckAlert.Checked then SelectRecipients(Font.Size, FActionType, RecipientList) ;
end;
procedure TfrmConsultAction.treServiceChange(Sender: TObject; Node: TTreeNode);
begin
if uChanging or FIsProcedure then Exit;
FToService := StrToIntDef(Piece(TORTreeNode(treService.Selected).StringData, U, 1), 0);
(* if (treService.Selected.Data <> nil) and (Piece(string(treService.Selected.Data), U, 5) <> '1') then
cboService.SelectByID(Piece(string(treService.Selected.Data), U, 1))*)
//cboService.SelectByID(Piece(string(treService.Selected.Data), U, 1));
cboService.ItemIndex := cboService.Items.IndexOf(Trim(treService.Selected.Text)); {RV}
ActiveControl := cboService; {RV}
end;
procedure TfrmConsultAction.treServiceExit(Sender: TObject);
begin
(* if (Piece(TORTreeNode(treService.Selected).StringData, U, 5) = '1') then WHY IS THIS IN HERE? (rv - v15.5)
InfoBox(TX_NOTTHISSVC_TEXT, TX_NOFORWARD_CAP, MB_OK or MB_ICONWARNING);*)
end;
procedure TfrmConsultAction.cboServiceSelect(Sender: TObject);
var
i: integer;
begin
if not FIsProcedure then
begin
uChanging := True;
with treService do for i := 0 to Items.Count-1 do
begin
if Piece(TORTreeNode(Items[i]).StringData, U, 1) = cboService.ItemID then
begin
Selected := Items[i];
//treServiceChange(Self, Items[i]);
break;
end;
end;
uChanging := False;
FToService := StrToIntDef(Piece(TORTreeNode(treService.Selected).StringData, U, 1), 0);
end
else
FToService := cboService.ItemIEN;
end;
procedure TfrmConsultAction.ShowAutoAlertText;
const
TX_ALERT1 = 'An alert will automatically be sent to ';
TX_ALERT_PROVIDER = 'the ordering provider';
TX_ALERT_SVC_USERS = 'notification recipients for this service.';
TX_ALERT_NOBODY = 'No automatic alerts will be sent.'; // this should be rare to never
var
x: string;
begin
case FUserLevel of
UL_NONE, UL_REVIEW:
begin
if FUserIsRequester then
x := TX_ALERT1 + TX_ALERT_SVC_USERS
else
x := TX_ALERT1 + TX_ALERT_PROVIDER + ' and to ' + TX_ALERT_SVC_USERS;
end;
UL_UPDATE, UL_ADMIN, UL_UPDATE_AND_ADMIN:
begin
if FUserIsRequester then
x := TX_ALERT_NOBODY
else
x := TX_ALERT1 + TX_ALERT_PROVIDER + '.';
end;
end;
lblAutoAlerts.Caption := x;
end;
initialization
SvcList := TStringList.Create ;
finalization
SvcList.Free ;
end.

103
CPRS-Chart/Consults/fConsultAlertTo.dfm Normal file
View File

@ -0,0 +1,103 @@
object frmConsultAlertsTo: TfrmConsultAlertsTo
Left = 297
Top = 206
BorderStyle = bsDialog
Caption = 'Send Alert'
ClientHeight = 262
ClientWidth = 358
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = True
Position = poScreenCenter
PixelsPerInch = 96
TextHeight = 13
object pnlBase: TORAutoPanel
Left = 0
Top = 0
Width = 358
Height = 262
Align = alClient
BevelOuter = bvNone
TabOrder = 0
object SrcLabel: TLabel
Left = 12
Top = 14
Width = 98
Height = 13
Caption = 'Select or enter name'
end
object DstLabel: TLabel
Left = 196
Top = 14
Width = 132
Height = 13
Caption = 'Currently selected recipients'
end
object cmdOK: TButton
Left = 105
Top = 226
Width = 75
Height = 25
Caption = 'OK'
ModalResult = 1
TabOrder = 2
OnClick = cmdOKClick
end
object cmdCancel: TButton
Left = 185
Top = 226
Width = 75
Height = 25
Cancel = True
Caption = 'Cancel'
ModalResult = 2
TabOrder = 3
OnClick = cmdCancelClick
end
object cboSrcList: TORComboBox
Left = 12
Top = 30
Width = 144
Height = 185
Style = orcsSimple
AutoSelect = True
Caption = 'Select or enter name'
Color = clWindow
DropDownCount = 8
ItemHeight = 13
ItemTipColor = clWindow
ItemTipEnable = True
ListItemsOnly = True
LongList = True
LookupPiece = 2
MaxLength = 0
Pieces = '2,3'
Sorted = False
SynonymChars = '<>'
TabOrder = 0
OnKeyDown = cboSrcListKeyDown
OnMouseClick = cboSrcListMouseClick
OnNeedData = cboSrcListNeedData
end
object DstList: TORListBox
Left = 196
Top = 30
Width = 144
Height = 185
ItemHeight = 13
MultiSelect = True
ParentShowHint = False
ShowHint = True
TabOrder = 1
OnClick = DstListClick
Caption = 'Currently selected recipients'
ItemTipColor = clWindow
LongList = False
Pieces = '2'
end
end
end

137
CPRS-Chart/Consults/fConsultAlertTo.pas Normal file
View File

@ -0,0 +1,137 @@
unit fConsultAlertTo;
interface
uses Windows, SysUtils, Classes, Graphics, Forms, Controls, StdCtrls,
Buttons, ORCtrls, ORfn, ExtCtrls;
type
TfrmConsultAlertsTo = class(TForm)
cmdOK: TButton;
cmdCancel: TButton;
cboSrcList: TORComboBox;
DstList: TORListBox;
SrcLabel: TLabel;
DstLabel: TLabel;
pnlBase: TORAutoPanel;
procedure cboSrcListNeedData(Sender: TObject; const StartFrom: String;
Direction, InsertAt: Integer);
procedure cmdOKClick(Sender: TObject);
procedure cmdCancelClick(Sender: TObject);
//procedure cboSrcListdblClick(Sender: TObject);
procedure cboSrcListKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
procedure DstListClick(Sender: TObject);
procedure cboSrcListMouseClick(Sender: TObject);
private
FActionType: integer;
FRecipients: string ;
FChanged: Boolean;
end;
TRecipientList = record
Changed: Boolean;
Recipients: string ;
end;
procedure SelectRecipients(FontSize: Integer; ActionType: integer; var RecipientList: TRecipientList) ;
implementation
{$R *.DFM}
uses rConsults, rCore, uCore, uConsults, fConsults;
const
TX_RCPT_TEXT = 'Select recipients or press Cancel.';
TX_RCPT_CAP = 'No Recipients Selected';
TX_REQ_TEXT = 'The requesting provider is always included in this type of alert';
TX_REQ_CAP = 'Cannot Remove Recipient';
procedure SelectRecipients(FontSize: Integer; ActionType: integer; var RecipientList: TRecipientList) ;
{ displays recipients select form for consults and returns a record of the selection }
var
frmConsultAlertsTo: TfrmConsultAlertsTo;
begin
frmConsultAlertsTo := TfrmConsultAlertsTo.Create(Application);
try
ResizeAnchoredFormToFont(frmConsultAlertsTo);
with frmConsultAlertsTo do
begin
FActionType := ActionType;
FChanged := False;
cboSrcList.InitLongList('');
(* cboSrcList.InitLongList(ConsultRec.SendingProviderName);
cboSrcList.SelectByIEN(ConsultRec.SendingProvider);
cboSrcListMouseClick(cboSrcList) ;*)
ShowModal;
with RecipientList do
begin
Recipients := Recipients + FRecipients ;
Changed := FChanged ;
end ;
end; {with frmConsultAlertsTo}
finally
frmConsultAlertsTo.Release;
end;
end;
procedure TfrmConsultAlertsTo.cboSrcListNeedData(Sender: TObject;
const StartFrom: String; Direction, InsertAt: Integer);
begin
(Sender as TORComboBox).ForDataUse(SubSetOfPersons(StartFrom, Direction));
end;
procedure TfrmConsultAlertsTo.cmdCancelClick(Sender: TObject);
begin
Close;
end;
procedure TfrmConsultAlertsTo.cmdOKClick(Sender: TObject);
var
i: integer ;
begin
if DstList.Items.Count = 0 then
begin
InfoBox(TX_RCPT_TEXT, TX_RCPT_CAP, MB_OK or MB_ICONWARNING);
FChanged := False ;
Exit;
end;
FChanged := True;
for i := 0 to DstList.Items.Count-1 do
FRecipients := Piece(DstList.Items[i],u,1) + ';' + FRecipients;
Close;
end;
(*procedure TfrmConsultAlertsTo.cboSrcListdblClick(Sender: TObject);
begin
if cboSrcList.ItemIndex = -1 then exit ;
if DstList.SelectByID(cboSrcList.ItemID) = -1 then
DstList.Items.Add(cboSrcList.Items[cboSrcList.Itemindex]) ;
end;*)
procedure TfrmConsultAlertsTo.DstListClick(Sender: TObject);
begin
if DstList.ItemIndex = -1 then exit ;
(* if (DstList.ItemIEN = ConsultRec.SendingProvider) and
((FActionType = CN_ACT_SIGFIND) or (FActionType = CN_ACT_ADMIN_COMPLETE)) then
begin
InfoBox(TX_REQ_TEXT, TX_REQ_CAP, MB_OK or MB_ICONWARNING);
exit ;
end ;*)
DstList.Items.Delete(DstList.ItemIndex) ;
end;
procedure TfrmConsultAlertsTo.cboSrcListKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if Key = VK_RETURN then cboSrcListMouseClick(Self);
end;
procedure TfrmConsultAlertsTo.cboSrcListMouseClick(Sender: TObject);
begin
if cboSrcList.ItemIndex = -1 then exit ;
if DstList.SelectByID(cboSrcList.ItemID) = -1 then
DstList.Items.Add(cboSrcList.Items[cboSrcList.Itemindex]) ;
end;
end.

92
CPRS-Chart/Consults/fConsultBD.dfm Normal file
View File

@ -0,0 +1,92 @@
object frmConsultsByDate: TfrmConsultsByDate
Left = 372
Top = 217
Width = 259
Height = 178
BorderIcons = []
Caption = 'List Consults by Date Range'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = True
Position = poScreenCenter
PixelsPerInch = 96
TextHeight = 13
object pnlBase: TORAutoPanel
Left = 0
Top = 0
Width = 251
Height = 151
Align = alClient
BevelOuter = bvNone
TabOrder = 0
object lblBeginDate: TLabel
Left = 8
Top = 8
Width = 73
Height = 13
Caption = 'Beginning Date'
end
object lblEndDate: TLabel
Left = 8
Top = 51
Width = 59
Height = 13
Caption = 'Ending Date'
end
object calBeginDate: TORDateBox
Left = 8
Top = 22
Width = 155
Height = 21
TabOrder = 0
DateOnly = False
RequireTime = False
Caption = 'Beginning Date'
end
object calEndDate: TORDateBox
Left = 8
Top = 65
Width = 155
Height = 21
TabOrder = 1
DateOnly = False
RequireTime = False
Caption = 'Ending Date'
end
object radSort: TRadioGroup
Left = 8
Top = 94
Width = 155
Height = 49
Caption = 'Sort Order'
Items.Strings = (
'&Ascending (oldest first)'
'&Descending (newest first)')
TabOrder = 2
end
object cmdOK: TButton
Left = 171
Top = 95
Width = 72
Height = 21
Caption = 'OK'
Default = True
TabOrder = 3
OnClick = cmdOKClick
end
object cmdCancel: TButton
Left = 171
Top = 122
Width = 72
Height = 21
Cancel = True
Caption = 'Cancel'
TabOrder = 4
OnClick = cmdCancelClick
end
end
end

127
CPRS-Chart/Consults/fConsultBD.pas Normal file
View File

@ -0,0 +1,127 @@
unit fConsultBD;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ORFN,
StdCtrls, ExtCtrls, ORCtrls, ORDtTm, uConsults;
type
TfrmConsultsByDate = class(TForm)
pnlBase: TORAutoPanel;
lblBeginDate: TLabel;
calBeginDate: TORDateBox;
lblEndDate: TLabel;
calEndDate: TORDateBox;
radSort: TRadioGroup;
cmdOK: TButton;
cmdCancel: TButton;
procedure cmdOKClick(Sender: TObject);
procedure cmdCancelClick(Sender: TObject);
procedure calBeginDateKeyPress(Sender: TObject; var Key: Char);
procedure calEndDateKeyPress(Sender: TObject; var Key: Char);
private
FChanged: Boolean;
FBeginDate: string;
FEndDate: string;
FAscending: Boolean;
end;
TConsultDateRange = record
Changed: Boolean;
BeginDate: string;
EndDate: string;
Ascending: Boolean;
end;
function SelectConsultDateRange(FontSize: Integer; CurrentContext: TSelectContext; var ConsultDateRange: TConsultDateRange): boolean;
implementation
{$R *.DFM}
uses rCore, rConsults;
const
TX_DATE_ERR = 'Enter valid beginning and ending dates or press Cancel.';
TX_DATE_ERR_CAP = 'Error in Date Range';
function SelectConsultDateRange(FontSize: Integer; CurrentContext: TSelectContext; var ConsultDateRange: TConsultDateRange): boolean;
{ displays date range select form for progress Consults and returns a record of the selection }
var
frmConsultsByDate: TfrmConsultsByDate;
W, H: Integer;
CurrentBegin, CurrentEnd: string;
begin
frmConsultsByDate := TfrmConsultsByDate.Create(Application);
try
with frmConsultsByDate do
begin
Font.Size := FontSize;
W := ClientWidth;
H := ClientHeight;
ResizeToFont(FontSize, W, H);
ClientWidth := W; pnlBase.Width := W;
ClientHeight := H; pnlBase.Height := H;
FChanged := False;
with radSort do {if SortConsultsAscending then ItemIndex := 0 else} ItemIndex := 1;
CurrentBegin := CurrentContext.BeginDate;
CurrentEnd := CurrentContext.EndDate;
if CurrentBegin <> '' then
calBeginDate.Text := CurrentBegin;
if CurrentEnd <> '' then
calEndDate.Text := CurrentEnd;
if calEndDate.Text = '' then calEndDate.Text := 'TODAY';
ShowModal;
with ConsultDateRange do
begin
Changed := FChanged;
BeginDate := FBeginDate;
EndDate := FEndDate;
Ascending := FAscending;
Result := Changed ;
end; {with ConsultDateRange}
end; {with frmConsultsByDate}
finally
frmConsultsByDate.Release;
end;
end;
procedure TfrmConsultsByDate.cmdOKClick(Sender: TObject);
var
bdate, edate: TFMDateTime;
begin
bdate := StrToFMDateTime(calBeginDate.Text);
edate := StrToFMDateTime(calEndDate.Text);
if ((bdate > 0) and (edate > 0)) and (bdate <= edate) then
begin
FChanged := True;
FBeginDate := calBeginDate.Text;
FEndDate := calEndDate.Text;
FAscending := radSort.ItemIndex = 0;
Close;
end else
begin
InfoBox(TX_DATE_ERR, TX_DATE_ERR_CAP, MB_OK or MB_ICONWARNING);
Exit;
end;
end;
procedure TfrmConsultsByDate.cmdCancelClick(Sender: TObject);
begin
Close;
end;
procedure TfrmConsultsByDate.calBeginDateKeyPress(Sender: TObject;
var Key: Char);
begin
if (Key = #13) then cmdOKClick(Self);
end;
procedure TfrmConsultsByDate.calEndDateKeyPress(Sender: TObject;
var Key: Char);
begin
if (Key = #13) then cmdOKClick(Self);
end;
end.

101
CPRS-Chart/Consults/fConsultBS.dfm Normal file
View File

@ -0,0 +1,101 @@
object frmConsultsByService: TfrmConsultsByService
Left = 339
Top = 175
Width = 328
Height = 412
BorderIcons = []
Caption = 'List Consults by Service'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = True
Position = poScreenCenter
PixelsPerInch = 96
TextHeight = 13
object pnlBase: TORAutoPanel
Left = 0
Top = 0
Width = 320
Height = 385
Align = alClient
BevelOuter = bvNone
TabOrder = 0
object lblService: TLabel
Left = 8
Top = 8
Width = 36
Height = 13
Caption = 'Service'
end
object radSort: TRadioGroup
Left = 52
Top = 289
Width = 212
Height = 49
Caption = 'Sort Order'
Items.Strings = (
'&Ascending (A-Z)'
'&Descending (Z-A)')
TabOrder = 2
end
object cmdOK: TButton
Left = 70
Top = 350
Width = 72
Height = 21
Caption = 'OK'
Default = True
TabOrder = 3
OnClick = cmdOKClick
end
object cmdCancel: TButton
Left = 157
Top = 350
Width = 72
Height = 21
Cancel = True
Caption = 'Cancel'
TabOrder = 4
OnClick = cmdCancelClick
end
object treService: TORTreeView
Left = 7
Top = 57
Width = 305
Height = 225
HideSelection = False
Indent = 19
ReadOnly = True
TabOrder = 1
OnChange = treServiceChange
Caption = 'Service'
NodePiece = 0
end
object cboService: TORComboBox
Left = 8
Top = 28
Width = 305
Height = 21
Style = orcsDropDown
AutoSelect = True
Caption = 'Service'
Color = clWindow
DropDownCount = 8
ItemHeight = 13
ItemTipColor = clWindow
ItemTipEnable = True
ListItemsOnly = True
LongList = False
MaxLength = 0
Pieces = '2'
Sorted = True
SynonymChars = '<>'
TabOrder = 0
OnKeyPause = cboServiceSelect
OnMouseClick = cboServiceSelect
end
end
end

165
CPRS-Chart/Consults/fConsultBS.pas Normal file
View File

@ -0,0 +1,165 @@
unit fConsultBS;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, ORCtrls, StdCtrls, ORFn, ComCtrls, uConsults;
type
TfrmConsultsByService = class(TForm)
pnlBase: TORAutoPanel;
lblService: TLabel;
radSort: TRadioGroup;
cmdOK: TButton;
cmdCancel: TButton;
treService: TORTreeView;
cboService: TORComboBox;
procedure cmdCancelClick(Sender: TObject);
procedure cmdOKClick(Sender: TObject);
procedure treServiceChange(Sender: TObject; Node: TTreeNode);
procedure cboServiceSelect(Sender: TObject);
private
FChanged: Boolean;
FService: string;
FServiceName: string;
FAscending: Boolean;
fConsultUser: boolean ;
end;
TServiceContext = record
Changed: Boolean;
Service: string;
ServiceName: string;
Ascending: Boolean;
ConsultUser: Boolean ;
end;
function SelectService(FontSize: Integer; CurrentContext: TSelectContext; var ServiceContext: TServiceContext): boolean;
implementation
{$R *.DFM}
uses rConsults, rCore, uCore;
var
SvcList: TStrings ;
SvcInfo: string ;
uChanging: Boolean;
const
TX_SVC_TEXT = 'Select a consult service or press Cancel.';
TX_SVC_CAP = 'Missing Service';
function SelectService(FontSize: Integer; CurrentContext: TSelectContext; var ServiceContext: TServiceContext): boolean;
{ displays service select form for consults and returns a record of the selection }
var
frmConsultsByService: TfrmConsultsByService;
W, H, i: Integer;
CurrentService: string;
begin
frmConsultsByService := TfrmConsultsByService.Create(Application);
try
with frmConsultsByService do
begin
Font.Size := FontSize;
W := ClientWidth;
H := ClientHeight;
ResizeToFont(FontSize, W, H);
ClientWidth := W; pnlBase.Width := W;
ClientHeight := H; pnlBase.Height := H;
FChanged := False;
//SvcList.Assign(LoadServiceList(CN_SVC_LIST_DISP)); {RV}
SvcList.Assign(LoadServiceListWithSynonyms(CN_SVC_LIST_DISP)); {RV}
SortByPiece(TStringList(SvcList), U, 2); {RV}
for i := 0 to SvcList.Count - 1 do
if cboService.Items.IndexOf(Trim(Piece(SvcList.Strings[i], U, 2))) = -1 then {RV}
//if cboService.SelectByID(Piece(SvcList.Strings[i], U, 1)) = -1 then
cboService.Items.Add(SvcList.Strings[i]);
BuildServiceTree(treService, SvcList, '0', nil) ;
with treService do
for i := 0 to Items.Count-1 do
begin
if Items[i].Level > 0 then Items[i].Expanded := False else Items[i].Expanded := True;
TopItem := Items[0] ;
Selected := Items[0] ;
end ;
FAscending := CurrentContext.Ascending;
radSort.ItemIndex := Ord(not FAscending);
CurrentService := CurrentContext.Service;
if StrToIntDef(CurrentService, 0) > 0 then
begin
cboservice.SelectByID(CurrentService);
cboServiceSelect(frmConsultsByService);
end;
ShowModal;
with ServiceContext do
begin
Changed := FChanged;
Service := FService;
ServiceName := FServiceName;
Ascending := FAscending;
ConsultUser := FConsultUser ;
Result := Changed ;
end; {with ServiceContext}
end; {with frmConsultsByService}
finally
frmConsultsByService.Release;
end;
end;
procedure TfrmConsultsByService.cmdCancelClick(Sender: TObject);
begin
Close;
end;
procedure TfrmConsultsByService.cmdOKClick(Sender: TObject);
begin
if (treService.Selected = nil) and (StrToIntDef(FService, 0) = 0 ) then
begin
InfoBox(TX_SVC_TEXT, TX_SVC_CAP, MB_OK or MB_ICONWARNING);
Exit;
end;
FChanged := True;
FService := Piece(SvcInfo,u,1);
FServiceName := Piece(SvcInfo,u,2) ;
FAscending := (radSort.ItemIndex = 0);
FConsultUser := ConsultServiceUser(StrToIntDef(FService, 0), User.DUZ) ;
Close;
end;
procedure TfrmConsultsByService.treServiceChange(Sender: TObject;
Node: TTreeNode);
begin
if uChanging then Exit;
SvcInfo := TORTreeNode(treService.Selected).StringData ;
cboService.ItemIndex := cboService.Items.IndexOf(Trim(treService.Selected.Text)); {RV}
//cboService.SelectByID(Piece(string(treService.Selected.Data), U, 1));
end;
procedure TfrmConsultsByService.cboServiceSelect(Sender: TObject);
var
i: integer;
begin
uChanging := True;
with treService do for i := 0 to Items.Count-1 do
begin
if Piece(TORTreeNode(Items[i]).StringData, U, 1) = cboService.ItemID then
begin
Selected := Items[i];
//treServiceChange(Self, Items[i]);
break;
end;
end;
uChanging := False;
SvcInfo := TORTreeNode(treService.Selected).StringData ;
end;
initialization
SvcList := TStringList.Create ;
finalization
SvcList.Free ;
end.

80
CPRS-Chart/Consults/fConsultBSt.dfm Normal file
View File

@ -0,0 +1,80 @@
object frmConsultsByStatus: TfrmConsultsByStatus
Left = 286
Top = 202
Width = 316
Height = 232
BorderIcons = []
Caption = 'List Consults by Status'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = True
Position = poScreenCenter
PixelsPerInch = 96
TextHeight = 13
object pnlBase: TORAutoPanel
Left = 0
Top = 0
Width = 308
Height = 205
Align = alClient
BevelOuter = bvNone
TabOrder = 0
object lblStatus: TLabel
Left = 8
Top = 8
Width = 30
Height = 13
Caption = 'Status'
end
object radSort: TRadioGroup
Left = 8
Top = 148
Width = 212
Height = 49
Caption = 'Sort Order'
Items.Strings = (
'&Ascending (A-Z)'
'&Descending (Z-A)')
TabOrder = 1
end
object lstStatus: TORListBox
Left = 8
Top = 22
Width = 212
Height = 118
ItemHeight = 13
MultiSelect = True
ParentShowHint = False
ShowHint = True
TabOrder = 0
Caption = 'Status'
ItemTipColor = clWindow
LongList = False
Pieces = '2'
end
object cmdOK: TButton
Left = 228
Top = 149
Width = 72
Height = 21
Caption = 'OK'
Default = True
TabOrder = 2
OnClick = cmdOKClick
end
object cmdCancel: TButton
Left = 228
Top = 176
Width = 72
Height = 21
Cancel = True
Caption = 'Cancel'
TabOrder = 3
OnClick = cmdCancelClick
end
end
end

120
CPRS-Chart/Consults/fConsultBSt.pas Normal file
View File

@ -0,0 +1,120 @@
unit fConsultBSt;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, ORCtrls, StdCtrls, ORFn, uConsults;
type
TfrmConsultsByStatus = class(TForm)
pnlBase: TORAutoPanel;
lblStatus: TLabel;
radSort: TRadioGroup;
lstStatus: TORListBox;
cmdOK: TButton;
cmdCancel: TButton;
procedure cmdCancelClick(Sender: TObject);
procedure cmdOKClick(Sender: TObject);
private
FChanged: Boolean;
FStatus: string;
FStatusName: string;
FAscending: Boolean;
end;
TStatusContext = record
Changed: Boolean;
Status: string;
StatusName: string;
Ascending: Boolean;
end;
function SelectStatus(FontSize: Integer; CurrentContext: TSelectContext; var StatusContext: TStatusContext): boolean ;
implementation
{$R *.DFM}
uses rConsults, rCore, uCore;
const
TX_STAT_TEXT = 'Select a consult status or press Cancel.';
TX_STAT_CAP = 'Missing Status';
function SelectStatus(FontSize: Integer; CurrentContext: TSelectContext; var StatusContext: TStatusContext): boolean ;
{ displays Status select form for consults and returns a record of the selection }
var
frmConsultsByStatus: TfrmConsultsByStatus;
W, H, i, j: Integer;
CurrentStatus: string;
begin
frmConsultsByStatus := TfrmConsultsByStatus.Create(Application);
try
with frmConsultsByStatus do
begin
Font.Size := FontSize;
W := ClientWidth;
H := ClientHeight;
ResizeToFont(FontSize, W, H);
ClientWidth := W; pnlBase.Width := W;
ClientHeight := H; pnlBase.Height := H;
FChanged := False;
with radSort do {if SortConsultsAscending then ItemIndex := 0 else} ItemIndex := 1;
lstStatus.Items.Assign(SubSetOfStatus);
CurrentStatus := CurrentContext.Status;
if CurrentStatus <> '' then with lstStatus do
begin
i := 1;
while Piece(CurrentStatus, ',', i) <> '' do
begin
j := SelectByID(Piece(CurrentStatus, ',', i));
if j > -1 then Selected[j] := True;
Inc(i);
end;
end;
ShowModal;
with StatusContext do
begin
Changed := FChanged;
Status := FStatus;
StatusName := FStatusName;
Ascending := FAscending;
Result := Changed ;
end; {with StatusContext}
end; {with frmConsultsByStatus}
finally
frmConsultsByStatus.Release;
end;
end;
procedure TfrmConsultsByStatus.cmdCancelClick(Sender: TObject);
begin
Close;
end;
procedure TfrmConsultsByStatus.cmdOKClick(Sender: TObject);
var
i: integer;
begin
if lstStatus.SelCount = 0 then
begin
InfoBox(TX_STAT_TEXT, TX_STAT_CAP, MB_OK or MB_ICONWARNING);
Exit;
end;
FChanged := True;
with lstStatus do for i := 0 to Items.Count-1 do if Selected[i] then
begin
if Piece(Items[i], U, 1) <> '999' then
FStatus := FStatus + Piece(Items[i], U, 1) + ','
else
FStatus := FStatus + Piece(Items[i],U,3) ;
FStatusName := FStatusName + DisplayText[i] + ',' ;
end;
FStatus := Copy(FStatus, 1, Length(FStatus)-1);
FStatusName := Copy(FStatusName, 1, Length(FStatusName)-1);
FAscending := radSort.ItemIndex = 0;
Close;
end;
end.

1046
CPRS-Chart/Consults/fConsults.dfm Normal file
View File

File diff suppressed because it is too large Load Diff

4830
CPRS-Chart/Consults/fConsults.pas Normal file
View File

File diff suppressed because it is too large Load Diff

199
CPRS-Chart/Consults/fConsultsView.dfm Normal file
View File

@ -0,0 +1,199 @@
object frmConsultsView: TfrmConsultsView
Left = 320
Top = 172
Width = 414
Height = 400
BorderIcons = []
Caption = 'List Selected Consults'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = True
Position = poScreenCenter
PixelsPerInch = 96
TextHeight = 13
object pnlBase: TORAutoPanel
Left = 0
Top = 0
Width = 406
Height = 373
Align = alClient
BevelOuter = bvNone
TabOrder = 0
object lblBeginDate: TLabel
Left = 239
Top = 128
Width = 73
Height = 13
Caption = 'Beginning Date'
end
object lblEndDate: TLabel
Left = 239
Top = 173
Width = 59
Height = 13
Caption = 'Ending Date'
end
object lblService: TLabel
Left = 8
Top = 9
Width = 36
Height = 13
Caption = 'Service'
end
object lblStatus: TLabel
Left = 239
Top = 10
Width = 30
Height = 13
Caption = 'Status'
end
object Label1: TLabel
Left = 239
Top = 217
Width = 44
Height = 13
Caption = 'Group By'
end
object calBeginDate: TORDateBox
Left = 239
Top = 142
Width = 155
Height = 21
TabOrder = 3
DateOnly = False
RequireTime = False
Caption = 'Beginning Date'
end
object calEndDate: TORDateBox
Left = 239
Top = 187
Width = 155
Height = 21
TabOrder = 4
DateOnly = False
RequireTime = False
Caption = 'Ending Date'
end
object lstStatus: TORListBox
Left = 239
Top = 24
Width = 156
Height = 96
ItemHeight = 13
MultiSelect = True
ParentShowHint = False
PopupMenu = popStatus
ShowHint = True
TabOrder = 2
Caption = 'Status'
ItemTipColor = clWindow
LongList = False
Pieces = '2'
end
object radSort: TRadioGroup
Left = 239
Top = 266
Width = 155
Height = 64
Caption = 'Sort Order'
Items.Strings = (
'&Ascending (oldest first)'
'&Descending (newest first)')
TabOrder = 6
end
object cmdOK: TButton
Left = 239
Top = 340
Width = 72
Height = 21
Caption = 'OK'
Default = True
TabOrder = 7
OnClick = cmdOKClick
end
object cmdCancel: TButton
Left = 324
Top = 340
Width = 72
Height = 21
Cancel = True
Caption = 'Cancel'
TabOrder = 8
OnClick = cmdCancelClick
end
object treService: TORTreeView
Left = 8
Top = 57
Width = 214
Height = 304
HideSelection = False
Indent = 19
ReadOnly = True
TabOrder = 1
OnChange = treServiceChange
Caption = 'Service'
NodePiece = 0
end
object cboService: TORComboBox
Left = 8
Top = 27
Width = 214
Height = 21
Style = orcsDropDown
AutoSelect = True
Caption = 'Service'
Color = clWindow
DropDownCount = 8
ItemHeight = 13
ItemTipColor = clWindow
ItemTipEnable = True
ListItemsOnly = True
LongList = False
MaxLength = 0
Pieces = '2'
Sorted = True
SynonymChars = '<>'
TabOrder = 0
OnKeyPause = cboServiceSelect
OnMouseClick = cboServiceSelect
end
object cboGroupBy: TORComboBox
Left = 239
Top = 230
Width = 155
Height = 21
Style = orcsDropDown
AutoSelect = True
Caption = 'Group By'
Color = clWindow
DropDownCount = 8
Items.Strings = (
'^(none)'
'T^Consults/Procedures'
'V^Service'
'S^Status')
ItemHeight = 13
ItemTipColor = clWindow
ItemTipEnable = True
ListItemsOnly = False
LongList = False
MaxLength = 0
Pieces = '2'
Sorted = False
SynonymChars = '<>'
TabOrder = 5
end
end
object popStatus: TPopupMenu
Left = 284
Top = 51
object popStatusSelectNone: TMenuItem
Caption = 'Select None'
OnClick = popStatusSelectNoneClick
end
end
end

259
CPRS-Chart/Consults/fConsultsView.pas Normal file
View File

@ -0,0 +1,259 @@
unit fConsultsView;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ORFN,
StdCtrls, ExtCtrls, ORCtrls, ComCtrls, ORDtTm, uConsults, Menus;
type
TfrmConsultsView = class(TForm)
pnlBase: TORAutoPanel;
lblBeginDate: TLabel;
calBeginDate: TORDateBox;
lblEndDate: TLabel;
calEndDate: TORDateBox;
radSort: TRadioGroup;
lblStatus: TLabel;
lstStatus: TORListBox;
lblService: TLabel;
cmdOK: TButton;
cmdCancel: TButton;
treService: TORTreeView;
cboService: TORComboBox;
cboGroupBy: TORComboBox;
Label1: TLabel;
popStatus: TPopupMenu;
popStatusSelectNone: TMenuItem;
procedure cmdOKClick(Sender: TObject);
procedure cmdCancelClick(Sender: TObject);
procedure treServiceChange(Sender: TObject; Node: TTreeNode);
procedure cboServiceSelect(Sender: TObject);
procedure popStatusSelectNoneClick(Sender: TObject);
private
FChanged: Boolean;
FBeginDate: string;
FEndDate: string;
FGroupBy: string;
FAscending: Boolean;
FService: string;
FServiceName: string;
FConsultUser: boolean ;
FStatus: string;
FStatusName: string;
end;
function SelectConsultsView(FontSize: Integer; CurrentContext: TSelectContext; var SelectContext: TSelectContext): boolean ;
var
uChanging: Boolean;
implementation
{$R *.DFM}
uses rCore, uCore, rConsults;
var
SvcList: TStrings ;
SvcInfo: string ;
const
TX_DATE_ERR = 'Enter valid beginning and ending dates or press Cancel.';
TX_DATE_ERR_CAP = 'Error in Date Range';
function SelectConsultsView(FontSize: Integer; CurrentContext: TSelectContext; var SelectContext: TSelectContext): boolean ;
{ displays select form for Consults and returns a record of the selection }
var
frmConsultsView: TfrmConsultsView;
W, H, i, j: Integer;
CurrentStatus, CurrentBegin, CurrentEnd, CurrentService: string;
begin
frmConsultsView := TfrmConsultsView.Create(Application);
try
with frmConsultsView do
begin
Font.Size := FontSize;
W := ClientWidth;
H := ClientHeight;
ResizeToFont(FontSize, W, H);
ClientWidth := W; pnlBase.Width := W;
ClientHeight := H; pnlBase.Height := H;
FChanged := False;
with radSort do ItemIndex := 1;
//SvcList.Assign(LoadServiceList(CN_SVC_LIST_DISP)); {RV}
SvcList.Assign(LoadServiceListWithSynonyms(CN_SVC_LIST_DISP)); {RV}
SortByPiece(TStringList(SvcList), U, 2); {RV}
for i := 0 to SvcList.Count - 1 do
if cboService.Items.IndexOf(Trim(Piece(SvcList.Strings[i], U, 2))) = -1 then {RV}
//if cboService.SelectByID(Piece(SvcList.Strings[i], U, 1)) = -1 then
cboService.Items.Add(SvcList.Strings[i]);
BuildServiceTree(treService, SvcList, '0', nil) ;
with treService do
for i:=0 to Items.Count-1 do
begin
if Items[i].Level > 0 then Items[i].Expanded := False else Items[i].Expanded := True;
TopItem := Items[0] ;
Selected := Items[0] ;
end ;
CurrentService := CurrentContext.Service;
if StrToIntDef(CurrentService, 0) > 0 then
begin
cboservice.SelectByID(CurrentService);
cboServiceSelect(frmConsultsView);
end;
lstStatus.Items.Assign(SubSetOfStatus);
CurrentStatus := CurrentContext.Status;
if CurrentStatus <> '' then with lstStatus do
begin
i := 1;
while Piece(CurrentStatus, ',', i) <> '' do
begin
j := SelectByID(Piece(CurrentStatus, ',', i));
if j > -1 then Selected[j] := True;
Inc(i);
end;
end;
CurrentBegin := CurrentContext.BeginDate;
CurrentEnd := CurrentContext.EndDate;
if CurrentBegin <> '' then
calBeginDate.Text := CurrentBegin;
if CurrentEnd <> '' then
calEndDate.Text := CurrentEnd;
if calEndDate.Text = '' then calEndDate.Text := 'TODAY';
cboGroupBy.SelectByID(CurrentContext.GroupBy);
ShowModal;
with SelectContext do
begin
Changed := FChanged;
BeginDate := FBeginDate;
EndDate := FEndDate;
Ascending := FAscending;
Service := FService;
ServiceName := FServiceName;
ConsultUser := FConsultUser ;
Status := FStatus;
StatusName := FStatusName;
GroupBy := FGroupBy;
Result := Changed ;
end;
end; {with frmConsultsView}
finally
frmConsultsView.Release;
end;
end;
procedure TfrmConsultsView.cmdOKClick(Sender: TObject);
var
bdate, edate: TFMDateTime;
i: integer;
begin
if calBeginDate.Text <> '' then
bdate := StrToFMDateTime(calBeginDate.Text)
else
bdate := 0 ;
if calEndDate.Text <> '' then
edate := StrToFMDateTime(calEndDate.Text)
else
edate := 0 ;
if (bdate <= edate) then
begin
FAscending := radSort.ItemIndex = 0;
FBeginDate := calBeginDate.Text;
FEndDate := calEndDate.Text;
end
else
begin
InfoBox(TX_DATE_ERR, TX_DATE_ERR_CAP, MB_OK or MB_ICONWARNING);
Exit;
end;
if treService.Selected <> nil then
begin
FService := Piece(SvcInfo,u,1) ;
FServiceName := Piece(SvcInfo,u,2) ;
FConsultUser := ConsultServiceUser(StrToIntDef(FService, 0), User.DUZ) ;
end
else
FService := '' ;
if lstStatus.SelCount > 0 then
begin
with lstStatus do for i := 0 to Items.Count-1 do if Selected[i] then
begin
if Piece(Items[i], U, 1) <> '999' then
FStatus := FStatus + Piece(Items[i], U, 1) + ','
else
FStatus := FStatus + Piece(Items[i],U,3) ;
FStatusName := FStatusName + DisplayText[i] + ',' ;
end;
FStatus := Copy(FStatus, 1, Length(FStatus)-1);
FStatusName := Copy(FStatusName, 1, Length(FStatusName)-1);
end
else
FStatus := '' ;
if cboGroupBy.ItemID <> '' then
FGroupBy := cboGroupBy.ItemID
else
FGroupBy := '';
FChanged := True;
Close;
end;
procedure TfrmConsultsView.cmdCancelClick(Sender: TObject);
begin
Close;
end;
procedure TfrmConsultsView.treServiceChange(Sender: TObject; Node: TTreeNode);
begin
if uChanging then Exit;
SvcInfo := TORTreeNode(treService.Selected).StringData ;
cboService.ItemIndex := cboService.Items.IndexOf(Trim(treService.Selected.Text)); {RV}
//cboService.SelectByID(Piece(string(treService.Selected.Data), U, 1));
end;
procedure TfrmConsultsView.cboServiceSelect(Sender: TObject);
var
i: integer;
begin
uChanging := True;
with treService do for i := 0 to Items.Count-1 do
begin
if Piece(TORTreeNode(Items[i]).StringData,U,1) = cboService.ItemID then
begin
Selected := Items[i];
//treServiceChange(Self, Items[i]);
break;
end;
end;
uChanging := False;
SvcInfo := TORTreeNode(treService.Selected).StringData ;
end;
procedure TfrmConsultsView.popStatusSelectNoneClick(Sender: TObject);
var
i: integer;
begin
with lstStatus do
begin
for i := 0 to Items.Count - 1 do
Selected[i] := False;
ItemIndex := -1;
end;
end;
initialization
SvcList := TStringList.Create ;
finalization
SvcList.Free ;
end.

78
CPRS-Chart/Consults/fCsltNote.dfm Normal file
View File

@ -0,0 +1,78 @@
object frmCsltNote: TfrmCsltNote
Left = 147
Top = 206
BorderStyle = bsDialog
Caption = 'Select Progress Note'
ClientHeight = 189
ClientWidth = 398
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = True
Position = poScreenCenter
PixelsPerInch = 96
TextHeight = 13
object pnlBase: TORAutoPanel
Left = 0
Top = 0
Width = 398
Height = 189
Align = alClient
BevelOuter = bvNone
TabOrder = 0
object lblAction: TLabel
Left = 12
Top = 14
Width = 372
Height = 16
AutoSize = False
Caption = 'Select a note for this action:'
end
object cmdOK: TButton
Left = 122
Top = 152
Width = 75
Height = 25
Caption = 'OK'
Default = True
ModalResult = 1
TabOrder = 1
OnClick = cmdOKClick
end
object cmdCancel: TButton
Left = 203
Top = 152
Width = 75
Height = 25
Cancel = True
Caption = 'Cancel'
ModalResult = 2
TabOrder = 2
OnClick = cmdCancelClick
end
object cboCsltNote: TORComboBox
Left = 15
Top = 32
Width = 370
Height = 103
Style = orcsSimple
AutoSelect = True
Caption = 'Select a note for this action'
Color = clWindow
DropDownCount = 8
ItemHeight = 13
ItemTipColor = clWindow
ItemTipEnable = True
ListItemsOnly = True
LongList = False
MaxLength = 0
Pieces = '2,3'
Sorted = True
SynonymChars = '<>'
TabOrder = 0
end
end
end

148
CPRS-Chart/Consults/fCsltNote.pas Normal file
View File

@ -0,0 +1,148 @@
unit fCsltNote;
interface
uses Windows, SysUtils, Classes, Graphics, Forms, Controls, StdCtrls,
Buttons, ORCtrls, ORfn, ExtCtrls;
type
TfrmCsltNote = class(TForm)
cmdOK: TButton;
cmdCancel: TButton;
cboCsltNote: TORComboBox;
lblAction: TLabel;
pnlBase: TORAutoPanel;
procedure cmdOKClick(Sender: TObject);
procedure cmdCancelClick(Sender: TObject);
private
FNoteIEN: string ;
FChanged: Boolean;
end;
procedure SelectNoteForProcessing(FontSize: Integer; ActionType: integer; NoteList: TStrings;
var NoteIEN: integer; CPStatus: integer) ;
implementation
{$R *.DFM}
uses rConsults, rCore, uCore, fConsults, uConsults;
const
TX_NOTE_TEXT = 'Select a document or press Cancel.';
TX_NOTE_CAP = 'No Document Selected';
procedure SelectNoteForProcessing(FontSize: Integer; ActionType: integer; NoteList: TStrings;
var NoteIEN: integer; CPStatus: integer) ;
{ displays progress note selection form and returns a record of the selection }
var
frmCsltNote: TfrmCsltNote;
W, H, i: Integer;
begin
frmCsltNote := TfrmCsltNote.Create(Application);
try
with frmCsltNote do
begin
Font.Size := FontSize;
W := ClientWidth;
H := ClientHeight;
ResizeToFont(FontSize, W, H);
ClientWidth := W; pnlBase.Width := W;
ClientHeight := H; pnlBase.Height := H;
FChanged := False;
Caption := fConsults.ActionType[ActionType];
case ActionType of
CN_ACT_CP_COMPLETE:
begin
if CPStatus = CP_INSTR_INCOMPLETE then
begin
lblAction.Caption := 'Interpret Clinical Procedure Results:';
cboCsltNote.Caption := lblAction.Caption;
for i := 0 to NoteList.Count-1 do
if ((not (Copy(Piece(Piece(NoteList[i], U, 1), ';', 2), 1, 4) = 'MCAR')) and
(Piece(NoteList[i], U, 13) <> '%') and
(Piece(NoteList[i], U, 7) <> 'completed')) then
cboCsltNote.Items.Add(Piece(NoteList[i], U, 1) + U + MakeConsultNoteDisplayText(Notelist[i]));
cboCsltNote.ItemIndex := 0;
FNoteIEN := cboCsltNote.ItemID;
//ShowModal;
end
else if CPStatus in [CP_NO_INSTRUMENT, CP_INSTR_COMPLETE] then
begin
lblAction.Caption := 'Select incomplete note to continue with:';
cboCsltNote.Caption := lblAction.Caption;
for i := 0 to NoteList.Count-1 do
if ((not (Copy(Piece(Piece(NoteList[i], U, 1), ';', 2), 1, 4) = 'MCAR')) and
(Piece(NoteList[i], U, 7) <> 'completed') and
((Piece(Piece(NoteList[i], U, 5), ';', 1) = IntToStr(User.DUZ)) or
(Piece(Piece(NoteList[i], U, 5), ';', 1) = '0'))) then
cboCsltNote.Items.Add(Piece(NoteList[i], U, 1) + U + MakeConsultNoteDisplayText(Notelist[i]));
if cboCsltNote.Items.Count > 0 then cboCsltNote.Items.Insert(0, CN_NEW_CP_NOTE + '^<Create new note>');
if cboCsltNote.Items.Count > 0 then
ShowModal
else
FNoteIEN := CN_NEW_CP_NOTE;
end;
end;
CN_ACT_COMPLETE:
begin
lblAction.Caption := 'Select incomplete note to continue with:';
cboCsltNote.Caption := lblAction.Caption;
for i := 0 to NoteList.Count-1 do
if ((not (Copy(Piece(Piece(NoteList[i], U, 1), ';', 2), 1, 4) = 'MCAR')) and
(Piece(NoteList[i], U, 7) <> 'completed') and
(Piece(Piece(NoteList[i], U, 5), ';', 1) = IntToStr(User.DUZ))) then
cboCsltNote.Items.Add(Piece(NoteList[i], U, 1) + U + MakeConsultNoteDisplayText(Notelist[i]));
if cboCsltNote.Items.Count > 0 then cboCsltNote.Items.Insert(0, CN_NEW_CSLT_NOTE + '^<Create new note>');
if cboCsltNote.Items.Count > 0 then
ShowModal
else
FNoteIEN := CN_NEW_CSLT_NOTE;
end;
(* CN_ACT_ADDENDUM: // no longer called in v15
begin
lblAction.Caption := 'Select completed note to addend to:';
for i := 0 to NoteList.Count-1 do
begin
if Copy(Piece(NoteList[i], U, 2), 1, 8) = 'Addendum' then continue;
if Piece(NoteList[i], U, 13) = '%' then continue;
cboCsltNote.Items.Add(Piece(NoteList[i], U, 1) + U + MakeConsultNoteDisplayText(Notelist[i]));
end;
if cboCsltNote.Items.Count > 0 then
ShowModal
else
FNoteIEN := '-30';
end;*)
end; {case}
NoteIEN:= StrToIntDef(FNoteIEN, -1) ;
end; {with frmCsltNote}
finally
frmCsltNote.Release;
end;
end;
procedure TfrmCsltNote.cmdCancelClick(Sender: TObject);
begin
FNoteIEN := '-1';
Close;
end;
procedure TfrmCsltNote.cmdOKClick(Sender: TObject);
begin
with cboCsltNote do
begin
if ItemIEN = 0 then
begin
InfoBox(TX_NOTE_TEXT, TX_NOTE_CAP, MB_OK or MB_ICONWARNING);
FChanged := False ;
FNoteIEN := '-1';
Exit;
end;
FChanged := True;
FNoteIEN := Piece(Items[ItemIndex],U,1);
Close;
end ;
end;
end.

409
CPRS-Chart/Consults/fEditConsult.dfm Normal file
View File

@ -0,0 +1,409 @@
object frmEditCslt: TfrmEditCslt
Tag = 110
Left = 409
Top = 225
Width = 569
Height = 367
HorzScrollBar.Range = 561
VertScrollBar.Range = 340
AutoScroll = False
Caption = 'Edit/Resubmit a Cancelled Consult'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = True
Position = poScreenCenter
DesignSize = (
561
340)
PixelsPerInch = 96
TextHeight = 13
object lblService: TLabel
Left = 4
Top = 4
Width = 134
Height = 13
Caption = 'Consult to Service/Specialty'
end
object lblReason: TLabel
Left = 4
Top = 166
Width = 90
Height = 13
Caption = 'Reason for Consult'
end
object lblComment: TLabel
Left = 4
Top = 105
Width = 77
Height = 13
Caption = 'New Comments:'
end
object lblComments: TLabel
Left = 4
Top = 51
Width = 89
Height = 13
Caption = 'Display Comments:'
end
object lblUrgency: TStaticText
Left = 196
Top = 4
Width = 44
Height = 17
Caption = 'Urgency'
TabOrder = 16
end
object lblPlace: TStaticText
Left = 376
Top = 41
Width = 104
Height = 17
Caption = 'Place of Consultation'
TabOrder = 17
end
object lblAttn: TStaticText
Left = 376
Top = 4
Width = 46
Height = 17
Caption = 'Attention'
TabOrder = 18
end
object lblProvDiag: TStaticText
Left = 195
Top = 82
Width = 104
Height = 17
Caption = 'Provisional Diagnosis'
TabOrder = 19
end
object lblInpOutp: TStaticText
Left = 197
Top = 47
Width = 127
Height = 17
Caption = 'Patient will be seen as an:'
TabOrder = 20
end
object memReason: TRichEdit
Left = 4
Top = 179
Width = 552
Height = 129
Anchors = [akLeft, akTop, akRight, akBottom]
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Courier New'
Font.Style = []
ParentFont = False
PopupMenu = popReason
ScrollBars = ssBoth
TabOrder = 11
WantTabs = True
OnChange = ControlChange
OnExit = memReasonExit
OnKeyDown = memCommentKeyDown
OnKeyPress = memCommentKeyPress
OnKeyUp = memCommentKeyUp
end
object pnlMessage: TPanel
Left = 21
Top = 292
Width = 381
Height = 44
Anchors = [akLeft, akRight, akBottom]
BevelInner = bvRaised
BorderStyle = bsSingle
Caption = 'pnlMessage'
TabOrder = 15
Visible = False
object imgMessage: TImage
Left = 4
Top = 4
Width = 32
Height = 32
end
object memMessage: TRichEdit
Left = 37
Top = 4
Width = 332
Height = 32
Color = clInfoBk
Font.Charset = DEFAULT_CHARSET
Font.Color = clInfoText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
ParentFont = False
ScrollBars = ssVertical
TabOrder = 0
WantReturns = False
end
end
object cboService: TORComboBox
Left = 4
Top = 19
Width = 180
Height = 21
Style = orcsDropDown
AutoSelect = True
Caption = 'Consult to Service/Specialty'
Color = clWindow
DropDownCount = 8
Enabled = False
Font.Charset = DEFAULT_CHARSET
Font.Color = clGrayText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
ItemHeight = 13
ItemTipColor = clWindow
ItemTipEnable = True
ListItemsOnly = True
LongList = False
LookupPiece = 0
MaxLength = 0
ParentFont = False
Pieces = '2'
Sorted = True
SynonymChars = '<>'
TabOrder = 0
CharsNeedMatch = 1
end
object cboUrgency: TORComboBox
Left = 196
Top = 19
Width = 170
Height = 21
Style = orcsDropDown
AutoSelect = True
Caption = 'Urgency'
Color = clWindow
DropDownCount = 8
ItemHeight = 13
ItemTipColor = clWindow
ItemTipEnable = True
ListItemsOnly = True
LongList = False
LookupPiece = 0
MaxLength = 0
Pieces = '2'
Sorted = False
SynonymChars = '<>'
TabOrder = 1
OnChange = ControlChange
CharsNeedMatch = 1
end
object radInpatient: TRadioButton
Left = 197
Top = 61
Width = 61
Height = 17
Caption = '&Inpatient'
TabOrder = 5
OnClick = radInpatientClick
end
object radOutpatient: TRadioButton
Left = 269
Top = 61
Width = 73
Height = 17
Caption = '&Outpatient'
TabOrder = 6
OnClick = radOutpatientClick
end
object cboPlace: TORComboBox
Left = 376
Top = 54
Width = 179
Height = 21
Anchors = [akLeft, akTop, akRight]
Style = orcsDropDown
AutoSelect = True
Caption = 'Place of Consultation'
Color = clWindow
DropDownCount = 8
ItemHeight = 13
ItemTipColor = clWindow
ItemTipEnable = True
ListItemsOnly = True
LongList = False
LookupPiece = 0
MaxLength = 0
Pieces = '2'
Sorted = False
SynonymChars = '<>'
TabOrder = 7
OnChange = ControlChange
CharsNeedMatch = 1
end
object txtProvDiag: TCaptionEdit
Left = 195
Top = 95
Width = 309
Height = 21
Anchors = [akLeft, akTop, akRight]
MaxLength = 180
ParentShowHint = False
PopupMenu = mnuPopProvDx
ShowHint = True
TabOrder = 8
OnChange = ControlChange
Caption = 'Provisional Diagnosis'
end
object txtAttn: TORComboBox
Left = 376
Top = 19
Width = 181
Height = 21
Anchors = [akLeft, akTop, akRight]
Style = orcsDropDown
AutoSelect = True
Caption = 'Attention'
Color = clWindow
DropDownCount = 8
ItemHeight = 13
ItemTipColor = clWindow
ItemTipEnable = True
ListItemsOnly = True
LongList = True
LookupPiece = 2
MaxLength = 0
Pieces = '2,3'
Sorted = False
SynonymChars = '<>'
TabOrder = 2
OnChange = ControlChange
OnNeedData = txtAttnNeedData
CharsNeedMatch = 1
end
object cboCategory: TORComboBox
Left = 561
Top = 103
Width = 10
Height = 21
Style = orcsDropDown
AutoSelect = True
Color = clWindow
DropDownCount = 8
ItemHeight = 13
ItemTipColor = clWindow
ItemTipEnable = True
ListItemsOnly = False
LongList = False
LookupPiece = 0
MaxLength = 0
Sorted = False
SynonymChars = '<>'
TabOrder = 14
Visible = False
CharsNeedMatch = 1
end
object cmdAccept: TButton
Left = 407
Top = 313
Width = 72
Height = 21
Anchors = [akRight, akBottom]
Caption = 'Resubmit'
TabOrder = 12
OnClick = cmdAcceptClick
end
object cmdQuit: TButton
Left = 484
Top = 313
Width = 72
Height = 21
Anchors = [akRight, akBottom]
Cancel = True
Caption = 'Cancel'
TabOrder = 13
OnClick = cmdQuitClick
end
object memComment: TRichEdit
Left = 4
Top = 121
Width = 550
Height = 41
Anchors = [akLeft, akTop, akRight]
PopupMenu = popReason
TabOrder = 10
WantTabs = True
OnChange = ControlChange
OnKeyDown = memCommentKeyDown
OnKeyPress = memCommentKeyPress
OnKeyUp = memCommentKeyUp
end
object btnCmtCancel: TButton
Left = 110
Top = 49
Width = 75
Height = 21
Caption = 'Cancellation'
TabOrder = 3
OnClick = btnCmtCancelClick
end
object btnCmtOther: TButton
Left = 110
Top = 75
Width = 75
Height = 21
Caption = 'Other'
TabOrder = 4
OnClick = btnCmtOtherClick
end
object cmdLexSearch: TButton
Left = 508
Top = 95
Width = 46
Height = 21
Anchors = [akTop, akRight]
Caption = 'Lexicon'
TabOrder = 9
OnClick = cmdLexSearchClick
end
object mnuPopProvDx: TPopupMenu
Left = 353
Top = 77
object mnuPopProvDxDelete: TMenuItem
Caption = 'Delete diagnosis'
OnClick = mnuPopProvDxDeleteClick
end
end
object popReason: TPopupMenu
OnPopup = popReasonPopup
Left = 411
Top = 169
object popReasonCut: TMenuItem
Caption = 'Cu&t'
ShortCut = 16472
OnClick = popReasonCutClick
end
object popReasonCopy: TMenuItem
Caption = '&Copy'
ShortCut = 16451
OnClick = popReasonCopyClick
end
object popReasonPaste: TMenuItem
Caption = '&Paste'
ShortCut = 16470
OnClick = popReasonPasteClick
end
object popReasonPaste2: TMenuItem
Caption = 'Paste2'
ShortCut = 8237
Visible = False
OnClick = popReasonPasteClick
end
object popReasonReformat: TMenuItem
Caption = 'Reformat Paragraph'
ShortCut = 16466
OnClick = popReasonReformatClick
end
end
end

671
CPRS-Chart/Consults/fEditConsult.pas Normal file
View File

@ -0,0 +1,671 @@
unit fEditConsult;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ORCtrls, ExtCtrls, ComCtrls, ORfn, uConst, uConsults, Buttons,
Menus ;
type
TfrmEditCslt = class(TForm)
cboService: TORComboBox;
cboUrgency: TORComboBox;
radInpatient: TRadioButton;
radOutpatient: TRadioButton;
cboPlace: TORComboBox;
txtProvDiag: TCaptionEdit;
txtAttn: TORComboBox;
lblReason: TLabel;
lblService: TLabel;
lblUrgency: TStaticText;
lblPlace: TStaticText;
lblAttn: TStaticText;
lblProvDiag: TStaticText;
cboCategory: TORComboBox;
pnlMessage: TPanel;
imgMessage: TImage;
memMessage: TRichEdit;
cmdAccept: TButton;
cmdQuit: TButton;
memComment: TRichEdit;
lblComment: TLabel;
lblComments: TLabel;
btnCmtCancel: TButton;
btnCmtOther: TButton;
mnuPopProvDx: TPopupMenu;
mnuPopProvDxDelete: TMenuItem;
cmdLexSearch: TButton;
lblInpOutp: TStaticText;
memReason: TRichEdit;
popReason: TPopupMenu;
popReasonCut: TMenuItem;
popReasonCopy: TMenuItem;
popReasonPaste: TMenuItem;
popReasonPaste2: TMenuItem;
popReasonReformat: TMenuItem;
procedure txtAttnNeedData(Sender: TObject; const StartFrom: String;
Direction, InsertAt: Integer);
procedure radInpatientClick(Sender: TObject);
procedure radOutpatientClick(Sender: TObject);
procedure ControlChange(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure cmdQuitClick(Sender: TObject);
procedure cmdAcceptClick(Sender: TObject);
procedure memReasonExit(Sender: TObject);
procedure OrderMessage(const AMessage: string);
procedure btnCmtCancelClick(Sender: TObject);
procedure btnCmtOtherClick(Sender: TObject);
procedure cmdLexSearchClick(Sender: TObject);
procedure mnuPopProvDxDeleteClick(Sender: TObject);
procedure popReasonCutClick(Sender: TObject);
procedure popReasonCopyClick(Sender: TObject);
procedure popReasonPasteClick(Sender: TObject);
procedure popReasonPopup(Sender: TObject);
procedure popReasonReformatClick(Sender: TObject);
procedure memCommentKeyUp(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure memCommentKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure memCommentKeyPress(Sender: TObject; var Key: Char);
private
FLastServiceID: string;
FChanged: boolean;
FChanging: boolean;
FEditCtrl: TCustomEdit;
FNavigatingTab: boolean;
procedure SetProvDiagPromptingMode;
protected
procedure InitDialog;
procedure Validate(var AnErrMsg: string);
function ValidSave: Boolean;
end;
function EditResubmitConsult(FontSize: Integer; ConsultIEN: integer): boolean;
var
frmEditCslt: TfrmEditCslt;
implementation
{$R *.DFM}
uses
rODBase, rConsults, uCore, rCore, fConsults, fRptBox, fPCELex, rPCE,
ORClasses, clipbrd, UBAGlobals, rOrders ;
var
SvcList: TStrings ;
OldRec, NewRec: TEditResubmitRec;
Defaults: TStringList;
uMessageVisible: DWORD;
ProvDx: TProvisionalDiagnosis;
{Begin BillingAware}
BADxUpdated: boolean;
{End BillingAware}
const
TX_NOTTHISSVC_TEXT = 'Consults cannot be ordered from this service' ;
TX_NO_SVC = 'A service must be specified.' ;
TX_NO_REASON = 'A reason for this consult must be entered.' ;
TX_SVC_ERROR = 'This service has not been defined in your Orderable Items file.' +
#13#10'Contact IRM for assistance.' ;
TX_NO_URGENCY = 'An urgency must be specified.';
TX_NO_PLACE = 'A place of consultation must be specified';
TX_NO_DIAG = 'A provisional diagnosis must be entered for consults to this service.';
TX_SELECT_DIAG = 'You must use the "Lexicon" button to select a diagnosis for consults to this service.';
TX_INACTIVE_CODE = 'The provisional diagnosis code is not active as of today''s date.' + #13#10 +
'Another code must be selected';
TC_INACTIVE_CODE = 'Inactive ICD Code';
function EditResubmitConsult(FontSize: Integer; ConsultIEN: integer): boolean;
begin
Result := False;
if ConsultIEN = 0 then exit;
FillChar(OldRec, SizeOf(OldRec), 0);
FillChar(NewRec, SizeOf(NewRec), 0);
FillChar(ProvDx, SizeOf(ProvDx), 0);
OldRec := LoadConsultForEdit(ConsultIEN);
NewRec.IEN := OldRec.IEN;
NewRec.RequestType := OldRec.RequestType;
with NewRec do
begin
RequestReason:= TStringList.Create ;
DenyComments:= TStringList.Create ;
OtherComments:= TStringList.Create ;
NewComments:= TStringList.Create ;
end;
StatusText('Loading Consult for Edit');
frmEditCslt := TfrmEditCslt.Create(Application);
SvcList := TStringList.Create ;
Defaults := TStringList.Create;
try
with frmEditCslt do
begin
ResizeAnchoredFormToFont(frmEditCslt);
FChanged := False;
InitDialog;
ShowModal ;
Result := FChanged ;
end ;
finally
OldRec.RequestReason.Free;
OldRec.DenyComments.Free;
OldRec.OtherComments.Free;
OldRec.NewComments.Free;
NewRec.RequestReason.Free;
NewRec.DenyComments.Free;
NewRec.OtherComments.Free;
NewRec.NewComments.Free;
SvcList.Free;
Defaults.Free;
frmEditCslt.Release;
end;
end;
procedure TfrmEditCslt.InitDialog;
var
i:integer;
begin
FChanging := True;
Defaults.Assign(ODForConsults);
FLastServiceID := '';
cboService.Items.Clear;
if OldRec.InpOutp <> '' then
case OldRec.InpOutp[1] of
'I': radInpatient.Checked := True; //INPATIENT CONSULT
'O': radOutpatient.Checked := True; //OUTPATIENT CONSULT
end
else
begin
if Patient.Inpatient then
radInpatient.Checked := True
else
radOutpatient.Checked := True;
end;
StatusText('Initializing Long List');
SvcList.Assign(LoadServiceList(CN_SVC_LIST_ORD)) ;
with cboService do
begin
for i := 0 to SvcList.Count - 1 do
if SelectByID(Piece(SvcList.Strings[i], U, 1)) = -1 then
Items.Add(SvcList.Strings[i]);
SelectByID(IntToStr(OldRec.ToService));
end;
cboPlace.SelectByID(OldRec.Place);
with cboUrgency do for i := 0 to Items.Count-1 do
if UpperCase(DisplayText[i]) = UpperCase(OldRec.UrgencyName) then ItemIndex := i;
txtProvDiag.Text := OldRec.ProvDiagnosis;
ProvDx.Code := OldRec.ProvDxCode;
if OldRec.ProvDxCodeInactive then
begin
InfoBox(TX_INACTIVE_CODE, TC_INACTIVE_CODE, MB_ICONWARNING or MB_OK);
ProvDx.CodeInactive := True;
end;
memReason.Lines.Assign(OldRec.RequestReason);
memComment.Clear ;
btnCmtCancel.Enabled := (OldRec.DenyComments.Count > 0);
btnCmtOther.Enabled := (OldRec.OtherComments.Count > 0);
txtAttn.InitLongList(OldRec.AttnName) ;
if OldRec.Attention > 0 then
txtAttn.SelectByIEN(OldRec.Attention)
else
txtAttn.ItemIndex := -1;
SetProvDiagPromptingMode;
FChanging := False;
StatusText('');
end;
procedure TfrmEditCslt.Validate(var AnErrMsg: string);
procedure SetError(const x: string);
begin
if Length(AnErrMsg) > 0 then AnErrMsg := AnErrMsg + CRLF;
AnErrMsg := AnErrMsg + x;
end;
begin
inherited;
if cboService.ItemIEN = 0 then SetError(TX_NO_SVC);
if cboUrgency.ItemIEN = 0 then SetError(TX_NO_URGENCY);
if cboPlace.ItemID = '' then SetError(TX_NO_PLACE);
if memReason.Lines.Count = 0 then SetError(TX_NO_REASON);
with cboService do
begin
if Piece(Items[ItemIndex], U, 5) = '1' then SetError(TX_NOTTHISSVC_TEXT);
if (Piece(Items[ItemIndex],U,5) <> '1')
and (Piece(Items[ItemIndex], U, 6) = '')
then SetError(TX_SVC_ERROR) ;
end;
if (ProvDx.Reqd = 'R') and (Length(txtProvDiag.Text) = 0) then
begin
if ProvDx.PromptMode = 'F' then
SetError(TX_NO_DIAG)
else
SetError(TX_SELECT_DIAG);
end;
if OldRec.ProvDxCodeInactive and ProvDx.CodeInactive then
SetError(TX_INACTIVE_CODE);
end;
procedure TfrmEditCslt.txtAttnNeedData(Sender: TObject;
const StartFrom: string; Direction, InsertAt: Integer);
begin
inherited;
txtAttn.ForDataUse(SubSetOfPersons(StartFrom, Direction));
end;
procedure TfrmEditCslt.radInpatientClick(Sender: TObject);
begin
inherited;
cboUrgency.Items.Clear;
cboPlace.Items.Clear;
cboCategory.Items.Clear;
cboCategory.Items.Add('I^Inpatient');
cboCategory.SelectById('I');
ExtractItems(cboPlace.Items, Defaults, 'Inpt Place');
ExtractItems(cboUrgency.Items, Defaults, 'Inpt Cslt Urgencies'); //S.GMRCR
ControlChange(Self);
end;
procedure TfrmEditCslt.radOutpatientClick(Sender: TObject);
begin
inherited;
cboUrgency.Items.Clear;
cboPlace.Items.Clear;
cboCategory.Items.Clear;
cboCategory.Items.Add('O^Outpatient');
cboCategory.SelectById('O');
ExtractItems(cboPlace.Items, Defaults, 'Outpt Place');
ExtractItems(cboUrgency.Items, Defaults, 'Outpt Urgencies'); //S.GMRCO
ControlChange(Self);
end;
procedure TfrmEditCslt.ControlChange(Sender: TObject);
begin
if FChanging then exit;
with NewRec do
begin
with cboService do if ItemIEN > 0 then
if ItemIEN <> OldRec.ToService then
begin
ToService := ItemIEN;
ToServiceName := Text;
end
else
begin
ToService := 0;
ToServiceName := '';
end;
with cboCategory do if Length(ItemID) > 0 then
if ItemID <> OldRec.InpOutP then
InpOutP := ItemID
else
InpOutP := '';
with cboUrgency do if ItemIEN > 0 then
if StrToIntDef(Piece(Items[ItemIndex], U, 3), 0) <> OldRec.Urgency then
begin
Urgency := StrToIntDef(Piece(Items[ItemIndex], U, 3), 0);
UrgencyName := Text;
end
else
begin
Urgency := 0;
UrgencyName := '';
end;
with cboPlace do if Length(ItemID) > 0 then
if ItemID <> OldRec.Place then
begin
Place := ItemID;
PlaceName := Text;
end
else
begin
Place := '';
PlaceName := '';
end;
with txtAttn do
if ItemIEN > 0 then
begin
if ItemIEN <> OldRec.Attention then
begin
Attention := ItemIEN;
AttnName := Text;
end
else
begin
Attention := 0;
AttnName := '';
end;
end
else // blank
begin
if OldRec.Attention > 0 then
begin
Attention := -1;
AttnName := '';
end
else
begin
Attention := 0;
AttnName := '';
end;
end;
with txtProvDiag do
if Length(Text) > 0 then
begin
if Text <> OldRec.ProvDiagnosis then
ProvDiagnosis := Text
else
ProvDiagnosis := '';
if ProvDx.Code <> OldRec.ProvDxCode then
ProvDxCode := ProvDx.Code
else
ProvDxCode := '';
if OldRec.ProvDxCodeInactive then
ProvDx.CodeInactive := (ProvDx.Code = OldRec.ProvDxCode);
end
else //blank
begin
ProvDx.Code := '';
ProvDx.CodeInactive := False;
if OldRec.ProvDiagnosis <> '' then
ProvDiagnosis := '@'
else
ProvDiagnosis := '';
end;
with memReason do if Lines.Count > 0 then
if Lines.Equals(OldRec.RequestReason) then
RequestReason.Clear
else
RequestReason.Assign(Lines);
with memComment do
if GetTextLen > 0 then
NewComments.Assign(Lines)
else
NewComments.Clear;
end;
end;
procedure TfrmEditCslt.FormClose(Sender: TObject; var Action: TCloseAction);
const
TX_ACCEPT = 'Resubmit this request?' + CRLF + CRLF;
TX_ACCEPT_CAP = 'Unsaved Changes';
begin
if FChanged then
if InfoBox(TX_ACCEPT, TX_ACCEPT_CAP, MB_YESNO) = ID_YES then
if not ValidSave then Action := caNone;
end;
procedure TfrmEditCslt.cmdAcceptClick(Sender: TObject);
{Begin BillingAware}
var
BADiagnosis: string;
//newDxRec: TBADxRecord;
//AnOrder: TOrder;
{End BillingAware}
begin
{Begin BillingAware}
if BILLING_AWARE then
begin
if BADxUpdated then
begin
BADiagnosis := ProvDx.Text + '^' + ProvDx.Code;
UBAGlobals.Dx1 := BADiagnosis; // add selected dx to BA Dx List.
UBAGlobals.SimpleAddTempDxList(UBAGlobals.BAOrderID);
end;
end;
{End BillingAware}
if ValidSave then
begin
FChanged := (ResubmitConsult(NewRec) = '0');
Close;
end;
end;
procedure TfrmEditCslt.memReasonExit(Sender: TObject);
var
AStringList: TStringList;
begin
inherited;
AStringList := TStringList.Create;
try
AStringList.Assign(memReason.Lines);
LimitStringLength(AStringList, 74);
memReason.Lines.Assign(AstringList);
ControlChange(Self);
finally
AStringList.Free;
end;
end;
procedure TfrmEditCslt.cmdQuitClick(Sender: TObject);
begin
inherited;
FChanged := False;
Close;
end;
function TfrmEditCslt.ValidSave: Boolean;
const
TX_NO_SAVE = 'This request cannot be saved for the following reason(s):' + CRLF + CRLF;
TX_NO_SAVE_CAP = 'Unable to Save Request';
TX_SAVE_ERR = 'Unexpected error - it was not possible to save this request.';
var
ErrMsg: string;
begin
Result := True;
Validate(ErrMsg);
if Length(ErrMsg) > 0 then
begin
InfoBox(TX_NO_SAVE + ErrMsg, TX_NO_SAVE_CAP, MB_OK);
Result := False;
end;
if (ProvDx.Reqd = 'R') and (Length(txtProvDiag.Text) = 0) and (ProvDx.PromptMode = 'L') then
cmdLexSearchClick(Self);
end;
procedure TfrmEditCslt.OrderMessage(const AMessage: string);
begin
memMessage.Lines.SetText(PChar(AMessage));
if ContainsVisibleChar(AMessage) then
begin
pnlMessage.Visible := True;
pnlMessage.BringToFront;
uMessageVisible := GetTickCount;
end
else pnlMessage.Visible := False;
end;
procedure TfrmEditCslt.btnCmtCancelClick(Sender: TObject);
begin
ReportBox(OldRec.DenyComments, 'Cancellation Comments', False);
end;
procedure TfrmEditCslt.btnCmtOtherClick(Sender: TObject);
begin
ReportBox(OldRec.OtherComments, 'Added Comments', False);
end;
procedure TfrmEditCslt.cmdLexSearchClick(Sender: TObject);
var
Match: string;
i: integer;
begin
inherited;
{Begin BillingAware}
if BILLING_AWARE then BADxUpdated := FALSE;
{End BillingAware}
LexiconLookup(Match, LX_ICD);
if Match = '' then Exit;
ProvDx.Code := Piece(Match, U, 1);
ProvDx.Text := Piece(Match, U, 2);
i := Pos(' (ICD', ProvDx.Text);
if i = 0 then i := Length(ProvDx.Text) + 1;
if ProvDx.Text[i-1] = '*' then i := i - 2;
ProvDx.Text := Copy(ProvDx.Text, 1, i - 1);
txtProvDiag.Text := ProvDx.Text + ' (' + ProvDx.Code + ')';
{Begin BillingAware}
if BILLING_AWARE then BADxUpdated := TRUE;
{End BillingAware}
ProvDx.CodeInactive := False;
end;
procedure TfrmEditCslt.SetProvDiagPromptingMode;
const
TX_USE_LEXICON = 'You must use the "Lexicon" button to select a provisional diagnosis for this service.';
TX_PROVDX_OPT = 'Provisional Diagnosis';
TX_PROVDX_REQD = 'Provisional Dx (REQUIRED)';
begin
cmdLexSearch.Enabled := False;
txtProvDiag.Enabled := False;
txtProvDiag.ReadOnly := True;
txtProvDiag.Color := clBtnFace;
txtProvDiag.Font.Color := clBtnText;
lblProvDiag.Enabled := False;
txtProvDiag.Hint := '';
if cboService.ItemIEN = 0 then Exit;
GetProvDxMode(ProvDx, cboService.ItemID + CSLT_PTR);
// Returns: string A^B
// A = O (optional), R (required) or S (suppress)
// B = F (free-text) or L (lexicon)
with ProvDx do if (Reqd = '') or (PromptMode = '') then Exit;
if ProvDx.Reqd = 'R' then
lblProvDiag.Caption := TX_PROVDX_REQD
else
lblProvDiag.Caption := TX_PROVDX_OPT;
if ProvDx.Reqd = 'S' then
begin
cmdLexSearch.Enabled := False;
txtProvDiag.Enabled := False;
txtProvDiag.ReadOnly := True;
txtProvDiag.Color := clBtnFace;
txtProvDiag.Font.Color := clBtnText;
lblProvDiag.Enabled := False;
end
else
case ProvDx.PromptMode[1] of
'F': begin
cmdLexSearch.Enabled := False;
txtProvDiag.Enabled := True;
txtProvDiag.ReadOnly := False;
txtProvDiag.Color := clWindow;
txtProvDiag.Font.Color := clWindowText;
lblProvDiag.Enabled := True;
end;
'L': begin
cmdLexSearch.Enabled := True;
txtProvDiag.Enabled := True;
txtProvDiag.ReadOnly := True;
txtProvDiag.Color := clInfoBk;
txtProvDiag.Font.Color := clInfoText;
lblProvDiag.Enabled := True;
txtProvDiag.Hint := TX_USE_LEXICON;
end;
end;
end;
procedure TfrmEditCslt.mnuPopProvDxDeleteClick(Sender: TObject);
begin
inherited;
ProvDx.Text := '';
ProvDx.Code := '';
ProvDx.CodeInactive := False;
txtProvDiag.Text := '';
ControlChange(Self);
end;
procedure TfrmEditCslt.popReasonPopup(Sender: TObject);
begin
inherited;
if PopupComponent(Sender, popReason) is TCustomEdit
then FEditCtrl := TCustomEdit(PopupComponent(Sender, popReason))
else FEditCtrl := nil;
if FEditCtrl <> nil then
begin
popReasonCut.Enabled := FEditCtrl.SelLength > 0;
popReasonCopy.Enabled := popReasonCut.Enabled;
popReasonPaste.Enabled := (not TORExposedCustomEdit(FEditCtrl).ReadOnly) and
Clipboard.HasFormat(CF_TEXT);
end else
begin
popReasonCut.Enabled := False;
popReasonCopy.Enabled := False;
popReasonPaste.Enabled := False;
end;
popReasonReformat.Enabled := True;
end;
procedure TfrmEditCslt.popReasonCutClick(Sender: TObject);
begin
inherited;
FEditCtrl.CutToClipboard;
end;
procedure TfrmEditCslt.popReasonCopyClick(Sender: TObject);
begin
inherited;
FEditCtrl.CopyToClipboard;
end;
procedure TfrmEditCslt.popReasonPasteClick(Sender: TObject);
begin
inherited;
FEditCtrl.SelText := Clipboard.AsText;
end;
procedure TfrmEditCslt.popReasonReformatClick(Sender: TObject);
begin
inherited;
if (Screen.ActiveControl <> memReason) and
(Screen.ActiveControl <> memComment)then Exit;
ReformatMemoParagraph(TCustomMemo(FEditCtrl));
end;
procedure TfrmEditCslt.memCommentKeyUp(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if FNavigatingTab then
begin
if ssShift in Shift then
FindNextControl(Sender as TWinControl, False, True, False).SetFocus //previous control
else if ssCtrl in Shift then
FindNextControl(Sender as TWinControl, True, True, False).SetFocus; //next control
FNavigatingTab := False;
end;
if (key = VK_ESCAPE) then begin
FindNextControl(Sender as TWinControl, False, True, False).SetFocus; //previous control
key := 0;
end;
end;
procedure TfrmEditCslt.memCommentKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
//The navigating tab controls were inadvertantently adding tab characters
//This should fix it
FNavigatingTab := (Key = VK_TAB) and ([ssShift,ssCtrl] * Shift <> []);
if FNavigatingTab then
Key := 0;
end;
procedure TfrmEditCslt.memCommentKeyPress(Sender: TObject; var Key: Char);
begin
if FNavigatingTab then
Key := #0; //Disable shift-tab processin
end;
end.

452
CPRS-Chart/Consults/fEditProc.dfm Normal file
View File

@ -0,0 +1,452 @@
object frmEditProc: TfrmEditProc
Tag = 112
Left = 296
Top = 245
Width = 569
Height = 335
HorzScrollBar.Range = 561
VertScrollBar.Range = 308
AutoScroll = False
Caption = 'Edit and resubmit a cancelled procedure'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = True
Position = poScreenCenter
DesignSize = (
561
308)
PixelsPerInch = 96
TextHeight = 13
object lblProc: TLabel
Left = 3
Top = 7
Width = 49
Height = 13
Caption = 'Procedure'
end
object lblReason: TLabel
Left = 3
Top = 167
Width = 90
Height = 13
Caption = 'Reason for Consult'
end
object lblService: TOROffsetLabel
Left = 3
Top = 49
Width = 158
Height = 15
Caption = 'Service to perform this procedure'
HorzOffset = 2
Transparent = False
VertOffset = 2
WordWrap = False
end
object lblComment: TLabel
Left = 106
Top = 109
Width = 74
Height = 13
Caption = 'New Comments'
end
object lblComments: TLabel
Left = 3
Top = 99
Width = 89
Height = 13
Caption = 'Display Comments:'
end
object lblUrgency: TStaticText
Left = 190
Top = 7
Width = 44
Height = 17
Caption = 'Urgency'
TabOrder = 18
end
object lblPlace: TStaticText
Left = 362
Top = 50
Width = 104
Height = 17
Caption = 'Place of Consultation'
TabOrder = 19
end
object lblAttn: TStaticText
Left = 362
Top = 7
Width = 46
Height = 17
Caption = 'Attention'
TabOrder = 20
end
object lblProvDiag: TStaticText
Left = 190
Top = 81
Width = 104
Height = 17
Caption = 'Provisional Diagnosis'
TabOrder = 21
end
object lblInpOutp: TStaticText
Left = 192
Top = 48
Width = 127
Height = 17
Caption = 'Patient will be seen as an:'
TabOrder = 17
end
object memReason: TRichEdit
Left = 2
Top = 181
Width = 555
Height = 95
Anchors = [akLeft, akTop, akRight, akBottom]
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Courier New'
Font.Style = []
ParentFont = False
PopupMenu = popReason
ScrollBars = ssBoth
TabOrder = 12
WantTabs = True
OnChange = ControlChange
OnExit = memReasonExit
OnKeyDown = memReasonKeyDown
OnKeyPress = memReasonKeyPress
OnKeyUp = memCommentKeyUp
end
object cmdAccept: TButton
Left = 399
Top = 282
Width = 72
Height = 21
Anchors = [akRight, akBottom]
Caption = 'Resubmit'
TabOrder = 13
OnClick = cmdAcceptClick
end
object cmdQuit: TButton
Left = 484
Top = 282
Width = 72
Height = 21
Anchors = [akRight, akBottom]
Cancel = True
Caption = 'Cancel'
TabOrder = 14
OnClick = cmdQuitClick
end
object cboUrgency: TORComboBox
Left = 190
Top = 22
Width = 165
Height = 21
Style = orcsDropDown
AutoSelect = True
Caption = 'Urgency'
Color = clWindow
DropDownCount = 8
ItemHeight = 13
ItemTipColor = clWindow
ItemTipEnable = True
ListItemsOnly = True
LongList = False
LookupPiece = 0
MaxLength = 0
Pieces = '2'
Sorted = False
SynonymChars = '<>'
TabOrder = 2
OnChange = ControlChange
CharsNeedMatch = 1
end
object radInpatient: TRadioButton
Left = 190
Top = 61
Width = 61
Height = 17
Caption = '&Inpatient'
TabOrder = 4
OnClick = radInpatientClick
end
object radOutpatient: TRadioButton
Left = 264
Top = 61
Width = 73
Height = 17
Caption = '&Outpatient'
TabOrder = 5
OnClick = radOutpatientClick
end
object cboPlace: TORComboBox
Left = 362
Top = 63
Width = 195
Height = 21
Anchors = [akLeft, akTop, akRight]
Style = orcsDropDown
AutoSelect = True
Caption = 'Place of Consultation'
Color = clWindow
DropDownCount = 8
ItemHeight = 13
ItemTipColor = clWindow
ItemTipEnable = True
ListItemsOnly = True
LongList = False
LookupPiece = 0
MaxLength = 0
Pieces = '2'
Sorted = False
SynonymChars = '<>'
TabOrder = 6
OnChange = ControlChange
CharsNeedMatch = 1
end
object txtProvDiag: TCaptionEdit
Left = 190
Top = 94
Width = 313
Height = 21
Anchors = [akLeft, akTop, akRight]
MaxLength = 180
ParentShowHint = False
PopupMenu = mnuPopProvDx
ShowHint = True
TabOrder = 7
OnChange = ControlChange
Caption = 'Provisional Diagnosis'
end
object txtAttn: TORComboBox
Left = 362
Top = 22
Width = 195
Height = 21
Anchors = [akLeft, akTop, akRight]
Style = orcsDropDown
AutoSelect = True
Caption = 'Attention'
Color = clWindow
DropDownCount = 8
ItemHeight = 13
ItemTipColor = clWindow
ItemTipEnable = True
ListItemsOnly = True
LongList = True
LookupPiece = 2
MaxLength = 0
Pieces = '2,3'
Sorted = False
SynonymChars = '<>'
TabOrder = 3
OnChange = ControlChange
OnNeedData = txtAttnNeedData
CharsNeedMatch = 1
end
object cboProc: TORComboBox
Left = 3
Top = 22
Width = 173
Height = 21
Style = orcsDropDown
AutoSelect = True
Caption = 'Procedure'
Color = clWindow
DropDownCount = 8
Enabled = False
Font.Charset = DEFAULT_CHARSET
Font.Color = clGrayText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
ItemHeight = 13
ItemTipColor = clWindow
ItemTipEnable = True
ListItemsOnly = True
LongList = True
LookupPiece = 0
MaxLength = 0
ParentFont = False
Pieces = '2'
Sorted = False
SynonymChars = '<>'
TabOrder = 0
OnChange = cboProcSelect
OnNeedData = cboProcNeedData
CharsNeedMatch = 1
end
object cboCategory: TORComboBox
Left = 505
Top = -11
Width = 2
Height = 21
Style = orcsDropDown
AutoSelect = True
Color = clWindow
DropDownCount = 8
ItemHeight = 13
ItemTipColor = clWindow
ItemTipEnable = True
ListItemsOnly = False
LongList = False
LookupPiece = 0
MaxLength = 0
Sorted = False
SynonymChars = '<>'
TabOrder = 15
Visible = False
OnChange = ControlChange
CharsNeedMatch = 1
end
object cboService: TORComboBox
Left = 3
Top = 65
Width = 173
Height = 21
Style = orcsDropDown
AutoSelect = True
Caption = 'Service to perform this procedure'
Color = clWindow
DropDownCount = 8
Enabled = False
Font.Charset = DEFAULT_CHARSET
Font.Color = clGrayText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
ItemHeight = 13
ItemTipColor = clWindow
ItemTipEnable = True
ListItemsOnly = False
LongList = False
LookupPiece = 0
MaxLength = 0
ParentFont = False
Pieces = '2'
Sorted = False
SynonymChars = '<>'
TabOrder = 1
OnChange = ControlChange
CharsNeedMatch = 1
end
object memComment: TRichEdit
Left = 106
Top = 123
Width = 449
Height = 38
Anchors = [akLeft, akTop, akRight]
PopupMenu = popReason
TabOrder = 11
WantTabs = True
OnChange = ControlChange
OnKeyUp = memCommentKeyUp
end
object pnlMessage: TPanel
Left = 29
Top = 264
Width = 381
Height = 44
Anchors = [akLeft, akRight, akBottom]
BevelInner = bvRaised
BorderStyle = bsSingle
Caption = 'pnlMessage'
TabOrder = 16
Visible = False
object imgMessage: TImage
Left = 4
Top = 4
Width = 32
Height = 32
end
object memMessage: TRichEdit
Left = 40
Top = 4
Width = 332
Height = 32
Color = clInfoBk
Font.Charset = DEFAULT_CHARSET
Font.Color = clInfoText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
ParentFont = False
ScrollBars = ssVertical
TabOrder = 0
WantReturns = False
end
end
object btnCmtCancel: TButton
Left = 11
Top = 116
Width = 75
Height = 21
Caption = 'Cancellation'
TabOrder = 9
OnClick = btnCmtCancelClick
end
object btnCmtOther: TButton
Left = 11
Top = 139
Width = 75
Height = 21
Caption = 'Other'
TabOrder = 10
OnClick = btnCmtOtherClick
end
object cmdLexSearch: TButton
Left = 507
Top = 94
Width = 49
Height = 21
Anchors = [akTop, akRight]
Caption = 'Lexicon'
TabOrder = 8
OnClick = cmdLexSearchClick
end
object mnuPopProvDx: TPopupMenu
Left = 353
Top = 77
object mnuPopProvDxDelete: TMenuItem
Caption = 'Delete diagnosis'
OnClick = mnuPopProvDxDeleteClick
end
end
object popReason: TPopupMenu
OnPopup = popReasonPopup
Left = 411
Top = 169
object popReasonCut: TMenuItem
Caption = 'Cu&t'
ShortCut = 16472
OnClick = popReasonCutClick
end
object popReasonCopy: TMenuItem
Caption = '&Copy'
ShortCut = 16451
OnClick = popReasonCopyClick
end
object popReasonPaste: TMenuItem
Caption = '&Paste'
ShortCut = 16470
OnClick = popReasonPasteClick
end
object popReasonPaste2: TMenuItem
Caption = 'Paste2'
ShortCut = 8237
Visible = False
OnClick = popReasonPasteClick
end
object popReasonReformat: TMenuItem
Caption = 'Reformat Paragraph'
ShortCut = 16466
OnClick = popReasonReformatClick
end
end
end

686
CPRS-Chart/Consults/fEditProc.pas Normal file
View File

@ -0,0 +1,686 @@
unit fEditProc;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ORCtrls, ExtCtrls, ComCtrls, ORfn, uConst, uConsults, Buttons,
Menus;
type
TfrmEditProc = class(TForm)
cmdAccept: TButton;
cmdQuit: TButton;
cboUrgency: TORComboBox;
radInpatient: TRadioButton;
radOutpatient: TRadioButton;
cboPlace: TORComboBox;
txtProvDiag: TCaptionEdit;
txtAttn: TORComboBox;
lblProc: TLabel;
cboProc: TORComboBox;
lblReason: TLabel;
lblUrgency: TStaticText;
lblPlace: TStaticText;
lblAttn: TStaticText;
lblProvDiag: TStaticText;
cboCategory: TORComboBox;
cboService: TORComboBox;
lblService: TOROffsetLabel;
memComment: TRichEdit;
lblComment: TLabel;
lblComments: TLabel;
pnlMessage: TPanel;
imgMessage: TImage;
memMessage: TRichEdit;
btnCmtCancel: TButton;
btnCmtOther: TButton;
mnuPopProvDx: TPopupMenu;
mnuPopProvDxDelete: TMenuItem;
cmdLexSearch: TButton;
lblInpOutp: TStaticText;
memReason: TRichEdit;
popReason: TPopupMenu;
popReasonCut: TMenuItem;
popReasonCopy: TMenuItem;
popReasonPaste: TMenuItem;
popReasonPaste2: TMenuItem;
popReasonReformat: TMenuItem;
procedure txtAttnNeedData(Sender: TObject; const StartFrom: String;
Direction, InsertAt: Integer);
procedure cboProcNeedData(Sender: TObject; const StartFrom: String;
Direction, InsertAt: Integer);
procedure radInpatientClick(Sender: TObject);
procedure radOutpatientClick(Sender: TObject);
procedure ControlChange(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure cboProcSelect(Sender: TObject);
procedure memReasonExit(Sender: TObject);
procedure cmdAcceptClick(Sender: TObject);
procedure cmdQuitClick(Sender: TObject);
procedure OrderMessage(const AMessage: string);
procedure btnCmtCancelClick(Sender: TObject);
procedure btnCmtOtherClick(Sender: TObject);
procedure cmdLexSearchClick(Sender: TObject);
procedure mnuPopProvDxDeleteClick(Sender: TObject);
procedure popReasonCutClick(Sender: TObject);
procedure popReasonCopyClick(Sender: TObject);
procedure popReasonPasteClick(Sender: TObject);
procedure popReasonPopup(Sender: TObject);
procedure popReasonReformatClick(Sender: TObject);
procedure memCommentKeyUp(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure memReasonKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure memReasonKeyPress(Sender: TObject; var Key: Char);
private
FLastProcID: string;
FChanged: boolean;
FChanging: boolean;
FEditCtrl: TCustomEdit;
FNavigatingTab: boolean;
procedure SetProvDiagPromptingMode;
protected
procedure InitDialog;
procedure Validate(var AnErrMsg: string);
function ValidSave: Boolean;
end;
function EditResubmitProcedure(FontSize: Integer; ConsultIEN: integer): boolean;
var
frmEditProc: TfrmEditProc;
implementation
{$R *.DFM}
uses
rConsults, uCore, rCore, fConsults, rODBase, fRptBox, fPCELex, rPCE, ORClasses, clipbrd ;
var
OldRec, NewRec: TEditResubmitRec;
Defaults: TStringList;
uMessageVisible: DWORD;
ProvDx: TProvisionalDiagnosis;
const
TX_NO_PROC = 'A procedure must be specified.' ;
TX_NO_REASON = 'A reason for this procedure must be entered.' ;
TX_NO_SERVICE = 'A service must be selected to perform this procedure.';
TX_NO_URGENCY = 'An urgency must be specified.';
TX_NO_PLACE = 'A place of consultation must be specified';
TX_NO_DIAG = 'A provisional diagnosis must be entered for consults to this service.';
TX_SELECT_DIAG = 'You must use the "Lexicon" button to select a diagnosis for consults to this service.';
TX_INACTIVE_CODE = 'The provisional diagnosis code is not active as of today''s date.' + #13#10 +
'Another code must be selected';
TC_INACTIVE_CODE = 'Inactive ICD Code';
function EditResubmitProcedure(FontSize: Integer; ConsultIEN: integer): boolean;
begin
Result := False;
if ConsultIEN = 0 then exit;
FillChar(OldRec, SizeOf(OldRec), 0);
FillChar(NewRec, SizeOf(NewRec), 0);
FillChar(ProvDx, SizeOf(ProvDx), 0);
OldRec := LoadConsultForEdit(ConsultIEN);
NewRec.IEN := OldRec.IEN;
NewRec.RequestType := OldRec.RequestType;
with NewRec do
begin
RequestReason:= TStringList.Create ;
DenyComments:= TStringList.Create ;
OtherComments:= TStringList.Create ;
NewComments:= TStringList.Create ;
end;
StatusText('Loading Procedure for Edit');
frmEditProc := TfrmEditProc.Create(Application);
Defaults := TStringList.Create;
try
ResizeAnchoredFormToFont(frmEditProc);
with frmEditProc do
begin
FChanged := False;
InitDialog;
ShowModal ;
Result := FChanged ;
end ;
finally
OldRec.RequestReason.Free;
OldRec.DenyComments.Free;
OldRec.OtherComments.Free;
OldRec.NewComments.Free;
NewRec.RequestReason.Free;
NewRec.DenyComments.Free;
NewRec.OtherComments.Free;
NewRec.NewComments.Free;
Defaults.Free;
frmEditProc.Release;
end;
end;
procedure TfrmEditProc.InitDialog;
var
i: integer;
begin
FChanging := True;
Defaults := TStringList.Create;
Defaults.Assign(ODForProcedures);
FLastProcID := '';
cboProc.InitLongList(OldRec.ConsultProcName) ;
cboProc.SelectByIEN(OldRec.OrderableItem);
if cboProc.ItemIndex = -1 then
begin
cboProc.Items.Insert(0, IntToStr(OldRec.OrderableItem) + U + OldRec.ConsultProcName +
U + OldRec.ConsultProcName + U + OldRec.ConsultProc);
cboProc.ItemIndex := 0;
end;
cboProcSelect(Self);
txtAttn.InitLongList(OldRec.AttnName) ;
if OldRec.Attention > 0 then
txtAttn.SelectByIEN(OldRec.Attention)
else
txtAttn.ItemIndex := -1;
cboService.SelectByIEN(OldRec.ToService);
if OldRec.InpOutp <> '' then
case OldRec.InpOutp[1] of
'I': radInpatient.Checked := True; //INPATIENT PROCEDURE
'O': radOutpatient.Checked := True; //OUTPATIENT PROCEDURE
end
else
begin
if Patient.Inpatient then
radInpatient.Checked := True
else
radOutpatient.Checked := True;
end;
cboPlace.SelectByID(OldRec.Place);
with cboUrgency do for i := 0 to Items.Count-1 do
if UpperCase(DisplayText[i]) = UpperCase(OldRec.UrgencyName) then ItemIndex := i;
txtProvDiag.Text := OldRec.ProvDiagnosis;
ProvDx.Code := OldRec.ProvDxCode;
if OldRec.ProvDxCodeInactive then
begin
InfoBox(TX_INACTIVE_CODE, TC_INACTIVE_CODE, MB_ICONWARNING or MB_OK);
ProvDx.CodeInactive := True;
end;
memReason.Lines.Assign(OldRec.RequestReason);
btnCmtCancel.Enabled := (OldRec.DenyComments.Count > 0);
btnCmtOther.Enabled := (OldRec.OtherComments.Count > 0);
memComment.Clear ;
SetProvDiagPromptingMode;
FChanging := False;
StatusText('');
end;
procedure TfrmEditProc.Validate(var AnErrMsg: string);
procedure SetError(const x: string);
begin
if Length(AnErrMsg) > 0 then AnErrMsg := AnErrMsg + CRLF;
AnErrMsg := AnErrMsg + x;
end;
begin
if cboProc.ItemIEN = 0 then SetError(TX_NO_PROC);
if memReason.Lines.Count = 0 then SetError(TX_NO_REASON);
if cboService.ItemIEN = 0 then SetError(TX_NO_SERVICE);
if cboUrgency.ItemIEN = 0 then SetError(TX_NO_URGENCY);
if cboPlace.ItemID = '' then SetError(TX_NO_PLACE);
if (ProvDx.Reqd = 'R') and (Length(txtProvDiag.Text) = 0) then
begin
if ProvDx.PromptMode = 'F' then
SetError(TX_NO_DIAG)
else
SetError(TX_SELECT_DIAG);
end;
if OldRec.ProvDxCodeInactive and ProvDx.CodeInactive then
SetError(TX_INACTIVE_CODE);
end;
procedure TfrmEditProc.txtAttnNeedData(Sender: TObject;
const StartFrom: string; Direction, InsertAt: Integer);
begin
inherited;
txtAttn.ForDataUse(SubSetOfPersons(StartFrom, Direction));
end;
procedure TfrmEditProc.cboProcNeedData(Sender: TObject;
const StartFrom: string; Direction, InsertAt: Integer);
begin
inherited;
cboProc.ForDataUse(SubSetOfProcedures(StartFrom, Direction));
end;
procedure TfrmEditProc.radInpatientClick(Sender: TObject);
begin
inherited;
cboCategory.Items.Clear;
cboCategory.Items.Add('I^Inpatient');
cboCategory.SelectById('I');
ExtractItems(cboPlace.Items, Defaults, 'Inpt Place');
ExtractItems(cboUrgency.Items, Defaults, 'Inpt Proc Urgencies'); //S.GMRCR
ControlChange(Self);
end;
procedure TfrmEditProc.radOutpatientClick(Sender: TObject);
begin
inherited;
cboCategory.Items.Clear;
cboCategory.Items.Add('O^Outpatient');
cboCategory.SelectById('O');
ExtractItems(cboPlace.Items, Defaults, 'Outpt Place');
ExtractItems(cboUrgency.Items, Defaults, 'Outpt Urgencies'); //S.GMRCO
ControlChange(Self);
end;
procedure TfrmEditProc.ControlChange(Sender: TObject);
begin
if FChanging then exit;
with NewRec do
begin
with cboProc do if ItemIEN > 0 then
if Piece(Items[ItemIndex], U, 4) <> OldRec.ConsultProc then
begin
ConsultProc := Piece(Items[ItemIndex], U, 4);
ConsultProcName := Text;
end
else
begin
ConsultProc := '';
ConsultProcName := '';
end;
with cboService do if ItemIEN > 0 then
if ItemIEN <> OldRec.ToService then
begin
ToService := ItemIEN;
ToServiceName := Text;
end
else
begin
ToService := 0;
ToServiceName := '';
end;
with cboCategory do if Length(ItemID) > 0 then
if ItemID <> OldRec.InpOutP then
InpOutP := ItemID
else
InpOutP := '';
with cboUrgency do if ItemIEN > 0 then
if StrToIntDef(Piece(Items[ItemIndex], U, 3), 0) <> OldRec.Urgency then
begin
Urgency := StrToIntDef(Piece(Items[ItemIndex], U, 3), 0);
UrgencyName := Text;
end
else
begin
Urgency := 0;
UrgencyName := '';
end;
with cboPlace do if Length(ItemID) > 0 then
if ItemID <> OldRec.Place then
begin
Place := ItemID;
PlaceName := Text;
end
else
begin
Place := '';
PlaceName := '';
end;
with txtAttn do
if ItemIEN > 0 then
begin
if ItemIEN <> OldRec.Attention then
begin
Attention := ItemIEN;
AttnName := Text;
end
else
begin
Attention := 0;
AttnName := '';
end;
end
else // blank
begin
if OldRec.Attention > 0 then
begin
Attention := -1;
AttnName := '';
end
else
begin
Attention := 0;
AttnName := '';
end;
end;
with txtProvDiag do
if Length(Text) > 0 then
begin
if Text <> OldRec.ProvDiagnosis then
ProvDiagnosis := Text
else
ProvDiagnosis := '';
if ProvDx.Code <> OldRec.ProvDxCode then
ProvDxCode := ProvDx.Code
else
ProvDxCode := '';
if OldRec.ProvDxCodeInactive then
ProvDx.CodeInactive := (ProvDx.Code = OldRec.ProvDxCode);
end
else //blank
begin
ProvDx.Code := '';
ProvDx.CodeInactive := False;
if OldRec.ProvDiagnosis <> '' then
ProvDiagnosis := '@'
else
ProvDiagnosis := '';
end;
with memReason do if Lines.Count > 0 then
if Lines.Equals(OldRec.RequestReason) then
RequestReason.Clear
else
RequestReason.Assign(Lines);
with memComment do
if GetTextLen > 0 then
NewComments.Assign(Lines)
else
NewComments.Clear;
end;
end;
procedure TfrmEditProc.FormClose(Sender: TObject; var Action: TCloseAction);
const
TX_ACCEPT = 'Resubmit this request?' + CRLF + CRLF;
TX_ACCEPT_CAP = 'Unsaved Changes';
begin
if FChanged then
if InfoBox(TX_ACCEPT, TX_ACCEPT_CAP, MB_YESNO) = ID_YES then
if not ValidSave then Action := caNone;
end;
function TfrmEditProc.ValidSave: Boolean;
const
TX_NO_SAVE = 'This request cannot be saved for the following reason(s):' + CRLF + CRLF;
TX_NO_SAVE_CAP = 'Unable to Save Request';
TX_SAVE_ERR = 'Unexpected error - it was not possible to save this request.';
var
ErrMsg: string;
begin
Result := True;
Validate(ErrMsg);
if Length(ErrMsg) > 0 then
begin
InfoBox(TX_NO_SAVE + ErrMsg, TX_NO_SAVE_CAP, MB_OK);
Result := False;
end;
if (ProvDx.Reqd = 'R') and (Length(txtProvDiag.Text) = 0) and (ProvDx.PromptMode = 'L') then
cmdLexSearchClick(Self);
end;
procedure TfrmEditProc.cboProcSelect(Sender: TObject);
begin
inherited;
with cboProc do
begin
if ItemIndex = -1 then Exit;
if ItemID <> FLastProcID then FLastProcID := ItemID else Exit;
with cboService do
begin
Clear;
Items.Assign(GetProcedureServices(cboProc.ItemIEN));
if Items.Count > 0 then
begin
ItemIndex := 0 ;
NewRec.ToService := ItemIEN;
NewRec.ToServiceName := Text;
end
else
begin
InfoBox('There are no services defined for this procedure.',
'Information', MB_OK or MB_ICONINFORMATION);
cboProc.ItemIndex := -1;
InitDialog;
Exit ;
end;
end;
end;
OrderMessage(ConsultMessage(cboProc.ItemIEN));
ControlChange(Self) ;
end;
procedure TfrmEditProc.memReasonExit(Sender: TObject);
var
AStringList: TStringList;
begin
inherited;
AStringList := TStringList.Create;
try
AStringList.Assign(memReason.Lines);
LimitStringLength(AStringList, 74);
memReason.Lines.Assign(AstringList);
ControlChange(Self);
finally
AStringList.Free;
end;
end;
procedure TfrmEditProc.cmdAcceptClick(Sender: TObject);
begin
if ValidSave then
begin
FChanged := (ResubmitConsult(NewRec) = '0');
Close;
end;
end;
procedure TfrmEditProc.cmdQuitClick(Sender: TObject);
begin
inherited;
FChanged := False;
Close;
end;
procedure TfrmEditProc.OrderMessage(const AMessage: string);
begin
memMessage.Lines.SetText(PChar(AMessage));
if ContainsVisibleChar(AMessage) then
begin
pnlMessage.Visible := True;
pnlMessage.BringToFront;
uMessageVisible := GetTickCount;
end
else pnlMessage.Visible := False;
end;
procedure TfrmEditProc.btnCmtCancelClick(Sender: TObject);
begin
ReportBox(OldRec.DenyComments, 'Cancellation Comments', False);
end;
procedure TfrmEditProc.btnCmtOtherClick(Sender: TObject);
begin
ReportBox(OldRec.OtherComments, 'Added Comments', False);
end;
procedure TfrmEditProc.cmdLexSearchClick(Sender: TObject);
var
Match: string;
i: integer;
begin
inherited;
LexiconLookup(Match, LX_ICD);
if Match = '' then Exit;
ProvDx.Code := Piece(Match, U, 1);
ProvDx.Text := Piece(Match, U, 2);
i := Pos(' (ICD', ProvDx.Text);
if i = 0 then i := Length(ProvDx.Text) + 1;
if ProvDx.Text[i-1] = '*' then i := i - 2;
ProvDx.Text := Copy(ProvDx.Text, 1, i - 1);
txtProvDiag.Text := ProvDx.Text + ' (' + ProvDx.Code + ')';
ProvDx.CodeInactive := False;
end;
procedure TfrmEditProc.SetProvDiagPromptingMode;
const
TX_USE_LEXICON = 'You must use the "Lexicon" button to select a provisional diagnosis for this service.';
TX_PROVDX_OPT = 'Provisional Diagnosis';
TX_PROVDX_REQD = 'Provisional Dx (REQUIRED)';
begin
cmdLexSearch.Enabled := False;
txtProvDiag.Enabled := False;
txtProvDiag.ReadOnly := True;
txtProvDiag.Color := clBtnFace;
txtProvDiag.Font.Color := clBtnText;
lblProvDiag.Enabled := False;
txtProvDiag.Hint := '';
if cboProc.ItemIEN = 0 then Exit;
//GetProvDxMode(ProvDx, cboService.ItemID);
GetProvDxMode(ProvDx, Piece(cboProc.Items[cboProc.ItemIndex], U, 4));
// Returns: string A^B
// A = O (optional), R (required) or S (suppress)
// B = F (free-text) or L (lexicon)
with ProvDx do if (Reqd = '') or (PromptMode = '') then Exit;
if ProvDx.Reqd = 'R' then
lblProvDiag.Caption := TX_PROVDX_REQD
else
lblProvDiag.Caption := TX_PROVDX_OPT;
if ProvDx.Reqd = 'S' then
begin
cmdLexSearch.Enabled := False;
txtProvDiag.Enabled := False;
txtProvDiag.ReadOnly := True;
txtProvDiag.Color := clBtnFace;
txtProvDiag.Font.Color := clBtnText;
lblProvDiag.Enabled := False;
end
else
case ProvDx.PromptMode[1] of
'F': begin
cmdLexSearch.Enabled := False;
txtProvDiag.Enabled := True;
txtProvDiag.ReadOnly := False;
txtProvDiag.Color := clWindow;
txtProvDiag.Font.Color := clWindowText;
lblProvDiag.Enabled := True;
end;
'L': begin
cmdLexSearch.Enabled := True;
txtProvDiag.Enabled := True;
txtProvDiag.ReadOnly := True;
txtProvDiag.Color := clInfoBk;
txtProvDiag.Font.Color := clInfoText;
lblProvDiag.Enabled := True;
txtProvDiag.Hint := TX_USE_LEXICON;
end;
end;
end;
procedure TfrmEditProc.mnuPopProvDxDeleteClick(Sender: TObject);
begin
inherited;
ProvDx.Text := '';
ProvDx.Code := '';
ProvDx.CodeInactive := False;
txtProvDiag.Text := '';
ControlChange(Self);
end;
procedure TfrmEditProc.popReasonPopup(Sender: TObject);
begin
inherited;
if PopupComponent(Sender, popReason) is TCustomEdit
then FEditCtrl := TCustomEdit(PopupComponent(Sender, popReason))
else FEditCtrl := nil;
if FEditCtrl <> nil then
begin
popReasonCut.Enabled := FEditCtrl.SelLength > 0;
popReasonCopy.Enabled := popReasonCut.Enabled;
popReasonPaste.Enabled := (not TORExposedCustomEdit(FEditCtrl).ReadOnly) and
Clipboard.HasFormat(CF_TEXT);
end else
begin
popReasonCut.Enabled := False;
popReasonCopy.Enabled := False;
popReasonPaste.Enabled := False;
end;
popReasonReformat.Enabled := True;
end;
procedure TfrmEditProc.popReasonCutClick(Sender: TObject);
begin
inherited;
FEditCtrl.CutToClipboard;
end;
procedure TfrmEditProc.popReasonCopyClick(Sender: TObject);
begin
inherited;
FEditCtrl.CopyToClipboard;
end;
procedure TfrmEditProc.popReasonPasteClick(Sender: TObject);
begin
inherited;
FEditCtrl.SelText := Clipboard.AsText;
end;
procedure TfrmEditProc.popReasonReformatClick(Sender: TObject);
begin
if (Screen.ActiveControl <> memReason) and
(Screen.ActiveControl <> memComment)then Exit;
ReformatMemoParagraph(TCustomMemo(FEditCtrl));
end;
procedure TfrmEditProc.memCommentKeyUp(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if FNavigatingTab then
begin
if ssShift in Shift then
FindNextControl(Sender as TWinControl, False, True, False).SetFocus //previous control
else if ssCtrl in Shift then
FindNextControl(Sender as TWinControl, True, True, False).SetFocus; //next control
end;
if (key = VK_ESCAPE) then begin
FindNextControl(Sender as TWinControl, False, True, False).SetFocus; //previous control
key := 0;
end;
end;
procedure TfrmEditProc.memReasonKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
//The navigating tab controls were inadvertantently adding tab characters
//This should fix it
FNavigatingTab := (Key = VK_TAB) and ([ssShift,ssCtrl] * Shift <> []);
if FNavigatingTab then
Key := 0;
end;
procedure TfrmEditProc.memReasonKeyPress(Sender: TObject; var Key: Char);
begin
if FNavigatingTab then
Key := #0; //Disable shift-tab processing
end;
end.

458
CPRS-Chart/Consults/fODConsult.dfm Normal file
View File

@ -0,0 +1,458 @@
inherited frmODCslt: TfrmODCslt
Tag = 110
Left = 430
Top = 203
Width = 606
Height = 376
HorzScrollBar.Range = 590
VertScrollBar.Range = 340
Caption = 'Order a Consult'
Constraints.MinHeight = 376
Constraints.MinWidth = 606
Font.Charset = ANSI_CHARSET
PixelsPerInch = 96
TextHeight = 13
object lblService: TLabel [0]
Left = 1
Top = 2
Width = 134
Height = 13
Caption = 'Consult to Service/Specialty'
end
object pnlReason: TPanel [1]
Left = 3
Top = 154
Width = 585
Height = 135
Anchors = [akLeft, akTop, akRight]
BevelOuter = bvNone
TabOrder = 11
object lblReason: TLabel
Left = 0
Top = 0
Width = 585
Height = 13
Align = alTop
Caption = 'Reason for Request'
end
object memReason: TRichEdit
Left = 0
Top = 13
Width = 585
Height = 122
Align = alClient
Font.Charset = ANSI_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Courier New'
Font.Style = []
Constraints.MinHeight = 40
ParentFont = False
PopupMenu = popReason
ScrollBars = ssBoth
TabOrder = 0
WantTabs = True
OnChange = ControlChange
OnExit = memReasonExit
OnKeyDown = memReasonKeyDown
OnKeyPress = memReasonKeyPress
OnKeyUp = memReasonKeyUp
end
end
object lblUrgency: TStaticText [2]
Left = 309
Top = 2
Width = 44
Height = 17
Anchors = [akTop, akRight]
Caption = 'Urgency'
TabOrder = 17
end
object lblPlace: TStaticText [3]
Left = 454
Top = 43
Width = 104
Height = 17
Anchors = [akTop, akRight]
Caption = 'Place of Consultation'
TabOrder = 18
end
object lblAttn: TStaticText [4]
Left = 454
Top = 2
Width = 46
Height = 17
Anchors = [akTop, akRight]
Caption = 'Attention'
TabOrder = 19
end
object lblProvDiag: TStaticText [5]
Left = 309
Top = 81
Width = 104
Height = 17
Anchors = [akTop, akRight]
Caption = 'Provisional Diagnosis'
TabOrder = 20
end
inherited memOrder: TCaptionMemo
Left = 3
Top = 305
Width = 417
Height = 41
Lines.Strings = (
'The order text...'
'----------------------------------------------'
'--------------------------------'
'An order message may be displayed here.')
TabOrder = 1
end
inherited cmdAccept: TButton
Left = 427
Top = 315
TabOrder = 12
end
inherited cmdQuit: TButton
Left = 531
Top = 315
Width = 61
TabOrder = 13
end
inherited pnlMessage: TPanel
Left = 13
Top = 295
Width = 377
Anchors = [akLeft, akRight, akBottom]
TabOrder = 14
inherited memMessage: TRichEdit
Width = 292
end
end
object cboService: TORComboBox
Left = 0
Top = 16
Width = 274
Height = 113
Anchors = [akLeft, akTop, akRight]
Style = orcsSimple
AutoSelect = True
Caption = 'Consult to Service/Specialty'
Color = clWindow
DropDownCount = 12
ItemHeight = 13
ItemTipColor = clWindow
ItemTipEnable = True
ListItemsOnly = True
LongList = False
LookupPiece = 0
MaxLength = 0
Pieces = '2'
Sorted = False
SynonymChars = '<>'
TabOrder = 0
OnChange = ControlChange
OnClick = cboServiceSelect
OnExit = cboServiceExit
OnKeyDown = cboServiceKeyDown
OnKeyUp = cboServiceKeyUp
CharsNeedMatch = 1
end
object cboUrgency: TORComboBox
Left = 309
Top = 16
Width = 133
Height = 21
Anchors = [akTop, akRight]
Style = orcsDropDown
AutoSelect = True
Caption = 'Urgency'
Color = clWindow
DropDownCount = 8
ItemHeight = 13
ItemTipColor = clWindow
ItemTipEnable = True
ListItemsOnly = True
LongList = False
LookupPiece = 0
MaxLength = 0
Pieces = '2'
Sorted = False
SynonymChars = '<>'
TabOrder = 4
TabStop = True
OnChange = ControlChange
CharsNeedMatch = 1
end
object cboPlace: TORComboBox
Left = 454
Top = 56
Width = 136
Height = 21
Anchors = [akTop, akRight]
Style = orcsDropDown
AutoSelect = True
Caption = 'Place of Consultation'
Color = clWindow
DropDownCount = 8
ItemHeight = 13
ItemTipColor = clWindow
ItemTipEnable = True
ListItemsOnly = True
LongList = False
LookupPiece = 0
MaxLength = 0
Pieces = '2'
Sorted = False
SynonymChars = '<>'
TabOrder = 7
OnChange = ControlChange
CharsNeedMatch = 1
end
object txtProvDiag: TCaptionEdit
Left = 309
Top = 94
Width = 231
Height = 21
Anchors = [akTop, akRight]
MaxLength = 180
ParentShowHint = False
PopupMenu = mnuPopProvDx
ShowHint = True
TabOrder = 9
OnChange = txtProvDiagChange
Caption = 'Provisional Diagnosis'
end
object txtAttn: TORComboBox
Left = 454
Top = 16
Width = 136
Height = 21
Anchors = [akTop, akRight]
Style = orcsDropDown
AutoSelect = True
Caption = 'Attention'
Color = clWindow
DropDownCount = 8
ItemHeight = 13
ItemTipColor = clWindow
ItemTipEnable = True
ListItemsOnly = True
LongList = True
LookupPiece = 2
MaxLength = 0
Pieces = '2,3'
Sorted = False
SynonymChars = '<>'
TabOrder = 5
OnChange = ControlChange
OnNeedData = txtAttnNeedData
CharsNeedMatch = 1
end
object treService: TORTreeView
Left = 0
Top = 38
Width = 298
Height = 220
Anchors = [akLeft, akTop, akRight, akBottom]
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -9
Font.Name = 'MS Sans Serif'
Font.Style = []
HideSelection = False
Indent = 19
ParentFont = False
ReadOnly = True
TabOrder = 3
Visible = False
OnChange = treServiceChange
OnCollapsing = treServiceCollapsing
OnExit = treServiceExit
OnKeyDown = treServiceKeyDown
OnKeyUp = treServiceKeyUp
OnMouseDown = treServiceMouseDown
Caption = 'object lblService: TLabel'
NodePiece = 0
end
object cboCategory: TORComboBox
Left = 225
Top = -5
Width = 5
Height = 21
Style = orcsDropDown
AutoSelect = True
Color = clWindow
DropDownCount = 8
ItemHeight = 13
ItemTipColor = clWindow
ItemTipEnable = True
ListItemsOnly = False
LongList = False
LookupPiece = 0
MaxLength = 0
Sorted = False
SynonymChars = '<>'
TabOrder = 15
Visible = False
CharsNeedMatch = 1
end
object pnlServiceTreeButton: TKeyClickPanel
Left = 274
Top = 14
Width = 26
Height = 26
Hint = 'View services/specialties hierarchically'
Anchors = [akTop, akRight]
BevelOuter = bvNone
BevelWidth = 2
Caption = 'View services/specialties hierarchically'
Font.Charset = ANSI_CHARSET
Font.Color = clBtnFace
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
ParentFont = False
TabOrder = 2
TabStop = True
OnClick = btnServiceTreeClick
OnEnter = pnlServiceTreeButtonEnter
OnExit = pnlServiceTreeButtonExit
object btnServiceTree: TSpeedButton
Left = 2
Top = 2
Width = 22
Height = 22
Glyph.Data = {
26050000424D26050000000000003604000028000000100000000F0000000100
080000000000F000000000000000000000000001000000010000000000000000
80000080000000808000800000008000800080800000C0C0C000C0DCC000F0CA
A6000020400000206000002080000020A0000020C0000020E000004000000040
20000040400000406000004080000040A0000040C0000040E000006000000060
20000060400000606000006080000060A0000060C0000060E000008000000080
20000080400000806000008080000080A0000080C0000080E00000A0000000A0
200000A0400000A0600000A0800000A0A00000A0C00000A0E00000C0000000C0
200000C0400000C0600000C0800000C0A00000C0C00000C0E00000E0000000E0
200000E0400000E0600000E0800000E0A00000E0C00000E0E000400000004000
20004000400040006000400080004000A0004000C0004000E000402000004020
20004020400040206000402080004020A0004020C0004020E000404000004040
20004040400040406000404080004040A0004040C0004040E000406000004060
20004060400040606000406080004060A0004060C0004060E000408000004080
20004080400040806000408080004080A0004080C0004080E00040A0000040A0
200040A0400040A0600040A0800040A0A00040A0C00040A0E00040C0000040C0
200040C0400040C0600040C0800040C0A00040C0C00040C0E00040E0000040E0
200040E0400040E0600040E0800040E0A00040E0C00040E0E000800000008000
20008000400080006000800080008000A0008000C0008000E000802000008020
20008020400080206000802080008020A0008020C0008020E000804000008040
20008040400080406000804080008040A0008040C0008040E000806000008060
20008060400080606000806080008060A0008060C0008060E000808000008080
20008080400080806000808080008080A0008080C0008080E00080A0000080A0
200080A0400080A0600080A0800080A0A00080A0C00080A0E00080C0000080C0
200080C0400080C0600080C0800080C0A00080C0C00080C0E00080E0000080E0
200080E0400080E0600080E0800080E0A00080E0C00080E0E000C0000000C000
2000C0004000C0006000C0008000C000A000C000C000C000E000C0200000C020
2000C0204000C0206000C0208000C020A000C020C000C020E000C0400000C040
2000C0404000C0406000C0408000C040A000C040C000C040E000C0600000C060
2000C0604000C0606000C0608000C060A000C060C000C060E000C0800000C080
2000C0804000C0806000C0808000C080A000C080C000C080E000C0A00000C0A0
2000C0A04000C0A06000C0A08000C0A0A000C0A0C000C0A0E000C0C00000C0C0
2000C0C04000C0C06000C0C08000C0C0A000F0FBFF00A4A0A000808080000000
FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00FFFFFFFF0700
07FFFFFFFFFFFFFFFFFFFFA4A407000400FF040404040404FFFFFFA4FFFF0700
07FFFFFFFFFFFFFFFFFFFFA4FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFA4FFFFFFFF
FFFF070007FFFFFFFFFFFFA4FFFFFFA4A407000400FF04040404FFA4FFFFFFA4
FFFF070007FFFFFFFFFFFFA4FFFFFF07FFFFFFFFFFFFFFFFFFFFFFA4FFFF0700
07FFFFFFFFFFFFFFFFFFFFA4A407000400FF0404040404FFFFFFFFA4FFFF0700
07FFFFFFFFFFFFFFFFFFFF07FFFFFFFFFFFFFFFFFFFFFFFFFFFF070007FFFFFF
FFFFFFFFFFFFFFFFFFFF00FB00FF0404040404FFFFFFFFFFFFFF070007FFFFFF
FFFFFFFFFFFFFFFFFFFF}
Margin = 0
OnClick = btnServiceTreeClick
end
end
object cmdLexSearch: TButton
Left = 543
Top = 94
Width = 49
Height = 21
Anchors = [akTop, akRight]
Caption = 'Lexicon'
TabOrder = 10
OnClick = cmdLexSearchClick
end
object gbInptOpt: TGroupBox
Left = 309
Top = 35
Width = 140
Height = 45
Anchors = [akTop, akRight]
Caption = 'Patient will be seen as an:'
TabOrder = 6
object radInpatient: TRadioButton
Left = 3
Top = 20
Width = 61
Height = 13
Caption = '&Inpatient'
TabOrder = 0
OnClick = radInpatientClick
end
object radOutpatient: TRadioButton
Left = 67
Top = 20
Width = 70
Height = 13
Caption = '&Outpatient'
TabOrder = 1
OnClick = radOutpatientClick
end
end
object btnDiagnosis: TButton
Left = 543
Top = 95
Width = 49
Height = 20
Anchors = [akTop, akRight]
Caption = 'Diagnosis'
TabOrder = 8
OnClick = btnDiagnosisClick
end
object mnuPopProvDx: TPopupMenu
Left = 353
Top = 77
object mnuPopProvDxDelete: TMenuItem
Caption = 'Delete diagnosis'
OnClick = mnuPopProvDxDeleteClick
end
end
object popReason: TPopupMenu
OnPopup = popReasonPopup
Left = 411
Top = 188
object popReasonCut: TMenuItem
Caption = 'Cu&t'
ShortCut = 16472
OnClick = popReasonCutClick
end
object popReasonCopy: TMenuItem
Caption = '&Copy'
ShortCut = 16451
OnClick = popReasonCopyClick
end
object popReasonPaste: TMenuItem
Caption = '&Paste'
ShortCut = 16470
OnClick = popReasonPasteClick
end
object popReasonPaste2: TMenuItem
Caption = 'Paste2'
ShortCut = 8237
Visible = False
OnClick = popReasonPasteClick
end
object popReasonReformat: TMenuItem
Caption = 'Reformat Paragraph'
ShortCut = 16466
OnClick = popReasonReformatClick
end
end
end

1410
CPRS-Chart/Consults/fODConsult.pas Normal file
View File

File diff suppressed because it is too large Load Diff

386
CPRS-Chart/Consults/fODProc.dfm Normal file
View File

@ -0,0 +1,386 @@
inherited frmODProc: TfrmODProc
Tag = 112
Left = 208
Top = 188
Width = 543
Height = 393
HorzScrollBar.Range = 523
VertScrollBar.Range = 295
Caption = 'Order a Procedure'
Constraints.MinHeight = 393
Constraints.MinWidth = 543
PixelsPerInch = 96
TextHeight = 13
object lblProc: TLabel [0]
Left = 4
Top = 4
Width = 49
Height = 13
Caption = 'Procedure'
end
object lblService: TOROffsetLabel [1]
Left = 4
Top = 42
Width = 158
Height = 15
Caption = 'Service to perform this procedure'
HorzOffset = 2
Transparent = False
VertOffset = 2
WordWrap = False
end
object lblReason: TLabel [2]
Left = 4
Top = 103
Width = 95
Height = 13
Caption = 'Reason for Request'
end
object lblUrgency: TStaticText [3]
Left = 249
Top = 4
Width = 44
Height = 17
Anchors = [akTop, akRight]
Caption = 'Urgency'
TabOrder = 15
end
object lblPlace: TStaticText [4]
Left = 396
Top = 43
Width = 104
Height = 17
Anchors = [akTop, akRight]
Caption = 'Place of Consultation'
TabOrder = 16
end
object lblAttn: TStaticText [5]
Left = 396
Top = 4
Width = 46
Height = 17
Anchors = [akTop, akRight]
Caption = 'Attention'
TabOrder = 17
end
object lblProvDiag: TStaticText [6]
Left = 249
Top = 81
Width = 104
Height = 17
Anchors = [akTop, akRight]
Caption = 'Provisional Diagnosis'
TabOrder = 18
end
object pnlReason: TPanel [7]
Left = 0
Top = 120
Width = 528
Height = 192
Anchors = [akLeft, akTop, akRight, akBottom]
BevelOuter = bvNone
TabOrder = 9
object memReason: TCaptionRichEdit
Left = 0
Top = 0
Width = 528
Height = 192
Align = alClient
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Courier New'
Font.Style = []
Constraints.MinHeight = 40
ParentFont = False
PopupMenu = popReason
ScrollBars = ssBoth
TabOrder = 0
WantTabs = True
OnChange = ControlChange
OnExit = memReasonExit
OnKeyDown = memReasonKeyDown
OnKeyPress = memReasonKeyPress
OnKeyUp = memReasonKeyUp
Caption = 'Reason for Request'
end
end
inherited memOrder: TCaptionMemo
Left = 0
Top = 321
Width = 380
Height = 41
Anchors = [akLeft, akRight]
Lines.Strings = (
'The order text...'
'----------------------------------------------------------------' +
'--------------'
'An order message may be displayed here.')
TabOrder = 1
end
object cboUrgency: TORComboBox [9]
Left = 249
Top = 17
Width = 133
Height = 21
Anchors = [akTop, akRight]
Style = orcsDropDown
AutoSelect = True
Caption = 'Urgency'
Color = clWindow
DropDownCount = 8
ItemHeight = 13
ItemTipColor = clWindow
ItemTipEnable = True
ListItemsOnly = True
LongList = False
LookupPiece = 0
MaxLength = 0
Pieces = '2'
Sorted = False
SynonymChars = '<>'
TabOrder = 2
OnChange = ControlChange
CharsNeedMatch = 1
end
object cboPlace: TORComboBox [10]
Left = 396
Top = 56
Width = 133
Height = 21
Anchors = [akTop, akRight]
Style = orcsDropDown
AutoSelect = True
Caption = 'Place of Consultation'
Color = clWindow
DropDownCount = 8
ItemHeight = 13
ItemTipColor = clWindow
ItemTipEnable = True
ListItemsOnly = True
LongList = False
LookupPiece = 0
MaxLength = 0
Pieces = '2'
Sorted = False
SynonymChars = '<>'
TabOrder = 6
OnChange = ControlChange
CharsNeedMatch = 1
end
object txtAttn: TORComboBox [11]
Left = 396
Top = 17
Width = 133
Height = 21
Anchors = [akTop, akRight]
Style = orcsDropDown
AutoSelect = True
Caption = 'Attention'
Color = clWindow
DropDownCount = 8
ItemHeight = 13
ItemTipColor = clWindow
ItemTipEnable = True
ListItemsOnly = True
LongList = True
LookupPiece = 2
MaxLength = 0
Pieces = '2,3'
Sorted = False
SynonymChars = '<>'
TabOrder = 3
OnChange = ControlChange
OnNeedData = txtAttnNeedData
CharsNeedMatch = 1
end
object cboProc: TORComboBox [12]
Left = 4
Top = 17
Width = 227
Height = 21
Anchors = [akLeft, akTop, akRight]
Style = orcsDropDown
AutoSelect = True
Caption = 'Procedure'
Color = clWindow
DropDownCount = 8
ItemHeight = 13
ItemTipColor = clWindow
ItemTipEnable = True
ListItemsOnly = True
LongList = True
LookupPiece = 0
MaxLength = 0
Pieces = '2'
Sorted = False
SynonymChars = '<>'
TabOrder = 0
OnChange = cboProcSelect
OnNeedData = cboProcNeedData
CharsNeedMatch = 1
end
object cboCategory: TORComboBox [13]
Left = 516
Top = 10
Width = 3
Height = 21
Style = orcsDropDown
AutoSelect = True
Color = clWindow
DropDownCount = 8
ItemHeight = 13
ItemTipColor = clWindow
ItemTipEnable = True
ListItemsOnly = False
LongList = False
LookupPiece = 0
MaxLength = 0
Sorted = False
SynonymChars = '<>'
TabOrder = 13
Visible = False
OnChange = ControlChange
CharsNeedMatch = 1
end
object cboService: TORComboBox [14]
Left = 4
Top = 58
Width = 227
Height = 21
Anchors = [akLeft, akTop, akRight]
Style = orcsDropDown
AutoSelect = True
Caption = 'Service to perform this procedure'
Color = clWindow
DropDownCount = 8
Enabled = False
ItemHeight = 13
ItemTipColor = clWindow
ItemTipEnable = True
ListItemsOnly = False
LongList = False
LookupPiece = 0
MaxLength = 0
Pieces = '2'
Sorted = False
SynonymChars = '<>'
TabOrder = 4
OnChange = cboServiceChange
CharsNeedMatch = 1
end
inherited cmdAccept: TButton
Left = 387
Top = 339
Anchors = [akRight, akBottom]
TabOrder = 10
end
inherited cmdQuit: TButton
Left = 469
Top = 339
Width = 64
Anchors = [akRight, akBottom]
TabOrder = 11
end
inherited pnlMessage: TPanel
Left = 50
Top = 320
Width = 316
Anchors = [akLeft, akRight, akBottom]
TabOrder = 12
inherited memMessage: TRichEdit
Width = 254
end
end
object cmdLexSearch: TButton
Left = 486
Top = 93
Width = 49
Height = 21
Anchors = [akTop, akRight]
Caption = 'Lexicon'
TabOrder = 8
OnClick = cmdLexSearchClick
end
object gbInptOpt: TGroupBox
Left = 249
Top = 36
Width = 140
Height = 45
Anchors = [akTop, akRight]
Caption = 'Patient will be seen as an:'
TabOrder = 5
object radInpatient: TRadioButton
Left = 3
Top = 20
Width = 61
Height = 17
Caption = '&Inpatient'
TabOrder = 0
OnClick = radInpatientClick
end
object radOutpatient: TRadioButton
Left = 67
Top = 20
Width = 71
Height = 17
Caption = '&Outpatient'
TabOrder = 1
OnClick = radOutpatientClick
end
end
object txtProvDiag: TCaptionEdit
Left = 249
Top = 93
Width = 234
Height = 21
Anchors = [akTop, akRight]
MaxLength = 180
ParentShowHint = False
PopupMenu = mnuPopProvDx
ShowHint = True
TabOrder = 7
OnChange = txtProvDiagChange
Caption = 'Provisional Diagnosis'
end
object mnuPopProvDx: TPopupMenu
Left = 353
Top = 77
object mnuPopProvDxDelete: TMenuItem
Caption = 'Delete diagnosis'
OnClick = mnuPopProvDxDeleteClick
end
end
object popReason: TPopupMenu
OnPopup = popReasonPopup
Left = 411
Top = 169
object popReasonCut: TMenuItem
Caption = 'Cu&t'
ShortCut = 16472
OnClick = popReasonCutClick
end
object popReasonCopy: TMenuItem
Caption = '&Copy'
ShortCut = 16451
OnClick = popReasonCopyClick
end
object popReasonPaste: TMenuItem
Caption = '&Paste'
ShortCut = 16470
OnClick = popReasonPasteClick
end
object popReasonPaste2: TMenuItem
Caption = 'Paste2'
ShortCut = 8237
Visible = False
OnClick = popReasonPasteClick
end
object popReasonReformat: TMenuItem
Caption = 'Reformat Paragraph'
ShortCut = 16466
OnClick = popReasonReformatClick
end
end
end

833
CPRS-Chart/Consults/fODProc.pas Normal file
View File

@ -0,0 +1,833 @@
unit fODProc;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
fODBase, StdCtrls, ORCtrls, ExtCtrls, ComCtrls, ORfn, uConst, Buttons,
Menus;
type
TfrmODProc = class(TfrmODBase)
cboUrgency: TORComboBox;
cboPlace: TORComboBox;
txtAttn: TORComboBox;
lblProc: TLabel;
cboProc: TORComboBox;
lblUrgency: TStaticText;
lblPlace: TStaticText;
lblAttn: TStaticText;
lblProvDiag: TStaticText;
cboCategory: TORComboBox;
cboService: TORComboBox;
lblService: TOROffsetLabel;
mnuPopProvDx: TPopupMenu;
mnuPopProvDxDelete: TMenuItem;
cmdLexSearch: TButton;
popReason: TPopupMenu;
popReasonCut: TMenuItem;
popReasonCopy: TMenuItem;
popReasonPaste: TMenuItem;
popReasonPaste2: TMenuItem;
popReasonReformat: TMenuItem;
pnlReason: TPanel;
memReason: TCaptionRichEdit;
gbInptOpt: TGroupBox;
radInpatient: TRadioButton;
radOutpatient: TRadioButton;
txtProvDiag: TCaptionEdit;
lblReason: TLabel;
procedure FormCreate(Sender: TObject);
procedure txtAttnNeedData(Sender: TObject; const StartFrom: String;
Direction, InsertAt: Integer);
procedure cboProcNeedData(Sender: TObject; const StartFrom: String;
Direction, InsertAt: Integer);
procedure radInpatientClick(Sender: TObject);
procedure radOutpatientClick(Sender: TObject);
procedure ControlChange(Sender: TObject);
procedure cboProcSelect(Sender: TObject);
procedure memReasonExit(Sender: TObject);
procedure cmdLexSearchClick(Sender: TObject);
procedure cboServiceChange(Sender: TObject);
procedure mnuPopProvDxDeleteClick(Sender: TObject);
procedure txtProvDiagChange(Sender: TObject);
procedure popReasonCutClick(Sender: TObject);
procedure popReasonCopyClick(Sender: TObject);
procedure popReasonPasteClick(Sender: TObject);
procedure popReasonPopup(Sender: TObject);
procedure popReasonReformatClick(Sender: TObject);
procedure memReasonKeyUp(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure FormDestroy(Sender: TObject);
procedure memReasonKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure memReasonKeyPress(Sender: TObject; var Key: Char);
procedure FormResize(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
FLastProcID: string;
FEditCtrl: TCustomEdit;
FNavigatingTab: boolean;
procedure ReadServerVariables;
procedure SetProvDiagPromptingMode;
procedure SetupReasonForRequest(OrderAction: integer);
procedure GetProvDxandValidateCode(AResponses: TResponses);
function ShowPrerequisites: boolean;
procedure DoSetFontSize( FontSize: integer);
protected
procedure InitDialog; override;
procedure Validate(var AnErrMsg: string); override;
function DefaultReasonForRequest(Service: string; Resolve: Boolean): TStrings;
public
procedure SetupDialog(OrderAction: Integer; const ID: string); override;
procedure SetFontSize( FontSize: integer); override;
end;
implementation
{$R *.DFM}
uses
rODBase, rConsults, uCore, uConsults, rCore, fConsults, fPCELex, rPCE, ORClasses,
clipbrd, fPreReq, uTemplates, uAccessibleRichEdit, fFrame, uODBase;
var
ProvDx: TProvisionalDiagnosis;
GMRCREAF: string;
const
TX_NO_PROC = 'A procedure must be specified.' ;
TX_NO_REASON = 'A reason for this procedure must be entered.' ;
TX_NO_SERVICE = 'A service must be selected to perform this procedure.';
TX_NO_URGENCY = 'An urgency must be specified.';
TX_NO_PLACE = 'A place of consultation must be specified';
TX_NO_DIAG = 'A provisional diagnosis must be entered for consults to this service.';
TX_SELECT_DIAG = 'You must use the "Lexicon" button to select a diagnosis for consults to this service.';
TC_INACTIVE_CODE = 'Inactive ICD Code';
TX_INACTIVE_CODE1 = 'The provisional diagnosis code is not active as of today''s date.' + #13#10;
TX_INACTIVE_CODE_REQD = 'Another code must be selected before the order can be saved.';
TX_INACTIVE_CODE_OPTIONAL = 'If another code is not selected, no code will be saved.';
procedure TfrmODProc.FormCreate(Sender: TObject);
begin
frmFrame.pnlVisit.Enabled := false;
AutoSizeDisabled := True;
inherited;
DoSetFontSize(MainFontSize);
TAccessibleRichEdit.WrapControl(memReason);
AllowQuickOrder := True;
FillChar(ProvDx, SizeOf(ProvDx), 0);
FillerID := 'GMRC'; // does 'on Display' order check **KCM**
StatusText('Loading Dialog Definition');
Responses.Dialog := 'GMRCOR REQUEST'; // loads formatting info
StatusText('Loading Default Values');
CtrlInits.LoadDefaults(ODForProcedures); // ODForProcedures returns TStrings with defaults
StatusText('Initializing Long List');
ReadServerVariables;
cboProc.InitLongList('') ;
txtAttn.InitLongList('') ;
PreserveControl(txtAttn);
PreserveControl(cboProc);
InitDialog;
end;
procedure TfrmODProc.InitDialog;
begin
inherited;
Changing := True;
FLastProcID := '';
with CtrlInits do
begin
SetControl(cboProc, 'ShortList');
cboProc.InsertSeparator;
if OrderForInpatient then
begin
radInpatient.Checked := True; //INPATIENT PROCEDURE
cboCategory.Items.Clear;
cboCategory.Items.Add('I^Inpatient');
cboCategory.SelectById('I');
SetControl(cboPlace, 'Inpt Place');
SetControl(cboUrgency, 'Inpt Proc Urgencies'); //S.GMRCR
end
else
begin
radOutpatient.Checked := True; //OUTPATIENT PROCEDURE
cboCategory.Items.Clear;
cboCategory.Items.Add('O^Outpatient');
cboCategory.SelectById('O');
SetControl(cboPlace, 'Outpt Place');
SetControl(cboUrgency, 'Outpt Urgencies'); //S.GMRCO
end ;
end ;
txtAttn.ItemIndex := -1;
memOrder.Clear ;
memReason.Clear;
cboProc.Enabled := True;
cboProc.Font.Color := clWindowText;
//cboService.Enabled := True;
//cboService.Font.Color := clWindowText;
ActiveControl := cboProc;
SetProvDiagPromptingMode;
if not ShowPrerequisites then
begin
Close;
Exit;
end;
StatusText('');
Changing := False;
end;
procedure TfrmODProc.SetupDialog(OrderAction: Integer; const ID: string);
var
tmpResp: TResponse;
begin
inherited;
ReadServerVariables;
if OrderAction in [ORDER_COPY, ORDER_EDIT, ORDER_QUICK] then with Responses do {*KCM*}
begin
SetControl(cboProc, 'ORDERABLE', 1);
if cboProc.ItemIndex < 0 then exit;
cboService.Items.Assign(GetProcedureServices(cboProc.ItemIEN));
Changing := True;
tmpResp := TResponse(FindResponseByName('CLASS',1));
cboCategory.SelectByID(tmpResp.IValue);
if tmpResp.IValue = 'I' then
radInpatient.Checked := True
else
radOutpatient.Checked := True ;
SetControl(cboUrgency, 'URGENCY', 1);
SetControl(cboPlace, 'PLACE', 1);
SetControl(txtAttn, 'PROVIDER', 1);
cboProc.Enabled := False;
cboProc.Font.Color := clGrayText;
//SetControl(cboService, 'SERVICE', 1); // to fix OR*3.0*95 bug in v17.6 (RV)
tmpResp := TResponse(FindResponseByName('SERVICE',1));
if tmpResp <> nil then
cboService.SelectByID(Piece(tmpResp.IValue, U, 1))
else if (cboService.Items.Count = 1) then
cboService.ItemIndex := 0
else if (cboService.Items.Count > 1) then
cboService.ItemIndex := -1 ;
if cboService.ItemIndex > -1 then
begin
cboService.Enabled := False;
cboService.Font.Color := clGrayText;
end
else
begin
cboService.Enabled := True;
cboService.Font.Color := clWindowText;
end;
if (OrderAction in [ORDER_COPY, ORDER_QUICK]) and (not ShowPrerequisites) then
begin
Close;
Exit;
end;
SetProvDiagPromptingMode;
GetProvDxandValidateCode(Responses);
SetControl(memReason, 'COMMENT', 1);
SetupReasonForRequest(OrderAction);
Changing := False;
OrderMessage(ConsultMessage(cboProc.ItemIEN));
ControlChange(Self);
end;
end;
procedure TfrmODProc.Validate(var AnErrMsg: string);
procedure SetError(const x: string);
begin
if Length(AnErrMsg) > 0 then AnErrMsg := AnErrMsg + CRLF;
AnErrMsg := AnErrMsg + x;
end;
begin
inherited;
if cboProc.ItemIEN = 0 then SetError(TX_NO_PROC);
if cboUrgency.ItemIEN = 0 then SetError(TX_NO_URGENCY);
if cboPlace.ItemID = '' then SetError(TX_NO_PLACE);
if (not ContainsVisibleChar(memReason.Text))
then SetError(TX_NO_REASON);
if cboService.ItemIEN = 0 then SetError(TX_NO_SERVICE);
if (ProvDx.Reqd = 'R') and (Length(txtProvDiag.Text) = 0) then
begin
if ProvDx.PromptMode = 'F' then
SetError(TX_NO_DIAG)
else
SetError(TX_SELECT_DIAG);
end;
end;
procedure TfrmODProc.txtAttnNeedData(Sender: TObject;
const StartFrom: string; Direction, InsertAt: Integer);
begin
inherited;
txtAttn.ForDataUse(SubSetOfPersons(StartFrom, Direction));
end;
procedure TfrmODProc.cboProcNeedData(Sender: TObject;
const StartFrom: string; Direction, InsertAt: Integer);
begin
inherited;
cboProc.ForDataUse(SubSetOfProcedures(StartFrom, Direction));
end;
procedure TfrmODProc.radInpatientClick(Sender: TObject);
begin
inherited;
with CtrlInits do
begin
SetControl(cboPlace, 'Inpt Place');
SetControl(cboUrgency, 'Inpt Proc Urgencies');
cboCategory.Items.Clear;
cboCategory.Items.Add('I^Inpatient') ;
cboCategory.SelectById('I');
end ;
ControlChange(Self);
end;
procedure TfrmODProc.radOutpatientClick(Sender: TObject);
begin
inherited;
with CtrlInits do
begin
SetControl(cboPlace, 'Outpt Place');
SetControl(cboUrgency, 'Outpt Urgencies');
cboCategory.Items.Clear;
cboCategory.Items.Add('O^Outpatient');
cboCategory.SelectById('O');
end ;
ControlChange(Self);
end;
procedure TfrmODProc.ControlChange(Sender: TObject);
var
x: string;
i: integer;
begin
inherited;
if Changing or (cboProc.ItemIEN = 0) then Exit;
with cboProc do
begin
if ItemIEN > 0 then
begin
i := Pos('<', Text);
if i > 0 then
begin
x := Piece(Copy(Text, i + 1, 99), '>', 1);
x := UpperCase(Copy(x, 1, 1)) + Copy(x, 2, 99);
end
else
x := Text;
Responses.Update('ORDERABLE', 1, ItemID, x);
end
else Responses.Update('ORDERABLE', 1, '', '');
end;
(* with cboProc do if ItemIEN > 0 then Responses.Update('ORDERABLE', 1, ItemID, Text)
else Responses.Update('ORDERABLE', 1, '', '');*)
with cboService do if ItemIEN > 0 then Responses.Update('SERVICE', 1, ItemID, Text)
else Responses.Update('SERVICE', 1, '', '');
with memReason do if GetTextLen > 0 then Responses.Update('COMMENT', 1, TX_WPTYPE, Text);
with cboCategory do if ItemID <> '' then Responses.Update('CLASS', 1, ItemID, Text);
with cboUrgency do if ItemIEN > 0 then Responses.Update('URGENCY', 1, ItemID, Text);
with cboPlace do if ItemID <> '' then Responses.Update('PLACE', 1, ItemID, Text);
with txtAttn do if ItemIEN > 0 then Responses.Update('PROVIDER', 1, ItemID, Text);
if Length(ProvDx.Text) > 0 then Responses.Update('MISC', 1, ProvDx.Text, ProvDx.Text)
else Responses.Update('MISC', 1, '', '');
if Length(ProvDx.Code) > 0 then Responses.Update('CODE', 1, ProvDx.Code, ProvDx.Code)
else Responses.Update('CODE', 1, '', '');
memOrder.Text := Responses.OrderText;
end;
procedure TfrmODProc.cboProcSelect(Sender: TObject);
begin
inherited;
with cboProc do
begin
if ItemIndex = -1 then Exit;
if ItemID <> FLastProcID then FLastProcID := ItemID else Exit;
Changing := True;
if Sender <> Self then Responses.Clear; // Sender=Self when called from SetupDialog
Changing := False;
if CharAt(ItemID, 1) = 'Q' then
begin
Responses.QuickOrder := ExtractInteger(ItemID);
Responses.SetControl(cboProc, 'ORDERABLE', 1);
FLastProcID := ItemID;
end;
with cboService do
begin
Clear;
Items.Assign(GetProcedureServices(cboProc.ItemIEN));
if Items.Count > 1 then
ItemIndex := -1
else if Items.Count = 1 then
begin
ItemIndex := 0 ;
Responses.Update('SERVICE', 1, ItemID, Text);
end
else
begin
if Sender = Self then // Sender=Self when called from SetupDialog
InfoBox('There are no services defined for this procedure.',
'Information', MB_OK or MB_ICONINFORMATION);
cboProc.ItemIndex := -1;
InitDialog;
Exit ;
end;
end;
end;
with Responses do if QuickOrder > 0 then
begin
SetControl(cboProc, 'ORDERABLE', 1);
Changing := True;
with cboService do
begin
Items.Assign(GetProcedureServices(cboProc.ItemIEN));
if Items.Count > 1 then
ItemIndex := -1
else if Items.Count = 1 then
ItemIndex := 0 ;
end;
if not ShowPrerequisites then
begin
Close;
Exit;
end;
SetControl(cboCategory, 'CLASS', 1);
if cboCategory.ItemID = 'I' then radInpatient.Checked := True
else radOutpatient.Checked := True ;
SetControl(cboUrgency, 'URGENCY', 1);
SetControl(cboPlace, 'PLACE', 1);
SetControl(txtAttn, 'PROVIDER', 1);
SetControl(memReason, 'COMMENT', 1);
// if ((cboProc.ItemIEN > 0) and (Length(memReason.Text) = 0)) then
// memReason.Lines.Assign(DefaultReasonForRequest(Piece(cboProc.Items[cboProc.ItemIndex], U, 4), True));
SetupReasonForRequest(ORDER_QUICK);
GetProvDxandValidateCode(Responses);
SetControl(cboService, 'SERVICE', 1);
cboProc.Enabled := False;
cboProc.Font.Color := clGrayText;
if cboService.ItemIndex > -1 then
begin
cboService.Enabled := False;
cboService.Font.Color := clGrayText;
end
else
begin
cboService.Enabled := True;
cboService.Font.Color := clWindowText;
end;
Changing := False;
end
else
begin
if cboProc.ItemIEN > 0 then
begin
if cboService.ItemIndex > -1 then
begin
cboService.Enabled := False;
cboService.Font.Color := clGrayText;
end
else
begin
cboService.Enabled := True;
cboService.Font.Color := clWindowText;
end;
if not ShowPrerequisites then
begin
Close;
Exit;
end;
memReason.Lines.Assign(DefaultReasonForRequest(Piece(cboProc.Items[cboProc.ItemIndex], U, 4), True));
SetupReasonForRequest(ORDER_NEW);
end;
end;
SetProvDiagPromptingMode;
OrderMessage(ConsultMessage(cboProc.ItemIEN));
ControlChange(Self) ;
end;
procedure TfrmODProc.memReasonExit(Sender: TObject);
var
AStringList: TStringList;
begin
inherited;
AStringList := TStringList.Create;
try
AStringList.Assign(memReason.Lines);
LimitStringLength(AStringList, 74);
memReason.Lines.Assign(AstringList);
ControlChange(Self);
finally
AStringList.Free;
end;
end;
procedure TfrmODProc.ReadServerVariables;
begin
if StrToIntDef(KeyVariable['GMRCNOAT'], 0) > 0 then
begin
txtAttn.Enabled := False;
txtAttn.Font.Color := clGrayText;
lblAttn.Enabled := False;
txtAttn.Color := clBtnFace;
end
else
begin
txtAttn.Enabled := True;
txtAttn.Font.Color := clWindowText;
lblAttn.Enabled := True;
txtAttn.Color := clWindow;
end;
if StrToIntDef(KeyVariable['GMRCNOPD'], 0) > 0 then
begin
cmdLexSearch.Enabled := False;
txtProvDiag.Enabled := False;
txtProvDiag.Font.Color := clGrayText;
lblProvDiag.Enabled := False;
txtProvDiag.ReadOnly := True;
txtProvDiag.Color := clBtnFace;
end
else SetProvDiagPromptingMode;
GMRCREAF := KeyVariable['GMRCREAF'];
end;
procedure TfrmODProc.cmdLexSearchClick(Sender: TObject);
var
Match: string;
i: integer;
begin
inherited;
LexiconLookup(Match, LX_ICD);
if Match = '' then Exit;
ProvDx.Code := Piece(Match, U, 1);
ProvDx.Text := Piece(Match, U, 2);
i := Pos(' (ICD', ProvDx.Text);
if i = 0 then i := Length(ProvDx.Text) + 1;
if ProvDx.Text[i-1] = '*' then i := i - 2;
ProvDx.Text := Copy(ProvDx.Text, 1, i - 1);
txtProvDiag.Text := ProvDx.Text + ' (' + ProvDx.Code + ')';
ProvDx.CodeInactive := False;
end;
procedure TfrmODProc.SetProvDiagPromptingMode;
const
TX_USE_LEXICON = 'You must use the "Lexicon" button to select a provisional diagnosis for this service.';
TX_PROVDX_OPT = 'Provisional Diagnosis';
TX_PROVDX_REQD = 'Provisional Dx (REQUIRED)';
begin
cmdLexSearch.Enabled := False;
txtProvDiag.Enabled := False;
txtProvDiag.ReadOnly := True;
txtProvDiag.Color := clBtnFace;
txtProvDiag.Font.Color := clBtnText;
lblProvDiag.Enabled := False;
txtProvDiag.Hint := '';
if cboProc.ItemIEN = 0 then Exit;
//GetProvDxMode(ProvDx, cboService.ItemID);
GetProvDxMode(ProvDx, Piece(cboProc.Items[cboProc.ItemIndex], U, 4));
// Returns: string A^B
// A = O (optional), R (required) or S (suppress)
// B = F (free-text) or L (lexicon)
with ProvDx do if (Reqd = '') or (PromptMode = '') then Exit;
if ProvDx.Reqd = 'R' then
lblProvDiag.Caption := TX_PROVDX_REQD
else
lblProvDiag.Caption := TX_PROVDX_OPT;
if ProvDx.Reqd = 'S' then
begin
cmdLexSearch.Enabled := False;
txtProvDiag.Enabled := False;
txtProvDiag.ReadOnly := True;
txtProvDiag.Color := clBtnFace;
txtProvDiag.Font.Color := clBtnText;
lblProvDiag.Enabled := False;
end
else
case ProvDx.PromptMode[1] of
'F': begin
cmdLexSearch.Enabled := False;
txtProvDiag.Enabled := True;
txtProvDiag.ReadOnly := False;
txtProvDiag.Color := clWindow;
txtProvDiag.Font.Color := clWindowText;
lblProvDiag.Enabled := True;
end;
'L': begin
cmdLexSearch.Enabled := True;
txtProvDiag.Enabled := True;
txtProvDiag.ReadOnly := True;
txtProvDiag.Color := clInfoBk;
txtProvDiag.Font.Color := clInfoText;
lblProvDiag.Enabled := True;
txtProvDiag.Hint := TX_USE_LEXICON;
end;
end;
end;
procedure TfrmODProc.cboServiceChange(Sender: TObject);
begin
inherited;
//SetProvDiagPromptingMode;
ControlChange(Self);
end;
procedure TfrmODProc.mnuPopProvDxDeleteClick(Sender: TObject);
begin
inherited;
ProvDx.Text := '';
ProvDx.Code := '';
txtProvDiag.Text := '';
ControlChange(Self);
end;
procedure TfrmODProc.txtProvDiagChange(Sender: TObject);
begin
inherited;
if ProvDx.PromptMode = 'F' then
ProvDx.Text := txtProvDiag.Text;
ControlChange(Self);
end;
procedure TfrmODProc.popReasonPopup(Sender: TObject);
begin
inherited;
if PopupComponent(Sender, popReason) is TCustomEdit
then FEditCtrl := TCustomEdit(PopupComponent(Sender, popReason))
else FEditCtrl := nil;
if FEditCtrl <> nil then
begin
popReasonCut.Enabled := FEditCtrl.SelLength > 0;
popReasonCopy.Enabled := popReasonCut.Enabled;
popReasonPaste.Enabled := (not TORExposedCustomEdit(FEditCtrl).ReadOnly) and
Clipboard.HasFormat(CF_TEXT);
end else
begin
popReasonCut.Enabled := False;
popReasonCopy.Enabled := False;
popReasonPaste.Enabled := False;
end;
popReasonReformat.Enabled := True;
end;
procedure TfrmODProc.popReasonCutClick(Sender: TObject);
begin
inherited;
FEditCtrl.CutToClipboard;
end;
procedure TfrmODProc.popReasonCopyClick(Sender: TObject);
begin
inherited;
FEditCtrl.CopyToClipboard;
end;
procedure TfrmODProc.popReasonPasteClick(Sender: TObject);
begin
inherited;
FEditCtrl.SelText := Clipboard.AsText;
end;
procedure TfrmODProc.popReasonReformatClick(Sender: TObject);
begin
inherited;
if Screen.ActiveControl <> memReason then Exit;
ReformatMemoParagraph(memReason);
end;
procedure TfrmODProc.SetupReasonForRequest(OrderAction: integer);
var
EditReason: string;
procedure EnableReason;
begin
memReason.Color := clWindow;
memReason.Font.Color := clWindowText;
memReason.ReadOnly := False;
lblReason.Caption := 'Reason for Request';
end;
procedure DisableReason;
begin
memReason.Color := clInfoBk;
memReason.Font.Color := clInfoText;
memReason.ReadOnly := True;
lblReason.Caption := 'Reason for Request (not editable)';
end;
begin
if ((OrderAction = ORDER_QUICK) and (cboProc.ItemID <> '') and (Length(memReason.Text) = 0)) then
memReason.Lines.Assign(DefaultReasonForRequest(Piece(cboProc.Items[cboProc.ItemIndex], U, 4), True));
EditReason := GMRCREAF;
if EditReason = '' then EditReason := ReasonForRequestEditable(Piece(cboProc.Items[cboProc.ItemIndex], U, 4));
case EditReason[1] of
'0': EnableReason;
'1': if OrderAction in [ORDER_COPY, ORDER_EDIT] then
EnableReason
else
DisableReason;
'2': DisableReason
else
EnableReason;
end;
end;
function TfrmODProc.ShowPrerequisites: boolean;
var
AList: TStringList;
const
TC_PREREQUISITES = 'Procedure Prerequisites - ';
begin
Result := True;
AbortOrder := False;
AList := TStringList.Create;
try
with cboProc do
if ItemIEN > 0 then
begin
Alist.Assign(GetServicePrerequisites(Piece(Items[ItemIndex], U, 4)));
if AList.Count > 0 then
begin
if not DisplayPrerequisites(AList, TC_PREREQUISITES + DisplayText[ItemIndex]) then
begin
memOrder.Clear;
Result := False;
AbortOrder := True;
//cmdQuitClick(Self);
end
else Result := True;
end;
end;
finally
AList.Free;
end;
end;
function TfrmODProc.DefaultReasonForRequest(Service: string; Resolve: Boolean): TStrings;
var
TmpSL: TStringList;
DocInfo: string;
x: string;
HasObjects: boolean;
begin
Resolve := FALSE ; // override value passed in - resolve on client - PSI-05-093
DocInfo := '';
TmpSL := TStringList.Create;
try
Result := GetDefaultReasonForRequest(Piece(cboProc.Items[cboProc.ItemIndex], U, 4), Resolve);
TmpSL.Assign(Result);
x := TmpSL.Text;
ExpandOrderObjects(x, HasObjects);
TmpSL.Text := x;
Responses.OrderContainsObjects := HasObjects;
ExecuteTemplateOrBoilerPlate(TmpSL, StrToIntDef(piece(piece(cboProc.Items[cboProc.ItemIndex],U,4),';',1),0),
ltProcedure, nil, 'Reason for Request: ' + cboProc.DisplayText[cboProc.ItemIndex], DocInfo);
if TmpSL.Text <> x then Responses.OrderContainsObjects := False;
Result.Assign(TmpSL);
finally
TmpSL.Free;
end;
end;
procedure TfrmODProc.memReasonKeyUp(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
inherited;
if FNavigatingTab then
begin
if ssShift in Shift then
FindNextControl(Sender as TWinControl, False, True, False).SetFocus //previous control
else if ssCtrl in Shift then
FindNextControl(Sender as TWinControl, True, True, False).SetFocus; //next control
FNavigatingTab := False;
end;
if (key = VK_ESCAPE) then begin
FindNextControl(Sender as TWinControl, False, True, False).SetFocus; //previous control
Key := 0;
end;
end;
procedure TfrmODProc.GetProvDxandValidateCode(AResponses: TResponses);
var
tmpDx: TResponse;
begin
with AResponses do
begin
tmpDx := TResponse(FindResponseByName('MISC',1));
if tmpDx <> nil then ProvDx.Text := tmpDx.Evalue;
tmpDx := TResponse(FindResponseByName('CODE',1));
if (tmpDx <> nil) and (tmpDx.EValue <> '') then
begin
if IsActiveICDCode(tmpDx.EValue) then
ProvDx.Code := tmpDx.Evalue
else
begin
if ProvDx.Reqd = 'R' then
InfoBox(TX_INACTIVE_CODE1 + TX_INACTIVE_CODE_REQD, TC_INACTIVE_CODE, MB_ICONWARNING or MB_OK)
else
InfoBox(TX_INACTIVE_CODE1 + TX_INACTIVE_CODE_OPTIONAL, TC_INACTIVE_CODE, MB_ICONWARNING or MB_OK);
ProvDx.Code := '';
ProvDx.Text := '';
end;
end;
txtProvDiag.Text := ProvDx.Text;
if ProvDx.Code <> '' then txtProvDiag.Text := txtProvDiag.Text + ' (' + ProvDx.Code + ')';
end;
end;
procedure TfrmODProc.FormDestroy(Sender: TObject);
begin
inherited;
TAccessibleRichEdit.UnwrapControl(memReason);
end;
procedure TfrmODProc.SetFontSize(FontSize: integer);
begin
inherited;
DoSetFontSize(FontSize);
end;
procedure TfrmODProc.DoSetFontSize(FontSize: integer);
begin
memReason.Width := pnlReason.ClientWidth;
memReason.Height := pnlReason.ClientHeight;// - memReason.Height; MAC-0104-61043 - RV
end;
procedure TfrmODProc.memReasonKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
inherited;
//The navigating tab controls were inadvertantently adding tab characters
//This should fix it
FNavigatingTab := (Key = VK_TAB) and ([ssShift,ssCtrl] * Shift <> []);
if FNavigatingTab then
Key := 0;
end;
procedure TfrmODProc.memReasonKeyPress(Sender: TObject; var Key: Char);
begin
inherited;
if FNavigatingTab then
Key := #0; //Disable shift-tab processing
end;
procedure TfrmODProc.FormResize(Sender: TObject);
begin
inherited;
memOrder.Top := PnlReason.Top + PnlReason.Height + 5;
end;
procedure TfrmODProc.FormClose(Sender: TObject; var Action: TCloseAction);
begin
inherited;
frmFrame.pnlVisit.Enabled := true;
end;
end.

101
CPRS-Chart/Consults/fPreReq.dfm Normal file
View File

@ -0,0 +1,101 @@
object frmPrerequisites: TfrmPrerequisites
Left = 337
Top = 219
Width = 377
Height = 348
BorderIcons = [biSystemMenu]
Caption = 'frmPrerequisites'
Color = clBtnFace
Font.Charset = ANSI_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = True
Position = poScreenCenter
OnClose = FormClose
OnCreate = FormCreate
OnShow = FormShow
PixelsPerInch = 96
TextHeight = 13
object lblFontTest: TLabel
Left = 148
Top = 208
Width = 77
Height = 14
Caption = 'lblFontTest'
Font.Charset = ANSI_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Courier New'
Font.Style = []
ParentFont = False
end
object memReport: TRichEdit
Left = 0
Top = 33
Width = 369
Height = 288
Align = alClient
Color = clCream
Font.Charset = ANSI_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Courier New'
Font.Style = []
Lines.Strings = (
'memReport')
ParentFont = False
ReadOnly = True
ScrollBars = ssBoth
TabOrder = 0
WantReturns = False
WordWrap = False
end
object pnlButton: TPanel
Left = 0
Top = 0
Width = 369
Height = 33
Align = alTop
BevelOuter = bvNone
TabOrder = 2
DesignSize = (
369
33)
object cmdContinue: TButton
Left = 209
Top = 6
Width = 75
Height = 21
Anchors = [akTop, akRight]
Caption = 'Continue'
TabOrder = 0
OnClick = cmdContinueClick
end
object cmdCancel: TButton
Left = 292
Top = 6
Width = 75
Height = 21
Anchors = [akTop, akRight]
Cancel = True
Caption = 'Cancel Order'
TabOrder = 1
OnClick = cmdCancelClick
end
end
object cmdPrint: TButton
Left = 2
Top = 6
Width = 75
Height = 21
Caption = 'Print'
TabOrder = 1
OnClick = cmdPrintClick
end
object dlgPrintReport: TPrintDialog
Left = 113
Top = 3
end
end

201
CPRS-Chart/Consults/fPreReq.pas Normal file
View File

@ -0,0 +1,201 @@
unit fPreReq;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ORFn, ComCtrls, ExtCtrls;
type
TfrmPrerequisites = class(TForm)
lblFontTest: TLabel;
memReport: TRichEdit;
pnlButton: TPanel;
cmdContinue: TButton;
cmdCancel: TButton;
cmdPrint: TButton;
dlgPrintReport: TPrintDialog;
procedure memReportClick(Sender: TObject);
procedure cmdContinueClick(Sender: TObject);
procedure cmdCancelClick(Sender: TObject);
procedure cmdPrintClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure FormShow(Sender: TObject);
private
procedure AlignButtons();
end;
function DisplayPrerequisites(ReportText: TStrings; ReportTitle: string): Boolean;
var
ContinueWithOrder: Boolean;
implementation
uses
uCore, rCore, rReports, Printers,rMisc;
{$R *.DFM}
function CreateReportBox(ReportText: TStrings; ReportTitle: string): TfrmPrerequisites;
var
i, AWidth, MaxWidth, AHeight: Integer;
Rect: TRect;
begin
Result := TfrmPrerequisites.Create(Application);
try
with Result do
begin
MaxWidth := PnlButton.Width;
for i := 0 to ReportText.Count - 1 do
begin
AWidth := lblFontTest.Canvas.TextWidth(ReportText[i]);
if AWidth > MaxWidth then MaxWidth := AWidth;
end;
MaxWidth := MaxWidth + (GetSystemMetrics(SM_CXFRAME) * 2) + GetSystemMetrics(SM_CXVSCROLL);
AHeight := (ReportText.Count * lblFontTest.Height) + ReportText.Count +
(GetSystemMetrics(SM_CYFRAME) * 3) + GetSystemMetrics(SM_CYCAPTION);
AHeight := AHeight + pnlbutton.Height;
AHeight := HigherOf(AHeight, 250);
if AHeight > (Screen.Height - 60) then AHeight := Screen.Height - 60;
if MaxWidth > Screen.Width then MaxWidth := Screen.Width;
Width := MaxWidth;
Height := AHeight;
Rect := BoundsRect;
ForceInsideWorkArea(Rect);
BoundsRect := Rect;
memReport.Lines.Assign(ReportText);
ResizeAnchoredFormToFont(result);
//Quick fix to work around glich in resize algorithim
AlignButtons();
for i := 1 to Length(ReportTitle) do if ReportTitle[i] = #9 then ReportTitle[i] := ' ';
Caption := ReportTitle;
memReport.SelStart := 0;
end;
except
KillObj(@Result);
raise;
end;
end;
function DisplayPrerequisites(ReportText: TStrings; ReportTitle: string): Boolean;
var
frmPrerequisites: TfrmPrerequisites;
begin
frmPrerequisites := CreateReportBox(ReportText, ReportTitle);
try
frmPrerequisites.ShowModal;
Result := ContinueWithOrder;
finally
frmPrerequisites.Release;
end;
end;
procedure TfrmPrerequisites.memReportClick(Sender: TObject);
begin
//Close;
end;
procedure TfrmPrerequisites.cmdContinueClick(Sender: TObject);
begin
ContinueWithOrder := True;
Close;
end;
procedure TfrmPrerequisites.cmdCancelClick(Sender: TObject);
begin
ContinueWithOrder := False;
Close;
end;
procedure TfrmPrerequisites.cmdPrintClick(Sender: TObject);
var
AHeader: TStringList;
memPrintReport: TRichEdit;
MaxLines, LastLine, ThisPage, i: integer;
ErrMsg: string;
RemoteSiteID: string; //for Remote site printing
RemoteQuery: string; //for Remote site printing
const
PAGE_BREAK = '**PAGE BREAK**';
begin
RemoteSiteID := '';
RemoteQuery := '';
if dlgPrintReport.Execute then
begin
AHeader := TStringList.Create;
CreatePatientHeader(AHeader, Self.Caption);
memPrintReport := TRichEdit.Create(Self);
try
MaxLines := 60 - AHeader.Count;
LastLine := 0;
ThisPage := 0;
with memPrintReport do
begin
Visible := False;
Parent := Self;
Font.Name := 'Courier New';
Font.Size := MainFontSize;
Width := Printer.Canvas.TextWidth(StringOfChar('-', 74));
//Width := 600;
repeat
with Lines do
begin
AddStrings(AHeader);
for i := 0 to MaxLines do
if i < memReport.Lines.Count then
Add(memReport.Lines[LastLine + i])
else
Break;
LastLine := LastLine + i;
Add(' ');
Add(' ');
Add(StringOfChar('-', 74));
if LastLine >= memReport.Lines.Count - 1 then
Add('End of report')
else
begin
ThisPage := ThisPage + 1;
Add('Page ' + IntToStr(ThisPage));
Add(PAGE_BREAK);
end;
end;
until LastLine >= memReport.Lines.Count - 1;
PrintWindowsReport(memPrintReport, PAGE_BREAK, Self.Caption, ErrMsg);
end;
finally
memPrintReport.Free;
AHeader.Free;
end;
end;
memReport.SelStart := 0;
memReport.Invalidate;
end;
procedure TfrmPrerequisites.FormCreate(Sender: TObject);
begin
memreport.Color := ReadOnlyColor;
end;
procedure TfrmPrerequisites.AlignButtons;
Const
BtnSpace = 8;
begin
cmdCancel.Left := self.Width - cmdCancel.Width - BtnSpace;
cmdContinue.Left := cmdCancel.Left - BtnSpace - cmdContinue.Width;
end;
procedure TfrmPrerequisites.FormClose(Sender: TObject;
var Action: TCloseAction);
begin
SaveUserBounds(Self); //Save Position & Size of Form
end;
procedure TfrmPrerequisites.FormShow(Sender: TObject);
begin
SetFormPosition(Self); //Get Saved Position & Size of Form
end;
end.

847
CPRS-Chart/Consults/rConsults.pas Normal file
View File

@ -0,0 +1,847 @@
unit rConsults;
interface
uses SysUtils, Classes, ORNet, ORFn, rCore, uCore, TRPCB, dialogs, uConsults, rTIU, uTIU;
type
TUnresolvedConsults = record
UnresolvedConsultsExist: boolean;
ShowNagScreen: boolean;
end;
{Consult Titles }
function DfltConsultTitle: integer;
function DfltConsultTitleName: string;
function DfltClinProcTitle: integer;
function DfltClinProcTitleName: string;
function IdentifyConsultsClass: integer;
function IdentifyClinProcClass: integer;
procedure ListConsultTitlesShort(Dest: TStrings);
procedure ListClinProcTitlesShort(Dest: TStrings);
function SubSetOfConsultTitles(const StartFrom: string; Direction: Integer; IDNoteTitlesOnly: boolean): TStrings;
function SubSetOfClinProcTitles(const StartFrom: string; Direction: Integer; IDNoteTitlesOnly: boolean): TStrings;
procedure ResetConsultTitles;
procedure ResetClinProcTitles;
{ Data Retrieval }
procedure GetConsultsList(Dest: TStrings; Early, Late: double;
Service, Status: string; SortAscending: Boolean);
procedure LoadConsultDetail(Dest: TStrings; IEN: integer) ;
function GetCurrentContext: TSelectContext;
procedure SaveCurrentContext(AContext: TSelectContext) ;
procedure DisplayResults(Dest: TStrings; IEN: integer) ;
procedure GetConsultRec(IEN: integer) ;
function ShowSF513(ConsultIEN: integer): TStrings ;
procedure PrintSF513ToDevice(AConsult: Integer; const ADevice: string; ChartCopy: string;
var ErrMsg: string);
function GetFormattedSF513(AConsult: Integer; ChartCopy: string): TStrings;
function UnresolvedConsultsExist: boolean;
procedure GetUnresolvedConsultsInfo;
{list box fillers}
function SubSetOfStatus: TStrings;
function SubSetOfUrgencies(ConsultIEN: integer): TStrings;
function LoadServiceList(Purpose: integer): TStrings ;
function LoadServiceListWithSynonyms(Purpose: integer): TStrings ; overload;
function LoadServiceListWithSynonyms(Purpose, ConsultIEN: integer): TStrings ; overload;
function SubSetOfServices(const StartFrom: string; Direction: Integer): TStrings;
function FindConsult(ConsultIEN: integer): string ;
{user access level functions}
function ConsultServiceUser(ServiceIEN: integer; DUZ: int64): boolean ;
function GetActionMenuLevel(ConsultIEN: integer): TMenuAccessRec ;
{consult result functions}
function GetAssignableMedResults(ConsultIEN: integer): TStrings;
function GetRemovableMedResults(ConsultIEN: integer): TStrings;
function GetDetailedMedicineResults(ResultID: string): TStrings;
procedure AttachMedicineResult(ConsultIEN: integer; ResultID: string; DateTime: TFMDateTime; ResponsiblePerson: int64; AlertTo: string);
procedure RemoveMedicineResult(ConsultIEN: integer; ResultID: string; DateTime: TFMDateTime; ResponsiblePerson: int64);
{Consult Request Actions}
procedure ReceiveConsult(Dest: TStrings; IEN: integer; ReceivedBy: int64; RcptDate: TFMDateTime; Comments: TStrings);
procedure ScheduleConsult(Dest: TStrings; IEN: integer; ScheduledBy: Int64; SchdDate: TFMDateTime; Alert: integer;
AlertTo: string; Comments: TStrings);
procedure DiscontinueConsult(Dest: TStrings; IEN: integer; DiscontinuedBy: int64;
DiscontinueDate: TFMDateTime; Comments: TStrings);
procedure DenyConsult(Dest: TStrings; IEN: integer; DeniedBy: int64;
DenialDate: TFMDateTime; Comments: TStrings);
procedure ForwardConsult(Dest: TStrings; IEN, ToService: integer; Forwarder, AttentionOf: int64;
Urgency: integer; ActionDate: TFMDateTime; Comments: TStrings);
procedure AddComment(Dest: TStrings; IEN: integer; Comments: TStrings; ActionDate: TFMDateTime; Alert: integer;
AlertTo: string) ;
procedure SigFindings(Dest: TStrings; IEN: integer; SigFindingsFlag: string; Comments: TStrings; ActionDate: TFMDateTime;Alert: integer;
AlertTo: string) ;
procedure AdminComplete(Dest: TStrings; IEN: integer; SigFindingsFlag: string; Comments: TStrings;
RespProv: Int64; ActionDate: TFMDateTime; Alert: integer; AlertTo: string) ;
{ Consults Ordering Calls }
function ODForConsults: TStrings;
function ODForProcedures: TStrings;
function ConsultMessage(AnIEN: Integer): string;
function LoadConsultsQuickList: TStrings ;
function GetProcedureServices(ProcIEN: integer): TStrings;
function ConsultCanBeResubmitted(ConsultIEN: integer): string;
function LoadConsultForEdit(ConsultIEN: integer): TEditResubmitRec;
function ResubmitConsult(EditResubmitRec: TEditResubmitRec): string;
function SubSetOfProcedures(const StartFrom: string; Direction: Integer): TStrings;
function GetDefaultReasonForRequest(Service: string; Resolve: Boolean): TStrings;
function ReasonForRequestEditable(Service: string): string;
function GetNewDialog(OrderType: string): string;
function GetServiceIEN(ORIEN: string): string;
function GetProcedureIEN(ORIEN: string): string;
function GetConsultOrderIEN(ConsultIEN: integer): string;
function GetServicePrerequisites(Service: string): TStrings;
procedure GetProvDxMode(var ProvDx: TProvisionalDiagnosis; SvcIEN: string);
{ Clinical Procedures Specific}
function GetSavedCPFields(NoteIEN: integer): TEditNoteRec;
var
uConsultsClass: integer;
uConsultTitles: TConsultTitles;
uClinProcClass: integer;
uClinProcTitles: TClinProcTitles;
uUnresolvedConsults: TUnresolvedConsults;
implementation
uses rODBase;
var
uLastOrderedIEN: Integer;
uLastOrderMsg: string;
{ -------------------------- Consult Titles --------------------------------- }
function IdentifyConsultsClass: integer;
begin
if uConsultsClass = 0 then
uConsultsClass := StrToIntDef(sCallV('TIU IDENTIFY CONSULTS CLASS',[nil]), 0) ;
Result := uConsultsClass;
end;
procedure LoadConsultTitles;
{ private - called one time to set up the uConsultTitles object }
var
x: string;
begin
if uConsultTitles <> nil then Exit;
CallV('TIU PERSONAL TITLE LIST', [User.DUZ, IdentifyConsultsClass]);
RPCBrokerV.Results.Insert(0, '~SHORT LIST'); // insert so can call ExtractItems
uConsultTitles := TConsultTitles.Create;
ExtractItems(uConsultTitles.ShortList, RPCBrokerV.Results, 'SHORT LIST');
x := ExtractDefault(RPCBrokerV.Results, 'SHORT LIST');
uConsultTitles.DfltTitle := StrToIntDef(Piece(x, U, 1), 0);
uConsultTitles.DfltTitleName := Piece(x, U, 2);
end;
procedure ResetConsultTitles;
begin
if uConsultTitles <> nil then
begin
uConsultTitles.Free;
uConsultTitles := nil;
LoadConsultTitles;
end;
end;
function DfltConsultTitle: integer;
{ returns the user defined default Consult title (if any) }
begin
if uConsultTitles = nil then LoadConsultTitles;
Result := uConsultTitles.DfltTitle;
end;
function DfltConsultTitleName: string;
{ returns the name of the user defined default progress note title (if any) }
begin
if uConsultTitles = nil then LoadConsultTitles;
Result := uConsultTitles.DfltTitleName;
end;
procedure ListConsultTitlesShort(Dest: TStrings);
{ returns the user defined list (short list) of Consult titles }
begin
if uConsultTitles = nil then LoadConsultTitles;
Dest.AddStrings(uConsultTitles.ShortList);
if uConsultTitles.ShortList.Count > 0 then
begin
Dest.Add('0^________________________________________________________________________');
Dest.Add('0^ ');
end;
end;
function SubSetOfConsultTitles(const StartFrom: string; Direction: Integer; IDNoteTitlesOnly: boolean): TStrings;
{ returns a pointer to a list of consults progress note titles (for use in a long list box) -
The return value is a pointer to RPCBrokerV.Results, so the data must be used BEFORE
the next broker call! }
begin
(* if IDNoteTitlesOnly then // This RPC not changed for initial ID Notes release
CallV('TIU LONG LIST CONSULT TITLES', [StartFrom, Direction, IDNoteTitlesOnly])
else*)
CallV('TIU LONG LIST CONSULT TITLES', [StartFrom, Direction]);
//MixedCaseList(RPCBrokerV.Results);
Result := RPCBrokerV.Results;
end;
{ -------------------------- Clinical Procedures Titles --------------------------------- }
function IdentifyClinProcClass: integer;
begin
if uClinProcClass = 0 then
uClinProcClass := StrToIntDef(sCallV('TIU IDENTIFY CLINPROC CLASS',[nil]), 0) ;
Result := uClinProcClass;
end;
procedure LoadClinProcTitles;
{ private - called one time to set up the uConsultTitles object }
var
x: string;
begin
if uClinProcTitles <> nil then Exit;
CallV('TIU PERSONAL TITLE LIST', [User.DUZ, IdentifyClinProcClass]);
RPCBrokerV.Results.Insert(0, '~SHORT LIST'); // insert so can call ExtractItems
uClinProcTitles := TClinProcTitles.Create;
ExtractItems(uClinProcTitles.ShortList, RPCBrokerV.Results, 'SHORT LIST');
x := ExtractDefault(RPCBrokerV.Results, 'SHORT LIST');
uClinProcTitles.DfltTitle := StrToIntDef(Piece(x, U, 1), 0);
uClinProcTitles.DfltTitleName := Piece(x, U, 2);
end;
procedure ResetClinProcTitles;
begin
if uClinProcTitles <> nil then
begin
uClinProcTitles.Free;
uClinProcTitles := nil;
LoadClinProcTitles;
end;
end;
function DfltClinProcTitle: integer;
{ returns the user defined default ClinProc title (if any) }
begin
if uClinProcTitles = nil then LoadClinProcTitles;
Result := uClinProcTitles.DfltTitle;
end;
function DfltClinProcTitleName: string;
{ returns the name of the user defined default progress note title (if any) }
begin
if uClinProcTitles = nil then LoadClinProcTitles;
Result := uClinProcTitles.DfltTitleName;
end;
procedure ListClinProcTitlesShort(Dest: TStrings);
{ returns the user defined list (short list) of ClinProc titles }
begin
if uClinProcTitles = nil then LoadClinProcTitles;
Dest.AddStrings(uClinProcTitles.ShortList);
if uClinProcTitles.ShortList.Count > 0 then
begin
Dest.Add('0^________________________________________________________________________');
Dest.Add('0^ ');
end;
end;
function SubSetOfClinProcTitles(const StartFrom: string; Direction: Integer; IDNoteTitlesOnly: boolean): TStrings;
{ returns a pointer to a list of clinical procedures titles (for use in a long list box) -
The return value is a pointer to RPCBrokerV.Results, so the data must be used BEFORE
the next broker call! }
begin
(* if IDNoteTitlesOnly then // This RPC not changed for initial ID Notes release
CallV('TIU LONG LIST CLINPROC TITLES', [StartFrom, Direction, IDNoteTitlesOnly])
else*)
CallV('TIU LONG LIST CLINPROC TITLES', [StartFrom, Direction]);
//MixedCaseList(RPCBrokerV.Results);
Result := RPCBrokerV.Results;
end;
{--------------- data retrieval ------------------------------------------}
procedure GetConsultsList(Dest: TStrings; Early, Late: double;
Service, Status: string; SortAscending: Boolean);
{ returns a list of consults for a patient, based on selected dates, service, status, or ALL}
var
i: Integer;
x, date1, date2: string;
begin
if Early <= 0 then date1 := '' else date1 := FloatToStr(Early) ;
if Late <= 0 then date2 := '' else date2 := FloatToStr(Late) ;
CallV('ORQQCN LIST', [Patient.DFN, date1, date2, Service, Status]);
with RPCBrokerV do
begin
if Copy(Results[0],1,1) <> '<' then
begin
SortByPiece(TStringList(Results), U, 2);
if not SortAscending then InvertStringList(TStringList(Results));
//SetListFMDateTime('mmm dd,yy', TStringList(Results), U, 2);
for i := 0 to Results.Count - 1 do
begin
x := MakeConsultListItem(Results[i]);
Results[i] := x;
end;
Dest.Assign(Results);
end
else
begin
Dest.Clear ;
Dest.Add('-1^No Matches') ;
end ;
end;
end;
procedure LoadConsultDetail(Dest: TStrings; IEN: integer) ;
{ returns the detail of a consult }
begin
CallV('ORQQCN DETAIL', [IEN]);
Dest.Assign(RPCBrokerV.Results);
end;
procedure DisplayResults(Dest: TStrings; IEN: integer) ;
{ returns the results for a consult }
begin
CallV('ORQQCN MED RESULTS', [IEN]);
Dest.Assign(RPCBrokerV.Results);
end;
procedure GetConsultRec(IEN: integer);
{returns zero node from file 123, plus a list of all related TIU documents, if any}
const
SHOW_ADDENDA = True;
var
alist: TStrings;
x: string ;
i: integer;
{ 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15
{ Pieces: EntDt^Pat^OrIFN^PtLoc^ToSvc^From^ReqDt^Typ^Urg^Place^Attn^Sts^LstAct^SndPrv^Rslt^
16 17 18 19 20 21 22
^EntMode^ReqTyp^InOut^SigFnd^TIUPtr^OrdFac^FrgnCslt}
begin
FillChar(ConsultRec, SizeOf(ConsultRec), 0);
CallV('ORQQCN GET CONSULT', [IEN, SHOW_ADDENDA]);
ConsultRec.IEN := IEN ;
alist := TStringList.Create ;
try
alist.Assign(RPCBrokerV.Results) ;
x := alist[0] ;
if Piece(x,u,1) <> '-1' then
with ConsultRec do
begin
EntryDate := MakeFMDateTime(Piece(x, U, 1));
ORFileNumber := StrToIntDef(Piece(x, U, 3),0);
PatientLocation := StrToIntDef(Piece(x, U, 4),0);
OrderingFacility := StrToIntDef(Piece(x, U, 21),0);
ForeignConsultFileNum := StrToIntDef(Piece(x, U, 22),0);
ToService := StrToIntDef(Piece(x, U, 5),0);
From := StrToIntDef(Piece(x, U, 6),0);
RequestDate := MakeFMDateTime(Piece(x, U, 7));
ConsultProcedure := Piece(x, U, 8) ;
Urgency := StrToIntDef(Piece(x, U, 9),0);
PlaceOfConsult := StrToIntDef(Piece(x, U, 10),0);
Attention := StrToInt64Def(Piece(x, U, 11),0);
ORStatus := StrToIntDef(Piece(x, U, 12),0);
LastAction := StrToIntDef(Piece(x, U, 13),0);
SendingProvider := StrToInt64Def(Piece(Piece(x, U, 14),';',1),0);
SendingProviderName := Piece(Piece(x, U, 14),';',2) ;
Result := Piece(x, U, 15) ;
ModeOfEntry := Piece(x, U, 16) ;
RequestType := StrToIntDef(Piece(x, U, 17),0);
InOut := Piece(x, U, 18) ;
Findings := Piece(x, U, 19) ;
TIUResultNarrative := StrToIntDef(Piece(x, U, 20),0);
//ProvDiagnosis := Piece(x, U, 23); NO!!!!! Up to 180 Characters!!!!
alist.delete(0) ;
TIUDocuments := TStringList.Create ;
MedResults := TStringList.Create;
if alist.count > 0 then
begin
SortByPiece(TStringList(alist), U, 3);
for i := 0 to alist.Count - 1 do
if Copy(Piece(Piece(alist[i], U, 1), ';', 2), 1, 4) = 'MCAR' then
MedResults.Add(alist[i])
else
TIUDocuments.Add(alist[i]);
end;
end {ConsultRec}
else
ConsultRec.EntryDate := -1 ;
finally
alist.free ;
end ;
end ;
{---------------- list box fillers -----------------------------------}
function SubSetOfStatus: TStrings;
{ returns a pointer to a list of stati (for use in a list box) }
begin
CallV('ORQQCN STATUS', [nil]);
MixedCaseList(RPCBrokerV.Results);
Result := RPCBrokerV.Results;
end;
function SubSetOfUrgencies(ConsultIEN: integer): TStrings;
{ returns a pointer to a list of urgencies }
begin
CallV('ORQQCN URGENCIES',[ConsultIEN]) ;
MixedCaseList(RPCBrokerV.Results);
Result := RPCBrokerV.Results;
end;
function FindConsult(ConsultIEN: integer): string ;
var
x: string;
begin
x := sCallV('ORQQCN FIND CONSULT',[ConsultIEN]);
Result := MakeConsultListItem(x);
end;
{-----------------consult result functions-----------------------------------}
function GetAssignableMedResults(ConsultIEN: integer): TStrings;
begin
CallV('ORQQCN ASSIGNABLE MED RESULTS', [ConsultIEN]);
Result := RPCBrokerV.Results;
end;
function GetRemovableMedResults(ConsultIEN: integer): TStrings;
begin
CallV('ORQQCN REMOVABLE MED RESULTS', [ConsultIEN]);
Result := RPCBrokerV.Results;
end;
function GetDetailedMedicineResults(ResultID: string): TStrings;
begin
CallV('ORQQCN GET MED RESULT DETAILS', [ResultID]);
Result := RPCBrokerV.Results;
end;
procedure AttachMedicineResult(ConsultIEN: integer; ResultID: string; DateTime: TFMDateTime; ResponsiblePerson: int64; AlertTo: string);
begin
CallV('ORQQCN ATTACH MED RESULTS', [ConsultIEN, ResultID, DateTime, ResponsiblePerson, AlertTo]);
end;
procedure RemoveMedicineResult(ConsultIEN: integer; ResultID: string; DateTime: TFMDateTime; ResponsiblePerson: int64);
begin
CallV('ORQQCN REMOVE MED RESULTS', [ConsultIEN, ResultID, DateTime, ResponsiblePerson]);
end;
{-------------- user access level functions ---------------------------------}
function ConsultServiceUser(ServiceIEN: integer; DUZ: int64): boolean ;
var
i: integer ;
begin
Result := False ;
CallV('ORWU GENERIC', ['',1,'^GMR(123.5,'+IntToStr(ServiceIEN)+',123.3,"B")']) ;
for i:=0 to RPCBrokerV.Results.Count-1 do
if StrToInt64(Piece(RPCBrokerV.Results[i],u,2))=DUZ then result := True ;
end ;
function GetActionMenuLevel(ConsultIEN: integer): TMenuAccessRec ;
var
x: string;
begin
x := sCallV('ORQQCN SET ACT MENUS', [ConsultIEN]) ;
Result.UserLevel := StrToIntDef(Piece(x, U, 1), 1);
Result.AllowMedResulting := (Piece(x, U, 4) = '1');
Result.AllowMedDissociate := (Piece(x, U, 5) = '1');
Result.AllowResubmit := (Piece(x, U, 6) = '1') and (Piece(ConsultCanBeResubmitted(ConsultIEN), U, 1) <> '0');
Result.ClinProcFlag := StrToIntDef(Piece(x, U, 7), CP_NOT_CLINPROC);
Result.IsClinicalProcedure := (Result.ClinProcFlag > CP_NOT_CLINPROC);
end ;
{------------------- Consult request actions -------------------------------}
procedure ReceiveConsult(Dest: TStrings; IEN: integer; ReceivedBy: int64; RcptDate: TFMDateTime; Comments: TStrings);
begin
CallV('ORQQCN RECEIVE', [IEN, ReceivedBy, RcptDate, Comments]);
Dest.Assign(RPCBrokerV.Results); {1^Error message' or '0'}
end;
procedure ScheduleConsult(Dest: TStrings; IEN: integer; ScheduledBy: Int64; SchdDate: TFMDateTime; Alert: integer;
AlertTo: string; Comments: TStrings);
begin
CallV('ORQQCN2 SCHEDULE CONSULT', [IEN, ScheduledBy, SchdDate, Alert, AlertTo, Comments]);
Dest.Assign(RPCBrokerV.Results); {1^Error message' or '0'}
end;
procedure DenyConsult(Dest: TStrings; IEN: integer; DeniedBy: int64;
DenialDate: TFMDateTime; Comments: TStrings);
begin
CallV('ORQQCN DISCONTINUE', [IEN, DeniedBy, DenialDate,'DY',Comments]);
Dest.Assign(RPCBrokerV.Results); {1^Error message' or '0'}
end;
procedure DiscontinueConsult(Dest: TStrings; IEN: integer; DiscontinuedBy: int64;
DiscontinueDate: TFMDateTime; Comments: TStrings);
begin
CallV('ORQQCN DISCONTINUE', [IEN, DiscontinuedBy, DiscontinueDate,'DC',Comments]);
Dest.Assign(RPCBrokerV.Results); {1^Error message' or '0'}
end;
procedure ForwardConsult(Dest: TStrings; IEN, ToService: integer; Forwarder, AttentionOf: int64; Urgency: integer;
ActionDate: TFMDateTime; Comments: TStrings);
begin
CallV('ORQQCN FORWARD', [IEN, ToService, Forwarder, AttentionOf, Urgency, ActionDate, Comments]);
Dest.Assign(RPCBrokerV.Results); {1^Error message' or '0'}
end ;
procedure AddComment(Dest: TStrings; IEN: integer; Comments: TStrings; ActionDate: TFMDateTime; Alert: integer;
AlertTo: string) ;
begin
CallV('ORQQCN ADDCMT', [IEN, Comments, Alert, AlertTo, ActionDate]);
Dest.Assign(RPCBrokerV.Results); {1^Error message' or '0'}
end ;
procedure AdminComplete(Dest: TStrings; IEN: integer; SigFindingsFlag: string; Comments: TStrings;
RespProv: Int64; ActionDate: TFMDateTime; Alert: integer; AlertTo: string) ;
begin
CallV('ORQQCN ADMIN COMPLETE', [IEN, SigFindingsFlag, Comments, RespProv, Alert, AlertTo, ActionDate]);
Dest.Assign(RPCBrokerV.Results); {1^Error message' or '0'}
end ;
procedure SigFindings(Dest: TStrings; IEN: integer; SigFindingsFlag: string; Comments: TStrings; ActionDate: TFMDateTime; Alert: integer;
AlertTo: string) ;
begin
CallV('ORQQCN SIGFIND', [IEN, SigFindingsFlag, Comments, Alert, AlertTo, ActionDate]);
Dest.Assign(RPCBrokerV.Results); {1^Error message' or '0'}
end ;
//================== Ordering functions ===================================
function ODForConsults: TStrings;
{ Returns init values for consults dialog. The results must be used immediately. }
begin
CallV('ORWDCN32 DEF', ['C']);
Result := RPCBrokerV.Results;
end;
function ODForProcedures: TStrings;
{ Returns init values for procedures dialog. The results must be used immediately. }
begin
CallV('ORWDCN32 DEF', ['P']);
Result := RPCBrokerV.Results;
end;
function SubSetOfProcedures(const StartFrom: string; Direction: Integer): TStrings;
begin
begin
CallV('ORWDCN32 PROCEDURES', [StartFrom, Direction]);
Result := RPCBrokerV.Results;
end;
end;
function LoadServiceList(Purpose: integer): TStrings ;
// Purpose: 0=display all services, 1=forward or order from possible services
begin
Callv('ORQQCN SVCTREE',[Purpose]) ;
MixedCaseList(RPCBrokerV.Results) ;
Result := RPCBrokerV.Results;
end ;
function LoadServiceListWithSynonyms(Purpose: integer): TStrings ;
// Param 1 = Starting service (1=All Services)
// Param 2 = Purpose: 0=display all services, 1=forward or order from possible services
// Param 3 = Show synonyms
begin
Callv('ORQQCN SVC W/SYNONYMS',[1, Purpose, True]) ;
MixedCaseList(RPCBrokerV.Results) ;
Result := RPCBrokerV.Results;
end ;
function LoadServiceListWithSynonyms(Purpose, ConsultIEN: integer): TStrings ;
// Param 1 = Starting service (1=All Services)
// Param 2 = Purpose: 0=display all services, 1=forward or order from possible services
// Param 3 = Show synonyms
// Param 4 = Consult IEN
begin
Callv('ORQQCN SVC W/SYNONYMS',[1, Purpose, True, ConsultIEN]) ;
MixedCaseList(RPCBrokerV.Results) ;
Result := RPCBrokerV.Results;
end ;
function SubSetOfServices(const StartFrom: string; Direction: Integer): TStrings;
// used only on consults order dialog for service long combo box, which needs to include quick orders
begin
CallV('ORQQCN SVCLIST', [StartFrom, Direction]);
Result := RPCBrokerV.Results;
end;
function LoadConsultsQuickList: TStrings ;
begin
Callv('ORWDXQ GETQLST',['CSLT', 'Q']) ;
Result := RPCBrokerV.Results;
end ;
function ShowSF513(ConsultIEN: integer): TStrings ;
var
x: string;
i: integer;
begin
CallV('ORQQCN SHOW SF513',[ConsultIEN]) ;
if RPCBrokerV.Results.Count > 0 then
begin
x := RPCBrokerV.Results[0];
i := Pos('-', x);
x := Copy(x, i, 999);
RPCBrokerV.Results[0] := x;
end;
Result := RPCBrokerV.Results;
end ;
procedure PrintSF513ToDevice(AConsult: Integer; const ADevice: string; ChartCopy: string;
var ErrMsg: string);
{ prints a SF 513 on the selected device }
begin
ErrMsg := sCallV('ORQQCN PRINT SF513', [AConsult, ChartCopy, ADevice]);
// if Piece(ErrMsg, U, 1) = '0' then ErrMsg := '' else ErrMsg := Piece(ErrMsg, U, 2);
end;
function GetFormattedSF513(AConsult: Integer; ChartCopy: string): TStrings;
begin
CallV('ORQQCN SF513 WINDOWS PRINT',[AConsult, ChartCopy]);
Result := RPCBrokerV.Results;
end;
function UnresolvedConsultsExist: boolean;
begin
Result := (sCallV('ORQQCN UNRESOLVED', [Patient.DFN]) = '1');
end;
procedure GetUnresolvedConsultsInfo;
var
x: string;
begin
x := sCallV('ORQQCN UNRESOLVED', [Patient.DFN]);
with uUnresolvedConsults do
begin
UnresolvedConsultsExist := (Piece(x, U, 1) = '1');
ShowNagScreen := (Piece(x, U, 2) = '1');
end;
end;
function ConsultMessage(AnIEN: Integer): string;
begin
if AnIEN = uLastOrderedIEN then Result := uLastOrderMsg else
begin
Result := sCallV('ORWDCN32 ORDRMSG', [AnIEN]);
uLastOrderedIEN := AnIEN;
uLastOrderMsg := Result;
end;
end;
function GetProcedureIEN(ORIEN: string): string;
begin
Result := sCallV('ORQQCN GET PROC IEN', [ORIEN]);
end;
function GetProcedureServices(ProcIEN: integer): TStrings;
begin
CallV('ORQQCN GET PROC SVCS',[ProcIEN]) ;
Result := RPCBrokerV.Results;
end;
function ConsultCanBeResubmitted(ConsultIEN: integer): string;
begin
Result := sCallV('ORQQCN CANEDIT', [ConsultIEN]);
end;
function LoadConsultForEdit(ConsultIEN: integer): TEditResubmitRec;
var
Dest: TStringList;
EditRec: TEditResubmitRec;
begin
Dest := TStringList.Create;
try
tCallV(Dest, 'ORQQCN LOAD FOR EDIT',[ConsultIEN]) ;
with EditRec do
begin
Changed := False;
IEN := ConsultIEN;
ToService := StrToIntDef(Piece(ExtractDefault(Dest, 'SERVICE'), U, 2), 0);
RequestType := Piece(ExtractDefault(Dest, 'TYPE'), U, 3);
OrderableItem := StrToIntDef(Piece(ExtractDefault(Dest, 'PROCEDURE'), U, 1), 0);
ConsultProc := Piece(ExtractDefault(Dest, 'PROCEDURE'), U, 3);
ConsultProcName := Piece(ExtractDefault(Dest, 'PROCEDURE'), U, 2);
Urgency := StrToIntDef(Piece(ExtractDefault(Dest, 'URGENCY'), U, 3), 0);
UrgencyName := Piece(ExtractDefault(Dest, 'URGENCY'), U, 2);
Place := Piece(ExtractDefault(Dest, 'PLACE'), U, 1);
PlaceName := Piece(ExtractDefault(Dest, 'PLACE'), U, 2);
Attention := StrToInt64Def(Piece(ExtractDefault(Dest, 'ATTENTION'), U, 1), 0);
AttnName := Piece(ExtractDefault(Dest, 'ATTENTION'), U, 2);
InpOutp := Piece(ExtractDefault(Dest, 'CATEGORY'), U, 1);
ProvDiagnosis := Piece(ExtractDefault(Dest, 'DIAGNOSIS'), U, 1);
ProvDxCode := Piece(ExtractDefault(Dest, 'DIAGNOSIS'), U, 2);
ProvDxCodeInactive := (Piece(ExtractDefault(Dest, 'DIAGNOSIS'), U, 3) = '1');
RequestReason := TStringList.Create;
ExtractText(RequestReason, Dest, 'REASON');
LimitStringLength(RequestReason, 74);
DenyComments := TStringList.Create;
ExtractText(DenyComments, Dest, 'DENY COMMENT');
OtherComments := TStringList.Create;
ExtractText(OtherComments, Dest, 'ADDED COMMENT');
NewComments := TStringList.Create;
end;
Result := EditRec;
finally
Dest.Free;
end;
end;
function ResubmitConsult(EditResubmitRec: TEditResubmitRec): string;
var
i: integer;
begin
with RPCBrokerV, EditResubmitRec do
begin
ClearParameters := True;
RemoteProcedure := 'ORQQCN RESUBMIT';
Param[0].PType := literal;
Param[0].Value := IntToStr(IEN);
Param[1].PType := list;
with Param[1] do
begin
if ToService > 0 then
Mult['1'] := 'GMRCSS^' + IntToStr(ToService);
if ConsultProc <> '' then
Mult['2'] := 'GMRCPROC^' + ConsultProc ;
if Urgency > 0 then
Mult['3'] := 'GMRCURG^' + IntToStr(Urgency);
if Length(Place) > 0 then
Mult['4'] := 'GMRCPL^' + Place;
if Attention > 0 then
Mult['5'] := 'GMRCATN^' + IntToStr(Attention)
else if Attention = -1 then
Mult['5'] := 'GMRCATN^' + '@';
if RequestType <> '' then
Mult['6'] := 'GMRCRQT^' + RequestType;
if Length(InpOutP) > 0 then
Mult['7'] := 'GMRCION^' + InpOutp;
if Length(ProvDiagnosis) > 0 then
Mult['8'] := 'GMRCDIAG^' + ProvDiagnosis + U + ProvDxCode;
if RequestReason.Count > 0 then
begin
Mult['9'] := 'GMRCRFQ^20';
for i := 0 to RequestReason.Count - 1 do
Mult['9,' + IntToStr(i+1)] := RequestReason.Strings[i];
end;
if NewComments.Count > 0 then
begin
Mult['10'] := 'COMMENT^';
for i := 0 to NewComments.Count - 1 do
Mult['10,' + IntToStr(i+1)] := NewComments.Strings[i];
end;
end;
CallBroker;
Result := '0';
//Result := Results[0];
end;
end;
function GetCurrentContext: TSelectContext;
var
x: string;
AContext: TSelectContext;
begin
x := sCallV('ORQQCN2 GET CONTEXT', [User.DUZ]) ;
with AContext do
begin
Changed := True;
BeginDate := Piece(x, ';', 1);
EndDate := Piece(x, ';', 2);
Status := Piece(x, ';', 3);
Service := Piece(x, ';', 4);
GroupBy := Piece(x, ';', 5);
Ascending := (Piece(x, ';', 6) = '1');
end;
Result := AContext;
end;
procedure SaveCurrentContext(AContext: TSelectContext) ;
var
x: string;
begin
with AContext do
begin
SetPiece(x, ';', 1, BeginDate);
SetPiece(x, ';', 2, EndDate);
SetPiece(x, ';', 3, Status);
SetPiece(x, ';', 4, Service);
SetPiece(x, ';', 5, GroupBy);
SetPiece(x, ';', 6, BOOLCHAR[Ascending]);
end;
CallV('ORQQCN2 SAVE CONTEXT', [x]);
end;
function GetDefaultReasonForRequest(Service: string; Resolve: Boolean): TStrings;
begin
CallV('ORQQCN DEFAULT REQUEST REASON',[Service, Patient.DFN, Resolve]) ;
Result := RPCBrokerV.Results;
end;
function ReasonForRequestEditable(Service: string): string;
begin
Result := sCallV('ORQQCN EDIT DEFAULT REASON', [Service]);
end;
function GetServicePrerequisites(Service: string): TStrings;
begin
CallV('ORQQCN2 GET PREREQUISITE',[Service, Patient.DFN]) ;
Result := RPCBrokerV.Results;
end;
function GetNewDialog(OrderType: string): string;
{ get dialog for new consults}
begin
Result := sCallV('ORWDCN32 NEWDLG', [OrderType, Encounter.Location]);
end;
function GetServiceIEN(ORIEN: string): string;
begin
Result := sCallV('ORQQCN GET SERVICE IEN', [ORIEN]);
end;
procedure GetProvDxMode(var ProvDx: TProvisionalDiagnosis; SvcIEN: string);
var
x: string;
begin
x := sCallV('ORQQCN PROVDX', [SvcIEN]);
ProvDx.Reqd := Piece(x, U, 1);
ProvDx.PromptMode := Piece(x, U, 2);
end;
function GetConsultOrderIEN(ConsultIEN: integer): string;
begin
Result := sCallV('ORQQCN GET ORDER NUMBER', [ConsultIEN]);
end;
function GetSavedCPFields(NoteIEN: integer): TEditNoteRec;
var
x: string;
AnEditRec: TEditNoteRec;
begin
x := sCallV('ORWTIU GET SAVED CP FIELDS', [NoteIEN]);
with AnEditRec do
begin
Author := StrToInt64Def(Piece(x, U, 1), 0);
Cosigner := StrToInt64Def(Piece(x, U, 2), 0);
ClinProcSummCode := StrToIntDef(Piece(x, U, 3), 0);
ClinProcDateTime := StrToFMDateTime(Piece(x, U, 4));
Title := StrToIntDef(Piece(x, U, 5), 0);
end;
Result := AnEditRec;
end;
initialization
uLastOrderedIEN := 0;
uLastOrderMsg := '';
uConsultsClass := 0;
uClinProcClass := 0;
finalization
if uConsultTitles <> nil then uConsultTitles.Free;
if uClinProcTitles <> nil then uClinProcTitles.Free;
end.

453
CPRS-Chart/Consults/uConsults.pas Normal file
View File

@ -0,0 +1,453 @@
unit uConsults;
interface
uses
SysUtils, Windows, Messages, Controls, Classes, StdCtrls, ORfn, uTIU, ORCtrls;
type
TConsultRequest = record {file 123} {Order Dialog}
IEN: integer ; {.001}
EntryDate: TFMDateTime ; { .01}
ORFileNumber: integer ; { .03}
PatientLocation: integer ; { .04}
OrderingFacility: integer ; { .05}
ForeignConsultFileNum: integer ; { .06}
ToService: integer ; { 1} { * }
From: integer ; { 2}
RequestDate: TFMDateTime ; { 3}
ConsultProcedure: string ; { 4}
Urgency: integer ; { 5} { * }
PlaceOfConsult: integer ; { 6} { * }
Attention: int64 ; { 7} { * }
ORStatus: integer ; { 8}
LastAction: integer ; { 9}
SendingProvider: int64 ; { 10}
SendingProviderName: string ;
Result: string ; { 11}
ModeOfEntry: string ; { 12}
RequestType: integer ; { 13}
InOut: string ; { 14} { * }
Findings: string ; { 15}
TIUResultNarrative: integer ; { 16}
TIUDocuments: TStrings ; {from '50' node of file 123}
MedResults: TStrings; {from '50' node of file 123}
RequestReason: TStringList ; { 20} { * }
ProvDiagnosis: string ; { 30} { * }
ProvDxCode: string; { 30.1}
RequestProcessingActivity: TStringList; { 40}
end ;
TEditResubmitRec = record
Changed: boolean;
IEN: integer;
OrderableItem: integer;
RequestType: string;
ToService: integer;
ToServiceName: string;
ConsultProc: string;
ConsultProcName: string;
Urgency: integer;
UrgencyName: string;
Place: string;
PlaceName: string;
Attention: int64;
AttnName: string;
InpOutp: string;
RequestReason: TStringList;
ProvDiagnosis: string;
ProvDxCode: string;
ProvDxCodeInactive: boolean;
DenyComments: TStringList;
OtherComments: TStringList;
NewComments: TStringList;
end;
TSelectContext = record
Changed: Boolean;
BeginDate: string;
EndDate: string;
Ascending: Boolean;
Service: string;
ServiceName: string;
ConsultUser: Boolean ;
Status: string;
StatusName: string;
GroupBy: string;
end ;
TMenuAccessRec = record
UserLevel: integer;
AllowMedResulting: Boolean;
AllowMedDissociate: Boolean;
AllowResubmit: Boolean;
ClinProcFlag: integer;
IsClinicalProcedure: Boolean;
end;
TProvisionalDiagnosis = record
Code: string;
Text: string;
CodeInactive: boolean;
Reqd: string;
PromptMode: string;
end;
TConsultTitles = class
DfltTitle: Integer;
DfltTitleName: string;
ShortList: TStringList;
constructor Create;
destructor Destroy; override;
end;
TClinProcTitles = class
DfltTitle: Integer;
DfltTitleName: string;
ShortList: TStringList;
constructor Create;
destructor Destroy; override;
end;
function MakeConsultListItem(InputString: string):string;
function MakeConsultListDisplayText(InputString: string): string;
function MakeConsultNoteDisplayText(RawText: string): string;
procedure BuildServiceTree(Tree: TORTreeView; SvcList: TStrings; const Parent: string; Node: TORTreeNode);
procedure CreateListItemsForConsultTree(Dest, Source: TStrings; Context: integer; GroupBy: string;
Ascending: Boolean);
procedure BuildConsultsTree(Tree: TORTreeView; tmpList: TStrings; const Parent: string; Node: TORTreeNode;
CurrentContext: TSelectContext);
procedure SetNodeImage(Node: TORTreeNode; CurrentContext: TSelectContext);
const
CN_SVC_LIST_DISP = 0 ;
CN_SVC_LIST_FWD = 1 ;
CN_SVC_LIST_ORD = 1 ;
CSLT_PTR = ';99CON';
PROC_PTR = ';99PRC';
{MenuAccessRec.UserLevel}
UL_NONE = 0;
UL_REVIEW = 1;
UL_UPDATE = 2;
UL_ADMIN = 3;
UL_UPDATE_AND_ADMIN = 4;
{Clinical Procedure statuses}
CP_NOT_CLINPROC = 0;
CP_NO_INSTRUMENT = 1;
CP_INSTR_NO_STUB = 2;
CP_INSTR_INCOMPLETE = 3;
CP_INSTR_COMPLETE = 4;
CN_NEW_CSLT_NOTE = '-30';
CN_NEW_CP_NOTE = '-20';
var
ConsultRec: TConsultRequest ;
implementation
uses
uConst;
constructor TConsultTitles.Create;
{ creates an object to store Consult titles so only obtained from server once }
begin
inherited Create;
ShortList := TStringList.Create;
end;
destructor TConsultTitles.Destroy;
{ frees the lists that were used to store the Consult titles }
begin
ShortList.Free;
inherited Destroy;
end;
constructor TClinProcTitles.Create;
{ creates an object to store ClinProc titles so only obtained from server once }
begin
inherited Create;
ShortList := TStringList.Create;
end;
destructor TClinProcTitles.Destroy;
{ frees the lists that were used to store the ClinProc titles }
begin
ShortList.Free;
inherited Destroy;
end;
{============================================================================================
1016^Jun 04,98 ^(dc)^ COLONOSCOPY GASTROENTEROLOGY Proc^Consult #: 1016^15814^^P
1033^Jun 10,98 ^(c)^ GASTROENTEROLOGY Cons^Consult #: 1033^15881^^C
=============================================================================================
function call [GetConsultsList] returns the following string '^' pieces:
===============================================================
1 - Consult IEN
2 - Consult Date
3 - (Status)
4 - Consult/Procedure Display Text
5 - Consult #: ###
6 - Order IFN
7 - '' (used for HasChildren in tree)
8 - Parent in tree
9 - 'Consult', 'Procedure', or 'Clinical Procedure'
10 - Service Name
11 - FMDate of piece 2
12 - 'C' or 'P' or 'M' or 'I' or 'R'
===============================================================}
function MakeConsultListItem(InputString: string): string;
var
x: string;
begin
x := InputString;
if Piece(x, U, 6) = '' then SetPiece(x, U, 6, ' ');
if Piece(x, U, 9) <> '' then
case Piece(x, U, 9)[1] of
'C': SetPiece(x, U, 10, 'Consult');
'P': SetPiece(x, U, 10, 'Procedure');
'M': SetPiece(x, U, 10, 'Procedure'); //'Clinical Procedure');
'I': SetPiece(x, U, 10, 'Consult - Interfacility');
'R': SetPiece(x, U, 10, 'Procedure - Interfacility');
end
else
begin
if Piece(x, U, 5) = 'Consult' then SetPiece(x, U, 10, 'Consult')
else SetPiece(x, U, 10, 'Procedure');
end;
x := Piece(x, U, 1) + U + FormatFMDateTime('mmm dd,yy', MakeFMDateTime(Piece(x, U, 2))) + ' ' + U + '(' + Piece(x, U, 3) + ')' + U + Piece(x, U, 6) + Piece(x, U, 7) + U +
'Consult #: ' + Piece(x, U, 1) + U + Piece(x, U, 8) + U + U + U + Piece(x, U, 10) + U + Piece(x, U, 4)+ U +
Piece(x, U, 2) + U + Piece(x, U, 9);
Result := x;
end;
function MakeConsultListDisplayText(InputString: string): string;
var
x: string;
begin
x := InputString;
x := Piece(x, U, 2) + ' ' + Piece(x, U, 3) + ' ' + Piece(x, U, 4) + ' ' + Piece(x, U, 5);
Result := x;
end;
function MakeConsultNoteDisplayText(RawText: string): string;
var
x: string;
begin
x := RawText;
if Piece(x, U, 1)[1] in ['A', 'N', 'E'] then
x := Piece(x, U, 2)
else
begin
x := FormatFMDateTime('mmm dd,yy', MakeFMDateTime(Piece(x, U, 3))) + ' ' + Piece(x, U, 2) +
' (#' + Piece(Piece(x, U, 1), ';', 1) + ')';
if not (Copy(Piece(Piece(RawText, U, 1), ';', 2), 1, 4) = 'MCAR') then
x := x + ', ' + Piece(RawText, U, 6) + ', ' + Piece(Piece(RawText, U, 5), ';', 2);
end;
Result := x;
end;
procedure BuildServiceTree(Tree: TORTreeView; SvcList: TStrings; const Parent: string; Node: TORTreeNode);
var
MyID, MyParent, Name, temp: string;
i: Integer;
ChildNode, tmpNode: TORTreeNode;
HasChildren: Boolean;
begin
Tree.Items.BeginUpdate;
with SvcList do for i := 0 to Count - 1 do
begin
if Piece(Strings[i], U, 5) = 'S' then Continue; // V19.4 {rv}
//if Piece(Strings[i], U, 6) = 'S' then Continue;
MyParent := Piece(Strings[i], U, 3);
if (MyParent = Parent) then
begin
MyID := Piece(Strings[i], U, 1);
Name := Piece(Strings[i], U, 2);
temp := Strings[i];
tmpNode := nil;
HasChildren := Piece(Strings[i], U, 4) = '+';
if Node <> nil then if Node.HasChildren then
tmpNode := Tree.FindPieceNode(MyID, 1, U, Node);
if (tmpNode <> nil) and tmpNode.HasAsParent(Node) then
Continue
else
begin
ChildNode := TORTreeNode(Tree.Items.AddChild(Node, Name));
ChildNode.StringData := temp;
if HasChildren then BuildServiceTree(Tree, SvcList, MyID, ChildNode);
end;
end;
end;
Tree.Items.EndUpdate;
end;
procedure CreateListItemsForConsultTree(Dest, Source: TStrings; Context: integer; GroupBy: string;
Ascending: Boolean);
var
i: Integer;
x, x3, MyParent, MyService, MyStatus, MyType, StatusText: string;
AList, SrcList: TStringList;
begin
AList := TStringList.Create;
SrcList := TStringList.Create;
try
SrcList.Assign(Source);
with SrcList do
begin
if (Count = 1) and (Piece(Strings[0], U, 1) = '-1') then
begin
Dest.Insert(0, IntToStr(Context) + '^^^' + 'No Matching Consults Found' + '^^^^0^^^^');
Exit;
end;
for i := 0 to Count - 1 do
begin
x := Strings[i];
MyType := Piece(x, U, 9);
if Context = 0 then Context := CC_ALL;
SetPiece(x, U, 8, IntToStr(Context));
MyParent := Piece(x, U, 8);
MyService := Piece(x, U, 10);
MyStatus := Piece(x, U, 3);
if Length(Trim(MyService)) = 0 then
begin
MyService := '** No Service **';
SetPiece(x, U, 10, MyService);
end;
if Length(Trim(MyStatus)) = 0 then
begin
MyStatus := '** No Status **';
SetPiece(x, U, 3, MyStatus);
end;
if GroupBy <> '' then case GroupBy[1] of
'S': begin
SetPiece(x, U, 8, MyParent + MyStatus);
if MyStatus = '(a)' then StatusText := 'Active'
else if MyStatus = '(p)' then StatusText := 'Pending'
else if MyStatus = '(pr)' then StatusText := 'Partial Results'
else if MyStatus = '(s)' then StatusText := 'Scheduled'
else if MyStatus = '(x)' then StatusText := 'Cancelled'
else if MyStatus = '(dc)' then StatusText := 'Discontinued'
else if MyStatus = '(c)' then StatusText := 'Completed'
else StatusText := 'Other';
x3 := MyStatus + U + StatusText + U + IntToStr(Context);
if (AList.IndexOf(x3) = -1) then AList.Add(x3);
end;
'V': begin
SetPiece(x, U, 8, MyParent + MyService);
x3 := MyService + U + MixedCase(MyService) + U + IntToStr(Context);
if (AList.IndexOf(x3) = -1) then AList.Add(x3);
end;
'T': begin
SetPiece(x, U, 8, MyParent + MyType);
x3 := MyType + U + MixedCase(MyType) + U + IntToStr(Context);
if (AList.IndexOf(x3) = -1) then AList.Add(x3);
end;
end;
Dest.Add(x);
end; {for}
SortByPiece(TStringList(Dest), U, 11);
if not Ascending then InvertStringList(TStringList(Dest));
Dest.Insert(0, IntToStr(Context) + '^^^' + CC_TV_TEXT[Context] + '^^^+^0^^^^');
Alist.Sort;
InvertStringList(AList);
for i := 0 to AList.Count-1 do
Dest.Insert(0, IntToStr(Context) + Piece(AList[i], U, 1) + '^^^' + Piece(AList[i], U, 2) + '^^^+^' + Piece(AList[i], U, 3) + '^^^^');
end;
finally
AList.Free;
SrcList.Free;
end;
end;
procedure BuildConsultsTree(Tree: TORTreeView; tmpList: TStrings; const Parent: string; Node: TORTreeNode;
CurrentContext: TSelectContext);
var
MyID, MyParent, Name, temp: string;
i: Integer;
ChildNode, tmpNode: TORTreeNode;
HasChildren: Boolean;
begin
Tree.Items.BeginUpdate;
with tmpList do for i := 0 to Count - 1 do
begin
MyParent := Piece(Strings[i], U, 8);
if (MyParent = Parent) then
begin
MyID := Piece(Strings[i], U, 1);
Name := MakeConsultListDisplayText(Strings[i]);
temp := Strings[i];
tmpNode := nil;
HasChildren := Piece(Strings[i], U, 7) = '+';
if Node <> nil then if Node.HasChildren then
tmpNode := Tree.FindPieceNode(MyID, 1, U, Node);
if (tmpNode <> nil) and tmpNode.HasAsParent(Node) then
Continue
else
begin
ChildNode := TORTreeNode(Tree.Items.AddChild(Node, Name));
ChildNode.StringData := temp;
SetNodeImage(ChildNode, CurrentContext);
if HasChildren then
BuildConsultsTree(Tree, tmpList, MyID, ChildNode, CurrentContext);
end;
end;
end;
Tree.Items.EndUpdate;
end;
procedure SetNodeImage(Node: TORTreeNode; CurrentContext: TSelectContext);
begin
with Node do
begin
if Piece(Stringdata, U, 8) = '0' then
begin
ImageIndex := IMG_GMRC_TOP_LEVEL;
SelectedIndex := IMG_GMRC_TOP_LEVEL;
if (Piece(StringData, U, 4) = 'No Matching Consults Found') then exit;
if Piece(Stringdata, U, 1) <> '-1' then
with CurrentContext, Node do
if GroupBy <> '' then case GroupBy[1] of
'V': Text := CC_TV_TEXT[StrToInt(Piece(Stringdata, U, 1))] + ' by Service';
'S': Text := CC_TV_TEXT[StrToInt(Piece(Stringdata, U, 1))] + ' by Status';
'T': Text := CC_TV_TEXT[StrToInt(Piece(Stringdata, U, 1))] + ' by Type';
end;
end
else
begin
if Piece(Stringdata, U, 7) <> '' then
case Piece(Stringdata, U, 7)[1] of
'+': begin
ImageIndex := IMG_GMRC_GROUP_SHUT;
SelectedIndex := IMG_GMRC_GROUP_OPEN;
end;
end
else
begin
if Piece(StringData, U, 12) <> '' then
case Piece(StringData, U, 12)[1] of
'C': ImageIndex := IMG_GMRC_CONSULT;
'P': ImageIndex := IMG_GMRC_ALL_PROC; //IMG_GMRC_PROC;
'M': ImageIndex := IMG_GMRC_ALL_PROC; //IMG_GMRC_CLINPROC;
'I': ImageIndex := IMG_GMRC_IFC_CONSULT;
'R': ImageIndex := IMG_GMRC_IFC_PROC;
end
else
begin
if Piece(StringData, U, 9) = 'Procedure' then
ImageIndex := IMG_GMRC_ALL_PROC
else
ImageIndex := IMG_GMRC_CONSULT;
end;
SelectedIndex := ImageIndex;
end;
end;
StateIndex := IMG_NONE;
end;
end;
end.

BIN
CPRS-Chart/Copy of fPtSelOptns.ddp Normal file
View File

Binary file not shown.

106
CPRS-Chart/Encounter/fDiagnoses.dfm Normal file
View File

@ -0,0 +1,106 @@
inherited frmDiagnoses: TfrmDiagnoses
Left = 304
Top = 169
Caption = 'Encounter Diagnoses'
PixelsPerInch = 96
TextHeight = 13
object lblAdd2PL: TLabel [0]
Left = 555
Top = 255
Width = 53
Height = 26
Caption = 'Add to Problem list'
WordWrap = True
end
inherited lblSection: TLabel
Width = 89
Caption = 'Diagnoses Section'
end
inherited btnOK: TBitBtn
TabOrder = 7
end
inherited btnCancel: TBitBtn
TabOrder = 8
end
inherited pnlGrid: TPanel
Width = 523
TabOrder = 1
inherited lbGrid: TORListBox
Tag = 20
Width = 523
Pieces = '1,2,3'
end
inherited hcGrid: THeaderControl
Width = 523
Sections = <
item
ImageIndex = -1
MinWidth = 60
Text = 'Add to PL'
Width = 60
end
item
ImageIndex = -1
MinWidth = 65
Text = 'Primary'
Width = 65
end
item
ImageIndex = -1
MinWidth = 110
Text = 'Selected Diagnoses'
Width = 110
end>
end
end
inherited edtComment: TCaptionEdit
TabOrder = 3
end
inherited btnRemove: TButton
TabOrder = 6
end
inherited btnSelectAll: TButton
Left = 454
TabOrder = 2
TabStop = True
end
inherited pnlMain: TPanel
TabOrder = 0
inherited lbxSection: TORListBox
Tag = 20
Height = 196
IntegralHeight = True
Pieces = '2,3,4,5'
end
inherited pnlLeft: TPanel
inherited lbSection: TORListBox
Tag = 20
TabOrder = 0
end
inherited btnOther: TButton
Tag = 12
Caption = 'Other Diagnosis...'
TabOrder = 1
end
end
end
object cmdDiagPrimary: TButton
Left = 536
Top = 306
Width = 75
Height = 21
Caption = 'Primary'
Enabled = False
TabOrder = 5
OnClick = cmdDiagPrimaryClick
end
object ckbDiagProb: TCheckBox
Left = 536
Top = 262
Width = 13
Height = 13
Caption = 'Add to Problem list'
TabOrder = 4
OnClick = ckbDiagProbClicked
end
end

259
CPRS-Chart/Encounter/fDiagnoses.pas Normal file
View File

@ -0,0 +1,259 @@
unit fDiagnoses;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
fPCEBase, StdCtrls, CheckLst, ORCtrls, ORNet, ExtCtrls, Buttons, uPCE, rPCE, ORFn,
ComCtrls, fPCEBaseMain, UBAGlobals, UBAConst, UCore;
type
TfrmDiagnoses = class(TfrmPCEBaseMain)
cmdDiagPrimary: TButton;
ckbDiagProb: TCheckBox;
lblAdd2PL: TLabel;
procedure cmdDiagPrimaryClick(Sender: TObject);
procedure ckbDiagProbClicked(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure btnRemoveClick(Sender: TObject);
procedure FormResize(Sender: TObject); override;
procedure lbxSectionClickCheck(Sender: TObject; Index: Integer);
procedure btnOKClick(Sender: TObject); override;
procedure lbSectionClick(Sender: TObject);
procedure GetEncounterDiagnoses;
procedure lbSectionDrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
private
procedure EnsurePrimaryDiag;
protected
procedure UpdateNewItemStr(var x: string); override;
procedure UpdateControls; override;
public
end;
const
TX_INACTIVE_CODE = 'The "#" character next to the code for this problem indicates that the problem' + #13#10 +
'references an ICD code that is not active as of the date of this encounter.' + #13#10 +
'Before you can select this problem, you must update the ICD code it contains' + #13#10 +
'via the Problems tab.';
TC_INACTIVE_CODE = 'Problem Contains Inactive Code';
var
frmDiagnoses: TfrmDiagnoses;
dxList : TStringList;
implementation
{$R *.DFM}
uses
fEncounterFrame, uConst, UBACore;
procedure TfrmDiagnoses.EnsurePrimaryDiag;
var
i: Integer;
Primary: Boolean;
begin
with lbGrid do
begin
Primary := False;
for i := 0 to Items.Count - 1 do
if TPCEDiag(Items.Objects[i]).Primary then
Primary := True;
if not Primary and (Items.Count > 0) then
begin
GridIndex := 0;
TPCEDiag(Items.Objects[0]).Primary := True;
GridChanged;
end;
end;
end;
procedure TfrmDiagnoses.cmdDiagPrimaryClick(Sender: TObject);
var
gi, i: Integer;
ADiagnosis: TPCEDiag;
begin
inherited;
gi := GridIndex;
with lbGrid do for i := 0 to Items.Count - 1 do
begin
ADiagnosis := TPCEDiag(Items.Objects[i]);
ADiagnosis.Primary := (gi = i);
end;
GridChanged;
end;
procedure TfrmDiagnoses.ckbDiagProbClicked(Sender: TObject);
var
i: integer;
const
PL_ITEMS = 'Problem List Items';
begin
inherited;
if(NotUpdating) then
begin
for i := 0 to lbGrid.Items.Count-1 do
if(lbGrid.Selected[i]) then
TPCEDiag(lbGrid.Items.Objects[i]).AddProb := (ckbDiagProb.Checked) and
(TPCEDiag(lbGrid.Items.Objects[i]).Category <> PL_ITEMS);
GridChanged;
end;
end;
procedure TfrmDiagnoses.FormCreate(Sender: TObject);
begin
inherited;
FTabName := CT_DiagNm;
FPCEListCodesProc := ListDiagnosisCodes;
FPCEItemClass := TPCEDiag;
FPCECode := 'POV';
FSectionTabCount := 3;
FormResize(Self);
end;
procedure TfrmDiagnoses.btnRemoveClick(Sender: TObject);
begin
inherited;
EnsurePrimaryDiag;
end;
procedure TfrmDiagnoses.UpdateNewItemStr(var x: string);
begin
inherited;
if lbGrid.Items.Count = 0 then
x := x + U + '1'
else
x := x + U + '0';
end;
procedure TfrmDiagnoses.UpdateControls;
var
i, j, k, PLItemCount: integer;
OK: boolean;
const
PL_ITEMS = 'Problem List Items';
begin
inherited;
if(NotUpdating) then
begin
BeginUpdate;
try
cmdDiagPrimary.Enabled := (lbGrid.SelCount = 1);
OK := (lbGrid.SelCount > 0);
PLItemCount := 0;
if OK then
for k := 0 to lbGrid.Items.Count - 1 do
if (lbGrid.Selected[k]) and (TPCEDiag(lbGrid.Items.Objects[k]).Category = PL_ITEMS) then
PLItemCount := PLItemCount + 1;
OK := OK and (PLItemCount < lbGrid.SelCount);
lblAdd2PL.Enabled := OK;
ckbDiagProb.Enabled := OK;
if(OK) then
begin
j := 0;
for i := 0 to lbGrid.Items.Count-1 do
begin
if(lbGrid.Selected[i]) and (TPCEDiag(lbGrid.Items.Objects[i]).AddProb) then
inc(j);
end;
if(j = 0) then
ckbDiagProb.Checked := FALSE
else
if(j < lbGrid.SelCount) then
ckbDiagProb.State := cbGrayed
else
ckbDiagProb.Checked := TRUE;
end
else
ckbDiagProb.Checked := FALSE;
finally
EndUpdate;
end;
end;
end;
procedure TfrmDiagnoses.FormResize(Sender: TObject);
begin
inherited;
FSectionTabs[0] := -(lbxSection.width - LBCheckWidthSpace - (8*MainFontWidth) - ScrollBarWidth);
FSectionTabs[1] := -FSectionTabs[0]+2;
FSectionTabs[2] := -FSectionTabs[0]+4;
UpdateTabPos;
end;
procedure TfrmDiagnoses.lbxSectionClickCheck(Sender: TObject;
Index: Integer);
begin
if not FUpdatingGrid then
if (lbxSection.Checked[Index]) and (Piece(lbxSection.Items[Index], U, 5) = '#') then
begin
InfoBox(TX_INACTIVE_CODE, TC_INACTIVE_CODE, MB_ICONWARNING or MB_OK);
lbxSection.Checked[Index] := False;
exit;
end;
inherited;
EnsurePrimaryDiag;
end;
procedure TfrmDiagnoses.btnOKClick(Sender: TObject);
begin
inherited;
if BILLING_AWARE then
GetEncounterDiagnoses;
end;
procedure TfrmDiagnoses.lbSectionClick(Sender: TObject);
begin
inherited;
//
end;
procedure TfrmDiagnoses.GetEncounterDiagnoses;
var
i: integer;
dxCode, dxName: string;
ADiagnosis: TPCEItem;
begin
inherited;
UBAGlobals.BAPCEDiagList.Clear;
with lbGrid do for i := 0 to Items.Count - 1 do
begin
ADiagnosis := TPCEDiag(Items.Objects[i]);
dxCode := ADiagnosis.Code;
dxName := ADiagnosis.Narrative;
if BAPCEDiagList.Count = 0 then
UBAGlobals.BAPCEDiagList.Add(U + DX_ENCOUNTER_LIST_TXT);
UBAGlobals.BAPCEDiagList.Add(dxCode + U + dxName);
end;
end;
procedure TfrmDiagnoses.lbSectionDrawItem(Control: TWinControl;
Index: Integer; Rect: TRect; State: TOwnerDrawState);
begin
inherited;
if (control as TListbox).items[index] = DX_PROBLEM_LIST_TXT then
(Control as TListBox).Canvas.Font.Style := [fsBold]
else
if (control as Tlistbox).items[index] = DX_PERSONAL_LIST_TXT then
(Control as TListBox).Canvas.Font.Style := [fsBold]
else
if (control as Tlistbox).items[index] = DX_TODAYS_DX_LIST_TXT then
(Control as TListBox).Canvas.Font.Style := [fsBold]
else
if (control as Tlistbox).items[index] = DX_ENCOUNTER_LIST_TXT then
(Control as TListBox).Canvas.Font.Style := [fsBold]
else
(Control as TListBox).Canvas.Font.Style := [];
(Control as TListBox).Canvas.TextOut(Rect.Left+2, Rect.Top+1, (Control as
TListBox).Items[Index]); {display the text }
end;
end.

454
CPRS-Chart/Encounter/fEncVitals.dfm Normal file
View File

@ -0,0 +1,454 @@
inherited frmEncVitals: TfrmEncVitals
Left = 353
Top = 210
Caption = 'Vitals'
KeyPreview = True
OnActivate = FormActivate
OnDestroy = FormDestroy
OnKeyDown = FormKeyDown
OnResize = FormResize
PixelsPerInch = 96
TextHeight = 13
object lvVitals: TCaptionListView [0]
Left = 0
Top = 0
Width = 624
Height = 368
Hint = 'To sort, click on column headers|'
Align = alClient
Columns = <>
Constraints.MinHeight = 50
HideSelection = False
MultiSelect = True
ReadOnly = True
RowSelect = True
ParentShowHint = False
ShowHint = True
TabOrder = 1
ViewStyle = vsReport
end
object pnlBottom: TPanel [1]
Left = 0
Top = 368
Width = 624
Height = 32
Align = alBottom
BevelOuter = bvNone
TabOrder = 5
end
inherited btnOK: TBitBtn
Left = 444
Top = 377
TabOrder = 3
end
inherited btnCancel: TBitBtn
Left = 524
Top = 377
TabOrder = 4
end
object pnlmain: TPanel
Left = 28
Top = 24
Width = 569
Height = 217
TabOrder = 0
Visible = False
object lblVitPointer: TOROffsetLabel
Left = 506
Top = 48
Width = 17
Height = 15
Caption = '<--'
Color = clBtnFace
HorzOffset = 5
ParentColor = False
Transparent = False
VertOffset = 2
WordWrap = False
end
object lblDate: TStaticText
Left = 56
Top = 23
Width = 31
Height = 17
Caption = 'Date'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = [fsBold]
ParentFont = False
TabOrder = 1
end
object lblDateBP: TStaticText
Tag = 3
Left = 50
Top = 122
Width = 24
Height = 17
Caption = 'N/A'
TabOrder = 17
end
object lblDateTemp: TStaticText
Left = 50
Top = 52
Width = 24
Height = 17
Caption = 'N/A'
TabOrder = 4
end
object lblDateResp: TStaticText
Tag = 2
Left = 50
Top = 98
Width = 24
Height = 17
Caption = 'N/A'
TabOrder = 13
end
object lblDatePulse: TStaticText
Tag = 1
Left = 50
Top = 75
Width = 24
Height = 17
Caption = 'N/A'
TabOrder = 9
end
object lblDateHeight: TStaticText
Tag = 4
Left = 50
Top = 145
Width = 24
Height = 17
Caption = 'N/A'
TabOrder = 21
end
object lblDateWeight: TStaticText
Tag = 5
Left = 50
Top = 169
Width = 24
Height = 17
Caption = 'N/A'
TabOrder = 26
end
object lblLstMeas: TStaticText
Left = 180
Top = 23
Width = 80
Height = 17
Caption = 'Last Measure'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = [fsBold]
ParentFont = False
TabOrder = 2
end
object lbllastBP: TStaticText
Tag = 3
Left = 188
Top = 122
Width = 24
Height = 17
Caption = 'N/A'
TabOrder = 18
end
object lblLastTemp: TStaticText
Left = 188
Top = 52
Width = 24
Height = 17
Caption = 'N/A'
TabOrder = 5
end
object lblLastResp: TStaticText
Tag = 2
Left = 188
Top = 98
Width = 24
Height = 17
Caption = 'N/A'
TabOrder = 14
end
object lblLastPulse: TStaticText
Tag = 1
Left = 188
Top = 75
Width = 24
Height = 17
Caption = 'N/A'
TabOrder = 10
end
object lblLastHeight: TStaticText
Tag = 4
Left = 188
Top = 145
Width = 24
Height = 17
Caption = 'N/A'
TabOrder = 22
end
object lblLastWeight: TStaticText
Tag = 5
Left = 188
Top = 169
Width = 24
Height = 17
Caption = 'N/A'
TabOrder = 27
end
object lblVital: TStaticText
Left = 344
Top = 23
Width = 29
Height = 17
Caption = 'Vital'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = [fsBold]
ParentFont = False
TabOrder = 3
end
object lblVitBP: TStaticText
Left = 344
Top = 122
Width = 23
Height = 17
Caption = 'B/P'
TabOrder = 19
end
object lnlVitTemp: TStaticText
Left = 344
Top = 52
Width = 31
Height = 17
Caption = 'Temp'
TabOrder = 6
end
object lblVitResp: TStaticText
Left = 344
Top = 98
Width = 29
Height = 17
Caption = 'Resp'
TabOrder = 15
end
object lblVitPulse: TStaticText
Left = 344
Top = 75
Width = 30
Height = 17
Caption = 'Pulse'
TabOrder = 11
end
object lblVitHeight: TStaticText
Left = 344
Top = 145
Width = 35
Height = 17
Caption = 'Height'
TabOrder = 23
end
object lblVitWeight: TStaticText
Left = 344
Top = 169
Width = 38
Height = 17
Caption = 'Weight'
TabOrder = 28
end
object lblVitPain: TStaticText
Left = 344
Top = 193
Width = 55
Height = 17
Caption = 'Pain Scale'
TabOrder = 33
end
object lblLastPain: TStaticText
Tag = 5
Left = 188
Top = 193
Width = 24
Height = 17
Caption = 'N/A'
TabOrder = 32
end
object lblDatePain: TStaticText
Tag = 5
Left = 50
Top = 193
Width = 24
Height = 17
Caption = 'N/A'
TabOrder = 31
end
object txtMeasBP: TCaptionEdit
Tag = 1
Left = 406
Top = 119
Width = 100
Height = 21
TabOrder = 20
OnEnter = SetVitPointer
OnExit = txtMeasBPExit
Caption = 'Blood Pressure'
end
object cboTemp: TCaptionComboBox
Tag = 7
Left = 448
Top = 48
Width = 57
Height = 21
DropDownCount = 2
ItemHeight = 13
TabOrder = 8
OnChange = cboTempChange
OnEnter = SetVitPointer
OnExit = cboTempExit
Items.Strings = (
'F'
'C')
Caption = 'Temperature'
end
object txtMeasTemp: TCaptionEdit
Tag = 2
Left = 406
Top = 48
Width = 43
Height = 21
TabOrder = 7
OnEnter = SetVitPointer
OnExit = txtMeasTempExit
Caption = 'Temperature'
end
object txtMeasResp: TCaptionEdit
Tag = 3
Left = 406
Top = 95
Width = 100
Height = 21
TabOrder = 16
OnEnter = SetVitPointer
OnExit = txtMeasRespExit
Caption = 'Resp'
end
object cboHeight: TCaptionComboBox
Tag = 8
Left = 449
Top = 142
Width = 57
Height = 21
ItemHeight = 13
TabOrder = 25
OnChange = cboHeightChange
OnEnter = SetVitPointer
OnExit = cboHeightExit
Items.Strings = (
'IN'
'CM')
Caption = 'Height'
end
object txtMeasWt: TCaptionEdit
Tag = 6
Left = 406
Top = 166
Width = 43
Height = 21
TabOrder = 29
OnEnter = SetVitPointer
OnExit = txtMeasWtExit
Caption = 'Weight'
end
object cboWeight: TCaptionComboBox
Tag = 9
Left = 449
Top = 166
Width = 57
Height = 21
ItemHeight = 13
TabOrder = 30
OnChange = cboWeightChange
OnEnter = SetVitPointer
OnExit = cboWeightExit
Items.Strings = (
'LB'
'KG')
Caption = 'Weight'
end
object txtMeasDate: TORDateBox
Tag = 11
Left = 406
Top = 16
Width = 121
Height = 21
TabOrder = 0
OnEnter = SetVitPointer
DateOnly = False
RequireTime = False
Caption = 'Current Vital Date '
end
object cboPain: TORComboBox
Tag = 10
Left = 406
Top = 190
Width = 102
Height = 21
Style = orcsDropDown
AutoSelect = True
Caption = 'Pain Scale'
Color = clWindow
DropDownCount = 12
ItemHeight = 13
ItemTipColor = clWindow
ItemTipEnable = True
ListItemsOnly = True
LongList = False
LookupPiece = 0
MaxLength = 0
Pieces = '1,2'
Sorted = False
SynonymChars = '<>'
TabOrder = 34
TabStop = True
OnEnter = SetVitPointer
CharsNeedMatch = 1
end
object txtMeasPulse: TCaptionEdit
Tag = 4
Left = 406
Top = 72
Width = 100
Height = 21
TabOrder = 12
OnEnter = SetVitPointer
OnExit = txtMeasPulseExit
Caption = 'Pulse'
end
object txtMeasHt: TCaptionEdit
Tag = 5
Left = 406
Top = 142
Width = 43
Height = 21
TabOrder = 24
OnEnter = SetVitPointer
OnExit = txtMeasHtExit
Caption = 'Height'
end
end
object btnEnterVitals: TButton
Left = 8
Top = 377
Width = 75
Height = 21
Caption = 'Enter Vitals'
TabOrder = 2
OnClick = btnEnterVitalsClick
end
end

666
CPRS-Chart/Encounter/fEncVitals.pas Normal file
View File

@ -0,0 +1,666 @@
unit fEncVitals;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
fPCEBase, ORDtTm, StdCtrls, ORCtrls, ExtCtrls, Buttons, fAutoSz, ORFn,
rvitals, ComCtrls, ORNet, uVitals
, TRPCB // Vitals Lite 2004-05-21 ===========================================
;
{== Vitals Lite 2004-05-21 ===================================================}
type
TGMV_GetInputPanel = function(
var anApp: TApplication;
aB: TRPCBroker;
aP, // Patient DFN
aL, // Hospitals IEN
aSig, // Application signature
aTemplate // Vitals Input template
: String;
aNow // Input Date/Time
:TDateTime):TCustomForm;
{== Vitals Lite 2004-05-21 ===================================================}
type
TfrmEncVitals = class(TfrmPCEBase)
pnlmain: TPanel;
lblDate: TStaticText;
lblDateBP: TStaticText;
lblDateTemp: TStaticText;
lblDateResp: TStaticText;
lblDatePulse: TStaticText;
lblDateHeight: TStaticText;
lblDateWeight: TStaticText;
lblLstMeas: TStaticText;
lbllastBP: TStaticText;
lblLastTemp: TStaticText;
lblLastResp: TStaticText;
lblLastPulse: TStaticText;
lblLastHeight: TStaticText;
lblLastWeight: TStaticText;
lblVitPointer: TOROffsetLabel;
lblVital: TStaticText;
lblVitBP: TStaticText;
lnlVitTemp: TStaticText;
lblVitResp: TStaticText;
lblVitPulse: TStaticText;
lblVitHeight: TStaticText;
lblVitWeight: TStaticText;
txtMeasBP: TCaptionEdit;
cboTemp: TCaptionComboBox;
txtMeasTemp: TCaptionEdit;
txtMeasResp: TCaptionEdit;
cboHeight: TCaptionComboBox;
txtMeasWt: TCaptionEdit;
cboWeight: TCaptionComboBox;
txtMeasDate: TORDateBox;
lblVitPain: TStaticText;
lblLastPain: TStaticText;
lblDatePain: TStaticText;
cboPain: TORComboBox;
txtMeasPulse: TCaptionEdit;
txtMeasHt: TCaptionEdit;
pnlBottom: TPanel;
btnEnterVitals: TButton;
lvVitals: TCaptionListView;
procedure SetVitPointer(Sender: TObject);
procedure txtMeasBPExit(Sender: TObject);
procedure cboTempChange(Sender: TObject);
procedure cboTempExit(Sender: TObject);
procedure txtMeasRespExit(Sender: TObject);
procedure txtMeasPulseExit(Sender: TObject);
procedure cboHeightChange(Sender: TObject);
procedure cboHeightExit(Sender: TObject);
procedure cboWeightChange(Sender: TObject);
procedure cboWeightExit(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure lbllastClick(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure FormActivate(Sender: TObject);
function HasData: Boolean;
function AssignVitals: boolean;
procedure cboPainChange(Sender: TObject);
procedure FormResize(Sender: TObject);
procedure txtMeasTempExit(Sender: TObject);
procedure txtMeasHtExit(Sender: TObject);
procedure txtMeasWtExit(Sender: TObject);
procedure FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure btnEnterVitalsClick(Sender: TObject); //vitals lite
private
FDataLoaded: boolean;
FChangingFocus: boolean;
UvitalNew: TStringList;
uVitalOld: TSTringList;
procedure InitVitalPanel;
procedure PopulateLastVital;
function GetVitHTRate: String;
procedure CheckVitalUnit;
procedure ChangeFocus(Control: TWinControl);
procedure ClearData;
procedure LoadVitalView(VitalsList : TStringList); //Vitals Lite
procedure LoadVitalsList;
public
function OK2SaveVitals: boolean;
property VitalNew: TStringList read uVitalNew;
property VitalOld: TStringList read uVitalOld;
end;
var
frmEncVitals: TfrmEncVitals;
// uVitalLocation: Real;
implementation
{$R *.DFM}
uses UCore, rCore, rPCE, fPCELex, fPCEOther, fVitals,fVisit, fFrame, fEncnt,
fEncounterFrame, uInit
// , fGMV_InputTemp // Vitals Lite 2004-05-21
;
const
TX_VDATE_REQ1 = 'Entered vitals information can not be saved without a Date.' + CRLF +
'Do you wish to use the encounter date of ';
TX_VDATE_REQ2 = '?';
TC_VDATE_REQ = 'Missing Vitals Entry Date';
TX_KILLDATA = 'Discard entered vitals information?';
var
UcboVitChanging: Boolean = False;
function TfrmEncVitals.HasData: Boolean;
begin
result := False;
if ((txtMeasBP.text <> '') or (txtMeasTemp.text <> '') or (txtMeasResp.text <> '') or
(txtMeasPulse.text <> '') or (txtMeasHt.text <> '') or (txtMeasWt.text <> '')) or
(cboPain.text <>'') then
result := True;
end;
procedure TfrmEncVitals.InitVitalPanel;
begin
lblDate.font.Style := [fsBold];
lblDateBP.font.Style := [fsBold];
lblDateTemp.font.Style := [fsBold];
lblDateResp.font.Style := [fsBold];
lblDatePulse.font.Style := [fsBold];
lblDateHeight.font.Style := [fsBold];
lblDateWeight.font.Style := [fsBold];
lblDatePain.font.style := [fsBold];
lblLstMeas.font.Style := [fsBold];
lblLastBP.font.Style := [fsBold];
lblLastTemp.font.Style := [fsBold];
lblLastResp.font.Style := [fsBold];
lblLastPulse.font.Style := [fsBold];
lblLastHeight.font.Style := [fsBold];
lblLastWeight.font.Style := [fsBold];
lblLastPain.font.style := [fsBold];
lblVital.font.Style := [fsbold];
{Use this area to read parameter for units and set apropriately
after parameter is defined. in next version
}
UcboVitchanging := true; //prevents entering code in CheckVitalUnit
try
InitPainCombo(cboPain);
cboTemp.Text := cboTemp.Items[0];
cboHeight.Text := cboHeight.Items[0];
cboWeight.Text := cboWeight.Items[0];
finally
UcboVitchanging := False; //prevents entering code in CheckVitalUnit
end;
if txtMeasDate.Text = '' then
txtMeasDate.Text := FormatFMDateTime('mmm dd,yy@hh:nn', uEncPCEData.VisitDateTime);
if (UvitalOld.text = '') then
PopulateLastVital;
end;
procedure TfrmEncVitals.PopulateLastVital;
var
i: integer;
begin
GetLastVital(uVitalOld,Patient.DFN);
//populate labels from UVitalOld;
with UVitalOld do
for i := 0 to count-1 do
begin
if piece(strings[i],U,2) = 'T' then
begin
lblLastTemp.Caption := ConvertVitalData(piece(strings[i],U,3), vtTemp);
lblDateTemp.Caption := FormatFMDateTime('mmm dd,yy',
StrToFloat(piece(strings[i],U,4)));
end;
if piece(strings[i],U,2) = 'P' then
begin
lblLastPulse.Caption := piece(strings[i],U,3);
lblDatePulse.Caption := FormatFMDateTime('mmm dd,yy',
StrToFloat(piece(strings[i],U,4)));
end;
if piece(strings[i],U,2) = 'R' then
begin
lblLastResp.Caption := piece(strings[i],U,3);
lblDateResp.Caption := FormatFMDateTime('mmm dd,yy',
StrToFloat(piece(strings[i],U,4)));
end;
if piece(strings[i],U,2) = 'BP' then
begin
lblLastBP.Caption := piece(strings[i],U,3);
lblDateBP.Caption := FormatFMDateTime('mmm dd,yy',
StrToFloat(piece(strings[i],U,4)));
end;
if piece(strings[i],U,2) = 'HT' then
begin
lblLastHeight.Caption := ConvertVitalData(piece(strings[i],U,3), vtHeight);
lblDateHeight.Caption := FormatFMDateTime('mmm dd,yy',
StrToFloat(piece(strings[i],U,4)));
end;
if piece(strings[i],U,2) = 'WT' then
begin
lblLastWeight.Caption := ConvertVitalData(piece(strings[i],U,3), vtWeight);
lblDateWeight.Caption := FormatFMDateTime('mmm dd,yy',
StrToFloat(piece(strings[i],U,4)));
end;
if piece(strings[i],U,2) = 'PN' then
begin
lblLastPain.Caption := piece(strings[i],U,3);
lblDatePain.Caption := FormatFMDateTime('mmm dd,yy',
StrToFloat(piece(strings[i],U,4)));
end;
end;
end;
procedure TfrmEncVitals.SetVitPointer(Sender: TObject);
begin
if ActiveCtrl.tag in VitalTagSet then
begin
// move pointer to some height and five pixels to right of edit box.
lblVitPointer.Top := ActiveCtrl.Top+((ActiveCtrl.height ) div
(lblVitPointer.height ));
if ActiveCtrl = txtMeasTemp then
lblVitPointer.left := (cboTemp.left + cboTemp.Width)
else if ActiveCtrl = txtMeasHT then
lblVitPointer.left := (cboHeight.left + cboHeight.Width)
else if ActiveCtrl = txtMeasWT then
lblVitPointer.left := (cboWeight.left + cboWeight.Width)
else
lblVitPointer.left := (ActiveCtrl.left + ActiveCtrl.Width);
end;
end;
function TfrmEncVitals.GetVitHTRate: String;
begin
Result := ConvertHeight2Inches(txtMeasHT.Text);
txtMeasHT.text := result;
end;
function TfrmEncVitals.AssignVitals: boolean;
var
TmpDate: TFMDateTime;
begin
TmpDate := txtMeasDate.FMDateTime;
Result := ValidVitalsDate(TmpDate);
if Result then
AssignVitals2List(uVitalNew, TmpDate, FloatToStr(PCERPCEncLocation),
txtMeasBP.text, txtMeasTemp.text, cboTemp.text,
txtMeasResp.text, txtMeasPulse.text, GetVitHTRate, cboHeight.text,
txtMeasWT.text, cboWeight.text, cboPain.ItemID);
end;
procedure TfrmEncVitals.cboTempChange(Sender: TObject);
begin
inherited;
if not (cbotemp.droppeddown) then
CheckVitalUnit;
end;
procedure TfrmEncVitals.CheckVitalUnit;
var
len,i: integer;
found: boolean;
comp: string; //substring for comparing
temp: string;
begin
if (UcboVitchanging = true) then exit;
UcboVitChanging := true;
try
with ActiveCtrl as TComboBox do
begin
found := False;
temp := text;
while (found = false) and (Length(temp) > 0) do
begin
i := 0;
while (found = false) and (length(items[i]) > 0) do
begin
len := length(temp);
//match text to string
comp := copy(items[i],0,len);
if (CompareText(comp,temp) = 0) then
begin
found := true;
Text := '';
text := items[i];
end;
inc(i);
end;
if (found = false) then Delete(temp,1,1);
end;
if (found = False) then
begin
Text := '';
end;
end;
finally
UcboVitChanging := false;
end;
end;
procedure TfrmEncVitals.cboHeightChange(Sender: TObject);
begin
inherited;
CheckVitalUnit;
end;
procedure TfrmEncVitals.cboWeightChange(Sender: TObject);
begin
inherited;
CheckVitalUnit;
end;
procedure TfrmEncVitals.txtMeasBPExit(Sender: TObject);
begin
inherited;
if VitalInvalid(txtMeasBP) then
ChangeFocus(txtMeasBP);
end;
procedure TfrmEncVitals.cboTempExit(Sender: TObject);
begin
inherited;
if(ActiveCtrl <> txtMeasTemp) then
begin
if VitalInvalid(txtMeasTemp, cboTemp) then
ChangeFocus(txtMeasTemp);
end;
end;
procedure TfrmEncVitals.txtMeasRespExit(Sender: TObject);
begin
inherited;
if VitalInvalid(txtMeasResp) then
ChangeFocus(txtMeasResp);
end;
procedure TfrmEncVitals.txtMeasPulseExit(Sender: TObject);
begin
inherited;
if VitalInvalid(txtMeasPulse) then
ChangeFocus(txtMeasPulse);
end;
procedure TfrmEncVitals.cboHeightExit(Sender: TObject);
begin
inherited;
if(ActiveCtrl <> txtMeasHt) then
begin
if VitalInvalid(txtMeasHt, cboHeight, GetVitHTRate) then
ChangeFocus(txtMeasHt);
end;
end;
procedure TfrmEncVitals.cboWeightExit(Sender: TObject);
begin
inherited;
if(ActiveCtrl <> txtMeasWt) then
begin
if VitalInvalid(txtMeasWt, cboWeight) then
ChangeFocus(txtMeasWt);
end;
end;
procedure TfrmEncVitals.FormCreate(Sender: TObject);
begin
inherited;
FTabName := CT_VitNm;
//uVisitType := TPCEProc.create;
uVitalOld := TStringList.create;
uVitalNew := TStringList.create;
end;
procedure TfrmEncVitals.FormDestroy(Sender: TObject);
begin
//uVisitType.Free;
uVitalOld.Free;
uVitalNew.free;
{== Vitals Lite 2004-05-21 ===================================================}
FreeLibrary(VitalsDLLHandle);
{== Vitals Lite 2004-05-21 ===================================================}
inherited;
end;
procedure TfrmEncVitals.lbllastClick(Sender: TObject);
begin
inherited;
//
try
frmEncVitals.Show;
except
with sender as TStaticText do
SelectVital(self.Font.Size, tag);
end; //end of try
end;
procedure TfrmEncVitals.FormShow(Sender: TObject);
var
GMV_LibName: String;
begin
inherited;
//Begin Vitals Lite
{Visit is Assumed to Be selected when Opening Encounter Dialog}
GMV_LibName :='GMV_VitalsViewEnter.dll';
GMV_LibName := GetProgramFilesPath + SHARE_DIR + GMV_LibName;
VitalsDLLHandle := LoadLibrary(PChar(GMV_LibName));
if VitalsDLLHandle = 0 then // No Handle found
MessageDLG('Can''t find library "'+GMV_LibName+'".',mtError,[mbok],0)
else
LoadVitalsList;
//End Vitals Lite
// frmEncVitals.caption := 'Vital entry for - '+ patient.name; {RAB 6/15/98}
FormActivate(Sender);
end;
procedure TfrmEncVitals.FormActivate(Sender: TObject);
begin
inherited;
if(not FChangingFocus) and (not FDataLoaded) then
begin
FDataLoaded := TRUE;
InitVitalPanel;
// txtMeasTemp.setfocus; //added 3/30/99 after changing tab order.
//The date is now first in tab order, but it shouldn't default there.
end;
end;
procedure TfrmEncVitals.cboPainChange(Sender: TObject);
begin
inherited;
CheckVitalUnit;
end;
procedure TfrmEncVitals.FormResize(Sender: TObject);
begin
inherited;
//added to make things austo size that do not heave the property.
cboTemp.height := txtmeastemp.height;
cboPain.height := txtmeastemp.height;
cboheight.height := txtmeastemp.height;
cboweight.height := txtmeastemp.height;
end;
procedure TfrmEncVitals.txtMeasTempExit(Sender: TObject);
begin
inherited;
if(ActiveCtrl <> cboTemp) then
begin
if VitalInvalid(txtMeasTemp, cboTemp) then
ChangeFocus(txtMeasTemp);
end;
end;
procedure TfrmEncVitals.txtMeasHtExit(Sender: TObject);
begin
inherited;
if(ActiveCtrl <> cboHeight) then
begin
if VitalInvalid(txtMeasHt, cboHeight, GetVitHTRate) then
ChangeFocus(txtMeasHt);
end;
end;
procedure TfrmEncVitals.txtMeasWtExit(Sender: TObject);
begin
inherited;
if(ActiveCtrl <> cboWeight) then
begin
if VitalInvalid(txtMeasWt, cboWeight) then
ChangeFocus(txtMeasWt);
end;
end;
procedure TfrmEncVitals.ChangeFocus(Control: TWinControl);
begin
FChangingFocus := TRUE;
try
Control.SetFocus;
finally
FChangingFocus := FALSE;
end;
end;
function TfrmEncVitals.OK2SaveVitals: boolean;
begin
Result := TRUE;
if(HasData and (abs(txtMeasDate.FMDateTime) <= 0.0000000000001)) then
begin
Result := (InfoBox(TX_VDATE_REQ1 + FormatFMDateTime('mmm dd,yy@hh:nn', uEncPCEData.DateTime) +
TX_VDATE_REQ2, TC_VDATE_REQ, MB_YESNO or MB_ICONWARNING) = IDYES);
if Result then
txtMeasDate.FMDateTime := uEncPCEData.DateTime
else
begin
Result := (InfoBox(TX_KILLDATA, TC_VDATE_REQ, MB_YESNO or MB_ICONWARNING) = IDYES);
if(Result) then
ClearData;
end;
end;
end;
procedure TfrmEncVitals.ClearData;
begin
txtMeasBP.text := '';
txtMeasTemp.text := '';
txtMeasResp.text := '';
txtMeasPulse.text := '';
txtMeasHt.text := '';
txtMeasWt.text := '';
cboPain.text := '';
end;
procedure TfrmEncVitals.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
{capture return key press if on the vital screen}
begin
inherited;
if (ActiveCtrl.tag in VitalDateTagSet)then
begin
if Key = VK_RETURN then
begin
Key := 0;
if (ActiveCtrl.Tag = TAG_VITPAIN) then
ChangeFocus(btnOK)
else
begin
GetParentForm(Self).Perform(WM_NEXTDLGCTL,0,0);
SetVitPointer(Sender);
end;
end;
end;
end;
end;
//Begin Vitals Lite
procedure TfrmEncVitals.LoadVitalView(VitalsList: TStringList);
var
i : integer;
curCol : TListColumn;
curItem : TListItem;
HeadingList,tmpList : TStringList;
begin
HeadingList := TStringList.Create;
tmpList := TStringList.Create;
lvVitals.ShowColumnHeaders := false; //CQ: 10069 - the column display becomes squished.
lvVitals.Items.Clear;
lvVitals.Columns.Clear;
PiecesToList(VitalsList[0],U,HeadingList);
for i := 0 to HeadingList.Count-1 do
begin
curCol := lvVitals.Columns.Add;
curCol.Caption := HeadingList[i];
curCol.AutoSize := true;
end;
for i := 1 to VitalsList.Count-1 do
begin
curItem := lvVitals.Items.Add;
PiecesToList(VitalsList[i],U,tmpList);
curItem.Caption := tmpList[0];
tmpList.Delete(0);
curItem.SubItems.Assign(tmpList);
end;
lvVitals.ShowColumnHeaders := true; //CQ: 10069 - the column display becomes squished.
HeadingList.Free;
tmpList.Free;
end;
procedure TfrmEncVitals.btnEnterVitalsClick(Sender: TObject);
var
VLPtVitals : TGMV_VitalsEnterDLG;
GMV_FName : String;
begin
inherited;
if VitalsDLLHandle = 0 then Exit;//The DLL was initialized on Create, but just in case....
GMV_FName := 'GMV_VitalsEnterDLG';
@VLPtVitals := GetProcAddress(VitalsDLLHandle,PChar(GMV_FName));
if assigned(VLPtVitals) then
begin
VLPtVitals(
RPCBrokerV,
Patient.DFN,
FloatToStr(uEncPCEData.Location),
GMV_DEFAULT_TEMPLATE,
GMV_APP_SIGNATURE,
FMDateTimeToDateTime(uEncPCEData.DateTime),
Patient.Name,
frmFrame.lblPtSSN.Caption + ' ' + frmFrame.lblPtAge.Caption
);
end
else
MessageDLG('Can not find function "'+GMV_FName+'".',mtError,[mbok],0);
@VLPtVitals := nil;
LoadVitalsList;
end;
procedure TfrmEncVitals.LoadVitalsList;
var
VitalsList : TStringList;
VLPtVitals : TGMV_LatestVitalsList;
GMV_FName : String;
begin
if VitalsDLLHandle = 0 then Exit;//The DLL was initialized on Create, but just in case....
GMV_FName := 'GMV_LatestVitalsList';
@VLPtVitals := GetProcAddress(VitalsDLLHandle,PChar(GMV_FName));
if assigned(VLPtVitals) then
begin
frmFrame.VitalsDLLActive := True; // need this flag for CCOW (RV)
VitalsList := VLPtVitals(RPCBrokerV,Patient.DFN,U,false);
if assigned(VitalsList) then
LoadVitalView(VitalsList);
end
else
MessageDLG('Can''t find function "'+GMV_FName+'".',mtError,[mbok],0);
@VLPtVitals := nil;
frmFrame.VitalsDLLActive := False; // need this flag for CCOW (RV)
end;
//End Vitals Lite
end.

67
CPRS-Chart/Encounter/fEncounterFrame.dfm Normal file
View File

@ -0,0 +1,67 @@
object frmEncounterFrame: TfrmEncounterFrame
Left = 290
Top = 108
Width = 640
Height = 451
Caption = 'Encounter Frame'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
FormStyle = fsMDIForm
KeyPreview = True
OldCreateOrder = True
Position = poScreenCenter
OnCanResize = FormCanResize
OnClose = FormClose
OnCloseQuery = FormCloseQuery
OnCreate = FormCreate
OnDestroy = FormDestroy
OnKeyDown = FormKeyDown
OnResize = FormResize
PixelsPerInch = 96
TextHeight = 13
object Bevel1: TBevel
Left = 0
Top = 0
Width = 632
Height = 2
Align = alTop
end
object StatusBar1: TStatusBar
Left = 0
Top = 417
Width = 632
Height = 0
Panels = <>
SimplePanel = False
end
object pnlPage: TPanel
Left = 0
Top = 24
Width = 632
Height = 393
Align = alClient
BevelOuter = bvNone
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
ParentFont = False
TabOrder = 1
end
object TabControl: TTabControl
Left = 0
Top = 2
Width = 632
Height = 22
Align = alTop
TabOrder = 2
OnChange = TabControlChange
OnChanging = TabControlChanging
OnExit = TabControlExit
end
end

838
CPRS-Chart/Encounter/fEncounterFrame.pas Normal file
View File

@ -0,0 +1,838 @@
unit fEncounterFrame;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Tabs, ComCtrls, ExtCtrls, Menus, StdCtrls, Buttons, fPCEBase,
fVisitType, fDiagnoses, fProcedure, fImmunization, fSkinTest, fPatientEd,
fHealthFactor, fExam, uPCE, rPCE, rTIU, ORCtrls, ORFn, fEncVitals,rvitals;
const
//tab names
CT_VisitNm = 'Visit Type';
CT_DiagNm = 'Diagnoses';
CT_ProcNm = 'Procedures';
CT_ImmNm = 'Immunizations';
CT_SkinNm = 'Skin Tests';
CT_PedNm = 'Patient Ed';
CT_HlthNm = 'Health Factors';
CT_XamNm = 'Exams';
CT_VitNm = 'Vitals';
CT_GAFNm = 'GAF';
//numbers assigned to tabs to make changes easier
//they must be sequential
CT_NOPAGE = -1;
CT_UNKNOWN = 0;
CT_VISITTYPE = 1; CT_FIRST = 1;
CT_DIAGNOSES = 2;
CT_PROCEDURES = 3;
CT_IMMUNIZATIONS = 4;
CT_SKINTESTS = 5;
CT_PATIENTED = 6;
CT_HEALTHFACTORS = 7;
CT_EXAMS = 8;
CT_VITALS = 9;
CT_GAF = 10; CT_LAST = 10;
NUM_TABS = 3;
TAG_VTYPE = 10;
TAG_DIAG = 20;
TAG_PROC = 30;
TAG_IMMUNIZ = 40;
TAG_SKIN = 50;
TAG_PED = 60;
TAG_HF = 70;
TAG_XAM = 80;
TAG_TRT = 90;
TX_NOSECTION = '-1^No sections found';
TX_PROV_REQ = 'A primary encounter provider must be selected before encounter data can' + CRLF +
'be saved. Select the Primary Encounter Provider on the VISIT TYPE tab.' + CRLF +
'Otherwise, press <Cancel> to quit without saving data.';
TC_PROV_REQ = 'Missing Primary Provider for Encounter';
type
TfrmEncounterFrame = class(TForm)
StatusBar1: TStatusBar;
pnlPage: TPanel;
Bevel1: TBevel;
TabControl: TTabControl;
procedure tabPageChange(Sender: TObject; NewTab: Integer;
var AllowChange: Boolean);
procedure FormResize(Sender: TObject);
procedure SectionClick(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
procedure TabControlChange(Sender: TObject);
procedure TabControlChanging(Sender: TObject;
var AllowChange: Boolean);
procedure TabControlExit(Sender: TObject);
procedure FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure FormCanResize(Sender: TObject; var NewWidth,
NewHeight: Integer; var Resize: Boolean);
private
FAutoSave: boolean;
FSaveNeeded: boolean;
FChangeSource: Integer;
FCancel: Boolean; //Indicates the cancel button has been pressed;
FAbort: boolean; // indicates that neither OK or Cancel has been pressed
FormList: TStringList; //Holds the types of any forms that will be used
//in the frame. They must be available at compile time
FLastPage: TfrmPCEBase;
procedure CreateChildForms(Sender: TObject; Location: integer);
procedure SynchPCEData;
procedure SwitchToPage(NewForm: TfrmPCEBase); //was tfrmPage
function PageIDToForm(PageID: Integer): TfrmPCEBase;
function PageIDToTab(PageID: Integer): string;
procedure LoadFormList(Location: integer);
procedure CreateForms;
procedure AddTabs;
function FormListContains(item: string): Boolean;
procedure SendData;
procedure UpdateEncounter(PCE: TPCEData);
procedure SetFormFonts;
public
procedure SelectTab(NewTabName: string);
property ChangeSource: Integer read FChangeSource;
property Forms: tstringlist read FormList;
property Cancel: Boolean read FCancel write FCancel;
property Abort: Boolean read FAbort write FAbort;
end;
var
frmEncounterFrame: TfrmEncounterFrame;
uSCCond: TSCConditions;
uVisitType: TPCEProc; // contains info for visit type page
uEncPCEData: TPCEData;
uProviders: TPCEProviderList;
// Returns true if PCE data still needs to be saved - vitals/gaf are always saved
function UpdatePCE(PCEData: TPCEData; SaveOnExit: boolean = TRUE): boolean;
implementation
uses
uCore,
fGAF, uConst,
rCore, fPCEProvider, rMisc;
{$R *.DFM}
{///////////////////////////////////////////////////////////////////////////////
//Name: function TfrmEncounterFrame.PageIDToTab(PageID: Integer): String;
//Created: Jan 1999
//By: Robert Bott
//Location: ISL
//Description: returns the tab index that corresponds to a given PageID .
///////////////////////////////////////////////////////////////////////////////}
function TfrmEncounterFrame.PageIDToTab(PageID: Integer): String;
begin
result := '';
case PageID of
CT_NOPAGE: Result := '';
CT_UNKNOWN: Result := '';
CT_VISITTYPE: Result := CT_VisitNm;
CT_DIAGNOSES: Result := CT_DiagNm;
CT_PROCEDURES: Result := CT_ProcNm;
CT_IMMUNIZATIONS: Result := CT_ImmNm;
CT_SKINTESTS: Result := CT_SkinNm;
CT_PATIENTED: Result := CT_PedNm;
CT_HEALTHFACTORS: Result := CT_HlthNm;
CT_EXAMS: Result := CT_XamNm;
CT_VITALS: Result := CT_VitNm;
CT_GAF: Result := CT_GAFNm;
end;
end;
{///////////////////////////////////////////////////////////////////////////////
//Name: function TfrmEncounterFrame.PageIDToForm(PageID: Integer): TfrmPCEBase;
//Created: Jan 1999
//By: Robert Bott
//Location: ISL
//Description: return the form name based on the PageID}
///////////////////////////////////////////////////////////////////////////////}
function TfrmEncounterFrame.PageIDToForm(PageID: Integer): TfrmPCEBase;
begin
case PageID of
CT_VISITTYPE: Result := frmVisitType;
CT_DIAGNOSES: Result := frmDiagnoses;
CT_PROCEDURES: Result := frmProcedures;
CT_IMMUNIZATIONS: Result := frmImmunizations;
CT_SKINTESTS: Result := frmSkinTests;
CT_PATIENTED: Result := frmPatientEd;
CT_HEALTHFACTORS: Result := frmHealthFactors;
CT_EXAMS: Result := frmExams;
CT_VITALS: Result := frmEncVitals;
CT_GAF: Result := frmGAF;
else //not a valid form
result := frmPCEBase;
end;
end;
{///////////////////////////////////////////////////////////////////////////////
//Name: procedure TfrmEncounterFrame.CreatChildForms(Sender: TObject);
//Created: Jan 1999
//By: Robert Bott
//Location: ISL
//Description: Finds out what pages to display, has the pages and tabs created.
///////////////////////////////////////////////////////////////////////////////}
procedure TfrmEncounterFrame.CreateChildForms(Sender: TObject; Location: integer);
begin
//load FormList with a list of all forms to display.
inherited;
LoadFormList(Location);
AddTabs;
CreateForms;
end;
{///////////////////////////////////////////////////////////////////////////////
//Name: TfrmEncounterFrame.LoadFormList;
//Created: Jan 1999
//By: Robert Bott
//Location: ISL
//Description: Loads Formlist with the forms to create, will be replaced by RPC call.
///////////////////////////////////////////////////////////////////////////////}
procedure TfrmEncounterFrame.LoadFormList(Location: integer);
begin
//change this to an RPC in RPCE.pas
FormList.clear;
FormList.add(CT_VisitNm);
FormList.add(CT_DiagNm);
FormList.add(CT_ProcNm);
formList.add(CT_VitNm);
formList.add(CT_ImmNm);
formList.add(CT_SkinNm);
formList.add(CT_PedNm);
formList.add(CT_HlthNm);
formList.add(CT_XamNm);
if MHClinic(Location) then
formList.add(CT_GAFNm);
end;
{///////////////////////////////////////////////////////////////////////////////
//Name: function TfrmEncounterFrame.FormListContains(item: string): Boolean;
//Created: 12/06/98
//By: Robert Bott
//Location: ISL
//Description: Returns a boolean value indicating if a given string exists in
// the formlist.
///////////////////////////////////////////////////////////////////////////////}
function TfrmEncounterFrame.FormListContains(item: string): Boolean;
begin
result := false;
if (FormList.IndexOf(item) <> -1 ) then
result := true;
end;
{///////////////////////////////////////////////////////////////////////////////
//Name: procedure TfrmEncounterFrame.CreateForms;
//Created: Jan 1999
//By: Robert Bott
//Location: ISL
//Description: Creates all of the forms in the list.
///////////////////////////////////////////////////////////////////////////////}
procedure TfrmEncounterFrame.CreateForms;
var
i: integer;
begin
//could this be placed in a loop using PagedIdToTab & PageIDToFOrm & ?
if FormListContains(CT_VisitNm) then
frmVisitType := TfrmVisitType.CreateLinked(pnlPage);
if FormListContains(CT_DiagNm) then
frmDiagnoses := TfrmDiagnoses.CreateLinked(pnlPage);
if FormListContains(CT_ProcNm) then
frmProcedures := TfrmProcedures.CreateLinked(pnlPage);
if FormListContains(CT_VitNm) then
frmEncVitals := TfrmEncVitals.CreateLinked(pnlPage);
if FormListContains(CT_ImmNm) then
frmImmunizations := TfrmImmunizations.CreateLinked(pnlPage);
if FormListContains(CT_SkinNm) then
frmSkinTests := TfrmSkinTests.CreateLinked(pnlPage);
if FormListContains(CT_PedNm) then
frmPatientEd := TfrmPatientEd.CreateLinked(pnlPage);
if FormListContains(CT_HlthNm) then
frmHealthFactors := TfrmHEalthFactors.CreateLinked(pnlPage);
if FormListContains(CT_XamNm) then
frmExams := TfrmExams.CreateLinked(pnlPage);
if FormListContains(CT_GAFNm) then
frmGAF := TfrmGAF.CreateLinked(pnlPage);
//must switch based on caption, as all tabs may not be present.
for i := CT_FIRST to CT_LAST do
begin
if Formlist.IndexOf(PageIdToTab(i)) <> -1 then
PageIDToForm(i).Visible := (Formlist.IndexOf(PageIdToTab(i)) = 0);
end;
end;
{///////////////////////////////////////////////////////////////////////////////
//Name: TfrmEncounterFrame.SwitchToPage(NewForm: tfrmPCEBase);
//Created: Jan 1999
//By: Robert Bott
//Location: ISL
//Description: Brings the selected page to the front for display.
///////////////////////////////////////////////////////////////////////////////}
procedure TfrmEncounterFrame.SwitchToPage(NewForm: tfrmPCEBase);// was TfrmPage);
{ unmerge/merge menus, bring page to top of z-order, call form-specific OnDisplay code }
begin
if (NewForm = nil) or (FLastPage = NewForm) then Exit;
if Assigned(FLastPage) then
FLastPage.Hide;
FLastPage := NewForm;
// KeyPreview := (NewForm = frmEncVitals);
NewForm.DisplayPage; // this calls BringToFront for the form
end;
{///////////////////////////////////////////////////////////////////////////////
//Name: procedure TfrmEncounterFrame.tabPageChange(Sender: TObject; NewTab: Integer; var AllowChange: Boolean);
//Created: Jan 1999
//By: Robert Bott
//Location: ISL
//Description: Finds the page, and calls SwithToPage to display it.
///////////////////////////////////////////////////////////////////////////////}
procedure TfrmEncounterFrame.tabPageChange(Sender: TObject; NewTab: Integer; var AllowChange: Boolean);
{ switches to form linked to NewTab }
var
i: integer;
begin
//must switch based on caption, as all tabs may not be present.
for i := CT_FIRST to CT_LAST do
begin
With Formlist do
if NewTab = IndexOf(PageIdToTab(i)) then
begin
PageIDToForm(i).show;
SwitchToPage(PageIDToForm(i));
end;
end;
end;
{ Resize and Font-Change procedures --------------------------------------------------------- }
{///////////////////////////////////////////////////////////////////////////////
//Name: procedure TfrmEncounterFrame.FormResize(Sender: TObject);
//Created: Jan 1999
//By: Robert Bott
//Location: ISL
//Description: Resizes all windows when parent changes.
///////////////////////////////////////////////////////////////////////////////}
procedure TfrmEncounterFrame.FormResize(Sender: TObject);
var
i: integer;
begin
for i := CT_FIRST to CT_LAST do
if (FormList.IndexOf(PageIdToTab(i)) <> -1) then
MoveWindow(PageIdToForm(i).Handle, 0, 0, pnlPage.ClientWidth, pnlpage.ClientHeight, true);
self.repaint;
end;
{///////////////////////////////////////////////////////////////////////////////
//Name: procedure TfrmEncounterFrame.AddTabs;
//Created: Jan 1999
//By: Robert Bott
//Location: ISL
//Description: adds a tab for each page that will be displayed
///////////////////////////////////////////////////////////////////////////////}
procedure TfrmEncounterFrame.AddTabs;
var
i: integer;
begin
TabControl.Tabs.Clear;
for I := 0 to (Formlist.count - 1) do
TabControl.Tabs.Add(Formlist.Strings[i]);
end;
{///////////////////////////////////////////////////////////////////////////////
//Name: procedure UpdatePCE(PCEData: TPCEData);
//Created: Jan 1999
//By: Robert Bott
//Location: ISL
//Description: The main call to open the encounter frame and capture encounter
// information.
///////////////////////////////////////////////////////////////////////////////}
function UpdatePCE(PCEData: TPCEData; SaveOnExit: boolean = TRUE): boolean;
var
// FontHeight,
// FontWidth: Integer;
AUser: string;
begin
frmEncounterFrame := TfrmEncounterFrame.Create(Application);
try
frmEncounterFrame.FAutoSave := SaveOnExit;
uEncPCEData := PCEData;
if(uEncPCEData.Empty and ((uEncPCEData.Location = 0) or (uEncPCEData.VisitDateTime = 0)) and
(not Encounter.NeedVisit)) then
uEncPCEData.UseEncounter := TRUE;
frmEncounterFrame.Caption := 'Encounter Form for ' + ExternalName(uEncPCEData.Location, 44) +
' (' + FormatFMDateTime('mmm dd,yyyy@hh:nn', uEncPCEData.VisitDateTime) + ')';
uProviders.Assign(uEncPCEData.Providers);
SetDefaultProvider(uProviders, uEncPCEData);
AUser := IntToStr(uProviders.PendingIEN(FALSE));
if(AUser <> '0') and (uProviders.IndexOfProvider(AUser) < 0) and
AutoCheckout(uEncPCEData.Location) then
uProviders.AddProvider(AUser, uProviders.PendingName(FALSE), FALSE);
frmEncounterFrame.CreateChildForms(frmEncounterFrame, PCEData.Location);
ResizeAnchoredFormToFont(frmEncounterFrame);
SetFormPosition(frmEncounterFrame);
with frmEncounterFrame do
begin
SetRPCEncLocation(PCEData.Location);
SynchPCEData;
TabControl.Tabindex := 0;
TabControlChange(TabControl);
ShowModal;
Result := FSaveNeeded;
end;
finally
// frmEncounterFrame.Free; v22.11 (JD and SM)
frmEncounterFrame.Release;
//frmEncounterFrame := nil; access violation source? removed 7/28/03 RV
end;
end;
{///////////////////////////////////////////////////////////////////////////////
//Name: TfrmEncounterFrame.SectionClick(Sender: TObject);
//Created: Jan 1999
//By: Robert Bott
//Location: ISL
//Description: Call the procedure apropriate for the selected tab
///////////////////////////////////////////////////////////////////////////////}
procedure TfrmEncounterFrame.SectionClick(Sender: TObject);
begin
with Sender as TListBox do case Tag of
TAG_VTYPE: if FormListContains(CT_VisitNm) then
begin
with frmVisitType do
lstVTypeSectionClick(Sender);
end;
end;
end;
{///////////////////////////////////////////////////////////////////////////////
//Name: procedure TfrmEncounterFrame.SynchPCEData;
//Created: Jan 1999
//By: Robert Bott
//Location: ISL
//Description: Synchronize any existing PCE data with what is displayed in the form.
///////////////////////////////////////////////////////////////////////////////}
procedure TfrmEncounterFrame.SynchPCEData;
procedure InitList(AListBox: TORListBox);
var
DoClick: boolean;
begin
with AListBox do
begin
DoClick := TRUE;
case Tag of
TAG_VTYPE: begin
if FormListContains(CT_VisitNm) then
ListVisitTypeSections(Items);
DoClick := AutoSelectVisit(PCERPCEncLocation);
end;
end;
if Items.Count > 0 then
begin
if DoClick then
begin
ItemIndex := 0;
SectionClick(AListBox);
end;
end
else Items.Add(TX_NOSECTION);
end;
end;
begin
if FormListContains(CT_VisitNm) then
with frmVisitType do
begin
InitList(frmVisitType.lstVTypeSection); // set up Visit Type page
ListSCDisabilities(memSCDisplay.Lines);
uSCCond := EligbleConditions;
frmVisitType.fraVisitRelated.InitAllow(uSCCond);
end;
with uEncPCEData do // load any existing data from PCEData
begin
if FormListContains(CT_VisitNm) then
frmVisitType.fraVisitRelated.InitRelated(uEncPCEData);
if FormListContains(CT_DiagNm) then
frmDiagnoses.InitTab(CopyDiagnoses, ListDiagnosisSections);
if FormListContains(CT_ProcNm) then
frmProcedures.InitTab(CopyProcedures, ListProcedureSections);
if FormListContains(CT_ImmNm) then
frmImmunizations.InitTab(CopyImmunizations,ListImmunizSections);
if FormListContains(CT_SkinNm) then
frmSkinTests.InitTab(CopySkinTests, ListSkinSections);
if FormListContains(CT_PedNm) then
frmPatientEd.InitTab(CopyPatientEds, ListPatientSections);
if FormListContains(CT_HlthNm) then
frmHealthFactors.InitTab(CopyHealthFactors, ListHealthSections);
if FormListContains(CT_XamNm) then
frmExams.InitTab(CopyExams, ListExamsSections);
uVisitType.Assign(VisitType);
if FormListContains(CT_VisitNm) then
with frmVisitType do
begin
MatchVType;
end;
end;
end;
{///////////////////////////////////////////////////////////////////////////////
//Name: procedure TfrmEncounterFrame.FormDestroy(Sender: TObject);
//Created: Jan 1999
//By: Robert Bott
//Location: ISL
//Description: Free up objects in memory when destroying form.
///////////////////////////////////////////////////////////////////////////////}
procedure TfrmEncounterFrame.FormDestroy(Sender: TObject);
var
i: integer;
begin
inherited;
for i := ComponentCount-1 downto 0 do
if(Components[i] is TForm) then
TForm(Components[i]).Free;
formlist.clear;
KillObj(@uProviders);
uVisitType.Free;
Formlist.free;
end;
{///////////////////////////////////////////////////////////////////////////////
//Name: procedure TfrmEncounterFrame.FormCreate(Sender: TObject);
//Created: Jan 1999
//By: Robert Bott
//Location: ISL
//Description: Create instances of the objects needed.
///////////////////////////////////////////////////////////////////////////////}
procedure TfrmEncounterFrame.FormCreate(Sender: TObject);
begin
uProviders := TPCEProviderList.Create;
uVisitType := TPCEProc.create;
//uVitalOld := TStringList.create;
//uVitalNew := TStringList.create;
FormList := TStringList.create;
fCancel := False;
FAbort := TRUE;
SetFormFonts;
end;
{///////////////////////////////////////////////////////////////////////////////
//Name: procedure TfrmEncounterFrame.SendData;
//Created: Jan 1999
//By: Robert Bott
//Location: ISL
//Description: Send Data back to the M side sor storing.
///////////////////////////////////////////////////////////////////////////////}
procedure TfrmEncounterFrame.SendData;
//send PCE data to the RPC
var
StoreMessage: string;
GAFScore: integer;
GAFDate: TFMDateTime;
GAFStaff: Int64;
begin
inherited;
// do validation for vitals & anything else here
//process vitals
if FormListContains(CT_VitNm) then
begin
with frmEncVitals do
if HasData then
begin
if AssignVitals then
begin
StoreMessage := ValAndStoreVitals(frmEncVitals.VitalNew);
if (Storemessage <> 'True') then
begin
showmessage(storemessage);
// exit;
end;
end;
end;
end;
if(FormListContains(CT_GAFNm)) then
begin
frmGAF.GetGAFScore(GAFScore, GAFDate, GAFStaff);
if(GAFScore > 0) then
SaveGAFScore(GAFScore, GAFDate, GAFStaff);
end;
//PCE
UpdateEncounter(uEncPCEData);
with uEncPCEData do
begin
if FAutoSave then
Save
else
FSaveNeeded := TRUE;
end;
Close;
end;
{///////////////////////////////////////////////////////////////////////////////
//Name: procedure TfrmEncounterFrame.FormCloseQuery(Sender: TObject;
//Created: Jan 1999
//By: Robert Bott
//Location: ISL
//Description: Check to see if the Cancel button was pressed, if not, call
// procedure to send the data to the server.
///////////////////////////////////////////////////////////////////////////////}
procedure TfrmEncounterFrame.FormCloseQuery(Sender: TObject;
var CanClose: Boolean);
const
TXT_SAVECHANGES = 'Save Changes?';
var
TmpPCEData: TPCEData;
ask, ChangeOK: boolean;
begin
CanClose := True;
if(FAbort) then
FCancel := (InfoBox(TXT_SAVECHANGES, TXT_SAVECHANGES, MB_YESNO) = ID_NO);
if FCancel then Exit; //*KCM*
if(uProviders.PrimaryIdx >= 0) then
ask := TRUE
else
begin
TmpPCEData := TPCEData.Create;
try
uEncPCEData.CopyPCEData(TmpPCEData);
UpdateEncounter(TmpPCEData);
ask := TmpPCEData.NeedProviderInfo;
finally
TmpPCEData.Free;
end;
end;
if ask and (NoPrimaryPCEProvider(uProviders, uEncPCEData)) then
begin
InfoBox(TX_PROV_REQ, TC_PROV_REQ, MB_OK or MB_ICONWARNING);
CanClose := False;
Exit;
end;
uVisitType.Provider := uProviders.PrimaryIEN; {RV - v20.1}
if FormListContains(CT_VitNm) then
CanClose := frmEncVitals.OK2SaveVitals;
if CanClose and FormListContains(CT_ProcNm) then
begin
CanClose := frmProcedures.OK2SaveProcedures;
if not CanClose then
begin
tabPageChange(Self, FormList.IndexOf(CT_ProcNm), ChangeOK);
SwitchToPage(PageIDToForm(CT_PROCEDURES));
TabControl.TabIndex := FormList.IndexOf(CT_ProcNm);
end;
end;
if CanClose then SendData; //*KCM*
end;
procedure TfrmEncounterFrame.TabControlChange(Sender: TObject);
var
i: integer;
begin
//must switch based on caption, as all tabs may not be present.
if (sender as tTabControl).tabindex = -1 then exit;
for i := CT_FIRST to CT_LAST do
begin
with Formlist do
with sender as tTabControl do
if Tabindex = IndexOf(PageIdToTab(i)) then
begin
PageIDToForm(i).show;
SwitchToPage(PageIDToForm(i));
end;
end;
end;
procedure TfrmEncounterFrame.TabControlChanging(Sender: TObject;
var AllowChange: Boolean);
begin
if(assigned(FLastPage)) then
FLastPage.AllowTabChange(AllowChange);
end;
procedure TfrmEncounterFrame.UpdateEncounter(PCE: TPCEData);
begin
with PCE do
begin
if FormListContains(CT_VisitNm) then
begin
VisitType := uVisitType;
frmVisitType.fraVisitRelated.GetRelated(uEncPCEData);
Providers.Merge(uProviders);
end;
if FormListContains(CT_DiagNm) then
SetDiagnoses(frmDiagnoses.lbGrid.Items);
if FormListContains(CT_ProcNm) then
SetProcedures(frmProcedures.lbGrid.Items);
if FormListContains(CT_ImmNm) then
SetImmunizations(frmImmunizations.lbGrid.Items);
if FormListContains(CT_SkinNm) then
SetSkinTests(frmSkinTests.lbGrid.Items);
if FormListContains(CT_PedNm) then
SetPatientEds(frmPatientEd.lbGrid.Items);
if FormListContains(CT_HlthNm) then
SetHealthFactors(frmHealthFactors.lbGrid.Items);
if FormListContains(CT_XamNm) then
SetExams(frmExams.lbGrid.Items);
end;
end;
procedure TfrmEncounterFrame.SelectTab(NewTabName: string);
var
AllowChange: boolean;
begin
AllowChange := True;
tabControl.TabIndex := FormList.IndexOf(NewTabName);
tabPageChange(Self, tabControl.TabIndex, AllowChange);
end;
procedure TfrmEncounterFrame.TabControlExit(Sender: TObject);
var
i: integer;
begin
//Keep the focus on the active page
if (sender as tTabControl).tabindex = -1 then exit;
for i := CT_FIRST to CT_LAST do
begin
with Formlist do
with sender as tTabControl do
if Tabindex = IndexOf(PageIdToTab(i)) then
begin
PageIDToForm(i).FocusFirstControl;
end;
end;
end;
procedure TfrmEncounterFrame.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
var
CanChange: boolean;
begin
if (Key = VK_ESCAPE) then
begin
Key := 0;
FLastPage.btnCancel.Click;
end
else if Key = VK_TAB then
begin
if ssCtrl in Shift then
begin
CanChange := True;
if Assigned(TabControl.OnChanging) then
TabControl.OnChanging(TabControl, CanChange);
if CanChange then
begin
if ssShift in Shift then
begin
if TabControl.TabIndex < 1 then
TabControl.TabIndex := TabControl.Tabs.Count -1
else
TabControl.TabIndex := TabControl.TabIndex - 1;
end
else
TabControl.TabIndex := (TabControl.TabIndex + 1) mod TabControl.Tabs.Count;
if Assigned(TabControl.OnChange) then
TabControl.OnChange(TabControl);
end;
Key := 0;
end;
end;
if FLastPage = frmEncVitals then
frmEncVitals.FormKeyDown(Sender, Key, Shift);
end;
procedure TfrmEncounterFrame.SetFormFonts;
var
NewFontSize: integer;
begin
NewFontSize := MainFontsize;
if FormListContains(CT_VisitNm) then
frmVisitType.Font.Size := NewFontSize;
if FormListContains(CT_DiagNm) then
frmDiagnoses.Font.Size := NewFontSize;
if FormListContains(CT_ProcNm) then
frmProcedures.Font.Size := NewFontSize;
if FormListContains(CT_ImmNm) then
frmImmunizations.Font.Size := NewFontSize;
if FormListContains(CT_SkinNm) then
frmSkinTests.Font.Size := NewFontSize;
if FormListContains(CT_PedNm) then
frmPatientEd.Font.Size := NewFontSize;
if FormListContains(CT_HlthNm) then
frmHealthFactors.Font.Size := NewFontSize;
if FormListContains(CT_XamNm) then
frmExams.Font.Size := NewFontSize;
if FormListContains(CT_VitNm) then
frmEncVitals.Font.Size := NewFontSize;
if FormListContains(CT_GAFNm) then
frmGAF.SetFontSize(NewFontSize);
end;
procedure TfrmEncounterFrame.FormClose(Sender: TObject;
var Action: TCloseAction);
begin
SaveUserBounds(Self);
end;
procedure TfrmEncounterFrame.FormCanResize(Sender: TObject; var NewWidth,
NewHeight: Integer; var Resize: Boolean);
begin
//CQ4740
if NewWidth < 200 then
begin
NewWidth := 200;
Resize := false;
end;
end;
end.

97
CPRS-Chart/Encounter/fExam.dfm Normal file
View File

@ -0,0 +1,97 @@
inherited frmExams: TfrmExams
Left = 509
Top = 223
Caption = 'Encounter Examinations'
PixelsPerInch = 96
TextHeight = 13
object lblExamResults: TLabel [0]
Left = 490
Top = 264
Width = 35
Height = 13
Caption = 'Results'
end
inherited lblSection: TLabel
Width = 65
Caption = 'Exam Section'
end
inherited btnOK: TBitBtn
TabOrder = 6
end
inherited btnCancel: TBitBtn
TabOrder = 7
end
inherited pnlGrid: TPanel
TabOrder = 1
inherited lbGrid: TORListBox
Caption = 'Exams'
Pieces = '1,2'
end
inherited hcGrid: THeaderControl
Sections = <
item
ImageIndex = -1
MinWidth = 60
Text = 'Results'
Width = 60
end
item
ImageIndex = -1
MinWidth = 90
Text = 'Selected Exams'
Width = 90
end>
end
end
inherited edtComment: TCaptionEdit
TabOrder = 3
end
inherited btnRemove: TButton
TabOrder = 5
end
inherited btnSelectAll: TButton
TabOrder = 2
TabStop = True
end
inherited pnlMain: TPanel
TabOrder = 0
inherited lbxSection: TORListBox
Tag = 80
end
inherited pnlLeft: TPanel
inherited lbSection: TORListBox
TabOrder = 0
Caption = 'Exam Section'
end
inherited btnOther: TButton
Tag = 24
Caption = 'Other Exam...'
TabOrder = 1
end
end
end
object cboExamResults: TORComboBox
Tag = 60
Left = 490
Top = 280
Width = 121
Height = 21
Style = orcsDropDown
AutoSelect = True
Caption = 'Results'
Color = clWindow
DropDownCount = 8
Enabled = False
ItemHeight = 13
ItemTipColor = clWindow
ItemTipEnable = True
ListItemsOnly = False
LongList = False
MaxLength = 0
Pieces = '2'
Sorted = False
SynonymChars = '<>'
TabOrder = 4
OnChange = cboExamResultsChange
end
end

117
CPRS-Chart/Encounter/fExam.pas Normal file
View File

@ -0,0 +1,117 @@
unit fExam;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
fPCEBase, StdCtrls, ORCtrls, CheckLst, ExtCtrls, Buttons, uPCE, rPCE, ORFn,
fPCELex, fPCEOther, ComCtrls, fPCEBaseMain;
type
TfrmExams = class(TfrmPCEBaseMain)
lblExamResults: TLabel;
cboExamResults: TORComboBox;
procedure cboExamResultsChange(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
protected
procedure UpdateNewItemStr(var x: string); override;
procedure UpdateControls; override;
public
end;
var
frmExams: TfrmExams;
implementation
{$R *.DFM}
uses
fEncounterFrame;
procedure TfrmExams.cboExamResultsChange(Sender: TObject);
var
i: integer;
begin
if(NotUpdating) and (cboExamResults.Text <> '') then
begin
for i := 0 to lbGrid.Items.Count-1 do
if(lbGrid.Selected[i]) then
TPCEExams(lbGrid.Items.Objects[i]).Results := cboExamResults.ItemID;
GridChanged;
end;
end;
procedure TfrmExams.FormCreate(Sender: TObject);
begin
inherited;
FTabName := CT_XamNm;
FPCEListCodesProc := ListExamsCodes;
FPCEItemClass := TPCEExams;
FPCECode := 'XAM';
PCELoadORCombo(cboExamResults);
end;
procedure TfrmExams.UpdateNewItemStr(var x: string);
begin
SetPiece(x, U, pnumExamResults, NoPCEValue);
end;
procedure TfrmExams.UpdateControls;
var
ok, First: boolean;
SameR: boolean;
i: integer;
Res: string;
Obj: TPCEExams;
begin
inherited;
if(NotUpdating) then
begin
BeginUpdate;
try
ok := (lbGrid.SelCount > 0);
lblExamResults.Enabled := ok;
cboExamResults.Enabled := ok;
if(ok) then
begin
First := TRUE;
SameR := TRUE;
Res := NoPCEValue;
for i := 0 to lbGrid.Items.Count-1 do
begin
if lbGrid.Selected[i] then
begin
Obj := TPCEExams(lbGrid.Items.Objects[i]);
if(First) then
begin
First := FALSE;
Res := Obj.Results;
end
else
begin
if(SameR) then
SameR := (Res = Obj.Results);
end;
end;
end;
if(SameR) then
cboExamResults.SelectByID(Res)
else
cboExamResults.Text := '';
end
else
begin
cboExamResults.Text := '';
end;
finally
EndUpdate;
end;
end;
end;
end.

194
CPRS-Chart/Encounter/fGAF.dfm Normal file
View File

@ -0,0 +1,194 @@
inherited frmGAF: TfrmGAF
Left = 255
Top = 178
ActiveControl = edtScore
Caption = 'frmGAF'
OnActivate = FormActivate
PixelsPerInch = 96
TextHeight = 13
object lblScore: TLabel [0]
Left = 139
Top = 175
Width = 31
Height = 13
Caption = 'Score:'
end
object lblDate: TLabel [1]
Left = 139
Top = 206
Width = 83
Height = 13
Caption = 'Date Determined:'
end
object lblDeterminedBy: TLabel [2]
Left = 139
Top = 237
Width = 72
Height = 13
Caption = 'Determined By:'
end
object Spacer1: TLabel [3]
Left = 0
Top = 0
Width = 624
Height = 13
Align = alTop
end
object Spacer2: TLabel [4]
Left = 0
Top = 122
Width = 624
Height = 13
Align = alTop
end
object lblGAF: TStaticText [5]
Left = 0
Top = 13
Width = 624
Height = 22
Align = alTop
Alignment = taCenter
AutoSize = False
Caption = 'Most recent Global Assessment of Functioning (GAF) scores:'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = [fsBold]
ParentFont = False
TabOrder = 8
end
object lblEntry: TStaticText [6]
Left = 0
Top = 135
Width = 624
Height = 30
Align = alTop
Alignment = taCenter
AutoSize = False
Caption = 'Global Assessment of Functioning (GAF) score entry:'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = [fsBold]
ParentFont = False
TabOrder = 9
end
inherited btnOK: TBitBtn
TabOrder = 6
end
inherited btnCancel: TBitBtn
TabOrder = 7
end
inherited pnlGrid: TPanel
Left = 0
Top = 35
Width = 624
Align = alTop
TabOrder = 0
inherited lbGrid: TORListBox
Width = 624
TabStop = False
MultiSelect = True
Caption = 'Most recent Global Assessment of Functioning (GAF) scores'
Pieces = '1,2,3,4'
end
inherited hcGrid: THeaderControl
Width = 624
Sections = <
item
ImageIndex = -1
MinWidth = 65
Text = 'GAF Score'
Width = 65
end
item
ImageIndex = -1
MinWidth = 95
Text = 'Date Determined'
Width = 95
end
item
ImageIndex = -1
MinWidth = 85
Text = 'Determined By'
Width = 85
end
item
ImageIndex = -1
MinWidth = 60
Text = 'Comment'
Width = 60
end>
end
end
object edtScore: TCaptionEdit
Left = 226
Top = 171
Width = 33
Height = 21
TabOrder = 1
Text = '0'
OnChange = edtScoreChange
Caption = 'Score'
end
object udScore: TUpDown
Left = 259
Top = 171
Width = 15
Height = 21
Associate = edtScore
Min = 0
Position = 0
TabOrder = 2
Wrap = False
end
object dteGAF: TORDateBox
Left = 226
Top = 202
Width = 121
Height = 21
TabOrder = 3
OnExit = dteGAFExit
DateOnly = True
RequireTime = False
Caption = 'Date Determined:'
end
object cboGAFProvider: TORComboBox
Left = 226
Top = 233
Width = 212
Height = 117
Style = orcsSimple
AutoSelect = True
Caption = 'Determined By'
Color = clWindow
DropDownCount = 8
ItemHeight = 13
ItemTipColor = clWindow
ItemTipEnable = True
ListItemsOnly = True
LongList = True
LookupPiece = 2
MaxLength = 0
Pieces = '2,3'
Sorted = False
SynonymChars = '<>'
TabOrder = 4
OnExit = cboGAFProviderExit
OnNeedData = cboGAFProviderNeedData
end
object btnURL: TButton
Left = 3
Top = 376
Width = 134
Height = 21
Hint = 'GAF Scale Rating Form'
Caption = 'Reference Information'
ParentShowHint = False
ShowHint = True
TabOrder = 5
OnClick = btnURLClick
end
end

206
CPRS-Chart/Encounter/fGAF.pas Normal file
View File

@ -0,0 +1,206 @@
unit fGAF;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
fPCEBase, StdCtrls, Buttons, ExtCtrls, Grids, ORFn, ORNet, ORCtrls,
ORDtTm, ComCtrls, fPCEBaseGrid, Menus;
type
TfrmGAF = class(TfrmPCEBaseGrid)
lblGAF: TStaticText;
edtScore: TCaptionEdit;
udScore: TUpDown;
dteGAF: TORDateBox;
lblEntry: TStaticText;
lblScore: TLabel;
lblDate: TLabel;
lblDeterminedBy: TLabel;
cboGAFProvider: TORComboBox;
btnURL: TButton;
Spacer1: TLabel;
Spacer2: TLabel;
procedure cboGAFProviderNeedData(Sender: TObject; const StartFrom: String;
Direction, InsertAt: Integer);
procedure edtScoreChange(Sender: TObject);
procedure dteGAFExit(Sender: TObject);
procedure cboGAFProviderExit(Sender: TObject);
procedure FormActivate(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure btnURLClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
FDataLoaded: boolean;
procedure LoadScores;
function BADData(ShowMessage: boolean): boolean;
public
procedure AllowTabChange(var AllowChange: boolean); override;
procedure GetGAFScore(var Score: integer; var Date: TFMDateTime; var Staff: Int64);
end;
function ValidGAFData(Score: integer; Date: TFMDateTime; Staff: Int64): boolean;
var
frmGAF: TfrmGAF;
implementation
uses rPCE, rCore, uCore, uPCE, fEncounterFrame;
{$R *.DFM}
function ValidGAFData(Score: integer; Date: TFMDateTime; Staff: Int64): boolean;
begin
if(Score < 1) or (Score > 100) or (Date <= 0) or (Staff = 0) then
Result := FALSE
else
Result := ((Patient.DateDied <= 0) or (Date <= Patient.DateDied));
end;
procedure TfrmGAF.LoadScores;
var
i: integer;
tmp: string;
begin
RecentGafScores(3);
if(RPCBrokerV.Results.Count > 0) and (RPCBrokerV.Results[0] = '[DATA]') then
begin
for i := 1 to RPCBrokerV.Results.Count-1 do
begin
tmp := RPCBrokerV.Results[i];
lbGrid.Items.Add(Piece(tmp,U,5) + U + Piece(Piece(tmp,U,2),NoPCEValue,1) + U +
Piece(tmp,U,7) + U + Piece(tmp,U,8));
end;
end;
if(lbGrid.Items.Count > 0) then
SyncGridData
else
lbGrid.Items.Add('No GAF scores found.');
end;
procedure TfrmGAF.cboGAFProviderNeedData(Sender: TObject;
const StartFrom: String; Direction, InsertAt: Integer);
begin
inherited;
cboGAFProvider.ForDataUse(SubSetOfPersons(StartFrom, Direction));
end;
function TfrmGAF.BADData(ShowMessage: boolean): boolean;
var
PName, msg: string;
GAFDate: TFMDateTime;
UIEN: Int64;
begin
GAFDate := dteGAF.FMDateTime;
msg := ValidateGAFDate(GAFDate);
if(dteGAF.FMDateTime <> GAFDate) then
dteGAF.FMDateTime := GAFDate;
if(cboGAFProvider.ItemID = '') then
begin
if(msg <> '') then
msg := msg + CRLF;
msg := msg + 'A determining party is required to enter a GAF score.';
UIEN := uProviders.PCEProvider;
if(UIEN <> 0) then
begin
PName := uProviders.PCEProviderName;
msg := msg + ' Determined By changed to ' + PName + '.';
cboGAFProvider.SelectByIEN(UIEN);
if(cboGAFProvider.ItemID = '') then
begin
cboGAFProvider.InitLongList(PName);
cboGAFProvider.SelectByIEN(UIEN);
end;
end;
end;
if(ShowMessage and (msg <> '')) then
InfoBox(msg, 'Invalid GAF Data', MB_OK);
if(udScore.Position > udScore.Min) then
Result := (msg <> '')
else
Result := FALSE;
end;
procedure TfrmGAF.edtScoreChange(Sender: TObject);
var
i: integer;
begin
inherited;
i := StrToIntDef(edtScore.Text,udScore.Min);
if(i < udScore.Min) or (i > udScore.Max) then
i := udScore.Min;
udScore.Position := i;
edtScore.Text := IntToStr(i);
edtScore.SelStart := length(edtScore.Text);
end;
procedure TfrmGAF.dteGAFExit(Sender: TObject);
begin
inherited;
// BadData(TRUE);
end;
procedure TfrmGAF.cboGAFProviderExit(Sender: TObject);
begin
inherited;
BadData(TRUE);
end;
procedure TfrmGAF.AllowTabChange(var AllowChange: boolean);
begin
AllowChange := (not BadData(TRUE));
end;
procedure TfrmGAF.GetGAFScore(var Score: integer; var Date: TFMDateTime; var Staff: Int64);
begin
Score := udScore.Position;
if(Score > 0) then BadData(TRUE);
Date := dteGAF.FMDateTime;
Staff := cboGAFProvider.ItemIEN;
if(not ValidGAFData(Score, Date, Staff)) then
begin
Score := 0;
Date := 0;
Staff := 0
end;
end;
procedure TfrmGAF.FormActivate(Sender: TObject);
begin
inherited;
if(not FDataLoaded) then
begin
FDataLoaded := TRUE;
LoadScores;
cboGAFProvider.InitLongList(Encounter.ProviderName);
BadData(FALSE);
end;
end;
procedure TfrmGAF.FormShow(Sender: TObject);
begin
inherited;
FormActivate(Sender);
end;
procedure TfrmGAF.btnURLClick(Sender: TObject);
begin
inherited;
GotoWebPage(GAFURL);
end;
procedure TfrmGAF.FormCreate(Sender: TObject);
begin
inherited;
FTabName := CT_GAFNm;
btnURL.Visible := (User.WebAccess and (GAFURL <> ''));
end;
end.

104
CPRS-Chart/Encounter/fHFSearch.dfm Normal file
View File

@ -0,0 +1,104 @@
inherited frmHFSearch: TfrmHFSearch
Left = 286
Top = 248
Width = 363
Height = 417
Caption = 'Other Health Factors'
Position = poScreenCenter
OnCreate = FormCreate
PixelsPerInch = 96
TextHeight = 13
object splMain: TSplitter
Left = 0
Top = 131
Width = 355
Height = 3
Cursor = crVSplit
Align = alTop
end
object lblCat: TLabel
Left = 0
Top = 0
Width = 355
Height = 13
Align = alTop
Caption = 'Category:'
end
object cbxSearch: TORComboBox
Left = 0
Top = 13
Width = 355
Height = 118
Style = orcsSimple
Align = alTop
AutoSelect = True
Caption = 'Category'
Color = clWindow
DropDownCount = 7
ItemHeight = 13
ItemTipColor = clWindow
ItemTipEnable = True
ListItemsOnly = True
LongList = False
MaxLength = 0
Pieces = '2'
Sorted = False
SynonymChars = '<>'
TabOrder = 0
TabStop = True
OnChange = cbxSearchChange
OnDblClick = tvSearchDblClick
end
object tvSearch: TORTreeView
Left = 0
Top = 134
Width = 355
Height = 229
Align = alClient
HideSelection = False
Indent = 23
ReadOnly = True
StateImages = dmodShared.imgTemplates
TabOrder = 1
OnChange = tvSearchChange
OnCollapsed = tvSearchGetImageIndex
OnDblClick = tvSearchDblClick
OnExpanded = tvSearchGetImageIndex
OnGetImageIndex = tvSearchGetImageIndex
OnGetSelectedIndex = tvSearchGetImageIndex
Caption = 'Other Health Factors'
NodePiece = 2
end
object pnlBottom: TPanel
Left = 0
Top = 363
Width = 355
Height = 27
Align = alBottom
BevelOuter = bvNone
TabOrder = 2
object btnOK: TButton
Left = 196
Top = 4
Width = 75
Height = 21
Anchors = [akTop, akRight]
Caption = '&OK'
Default = True
Enabled = False
TabOrder = 0
OnClick = btnOKClick
end
object btnCancel: TButton
Left = 276
Top = 4
Width = 75
Height = 21
Anchors = [akTop, akRight]
Cancel = True
Caption = '&Cancel'
ModalResult = 2
TabOrder = 1
end
end
end

226
CPRS-Chart/Encounter/fHFSearch.pas Normal file
View File

@ -0,0 +1,226 @@
unit fHFSearch;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
fAutoSz, ORFn, StdCtrls, ComCtrls, ORCtrls, ExtCtrls;
type
TfrmHFSearch = class(TfrmAutoSz)
cbxSearch: TORComboBox;
tvSearch: TORTreeView;
pnlBottom: TPanel;
btnOK: TButton;
btnCancel: TButton;
splMain: TSplitter;
lblCat: TLabel;
procedure FormCreate(Sender: TObject);
procedure btnOKClick(Sender: TObject);
procedure tvSearchDblClick(Sender: TObject);
procedure tvSearchGetImageIndex(Sender: TObject; Node: TTreeNode);
procedure tvSearchChange(Sender: TObject; Node: TTreeNode);
procedure cbxSearchChange(Sender: TObject);
private
FCode: string;
FChanging: boolean;
procedure UpdateCat;
public
end;
procedure HFLookup(var Code: string);
implementation
uses rPCE, dShared, fEncounterFrame;
{$R *.DFM}
const
CatTxt = 'Category: ';
procedure HFLookup(var Code: string);
var
frmHFSearch: TfrmHFSearch;
begin
frmHFSearch := TfrmHFSearch.Create(Application);
try
ResizeFormToFont(TForm(frmHFSearch));
frmHFSearch.ShowModal;
Code := frmHFSearch.FCode;
finally
frmHFSearch.Free;
end;
end;
procedure TfrmHFSearch.cbxSearchChange(Sender: TObject);
var
Node: TORTreeNode;
CurCat, NodeCat: TTreeNode;
ID: string;
begin
inherited;
if(not FChanging) then
begin
FChanging := TRUE;
try
btnOK.Enabled := (cbxSearch.ItemIndex >= 0);
if(cbxSearch.ItemIndex < 0) then
tvSearch.Selected := nil
else
begin
ID := cbxSearch.ItemID;
if(assigned(tvSearch.Selected)) then
begin
CurCat := tvSearch.Selected;
while (assigned(CurCat.Parent)) do
CurCat := CurCat.Parent;
end
else
CurCat := nil;
Node := TORTreeNode(tvSearch.Items.GetFirstNode);
while assigned(Node) do
begin
if(piece(Node.StringData,U,1)= ID) then
begin
NodeCat := Node;
while (assigned(NodeCat.Parent)) do
NodeCat := NodeCat.Parent;
RedrawSuspend(tvSearch.Handle);
try
if(CurCat <> NodeCat) then
tvSearch.FullCollapse;
tvSearch.Selected := Node;
Node.EnsureVisible;
finally
RedrawActivate(tvSearch.Handle);
end;
break;
end;
Node := TORTreeNode(Node.GetNext);
end;
end;
UpdateCat;
finally
FChanging := FALSE;
end;
end;
end;
procedure TfrmHFSearch.FormCreate(Sender: TObject);
var
HFList: TStringList;
i: integer;
Node :TORTreeNode;
CAT: string;
begin
inherited;
HFList := TStringList.Create;
try
LoadcboOther(HFList, uEncPCEData.Location, PCE_HF);
for i := 0 to HFList.Count-1 do
begin
if(Piece(HFList[i],U,3)='F') then
cbxSearch.Items.Add(pieces(HFList[i],U,1,2));
end;
for i := 0 to HFList.Count-1 do
begin
if(Piece(HFList[i],U,3)='C') then
begin
with TORTreeNode(tvSearch.Items.Add(nil, '')) do
begin
StringData := HFList[i];
StateIndex := 2;
end;
end;
end;
for i := 0 to HFList.Count-1 do
begin
if(Piece(HFList[i],U,3)='F') then
begin
CAT := piece(HFList[i],U,4);
Node := TORTreeNode(tvSearch.Items.GetFirstNode);
while(assigned(Node)) do
begin
if(Piece(Node.StringData, U, 1) = CAT) then
break;
Node := TORTreeNode(Node.GetNextSibling);
end;
TORTreeNode(tvSearch.Items.AddChild(Node, '')).StringData := Pieces(HFList[i],U,1,2);
end;
end;
// tvSearch.Invalidate;
finally
HFList.Free;
end;
end;
procedure TfrmHFSearch.btnOKClick(Sender: TObject);
begin
inherited;
if cbxSearch.ItemIndex = -1 then Exit;
FCode := cbxSearch.Items[cbxSearch.ItemIndex];
ModalResult := mrOK;
end;
procedure TfrmHFSearch.tvSearchDblClick(Sender: TObject);
begin
inherited;
btnOKClick(Sender);
end;
procedure TfrmHFSearch.tvSearchGetImageIndex(Sender: TObject;
Node: TTreeNode);
begin
inherited;
if(piece(TORTreeNode(Node).StringData,U,3)= 'C') then
begin
if(Node.Expanded) then
Node.StateIndex := 3
else
Node.StateIndex := 2;
end;
// tvSearch.Invalidate;
end;
procedure TfrmHFSearch.tvSearchChange(Sender: TObject; Node: TTreeNode);
begin
inherited;
if(not FChanging) then
begin
FChanging := TRUE;
try
if(assigned(Node)) then
cbxSearch.SelectByID(Piece(TORTreeNode(Node).StringData,U,1))
else
cbxSearch.ItemIndex := -1;
btnOK.Enabled := (cbxSearch.ItemIndex >= 0);
UpdateCat;
finally
FChanging := FALSE;
end;
end;
end;
procedure TfrmHFSearch.UpdateCat;
var
NodeCat: TTreeNode;
begin
NodeCat := tvSearch.Selected;
if(assigned(NodeCat)) then
begin
while (assigned(NodeCat.Parent)) do
NodeCat := NodeCat.Parent;
lblCat.Caption := CatTxt + NodeCat.Text;
end
else
lblCat.Caption := CatTxt;
cbxSearch.Caption := lblCat.Caption;
end;
end.

102
CPRS-Chart/Encounter/fHealthFactor.dfm Normal file
View File

@ -0,0 +1,102 @@
inherited frmHealthFactors: TfrmHealthFactors
Left = 374
Top = 205
Caption = 'Health Factor page'
PixelsPerInch = 96
TextHeight = 13
object lblHealthLevel: TLabel [0]
Left = 490
Top = 264
Width = 69
Height = 13
Caption = 'Level/Severity'
end
inherited lblSection: TLabel
Width = 103
Caption = 'Health Factor Section'
end
inherited btnOK: TBitBtn
TabOrder = 6
end
inherited btnCancel: TBitBtn
TabOrder = 7
end
inherited pnlGrid: TPanel
TabOrder = 1
inherited lbGrid: TORListBox
Tag = 70
Caption = 'Selected Health Factors'
Pieces = '1,2'
end
inherited hcGrid: THeaderControl
Sections = <
item
ImageIndex = -1
MinWidth = 85
Text = 'Level/Severity'
Width = 85
end
item
ImageIndex = -1
MinWidth = 130
Text = 'Selected Health Factors'
Width = 130
end>
end
end
inherited edtComment: TCaptionEdit
MaxLength = 245
TabOrder = 3
end
inherited btnRemove: TButton
TabOrder = 5
end
inherited btnSelectAll: TButton
TabOrder = 2
TabStop = True
end
inherited pnlMain: TPanel
TabOrder = 0
inherited lbxSection: TORListBox
Tag = 70
end
inherited pnlLeft: TPanel
inherited lbSection: TORListBox
Tag = 70
TabOrder = 0
Caption = 'Health Factor Section'
end
inherited btnOther: TButton
Tag = 23
Caption = 'Other Health Factor...'
TabOrder = 1
end
end
end
object cboHealthLevel: TORComboBox
Tag = 50
Left = 490
Top = 280
Width = 121
Height = 21
Style = orcsDropDown
AutoSelect = True
Caption = 'Level/Severity'
Color = clWindow
DropDownCount = 8
Enabled = False
ItemHeight = 13
ItemTipColor = clWindow
ItemTipEnable = True
ListItemsOnly = False
LongList = False
LookupPiece = 0
MaxLength = 0
Pieces = '2'
Sorted = False
SynonymChars = '<>'
TabOrder = 4
OnChange = cboHealthLevelChange
CharsNeedMatch = 1
end
end

117
CPRS-Chart/Encounter/fHealthFactor.pas Normal file
View File

@ -0,0 +1,117 @@
unit fHealthFactor;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
fPCEBase, StdCtrls, ORCtrls, CheckLst, ExtCtrls, Buttons, uPCE, rPCE, ORFn,
fPCELex, fPCEOther, ComCtrls, fPCEBaseMain;
type
TfrmHealthFactors = class(TfrmPCEBaseMain)
lblHealthLevel: TLabel;
cboHealthLevel: TORComboBox;
procedure cboHealthLevelChange(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
protected
procedure UpdateNewItemStr(var x: string); override;
procedure UpdateControls; override;
public
end;
var
frmHealthFactors: TfrmHealthFactors;
implementation
{$R *.DFM}
uses
fEncounterFrame;
procedure tfrmHealthFactors.cboHealthLevelChange(Sender: TObject);
var
i: integer;
begin
if(NotUpdating) and (cboHealthLevel.Text <> '') then
begin
for i := 0 to lbGrid.Items.Count-1 do
if(lbGrid.Selected[i]) then
TPCEPat(lbGrid.Items.Objects[i]).Level := cboHealthLevel.ItemID;
GridChanged;
end;
end;
procedure TfrmHealthFactors.FormCreate(Sender: TObject);
begin
inherited;
FTabName := CT_HlthNm;
FPCEListCodesProc := ListHealthCodes;
FPCEItemClass := TPCEHealth;
FPCECode := 'HF';
PCELoadORCombo(cboHealthLevel);
end;
procedure TfrmHealthFactors.UpdateNewItemStr(var x: string);
begin
SetPiece(x, U, pnumHFLevel, NoPCEValue);
end;
procedure TfrmHealthFactors.UpdateControls;
var
ok, First: boolean;
SameHL: boolean;
i: integer;
HL: string;
Obj: TPCEHealth;
begin
inherited;
if(NotUpdating) then
begin
BeginUpdate;
try
ok := (lbGrid.SelCount > 0);
lblHealthLevel.Enabled := ok;
cboHealthLevel.Enabled := ok;
if(ok) then
begin
First := TRUE;
SameHL := TRUE;
HL := NoPCEValue;
for i := 0 to lbGrid.Items.Count-1 do
begin
if lbGrid.Selected[i] then
begin
Obj := TPCEHealth(lbGrid.Items.Objects[i]);
if(First) then
begin
First := FALSE;
HL := Obj.Level;
end
else
begin
if(SameHL) then
SameHL := (HL = Obj.Level);
end;
end;
end;
if(SameHL) then
cboHealthLevel.SelectByID(HL)
else
cboHealthLevel.Text := '';
end
else
begin
cboHealthLevel.Text := '';
end;
finally
EndUpdate;
end;
end;
end;
end.

159
CPRS-Chart/Encounter/fImmunization.dfm Normal file
View File

@ -0,0 +1,159 @@
inherited frmImmunizations: TfrmImmunizations
Left = 373
Top = 169
Caption = 'Encouner Immunization'
PixelsPerInch = 96
TextHeight = 13
object lblReaction: TLabel [0]
Left = 490
Top = 274
Width = 43
Height = 13
Caption = 'Reaction'
end
object lblSeries: TLabel [1]
Left = 490
Top = 236
Width = 29
Height = 13
Caption = 'Series'
end
inherited lblSection: TLabel
Width = 100
Caption = 'Immunization Section'
end
object lblContra: TLabel [6]
Left = 509
Top = 312
Width = 74
Height = 26
Caption = 'Repeat Contraindicated'
WordWrap = True
end
inherited btnOK: TBitBtn
TabOrder = 8
end
inherited btnCancel: TBitBtn
TabOrder = 9
end
inherited pnlGrid: TPanel
TabOrder = 1
inherited lbGrid: TORListBox
Tag = 40
Caption = 'Selected Immunizations'
Pieces = '1,2,3,4'
end
inherited hcGrid: THeaderControl
Sections = <
item
ImageIndex = -1
MinWidth = 43
Text = 'Series'
Width = 96
end
item
ImageIndex = -1
MinWidth = 57
Text = 'Reaction'
Width = 134
end
item
ImageIndex = -1
MinWidth = 45
Text = 'Contra'
Width = 45
end
item
ImageIndex = -1
MinWidth = 124
Text = 'Selected Immunizations'
Width = 124
end>
end
end
inherited edtComment: TCaptionEdit
TabOrder = 3
end
inherited btnRemove: TButton
TabOrder = 7
end
inherited btnSelectAll: TButton
TabOrder = 2
TabStop = True
end
inherited pnlMain: TPanel
TabOrder = 0
inherited lbxSection: TORListBox
Tag = 40
end
inherited pnlLeft: TPanel
inherited lbSection: TORListBox
Tag = 40
TabOrder = 0
Caption = 'Immunization Section'
end
inherited btnOther: TButton
Tag = 20
Caption = 'Other Immunization...'
TabOrder = 1
end
end
end
object cboImmReaction: TORComboBox
Tag = 20
Left = 490
Top = 288
Width = 121
Height = 21
Style = orcsDropDown
AutoSelect = True
Caption = 'Reaction'
Color = clWindow
DropDownCount = 8
Enabled = False
ItemHeight = 13
ItemTipColor = clWindow
ItemTipEnable = True
ListItemsOnly = False
LongList = False
MaxLength = 0
Pieces = '2'
Sorted = False
SynonymChars = '<>'
TabOrder = 5
OnChange = cboImmReactionChange
end
object cboImmSeries: TORComboBox
Tag = 10
Left = 490
Top = 250
Width = 121
Height = 21
Style = orcsDropDown
AutoSelect = True
Caption = 'Series'
Color = clWindow
DropDownCount = 8
Enabled = False
ItemHeight = 13
ItemTipColor = clWindow
ItemTipEnable = True
ListItemsOnly = False
LongList = False
MaxLength = 0
Pieces = '2'
Sorted = False
SynonymChars = '<>'
TabOrder = 4
OnChange = cboImmSeriesChange
end
object ckbContra: TCheckBox
Left = 490
Top = 319
Width = 13
Height = 13
Enabled = False
TabOrder = 6
OnClick = ckbContraClick
end
end

181
CPRS-Chart/Encounter/fImmunization.pas Normal file
View File

@ -0,0 +1,181 @@
unit fImmunization;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
fPCEBase, StdCtrls, ORCtrls, CheckLst, ExtCtrls, Buttons, uPCE, rPCE, ORFn,
fPCELex, fPCEOther, ComCtrls, fPCEBaseMain;
type
TfrmImmunizations = class(TfrmPCEBaseMain)
lblReaction: TLabel;
lblSeries: TLabel;
cboImmReaction: TORComboBox;
cboImmSeries: TORComboBox;
ckbContra: TCheckBox;
lblContra: TLabel;
procedure cboImmSeriesChange(Sender: TObject);
procedure cboImmReactionChange(Sender: TObject);
procedure ckbContraClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
protected
procedure UpdateNewItemStr(var x: string); override;
procedure UpdateControls; override;
public
// procedure ChangeProvider;
end;
var
frmImmunizations: TfrmImmunizations;
implementation
{$R *.DFM}
uses
fEncounterFrame;
procedure TfrmImmunizations.cboImmSeriesChange(Sender: TObject);
var
i: integer;
begin
if(NotUpdating) and (cboImmSeries.Text <> '') then
begin
for i := 0 to lbGrid.Items.Count-1 do
if(lbGrid.Selected[i]) then
TPCEImm(lbGrid.Items.Objects[i]).Series := cboImmSeries.ItemID;
GridChanged;
end;
end;
procedure TfrmImmunizations.cboImmReactionChange(Sender: TObject);
var
i: integer;
begin
if(NotUpdating) and (cboImmReaction.Text <> '') then
begin
for i := 0 to lbGrid.Items.Count-1 do
if(lbGrid.Selected[i]) then
TPCEImm(lbGrid.Items.Objects[i]).Reaction := cboImmReaction.ItemID;
GridChanged;
end;
end;
procedure TfrmImmunizations.ckbContraClick(Sender: TObject);
var
i: integer;
begin
if(NotUpdating) then
begin
for i := 0 to lbGrid.Items.Count-1 do
if(lbGrid.Selected[i]) then
TPCEImm(lbGrid.Items.Objects[i]).Contraindicated := ckbContra.Checked;
GridChanged;
end;
end;
procedure TfrmImmunizations.FormCreate(Sender: TObject);
begin
inherited;
FTabName := CT_ImmNm;
FPCEListCodesProc := ListImmunizCodes;
FPCEItemClass := TPCEImm;
FPCECode := 'IMM';
PCELoadORCombo(cboImmReaction);
PCELoadORCombo(cboImmSeries);
end;
procedure TfrmImmunizations.UpdateNewItemStr(var x: string);
begin
inherited;
SetPiece(x, U, pnumImmSeries, NoPCEValue);
SetPiece(x, U, pnumImmReaction, NoPCEValue);
SetPiece(x, U, pnumImmRefused, '0');
SetPiece(x, U, pnumImmContra, '0');
end;
procedure TfrmImmunizations.UpdateControls;
var
ok, Contra, First: boolean;
SameS, SameR, SameC: boolean;
i: integer;
Ser, React: string;
Obj: TPCEImm;
begin
inherited;
if(NotUpdating) then
begin
BeginUpdate;
try
ok := (lbGrid.SelCount > 0);
lblSeries.Enabled := ok;
lblReaction.Enabled := ok;
cboImmSeries.Enabled := ok;
cboImmReaction.Enabled := ok;
ckbContra.Enabled := ok;
if(ok) then
begin
First := TRUE;
SameS := TRUE;
SameR := TRUE;
SameC := TRUE;
Contra := FALSE;
Ser := NoPCEValue;
React := NoPCEValue;
for i := 0 to lbGrid.Items.Count-1 do
begin
if lbGrid.Selected[i] then
begin
Obj := TPCEImm(lbGrid.Items.Objects[i]);
if(First) then
begin
First := FALSE;
Contra := Obj.Contraindicated;
Ser := Obj.Series;
React := Obj.Reaction;
end
else
begin
if(SameS) then
SameS := (Ser = Obj.Series);
if(SameR) then
SameR := (React = Obj.Reaction);
if(SameC) then
SameC := (Contra = Obj.Contraindicated);
end;
end;
end;
if(SameS) then
cboImmSeries.SelectByID(Ser)
else
cboImmSeries.Text := '';
if(SameR) then
cboImmReaction.SelectByID(React)
else
cboImmReaction.Text := '';
if(SameC) then
ckbContra.Checked := Contra
else
ckbContra.State := cbGrayed;
end
else
begin
cboImmSeries.Text := '';
cboImmReaction.Text := '';
ckbContra.Checked := FALSE;
end;
finally
EndUpdate;
end;
end;
end;
end.

47
CPRS-Chart/Encounter/fPCEBase.dfm Normal file
View File

@ -0,0 +1,47 @@
object frmPCEBase: TfrmPCEBase
Left = 194
Top = 170
AutoScroll = False
Caption = 'Basic Page'
ClientHeight = 400
ClientWidth = 624
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = True
OnClose = FormClose
OnCreate = FormCreate
OnShow = FormShow
DesignSize = (
624
400)
PixelsPerInch = 96
TextHeight = 13
object btnOK: TBitBtn
Left = 467
Top = 376
Width = 75
Height = 21
Anchors = [akRight, akBottom]
Caption = 'OK'
ModalResult = 1
TabOrder = 0
OnClick = btnOKClick
NumGlyphs = 2
end
object btnCancel: TBitBtn
Left = 547
Top = 376
Width = 75
Height = 21
Anchors = [akRight, akBottom]
Caption = 'Cancel'
ModalResult = 2
TabOrder = 1
OnClick = btnCancelClick
NumGlyphs = 2
end
end

376
CPRS-Chart/Encounter/fPCEBase.pas Normal file
View File

@ -0,0 +1,376 @@
{///////////////////////////////////////////////////////////////////////////////
//Name: fPCEBase.pas, fPCEBase.dfm
//Created: Jan 1999
//By: Robert Bott
//Location: ISL
//Description: Parent form for all PCE tabs. This form will hold methods that are
// universal for a PCE tabs. These forms will be child forms to fEncounterFrame.
////////////////////////////////////////////////////////////////////////////////}
unit fPCEBase;
{$OPTIMIZATION OFF} // REMOVE AFTER UNIT IS DEBUGGED
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, uConst,
StdCtrls, fAutoSz, Buttons, ORCtrls, ORFn, uPCE, ORDtTm, Checklst,
ComCtrls;
type
TfrmPCEBase = class(TfrmAutoSz)
btnOK: TBitBtn;
btnCancel: TBitBtn;
procedure FormCreate(Sender: TObject);
procedure btnCancelClick(Sender: TObject);
procedure btnOKClick(Sender: TObject); virtual;
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure FormShow(Sender: TObject);
private
FDisplayCount: Integer; // number of times page displayed
FPatientCount: Integer; // number of times page displayed for given pt
FCallingContext: Integer;
// function GetInitPage: Boolean;
// function GetInitPatient: Boolean;
// function GetPatientViewed: Boolean;
procedure UMResizePage(var Message: TMessage); message UM_RESIZEPAGE;
protected
FClosing: boolean;
FSectionTabs: array[0..2] of Integer;
FSectionTabCount: integer;
FTabName: string;
// procedure CreateParams(var Params: TCreateParams); override;
function ActiveCtrl: TWinControl;
function SectionString: string;
procedure DoEnter; override;
public
constructor CreateLinked(AParent: TWinControl);
procedure Loaded; override;
// function AllowContextChange: Boolean; virtual;
// procedure ClearPtData; virtual;
procedure DisplayPage; virtual;
// procedure NotifyOrder(OrderAction: Integer; AnOrder: TOrder); virtual; //*no ordering will be done*//
// procedure RequestPrint; virtual;
procedure SetFontSize(NewFontSize: Integer); virtual;
procedure AllowTabChange(var AllowChange: boolean); virtual;
property CallingContext: Integer read FCallingContext;
// property InitPage: Boolean read GetInitPage;
// property InitPatient: Boolean read GetInitPatient;
// property PatientViewed: Boolean read GetPatientViewed;
procedure FocusFirstControl;
end;
var
frmPCEBase: TfrmPCEBase;
implementation
{$R *.DFM}
uses
fEncounterFrame;
{///////////////////////////////////////////////////////////////////////////////
//Name: procedure TfrmPCEBase.FormCreate(Sender: TObject);
//Created: Jan 1999
//By: Robert Bott
//Location: ISL
//Description: Initialize counters to zero
///////////////////////////////////////////////////////////////////////////////}
procedure TfrmPCEBase.FormCreate(Sender: TObject);
begin
FDisplayCount := 0;
FPatientCount := 0;
end;
{///////////////////////////////////////////////////////////////////////////////
//Name: procedure TfrmPCEBase.CreateParams(var Params: TCreateParams);
//Created: Jan 1999
//By: Robert Bott
//Location: ISL
//Description: turn the form into a child window
///////////////////////////////////////////////////////////////////////////////}
(*procedure TfrmPCEBase.CreateParams(var Params: TCreateParams);
{ turn the form into a child window }
begin
inherited CreateParams(Params);
with Params do
begin
if Owner is TPanel
then WndParent := TPanel(Owner).Handle
else if owner is TForm then
WndParent := (Owner as TForm).Handle;
Style := WS_CHILD or WS_CLIPSIBLINGS;
X := 0; Y := 0;
end;
end;
*)
{///////////////////////////////////////////////////////////////////////////////
//Name: procedure TfrmPCEBase.Loaded;
//Created: Jan 1999
//By: Robert Bott
//Location: ISL
//Description: make the form borderless to allow it to be a child window
///////////////////////////////////////////////////////////////////////////////}
procedure TfrmPCEBase.Loaded;
begin
inherited Loaded;
Visible := False;
Position := poDefault;
BorderIcons := [];
BorderStyle := bsNone;
HandleNeeded;
SetBounds(0, 0, Width, Height);
end;
{///////////////////////////////////////////////////////////////////////////////
//Name: function TfrmPCEBase.AllowContextChange: Boolean;
//Created: Jan 1999
//By: Robert Bott
//Location: ISL
//Description:
///////////////////////////////////////////////////////////////////////////////}
(*function TfrmPCEBase.AllowContextChange: Boolean;
begin
Result := True;
end;
{///////////////////////////////////////////////////////////////////////////////
//Name: procedure TfrmPCEBase.ClearPtData;
//Created: Jan 1999
//By: Robert Bott
//Location: ISL
//Description: clear all patient related data on a page
///////////////////////////////////////////////////////////////////////////////}
procedure TfrmPCEBase.ClearPtData;
begin
FPatientCount := 0;
end;
*)
{///////////////////////////////////////////////////////////////////////////////
//Name: procedure TfrmPCEBase.DisplayPage;
//Created: Jan 1999
//By: Robert Bott
//Location: ISL
//Description: cause the page to be displayed and update the display counters
///////////////////////////////////////////////////////////////////////////////}
procedure TfrmPCEBase.DisplayPage;
begin
BringToFront;
// FocusControl(ActiveCtrl);
//SetFocus;
Inc(FDisplayCount);
Inc(FPatientCount);
FCallingContext := frmEncounterFrame.ChangeSource;
if (FCallingContext = CC_CLICK) and (FPatientCount = 1)
then FCallingContext := CC_INIT_PATIENT;
end;
(*
{///////////////////////////////////////////////////////////////////////////////
//Name: procedure TfrmPCEBase.RequestPrint;
//Created: Jan 1999
//By: Robert Bott
//Location: ISL
//Description: For posible future use when printing is supported.
///////////////////////////////////////////////////////////////////////////////}
procedure TfrmPCEBase.RequestPrint;
begin
//
end;
*)
{///////////////////////////////////////////////////////////////////////////////
//Name: procedure TfrmPCEBase.SetFontSize(NewFontSize: Integer);
//Created: Jan 1999
//By: Robert Bott
//Location: ISL
//Description: Assign the new font size.
///////////////////////////////////////////////////////////////////////////////}
procedure TfrmPCEBase.SetFontSize(NewFontSize: Integer);
begin
Font.Size := NewFontSize;
end;
(*
{///////////////////////////////////////////////////////////////////////////////
//Name: function TfrmPCEBase.GetInitPage: Boolean;
//Created: Jan 1999
//By: Robert Bott
//Location: ISL
//Description: if the count is one, this is the first time the page is being displayed.
///////////////////////////////////////////////////////////////////////////////}
function TfrmPCEBase.GetInitPage: Boolean;
begin
Result := FDisplayCount = 1;
end;
{///////////////////////////////////////////////////////////////////////////////
//Name: function TfrmPCEBase.GetInitPatient: Boolean;
//Created: Jan 1999
//By: Robert Bott
//Location: ISL
//Description: if the count is one, this is the first time the page is being
// displayed for a given patient
///////////////////////////////////////////////////////////////////////////////}
function TfrmPCEBase.GetInitPatient: Boolean;
begin
Result := FPatientCount = 1;
end;
{///////////////////////////////////////////////////////////////////////////////
//Name: function TfrmPCEBase.GetPatientViewed: Boolean;
//Created: Jan 1999
//By: Robert Bott
//Location: ISL
//Description: returns false if the tab has never been clicked for this patient
///////////////////////////////////////////////////////////////////////////////}
function TfrmPCEBase.GetPatientViewed: Boolean;
begin
Result := FPatientCount > 0;
end;
*)
(*
procedure RepaintControl(AControl: TControl);
var
i: Integer;
begin
AControl.Invalidate;
AControl.Update;
if AControl is TWinControl then with TWinControl(AControl) do
for i := 0 to ControlCount - 1 do RepaintControl(Controls[i]);
end;
*)
{///////////////////////////////////////////////////////////////////////////////
//Name: procedure TfrmPCEBase.UMResizePage(var Message: TMessage);
//Created: Jan 1999
//By: Robert Bott
//Location: ISL
//Description: Redraw the controls on the form when it is resized.
///////////////////////////////////////////////////////////////////////////////}
procedure TfrmPCEBase.UMResizePage(var Message: TMessage);
var
i: Integer;
begin
for i := 0 to ComponentCount - 1 do
if Components[i] is TControl then with TControl(Components[i]) do Invalidate;
Update;
end;
{///////////////////////////////////////////////////////////////////////////////
//Name: procedure TfrmPCEBase.btnCancelClick(Sender: TObject);
//Created: Jan 1999
//By: Robert Bott
//Location: ISL
//Description: Indicate to the frame that cancel was pressed, and close the frame.
///////////////////////////////////////////////////////////////////////////////}
procedure TfrmPCEBase.btnCancelClick(Sender: TObject);
begin
inherited;
frmencounterframe.Abort := FALSE;
frmEncounterFrame.Cancel := true;
frmencounterframe.Close;
end;
{///////////////////////////////////////////////////////////////////////////////
//Name: procedure TfrmPCEBase.btnCancelClick(Sender: TObject);
//Created: Jan 1999
//By: Robert Bott
//Location: ISL
//Description: Indicate to the frame that it should close and save data.
///////////////////////////////////////////////////////////////////////////////}
procedure TfrmPCEBase.btnOKClick(Sender: TObject);
begin
frmencounterframe.Abort := FALSE;
frmencounterframe.Close;
end;
{///////////////////////////////////////////////////////////////////////////////
//Name: procedure TfrmPCEBase.FormClose(Sender: TObject; var Action: TCloseAction);
//Created: Jan 1999
//By: Robert Bott
//Location: ISL
//Description: Free the memory held by the form.
///////////////////////////////////////////////////////////////////////////////}
procedure TfrmPCEBase.FormClose(Sender: TObject; var Action: TCloseAction);
begin
inherited;
action := caFree; //destroy the forms when closed
FClosing := TRUE;
end;
{///////////////////////////////////////////////////////////////////////////////
//Name: procedure TfrmPCEBase.CheckListDrawItem(Control: TWinControl; Index: Integer; Rect: TRect;
// State: TOwnerDrawState);
//Created: Jan 1999
//By: Robert Bott
//Location: ISL
//Description: Populate the checklist
///////////////////////////////////////////////////////////////////////////////}
procedure TfrmPCEBase.AllowTabChange(var AllowChange: boolean);
begin
end;
constructor TfrmPCEBase.CreateLinked(AParent: TWinControl);
begin
inherited Create(GetParentForm(AParent));
Parent := AParent;
Align := alClient;
Show;
end;
function TfrmPCEBase.ActiveCtrl: TWinControl;
begin
Result := GetParentForm(Self).ActiveControl;
if(Result is TORComboEdit) then
Result := TWinControl(Result.Owner);
end;
function TfrmPCEBase.SectionString: string;
var
v, i: integer;
begin
Result := '';
if FSectionTabCount = 0 then exit;
v := 0;
for i := 0 to FSectionTabCount-1 do
begin
if(Result <> '') then
Result := Result + ',';
Result := Result + IntToStr(FSectionTabs[i]);
v := FSectionTabs[i];
end;
for i := 1 to 20 do
begin
if(v<0) then
dec(v,32)
else
inc(v,32);
if Result <> '' then Result := Result + ',';
Result := Result + inttostr(v);
end;
end;
procedure TfrmPCEBase.DoEnter;
begin
inherited;
frmEncounterFrame.SelectTab(FTabName);
end;
procedure TfrmPCEBase.FocusFirstControl;
begin
// SetFocus;
FindNextControl(self, True, True, False).SetFocus;
end;
procedure TfrmPCEBase.FormShow(Sender: TObject);
begin
inherited;
FocusFirstControl;
end;
end.

49
CPRS-Chart/Encounter/fPCEBaseGrid.dfm Normal file
View File

@ -0,0 +1,49 @@
inherited frmPCEBaseGrid: TfrmPCEBaseGrid
Left = 200
Top = 303
Caption = 'frmPCEBaseGrid'
PixelsPerInch = 96
TextHeight = 13
object pnlGrid: TPanel
Left = 6
Top = 238
Width = 451
Height = 87
BevelOuter = bvNone
Caption = 'pnlGrid'
TabOrder = 2
OnResize = pnlGridResize
object lbGrid: TORListBox
Left = 0
Top = 17
Width = 451
Height = 70
Align = alClient
Color = clCream
ItemHeight = 13
ParentShowHint = False
ShowHint = True
TabOrder = 0
ItemTipColor = clCream
LongList = False
TabPosInPixels = True
end
object hcGrid: THeaderControl
Left = 0
Top = 0
Width = 451
Height = 17
DragReorder = False
Sections = <
item
ImageIndex = -1
Width = 50
end
item
ImageIndex = -1
Width = 50
end>
OnSectionResize = hcGridSectionResize
end
end
end

225
CPRS-Chart/Encounter/fPCEBaseGrid.pas Normal file
View File

@ -0,0 +1,225 @@
unit fPCEBaseGrid;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
fPCEBase, ComCtrls, StdCtrls, ORCtrls, ExtCtrls, Buttons, ORFn;
type
TfrmPCEBaseGrid = class(TfrmPCEBase)
pnlGrid: TPanel;
lbGrid: TORListBox;
hcGrid: THeaderControl;
procedure FormCreate(Sender: TObject);
procedure hcGridSectionResize(HeaderControl: THeaderControl;
Section: THeaderSection);
procedure pnlGridResize(Sender: TObject);
private
FSel: string;
FGridHeaderSyncing: boolean;
function GetGridIndex: integer;
procedure SetGridIndex(const Value: integer);
protected
FSectionGap: integer;
procedure UpdateControls; virtual;
procedure SaveGridSelected;
procedure RestoreGridSelected;
public
procedure SyncGridHeader(FromHeader: boolean);
procedure SyncGridData;
procedure ClearGrid;
property GridIndex: integer read GetGridIndex write SetGridIndex;
end;
var
frmPCEBaseGrid: TfrmPCEBaseGrid;
implementation
{$R *.DFM}
const
JustificationGap = 5;
procedure TfrmPCEBaseGrid.FormCreate(Sender: TObject);
begin
inherited;
lbGrid.Color := ReadOnlyColor;
lbGrid.ItemTipColor := ReadOnlyColor;
FSectionGap := 15;
SyncGridHeader(TRUE);
end;
procedure TfrmPCEBaseGrid.SyncGridHeader(FromHeader: boolean);
var
i, w, wd, wp, Gap: integer;
txt: string;
begin
if(not FGridHeaderSyncing) then
begin
Gap := JustificationGap;
FGridHeaderSyncing := TRUE;
try
if(FromHeader) then
begin
txt := '';
w := 0;
for i := 0 to hcGrid.Sections.Count-2 do
begin
if(i > 0) then
txt := txt + ',';
inc(w,(hcGrid.Sections[i].Width div 2)*2);
txt := txt + IntToStr(w + Gap);
Gap := 0;
end;
lbGrid.TabPositions := txt;
end
else
begin
txt := lbGrid.TabPositions;
wd := 0;
for i := 0 to hcGrid.Sections.Count-2 do
begin
wp := StrToIntDef(Piece(txt,',',i+1),hcGrid.Sections[i].MinWidth);
w := wp - wd;
hcGrid.Sections[i].Width := w - Gap;
Gap := 0;
wd := wp;
end;
end;
w := 0;
for i := 0 to hcGrid.Sections.Count-2 do
inc(w,hcGrid.Sections[i].Width);
hcGrid.Sections[hcGrid.Sections.Count-1].Width := pnlGrid.Width - w;
finally
FGridHeaderSyncing := FALSE;
end;
end;
end;
procedure TfrmPCEBaseGrid.hcGridSectionResize(
HeaderControl: THeaderControl; Section: THeaderSection);
begin
inherited;
SyncGridHeader(TRUE);
end;
procedure TfrmPCEBaseGrid.pnlGridResize(Sender: TObject);
begin
inherited;
SyncGridHeader(TRUE);
end;
procedure TfrmPCEBaseGrid.SyncGridData;
var
tp, ltp, i, j, tlen: integer;
max: array[0..9] of integer; // more than 10 header sections will cause this to explode
tmp: string;
begin
if(lbGrid.Items.Count > 0) then
begin
for j := 0 to hcGrid.Sections.Count-2 do max[j] := 0;
for i := 0 to lbGrid.Items.Count-1 do
begin
tmp := lbGrid.Items[i];
for j := 0 to hcGrid.Sections.Count-2 do
begin
tlen := Canvas.TextWidth(Piece(tmp,U,j+1)) + FSectionGap;
if(max[j] < tlen) then
max[j] := tlen;
end;
end;
ltp := 0;
tmp := lbGrid.TabPositions;
for i := 0 to hcGrid.Sections.Count-2 do
begin
if(max[i] < hcGrid.Sections[i].MinWidth) then
max[i] := hcGrid.Sections[i].MinWidth;
tp := StrToIntDef(Piece(tmp,',',i+1),0);
tlen := tp - ltp;
ltp := tp;
if(max[i] < tlen) then
max[i] := tlen;
end;
for i := 1 to hcGrid.Sections.Count-2 do
inc(max[i], max[i-1]);
tmp := '';
for i := 0 to hcGrid.Sections.Count-2 do
tmp := tmp + ',' + inttostr(max[i]);
delete(tmp,1,1);
if(lbGrid.TabPositions <> tmp) then
begin
SaveGridSelected;
lbGrid.TabPositions := tmp;
RestoreGridSelected;
end;
SyncGridHeader(FALSE);
end;
end;
function TfrmPCEBaseGrid.GetGridIndex: integer;
var
i: integer;
begin
Result := -1;
if(lbGrid.SelCount > 0) then
begin
for i := 0 to lbGrid.Items.Count-1 do
if(lbGrid.Selected[i]) then
begin
Result := i;
exit;
end;
end;
end;
procedure TfrmPCEBaseGrid.SetGridIndex(const Value: integer);
var
i: integer;
begin
for i := 0 to lbGrid.Items.Count-1 do
lbGrid.Selected[i] := (i = Value);
UpdateControls;
end;
procedure TfrmPCEBaseGrid.ClearGrid;
var
i: integer;
begin
if lbGrid.SelCount > 0 then
begin
for i := 0 to lbGrid.Items.Count-1 do
lbGrid.Selected[i] := FALSE;
end;
UpdateControls;
end;
procedure TfrmPCEBaseGrid.UpdateControls;
begin
end;
procedure TfrmPCEBaseGrid.RestoreGridSelected;
var
i: integer;
begin
for i := 0 to lbGrid.Items.Count-1 do
lbGrid.Selected[i] := (copy(FSel,i+1,1) = BOOLCHAR[TRUE]);
end;
procedure TfrmPCEBaseGrid.SaveGridSelected;
var
i: integer;
begin
FSel := '';
for i := 0 to lbGrid.Items.Count-1 do
FSel := FSel + BOOLCHAR[lbGrid.Selected[i]];
end;
end.

167
CPRS-Chart/Encounter/fPCEBaseMain.dfm Normal file
View File

@ -0,0 +1,167 @@
inherited frmPCEBaseMain: TfrmPCEBaseMain
Left = 302
Top = 166
Caption = 'frmPCEBaseMain'
OnDestroy = FormDestroy
OnResize = FormResize
PixelsPerInch = 96
TextHeight = 13
object lblSection: TLabel [0]
Left = 6
Top = 6
Width = 46
Height = 13
Caption = 'lblSection'
end
object lblList: TLabel [1]
Left = 213
Top = 6
Width = 67
Height = 13
Caption = 'Section Name'
end
object lblComment: TLabel [2]
Left = 6
Top = 328
Width = 49
Height = 13
Caption = 'Comments'
end
object bvlMain: TBevel [3]
Left = 0
Top = 230
Width = 619
Height = 140
end
inherited btnOK: TBitBtn
Left = 464
TabOrder = 1
end
inherited btnCancel: TBitBtn
Left = 544
TabOrder = 2
end
inherited pnlGrid: TPanel
Width = 475
TabOrder = 0
inherited lbGrid: TORListBox
Width = 475
MultiSelect = True
OnClick = lbGridSelect
OnChange = lbGridSelect
CheckEntireLine = True
end
inherited hcGrid: THeaderControl
Width = 475
end
end
object edtComment: TCaptionEdit
Left = 6
Top = 343
Width = 523
Height = 21
TabOrder = 5
OnChange = edtCommentChange
OnExit = edtCommentExit
OnKeyPress = edtCommentKeyPress
Caption = 'Comments'
end
object btnRemove: TButton
Left = 536
Top = 343
Width = 75
Height = 21
Caption = 'Remove'
TabOrder = 4
OnClick = btnRemoveClick
end
object btnSelectAll: TButton
Left = 406
Top = 326
Width = 75
Height = 17
Caption = 'Select All'
TabOrder = 3
TabStop = False
OnClick = btnSelectAllClick
end
object pnlMain: TPanel
Left = 6
Top = 20
Width = 612
Height = 204
Anchors = [akLeft, akTop, akRight, akBottom]
BevelOuter = bvNone
TabOrder = 6
object splLeft: TSplitter
Left = 204
Top = 0
Width = 3
Height = 204
Cursor = crHSplit
OnMoved = splLeftMoved
end
object lbxSection: TORListBox
Left = 207
Top = 0
Width = 405
Height = 204
Style = lbOwnerDrawFixed
Align = alClient
ExtendedSelect = False
ItemHeight = 16
ParentShowHint = False
ShowHint = True
TabOrder = 1
OnClick = clbListClick
OnMouseDown = clbListMouseDown
Caption = 'Section Name'
ItemTipColor = clWindow
LongList = False
Pieces = '2'
TabPosInPixels = True
CheckBoxes = True
CheckEntireLine = True
OnClickCheck = lbxSectionClickCheck
end
object pnlLeft: TPanel
Left = 0
Top = 0
Width = 204
Height = 204
Align = alLeft
BevelOuter = bvNone
TabOrder = 0
DesignSize = (
204
204)
object lbSection: TORListBox
Left = 0
Top = 0
Width = 204
Height = 174
Align = alTop
ItemHeight = 13
ParentShowHint = False
ShowHint = True
TabOrder = 1
OnClick = lbSectionClick
Caption = 'Section'
ItemTipColor = clWindow
LongList = False
Pieces = '3'
CheckEntireLine = True
end
object btnOther: TButton
Left = 65
Top = 178
Width = 139
Height = 21
Anchors = [akTop, akRight]
Caption = 'Other'
TabOrder = 0
OnClick = btnOtherClick
end
end
end
end

505
CPRS-Chart/Encounter/fPCEBaseMain.pas Normal file
View File

@ -0,0 +1,505 @@
unit fPCEBaseMain;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
fPCEBaseGrid, ComCtrls, StdCtrls, ORCtrls, ExtCtrls, Buttons, rPCE, uPCE,
CheckLst, ORFn;
type
TCopyItemsMethod = procedure(Dest: TStrings) of object;
TListSectionsProc = procedure(Dest: TStrings);
TfrmPCEBaseMain = class(TfrmPCEBaseGrid)
lbSection: TORListBox;
edtComment: TCaptionEdit;
lblSection: TLabel;
lblList: TLabel;
lblComment: TLabel;
btnRemove: TButton;
btnOther: TButton;
bvlMain: TBevel;
btnSelectAll: TButton;
lbxSection: TORListBox;
pnlMain: TPanel;
pnlLeft: TPanel;
splLeft: TSplitter;
procedure lbSectionClick(Sender: TObject);
procedure btnOtherClick(Sender: TObject);
procedure edtCommentExit(Sender: TObject);
procedure edtCommentChange(Sender: TObject);
procedure btnRemoveClick(Sender: TObject);
procedure clbListClick(Sender: TObject);
procedure lbGridSelect(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure btnSelectAllClick(Sender: TObject);
procedure FormResize(Sender: TObject); virtual;
procedure clbListMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure lbxSectionClickCheck(Sender: TObject; Index: Integer);
procedure splLeftMoved(Sender: TObject);
procedure edtCommentKeyPress(Sender: TObject; var Key: Char);
private
FCommentItem: integer;
FCommentChanged: boolean;
FUpdateCount: integer;
//FUpdatingGrid: boolean; moved to 'protected' so frmDiagnoses can see it (RV)
protected
FUpdatingGrid: boolean;
FPCEListCodesProc: TPCEListCodesProc;
FPCEItemClass: TPCEItemClass;
FPCECode: string;
FSplitterMove: boolean;
function GetCat: string;
procedure UpdateNewItemStr(var x: string); virtual;
// procedure UpdateNewItem(APCEItem: TPCEItem); virtual;
procedure GridChanged; virtual;
procedure UpdateControls; override;
procedure BeginUpdate;
procedure EndUpdate;
function NotUpdating: boolean;
procedure CheckOffEntries;
procedure UpdateTabPos;
procedure Sync2Grid;
procedure Sync2Section;
public
procedure AllowTabChange(var AllowChange: boolean); override;
procedure InitTab(ACopyProc: TCopyItemsMethod; AListProc: TListSectionsProc);
end;
var
frmPCEBaseMain: TfrmPCEBaseMain;
const
LBCheckWidthSpace = 18;
implementation
uses fPCELex, fPCEOther, fEncounterFrame, fHFSearch;
{$R *.DFM}
procedure TfrmPCEBaseMain.lbSectionClick(Sender: TObject);
begin
inherited;
ClearGrid;
FPCEListCodesProc(lbxSection.Items, lbSection.ItemIEN);
CheckOffEntries;
end;
procedure TfrmPCEBaseMain.UpdateNewItemStr(var x: string);
begin
end;
procedure TfrmPCEBaseMain.GridChanged;
var
i: integer;
tmpList: TStringList;
begin
tmpList := TStringList.Create;
BeginUpdate;
try
SaveGridSelected;
tmpList.Assign(lbGrid.Items);
for i := 0 to lbGrid.Items.Count-1 do
begin
//lbGrid.Items[i] := TPCEItem(lbGrid.Items.Objects[i]).ItemStr; v22.5 - RV
tmpList[i] := TPCEItem(lbGrid.Items.Objects[i]).ItemStr;
tmpList.Objects[i] := lbGrid.Items.Objects[i];
end;
lbGrid.Items.Assign(tmpList);
RestoreGridSelected;
SyncGridData;
finally
EndUpdate;
tmpList.Free;
end;
UpdateControls;
end;
//procedure TfrmPCEBaseMain.UpdateNewItem(APCEItem: TPCEItem);
//begin
//end;
procedure TfrmPCEBaseMain.btnOtherClick(Sender: TObject);
var
x, Code: string;
APCEItem: TPCEItem;
SrchCode: integer;
begin
inherited;
ClearGrid;
SrchCode := (Sender as TButton).Tag;
if(SrchCode <= LX_Threshold) then
LexiconLookup(Code, SrchCode)
else
if(SrchCode = PCE_HF) then
HFLookup(Code)
else
OtherLookup(Code, SrchCode);
btnOther.SetFocus;
if Code <> '' then
begin
x := FPCECode + U + Piece(Code, U, 1) + U + U + Piece(Code, U, 2);
if FPCEItemClass = TPCEProc then
SetPiece(x, U, pnumProvider, IntToStr(uProviders.PCEProvider));
UpdateNewItemStr(x);
APCEItem := FPCEItemClass.Create;
APCEItem.SetFromString(x);
// UpdateNewItem(APCEItem);
GridIndex := lbGrid.Items.AddObject(APCEItem.ItemStr, APCEItem);
SyncGridData;
end;
UpdateControls;
end;
procedure TfrmPCEBaseMain.edtCommentExit(Sender: TObject);
begin
inherited;
if(FCommentChanged) then
begin
FCommentChanged := FALSE;
if(FCommentItem >= 0) then
TPCEItem(lbGrid.Items.Objects[FCommentItem]).Comment := edtComment.text;
end;
end;
procedure TfrmPCEBaseMain.AllowTabChange(var AllowChange: boolean);
begin
edtCommentExit(Self);
end;
procedure TfrmPCEBaseMain.edtCommentChange(Sender: TObject);
begin
inherited;
FCommentItem := GridIndex;
FCommentChanged := TRUE;
end;
procedure TfrmPCEBaseMain.btnRemoveClick(Sender: TObject);
var
i, j: Integer;
APCEItem: TPCEItem;
CurCategory: string;
begin
inherited;
FUpdatingGrid := TRUE;
try
for i := lbGrid.Items.Count-1 downto 0 do if(lbGrid.Selected[i]) then
begin
CurCategory := GetCat;
APCEItem := TPCEDiag(lbGrid.Items.Objects[i]);
if APCEItem.Category = CurCategory then
begin
with APCEItem do for j := 0 to lbxSection.Items.Count - 1 do
if ORFn.Pieces(lbxSection.Items[j], U, 1, 2) = Code + U + Narrative then
lbxSection.Checked[j] := False;
end;
APCEItem.Free;
lbGrid.Items.Delete(i);
end;
ClearGrid;
finally
FUpdatingGrid := FALSE;
end;
end;
procedure TfrmPCEBaseMain.UpdateControls;
var
CommentOK: boolean;
begin
btnSelectAll.Enabled := (lbGrid.Items.Count > 0);
btnRemove.Enabled := (lbGrid.SelCount > 0);
if(NotUpdating) then
begin
BeginUpdate;
try
inherited;
CommentOK := (lbGrid.SelCount = 1);
lblComment.Enabled := CommentOK;
edtComment.Enabled := CommentOK;
if(CommentOK) then
edtComment.Text := TPCEItem(lbGrid.Items.Objects[GridIndex]).Comment
else
edtComment.Text := '';
finally
EndUpdate;
end;
end;
end;
procedure TfrmPCEBaseMain.clbListClick(Sender: TObject);
begin
inherited;
// with clbList do
// if(ItemIndex >= 0) and (not(Checked[ItemIndex])) then
// ClearGrid;
end;
procedure TfrmPCEBaseMain.lbGridSelect(Sender: TObject);
begin
inherited;
// clbList.ItemIndex := -1;
UpdateControls;
end;
procedure TfrmPCEBaseMain.FormDestroy(Sender: TObject);
var
i:integer;
begin
inherited;
with lbGrid.Items do for i := 0 to Count - 1 do TPCEItem(Objects[i]).Free;
end;
procedure TfrmPCEBaseMain.InitTab(ACopyProc: TCopyItemsMethod; AListProc: TListSectionsProc);
begin
AListProc(lbSection.Items);
ACopyProc(lbGrid.Items);
lbSection.ItemIndex := 0;
lbSectionClick(lbSection);
ClearGrid;
GridChanged;
// CheckOffEntries;
end;
procedure TfrmPCEBaseMain.BeginUpdate;
begin
inc(FUpdateCount);
end;
procedure TfrmPCEBaseMain.EndUpdate;
begin
if(FUpdateCount > 0) then
dec(FUpdateCount);
end;
function TfrmPCEBaseMain.NotUpdating: boolean;
begin
Result := (FUpdateCount = 0);
end;
procedure TfrmPCEBaseMain.CheckOffEntries;
{ TODO -oRich V. -cCode Set Versioning : Uncomment these lines to prevent acceptance of existing inactive DX codes. }
(*const
TX_INACTIVE_ICD_CODE1 = 'The diagnosis of "';
TX_INACTIVE_ICD_CODE2 = '" entered for this encounter' + #13#10 + 'contains an inactive ICD code of "';
TX_INACTIVE_ICD_CODE3 = '" as of the encounter date, and will be removed.' + #13#10#13#10 +
'Please select another diagnosis.';
TC_INACTIVE_ICD_CODE = 'Diagnosis Contains Inactive Code';*)
var
i, j: Integer;
CurCategory, CodeNarr: string;
APCEItem: TPCEItem;
begin
FUpdatingGrid := TRUE;
try
if(lbSection.Items.Count < 1) then exit;
CurCategory := GetCat;
for i := lbGrid.Items.Count - 1 downto 0 do
begin
APCEItem := TPCEItem(lbGrid.Items.Objects[i]);
if APCEItem.Category = CurCategory then
begin
CodeNarr := APCEItem.Code + U + APCEItem.Narrative;
for j := 0 to lbxSection.Items.Count - 1 do
if ORFn.Pieces(lbxSection.Items[j], U, 1, 2) = CodeNarr then
begin
{ TODO -oRich V. -cCode Set Versioning : Uncomment these lines to prevent acceptance of existing inactive DX codes. }
(* if (CurCategory = 'Problem List Items') and (Piece(lbxSection.Items[j], U, 5) = '#') then
begin
InfoBox(TX_INACTIVE_ICD_CODE1 + APCEItem.Narrative + TX_INACTIVE_ICD_CODE2 +
APCEItem.Code + TX_INACTIVE_ICD_CODE3, TC_INACTIVE_ICD_CODE, MB_ICONWARNING or MB_OK);
lbxSection.Checked[j] := False;
APCEItem.Free;
lbGrid.Items.Delete(i);
end
else*)
lbxSection.Checked[j] := True;
end;
end;
end;
finally
FUpdatingGrid := FALSE;
end;
end;
procedure TfrmPCEBaseMain.btnSelectAllClick(Sender: TObject);
var
i: integer;
begin
inherited;
BeginUpdate;
try
for i := 0 to lbGrid.Items.Count-1 do
lbGrid.Selected[i] := TRUE;
finally
EndUpdate;
end;
UpdateControls;
end;
procedure TfrmPCEBaseMain.FormResize(Sender: TObject);
begin
if FSplitterMove then
FSplitterMove := FALSE
else
inherited;
end;
procedure TfrmPCEBaseMain.clbListMouseDown(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
inherited;
// if(Button <> mbLeft) then
// clbList.Itemindex := clbList.itemAtPos(Point(X,Y), TRUE);
end;
function TfrmPCEBaseMain.GetCat: string;
begin
Result := '';
if(lbSection.Items.Count > 0) and (lbSection.ItemIndex >= 0) then
Result := Piece(lbSection.Items[lbSection.ItemIndex], U, 2);
end;
procedure TfrmPCEBaseMain.lbxSectionClickCheck(Sender: TObject;
Index: Integer);
var
i, j: Integer;
x, x0, CodeCatNarr: string;
APCEItem: TPCEItem;
Found, DoSync: boolean;
begin
inherited;
if FUpdatingGrid or FClosing then exit;
DoSync := FALSE;
x0 := GetCat;
for i := 0 to lbxSection.Items.Count-1 do
begin
x := x0 + U + ORFn.Pieces(lbxSection.Items[i], U, 1, 2);
CodeCatNarr := Piece(x, U, 2) + U + Piece(x, U, 1) + U + Piece(x, U, 3);
Found := FALSE;
for j := lbGrid.Items.Count - 1 downto 0 do
begin
APCEItem := TPCEItem(lbGrid.Items.Objects[j]);
with APCEItem do if CodeCatNarr = Code + U + Category + U + Narrative then
begin
Found := TRUE;
if(lbxSection.Checked[i]) then break;
APCEItem.Free;
lbGrid.Items.Delete(j);
end;
end;
if(lbxSection.Checked[i] and (not Found)) then
begin
x := FPCECode + U + CodeCatNarr;
if FPCEItemClass = TPCEProc then
SetPiece(x, U, pnumProvider, IntToStr(uProviders.PCEProvider));
UpdateNewItemStr(x);
APCEItem := FPCEItemClass.Create;
APCEItem.SetFromString(x);
GridIndex := lbGrid.Items.AddObject(APCEItem.ItemStr, APCEItem);
DoSync := TRUE;
end;
end;
if(DoSync) then
SyncGridData;
UpdateControls;
end;
procedure TfrmPCEBaseMain.UpdateTabPos;
begin
lbxSection.TabPositions := SectionString;
end;
procedure TfrmPCEBaseMain.splLeftMoved(Sender: TObject);
begin
inherited;
lblList.Left := lbxSection.Left + pnlMain.Left;
FSplitterMove := TRUE;
FormResize(Sender);
end;
procedure TfrmPCEBaseMain.Sync2Grid;
var
i, idx, cnt, NewIdx: Integer;
CodeNarr: string;
APCEItem: TPCEItem;
begin
if(FUpdatingGrid or FClosing) then exit;
FUpdatingGrid := TRUE;
try
cnt := 0;
idx := -1;
for i := 0 to lbGrid.Items.Count - 1 do
begin
if(lbGrid.Selected[i]) then
begin
if(idx < 0) then idx := i;
inc(cnt);
if(cnt > 1) then break;
end;
end;
NewIdx := -1;
if(cnt = 1) then
begin
APCEItem := TPCEItem(lbGrid.Items.Objects[idx]);
if APCEItem.Category = GetCat then
begin
CodeNarr := APCEItem.Code + U + APCEItem.Narrative;
for i := 0 to lbxSection.Items.Count - 1 do
begin
if Pieces(lbxSection.Items[i], U, 1, 2) = CodeNarr then
begin
NewIdx := i;
break;
end;
end;
end;
end;
lbxSection.ItemIndex := NewIdx;
finally
FUpdatingGrid := FALSE;
end;
end;
procedure TfrmPCEBaseMain.Sync2Section;
var
i, idx: Integer;
ACode: string;
begin
if(FUpdatingGrid or FClosing) then exit;
FUpdatingGrid := TRUE;
try
idx := lbxSection.ItemIndex;
if(idx >= 0) then
ACode := GetCat + U + Pieces(lbxSection.Items[idx], U, 1, 2)
else
ACode := '~@^~@^@~';
for i := 0 to lbGrid.Items.Count - 1 do
begin
with TPCEItem(lbGrid.Items.Objects[i]) do
lbGrid.Selected[i] := (ACode = (Category + U + Code + U + Narrative));
end;
finally
FUpdatingGrid := FALSE;
end;
end;
procedure TfrmPCEBaseMain.edtCommentKeyPress(Sender: TObject;
var Key: Char);
begin
inherited;
if (Key = '?') and
((edtComment.Text = '') or (edtComment.SelStart = 0)) then
Key := #0;
end;
end.

91
CPRS-Chart/Encounter/fPCEEdit.dfm Normal file
View File

@ -0,0 +1,91 @@
object frmPCEEdit: TfrmPCEEdit
Left = 214
Top = 107
BorderStyle = bsDialog
Caption = 'Edit Encounter'
ClientHeight = 128
ClientWidth = 543
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
Position = poScreenCenter
OnCreate = FormCreate
DesignSize = (
543
128)
PixelsPerInch = 96
TextHeight = 13
object Label1: TStaticText
Left = 0
Top = 0
Width = 543
Height = 24
Align = alTop
Alignment = taCenter
Caption = 'Select Encounter to Edit'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -16
Font.Name = 'MS Sans Serif'
Font.Style = [fsBold]
ParentFont = False
TabOrder = 5
end
object lblNew: TMemo
Left = 136
Top = 32
Width = 401
Height = 26
TabStop = False
BorderStyle = bsNone
Color = clBtnFace
Lines.Strings = (
'New')
TabOrder = 3
end
object lblNote: TMemo
Left = 136
Top = 73
Width = 401
Height = 26
TabStop = False
BorderStyle = bsNone
Color = clBtnFace
Lines.Strings = (
'Note')
TabOrder = 4
end
object btnNew: TButton
Left = 8
Top = 28
Width = 121
Height = 21
Caption = 'Edit Current Encounter'
ModalResult = 6
TabOrder = 0
end
object btnNote: TButton
Left = 8
Top = 69
Width = 121
Height = 21
Caption = 'Edit Note Encounter'
ModalResult = 7
TabOrder = 1
end
object btnCancel: TButton
Left = 465
Top = 104
Width = 75
Height = 21
Anchors = [akRight, akBottom]
Cancel = True
Caption = '&Cancel'
ModalResult = 2
TabOrder = 2
end
end

147
CPRS-Chart/Encounter/fPCEEdit.pas Normal file
View File

@ -0,0 +1,147 @@
unit fPCEEdit;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ORFn, uPCE;
type
TfrmPCEEdit = class(TForm)
btnNew: TButton;
btnNote: TButton;
lblNew: TMemo;
lblNote: TMemo;
btnCancel: TButton;
Label1: TStaticText;
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
function EditPCEData(NoteData: TPCEData): boolean;
implementation
uses uCore, rCore, fEncnt, fFrame, fEncounterFrame;
{$R *.DFM}
const
TX_NEED_VISIT2 = 'A visit is required before entering encounter information.';
TX_NOPCE_TXT1 = 'the encounter date is in the future.';
TX_NOPCE_TXT2 = 'encounter entry has been disabled.';
TX_NOPCE_TXT = 'You can not edit encounter information because ';
TX_NOPCE_HDR = 'Can not edit encounter';
var
uPCETemp: TPCEData = nil;
uPCETempOld: TPCEData = nil;
uPatient: string = '';
function EditPCEData(NoteData: TPCEData): boolean; // Returns TRUE if NoteData is edited
var
frmPCEEdit: TfrmPCEEdit;
BtnTxt, NewTxt, txt: string;
Ans: integer;
begin
Result := FALSE;
if (Encounter.VisitCategory = 'H') then
begin
if Assigned(NoteData) then
Ans := mrNo
else
begin
InfoBox('Can not edit admission encounter', 'Error', MB_OK or MB_ICONERROR);
Ans := mrCancel;
end;
end
else
if not Assigned(NoteData) then
Ans := mrYes
else
if (NoteData.VisitString = Encounter.VisitStr) then
Ans := mrNo
else
begin
frmPCEEdit := TfrmPCEEdit.Create(Application);
try
if Encounter.NeedVisit then
begin
NewTxt := 'Create New Encounter';
BtnTxt := 'New Encounter';
end
else
begin
NewTxt := 'Edit Encounter for ' + Encounter.LocationName + ' on ' +
FormatFMDateTime('mmm dd yyyy hh:nn', Encounter.DateTime);
BtnTxt := 'Edit Current Encounter';
end;
frmPCEEdit.lblNew.Text := NewTxt;
frmPCEEdit.btnNew.Caption := BtnTxt;
frmPCEEdit.lblNote.Text := 'Edit Note Encounter for ' + ExternalName(NoteData.Location, 44) + ' on ' +
FormatFMDateTime('mmm dd yyyy hh:nn', NoteData.VisitDateTime);
ans := frmPCEEdit.ShowModal;
finally
frmPCEEdit.Free;
end;
end;
if ans = mrYes then
begin
if Encounter.NeedVisit then
begin
UpdateVisit(8);
frmFrame.DisplayEncounterText;
end;
if Encounter.NeedVisit then
begin
InfoBox(TX_NEED_VISIT2, TX_NO_VISIT, MB_OK or MB_ICONWARNING);
Exit;
end;
if not assigned(uPCETemp) then
uPCETemp := TPCEData.Create;
uPCETemp.UseEncounter := True;
if not CanEditPCE(uPCETemp) then
begin
if FutureEncounter(uPCETemp) then
txt := TX_NOPCE_TXT1
else
txt := TX_NOPCE_TXT2;
InfoBox(TX_NOPCE_TXT + txt, TX_NOPCE_HDR, MB_OK or MB_ICONWARNING);
Exit;
end;
uPCETemp.PCEForNote(USE_CURRENT_VISITSTR, uPCETempOld);
UpdatePCE(uPCETemp);
if not assigned(uPCETempOld) then
uPCETempOld := TPCEData.Create;
uPCETemp.CopyPCEData(uPCETempOld);
end
else
if ans = mrNo then
begin
UpdatePCE(NoteData);
Result := TRUE;
end;
end;
procedure TfrmPCEEdit.FormCreate(Sender: TObject);
begin
if uPatient <> Patient.DFN then
begin
KillObj(@uPCETemp);
KillObj(@uPCETempOld);
end;
uPatient := Patient.DFN;
end;
initialization
finalization
KillObj(@uPCETemp);
KillObj(@uPCETempOld);
uPatient := '';
end.

80
CPRS-Chart/Encounter/fPCELex.dfm Normal file
View File

@ -0,0 +1,80 @@
inherited frmPCELex: TfrmPCELex
Left = 639
Top = 480
BorderIcons = []
BorderStyle = bsDialog
Caption = 'Lookup Other Diagnosis'
Position = poScreenCenter
OnCreate = FormCreate
PixelsPerInch = 96
TextHeight = 13
object lblSearch: TLabel
Left = 6
Top = 16
Width = 98
Height = 13
Caption = 'Search for Diagnosis'
end
object lblSelect: TLabel
Left = 6
Top = 67
Width = 175
Height = 13
Caption = 'Select from one of the following items'
Visible = False
end
object txtSearch: TCaptionEdit
Left = 6
Top = 30
Width = 331
Height = 21
TabOrder = 0
OnChange = txtSearchChange
Caption = 'Search for Diagnosis'
end
object cmdSearch: TButton
Left = 346
Top = 30
Width = 75
Height = 21
Caption = 'Search'
Default = True
TabOrder = 1
OnClick = cmdSearchClick
end
object cmdOK: TButton
Left = 263
Top = 245
Width = 75
Height = 22
Caption = 'OK'
TabOrder = 3
OnClick = cmdOKClick
end
object cmdCancel: TButton
Left = 346
Top = 245
Width = 75
Height = 22
Cancel = True
Caption = 'Cancel'
TabOrder = 4
OnClick = cmdCancelClick
end
object lstSelect: TORListBox
Left = 6
Top = 81
Width = 415
Height = 156
ItemHeight = 13
ParentShowHint = False
ShowHint = True
TabOrder = 2
OnClick = lstSelectClick
OnDblClick = lstSelectDblClick
Caption = 'Select from one of the following items'
ItemTipColor = clWindow
LongList = False
Pieces = '2'
end
end

151
CPRS-Chart/Encounter/fPCELex.pas Normal file
View File

@ -0,0 +1,151 @@
unit fPCELex;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
fAutoSz, StdCtrls, ORFn, ORCtrls;
type
TfrmPCELex = class(TfrmAutoSz)
txtSearch: TCaptionEdit;
cmdSearch: TButton;
cmdOK: TButton;
cmdCancel: TButton;
lblSearch: TLabel;
lblSelect: TLabel;
lstSelect: TORListBox;
procedure cmdSearchClick(Sender: TObject);
procedure cmdCancelClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure cmdOKClick(Sender: TObject);
procedure lstSelectClick(Sender: TObject);
procedure txtSearchChange(Sender: TObject);
procedure lstSelectDblClick(Sender: TObject);
private
FLexApp: Integer;
FCode: string;
FDate: TFMDateTime;
procedure SetApp(LexApp: Integer);
procedure SetDate(ADate: TFMDateTime);
end;
procedure LexiconLookup(var Code: string; LexApp: Integer; ADate: TFMDateTime = 0);
implementation
{$R *.DFM}
uses rPCE,UBAGlobals;
procedure LexiconLookup(var Code: string; LexApp: Integer; ADate: TFMDateTime = 0);
var
frmPCELex: TfrmPCELex;
begin
frmPCELex := TfrmPCELex.Create(Application);
try
ResizeFormToFont(TForm(frmPCELex));
frmPCELex.SetApp(LexApp);
frmPCELex.SetDate(ADate);
frmPCELex.ShowModal;
Code := frmPCELex.FCode;
finally
frmPCELex.Free;
end;
end;
procedure TfrmPCELex.FormCreate(Sender: TObject);
begin
inherited;
FCode := '';
end;
procedure TfrmPCELex.SetApp(LexApp: Integer);
begin
FLexApp := LexApp;
case LexApp of
LX_ICD: begin
Caption := 'Lookup Diagnosis';
lblSearch.Caption := 'Search for Diagnosis';
end;
LX_CPT: begin
Caption := 'Lookup Procedure';
lblSearch.Caption := 'Search for Procedure';
end;
end;
end;
procedure TfrmPCELex.SetDate(ADate: TFMDateTime);
begin
FDate := ADate;
end;
procedure TfrmPCELex.txtSearchChange(Sender: TObject);
begin
inherited;
cmdSearch.Default := True;
cmdOK.Default := False;
end;
procedure TfrmPCELex.cmdSearchClick(Sender: TObject);
begin
inherited;
if Length(txtSearch.Text) = 0 then Exit;
StatusText('Searching clinical lexicon...');
ListLexicon(lstSelect.Items, txtSearch.Text, FLexApp, FDate);
if lstSelect.GetIEN(0) = -1 then
begin
lblSelect.Visible := False;
txtSearch.SetFocus;
txtSearch.SelectAll;
cmdOK.Default := False;
cmdSearch.Default := True;
end else
begin
lblSelect.Visible := True;
lstSelect.SetFocus;
cmdSearch.Default := False;
end;
StatusText('');
end;
procedure TfrmPCELex.lstSelectClick(Sender: TObject);
begin
inherited;
if(lstSelect.ItemIndex > -1) and (lstSelect.ItemIEN > 0) then
begin
cmdSearch.Default := False;
cmdOK.Default := True;
end;
end;
procedure TfrmPCELex.cmdOKClick(Sender: TObject);
begin
inherited;
if(lstSelect.ItemIndex = -1) or (lstSelect.ItemIEN <= 0) then Exit;
with lstSelect do
begin
if BAPersonalDX then
FCode := (LexiconToCode(ItemIEN, FLexApp, FDate) + U + DisplayText[ItemIndex] + U + IntToStr(ItemIEN) )
else
FCode := LexiconToCode(ItemIEN, FLexApp, FDate) + U + DisplayText[ItemIndex];
Close;
end;
end;
procedure TfrmPCELex.cmdCancelClick(Sender: TObject);
begin
inherited;
FCode := '';
Close;
end;
procedure TfrmPCELex.lstSelectDblClick(Sender: TObject);
begin
inherited;
lstSelectClick(Sender);
cmdOKClick(Sender);
end;
end.

62
CPRS-Chart/Encounter/fPCEOther.dfm Normal file
View File

@ -0,0 +1,62 @@
object frmPCEOther: TfrmPCEOther
Left = 451
Top = 201
Width = 279
Height = 340
ActiveControl = cboOther
Caption = 'OtherItems'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = True
Position = poScreenCenter
OnCreate = FormCreate
PixelsPerInch = 96
TextHeight = 13
object cmdCancel: TButton
Left = 190
Top = 287
Width = 75
Height = 22
Cancel = True
Caption = 'Cancel'
TabOrder = 2
OnClick = cmdCancelClick
end
object cmdOK: TButton
Left = 110
Top = 287
Width = 75
Height = 22
Caption = 'OK'
Enabled = False
TabOrder = 1
OnClick = cmdOKClick
end
object cboOther: TORComboBox
Left = 8
Top = 8
Width = 257
Height = 273
Style = orcsSimple
AutoSelect = True
Caption = 'Other Items'
Color = clWindow
DropDownCount = 8
ItemHeight = 13
ItemTipColor = clWindow
ItemTipEnable = True
ListItemsOnly = False
LongList = False
MaxLength = 0
Pieces = '2'
Sorted = False
SynonymChars = '<>'
TabOrder = 0
OnChange = cboOtherChange
OnDblClick = cboOtherDblClick
end
end

105
CPRS-Chart/Encounter/fPCEOther.pas Normal file
View File

@ -0,0 +1,105 @@
unit fPCEOther;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
fAutoSz, ORFn, ORCtrls, StdCtrls;
type
TfrmPCEOther = class(TfrmAutoSz)
cmdCancel: TButton;
cmdOK: TButton;
cboOther: TORComboBox;
procedure cmdOKClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure cmdCancelClick(Sender: TObject);
procedure cboOtherDblClick(Sender: TObject);
procedure cboOtherChange(Sender: TObject);
private
fOtherApp: Integer;
FCode: string;
procedure SetApp(OtherApp: Integer);
public
{ Public declarations }
end;
procedure OtherLookup(var Code: string; OtherApp: Integer);
implementation
{$R *.DFM}
uses rPCE, fEncounterFrame;
procedure OtherLookup(var Code: string; OtherApp: Integer);
var
frmPCEOther: TfrmPCEOther;
begin
frmPCEOther := TfrmPCEOther.Create(Application);
try
ResizeFormToFont(TForm(frmPCEOther));
frmPCEOther.SetApp(OtherApp);
frmPCEOther.ShowModal;
Code := frmPCEOther.FCode;
finally
frmPCEOther.Free;
end;
end;
procedure TfrmPCEOther.SetApp(OtherApp: Integer);
begin
fOtherApp := OtherApp;
case OtherApp of
PCE_IMM: Caption := 'Other Immunizations';
PCE_SK: Caption := 'Other Skin Tests';
PCE_PED: Caption := 'Other Education Topics';
// PCE_HF: Caption := 'Other Health Factors';
PCE_XAM: Caption := 'Other Examinations';
end;
cboOther.Caption := Caption;
LoadcboOther(cboOther.Items, uEncPCEData.Location, OtherApp);
end;
procedure TfrmPCEOther.cmdOKClick(Sender: TObject);
begin
inherited;
with cboOther do
begin
if ItemIndex = -1 then Exit;
FCode := CboOther.Items[ItemIndex];
//
Close;
end;
end;
procedure TfrmPCEOther.FormCreate(Sender: TObject);
begin
inherited;
FCode := '';
end;
procedure TfrmPCEOther.cmdCancelClick(Sender: TObject);
begin
inherited;
fCode := '';
close();
end;
procedure TfrmPCEOther.cboOtherDblClick(Sender: TObject);
begin
inherited;
cmdOKClick(Sender);
end;
procedure TfrmPCEOther.cboOtherChange(Sender: TObject);
begin
inherited;
cmdOK.Enabled := (cboOther.ItemIndex >= 0);
end;
end.

104
CPRS-Chart/Encounter/fPCEProvider.dfm Normal file
View File

@ -0,0 +1,104 @@
object frmPCEProvider: TfrmPCEProvider
Left = 192
Top = 104
BorderIcons = [biSystemMenu]
BorderStyle = bsDialog
Caption = 'Primary Encounter Provider'
ClientHeight = 254
ClientWidth = 317
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
Position = poScreenCenter
OnCreate = FormCreate
PixelsPerInch = 96
TextHeight = 13
object Spacer1: TLabel
Left = 0
Top = 0
Width = 317
Height = 13
Align = alTop
end
object lblMsg: TMemo
Left = 0
Top = 13
Width = 317
Height = 29
TabStop = False
Align = alTop
Alignment = taCenter
BorderStyle = bsNone
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = [fsBold]
Lines.Strings = (
'Primary Provider for this Encounter')
ParentFont = False
ReadOnly = True
TabOrder = 4
end
object cboPrimary: TORComboBox
Left = 6
Top = 69
Width = 307
Height = 180
Style = orcsSimple
AutoSelect = True
Caption = 'Primary Provider for this Encounter'
Color = clWindow
DropDownCount = 8
ItemHeight = 13
ItemTipColor = clWindow
ItemTipEnable = True
ListItemsOnly = True
LongList = True
LookupPiece = 2
MaxLength = 0
Pieces = '2,3'
Sorted = False
SynonymChars = '<>'
TabOrder = 0
TabStop = True
Visible = False
OnChange = cboPrimaryChange
OnNeedData = cboPrimaryNeedData
CharsNeedMatch = 1
end
object btnYes: TButton
Left = 158
Top = 40
Width = 75
Height = 21
Caption = '&Yes'
Default = True
ModalResult = 6
TabOrder = 1
end
object btnNo: TButton
Left = 238
Top = 40
Width = 75
Height = 21
Cancel = True
Caption = '&No'
ModalResult = 7
TabOrder = 2
end
object btnSelect: TButton
Left = 6
Top = 40
Width = 90
Height = 21
Caption = '&Select Primary'
TabOrder = 3
OnClick = btnSelectClick
end
end

187
CPRS-Chart/Encounter/fPCEProvider.pas Normal file
View File

@ -0,0 +1,187 @@
unit fPCEProvider;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ORCtrls, ExtCtrls, uPCE, ORFn;
type
TfrmPCEProvider = class(TForm)
cboPrimary: TORComboBox;
lblMsg: TMemo;
btnYes: TButton;
btnNo: TButton;
btnSelect: TButton;
Spacer1: TLabel;
procedure cboPrimaryNeedData(Sender: TObject; const StartFrom: String;
Direction, InsertAt: Integer);
procedure cboPrimaryChange(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure btnSelectClick(Sender: TObject);
private
FPCEData: TPCEData;
FUseDefault: boolean;
FIEN: array[boolean] of Int64;
FName: array[boolean] of string;
public
procedure AskUser(ForceSelect: boolean);
end;
function NoPrimaryPCEProvider(AProviders: TPCEProviderList; PCEData: TPCEData): boolean;
implementation
uses rCore, uCore, rTIU, rPCE;
{$R *.DFM}
const
AreYouStr = 'Are You, ';
PEPStr2 = ' the Primary Provider for this Encounter';
PEPStr = PEPStr2 + '?';
IsStr = 'Is ';
SelectStr = 'Please Select' + PEPStr2 + '.';
function NoPrimaryPCEProvider(AProviders: TPCEProviderList; PCEData: TPCEData): boolean;
var
frmPCEProvider: TfrmPCEProvider;
idx: integer;
b: boolean;
X: string;
mr: TModalResult;
begin
if(AProviders.PrimaryIdx < 0) then
SetDefaultProvider(AProviders, PCEData);
if(AProviders.PrimaryIdx < 0) then
begin
frmPCEProvider := TfrmPCEProvider.Create(Application);
try
with frmPCEProvider do
begin
FPCEData := PCEData;
for b := FALSE to TRUE do
begin
FIEN[b] := AProviders.PendingIEN(b);
FName[b] := AProviders.PendingNAME(b);
end;
if(FIEN[TRUE] = 0) and (FIEN[FALSE] = 0) then
begin
AskUser(TRUE);
mr := ModalResult;
end
else
begin
FUseDefault := TRUE;
AskUser(FALSE);
mr := ModalResult;
if((mr in [mrAbort, mrNo]) and (FIEN[TRUE] <> FIEN[FALSE])) then
begin
FUseDefault := FALSE;
AskUser(FALSE);
mr := ModalResult;
end;
end;
if (mr = mrYes) then
begin
AProviders.AddProvider(IntToStr(FIEN[FUseDefault]), FName[FUseDefault], TRUE);
end
else
if (mr = mrOK) then
begin
idx := cboPrimary.ItemIndex;
if(idx >= 0) then
begin
X := frmPCEProvider.cboPrimary.Items[idx];
AProviders.AddProvider(Piece(X, U, 1), Piece(X, U, 2), TRUE);
end;
end;
end;
finally
frmPCEProvider.Free;
end;
Result := (AProviders.PrimaryIdx < 0);
end
else
Result := FALSE;
end;
{ TfrmPCEProvider }
procedure TfrmPCEProvider.cboPrimaryNeedData(Sender: TObject;
const StartFrom: String; Direction, InsertAt: Integer);
begin
if(FPCEData.VisitCategory = 'E') then
cboPrimary.ForDataUse(SubSetOfPersons(StartFrom, Direction))
else
cboPrimary.ForDataUse(SubSetOfUsersWithClass(StartFrom, Direction,
FloatToStr(FPCEData.PersonClassDate)));
end;
procedure TfrmPCEProvider.cboPrimaryChange(Sender: TObject);
var
txt: string;
begin
if(cboPrimary.ItemIEN <> 0) and (FPCEData.VisitCategory <> 'E') then
begin
txt := InvalidPCEProviderTxt(cboPrimary.ItemIEN, FPCEData.PersonClassDate);
if(txt <> '') then
begin
InfoBox(cboPrimary.DisplayText[cboPrimary.ItemIndex] + txt, TX_BAD_PROV, MB_OK);
cboPrimary.ItemIndex := -1;
end;
end;
end;
procedure TfrmPCEProvider.FormCreate(Sender: TObject);
begin
ResizeAnchoredFormToFont(self);
ClientHeight := cboPrimary.Top;
end;
procedure TfrmPCEProvider.btnSelectClick(Sender: TObject);
begin
ClientHeight := cboPrimary.Top + cboPrimary.Height + 5;
cboPrimary.Visible := TRUE;
btnSelect.Visible := FALSE;
btnYes.Caption := '&OK';
btnYes.ModalResult := mrOK;
btnNo.Caption := '&Cancel';
btnNo.ModalResult := mrCancel;
lblMsg.Text := SelectStr;
cboPrimary.Caption := lblMsg.Text;
cboPrimary.InitLongList(User.Name);
end;
procedure TfrmPCEProvider.AskUser(ForceSelect: boolean);
var
msg: string;
begin
if(ForceSelect) then
begin
btnSelectClick(Self);
end
else
begin
if(FIEN[FUseDefault] = 0) then
begin
ModalResult := mrAbort;
exit;
end
else
begin
if(FIEN[FUseDefault] = User.DUZ) then
msg := AreYouStr + FName[FUseDefault] + ',' + PEPStr
else
msg := IsStr + FName[FUseDefault] + PEPStr;
end;
lblMsg.text := msg;
cboPrimary.Caption := lblMsg.text;
end;
ShowModal;
end;
end.

99
CPRS-Chart/Encounter/fPatientEd.dfm Normal file
View File

@ -0,0 +1,99 @@
inherited frmPatientEd: TfrmPatientEd
Left = 275
Top = 267
Caption = 'Patient Education'
PixelsPerInch = 96
TextHeight = 13
object lblUnderstanding: TLabel [0]
Left = 490
Top = 264
Width = 112
Height = 13
Caption = 'Level Of Understanding'
end
inherited lblSection: TLabel
Width = 123
Caption = 'Patient Education Section'
end
inherited btnOK: TBitBtn
TabOrder = 6
end
inherited btnCancel: TBitBtn
TabOrder = 7
end
inherited pnlGrid: TPanel
TabOrder = 1
inherited lbGrid: TORListBox
Tag = 60
Caption = 'Selected Patient Educations'
Pieces = '1,2'
end
inherited hcGrid: THeaderControl
Sections = <
item
ImageIndex = -1
MinWidth = 124
Text = 'Level of Understanding'
Width = 124
end
item
ImageIndex = -1
MinWidth = 150
Text = 'Selected Patient Educations'
Width = 150
end>
end
end
inherited edtComment: TCaptionEdit
TabOrder = 3
end
inherited btnRemove: TButton
TabOrder = 5
end
inherited btnSelectAll: TButton
TabOrder = 2
TabStop = True
end
inherited pnlMain: TPanel
TabOrder = 0
inherited lbxSection: TORListBox
Tag = 60
end
inherited pnlLeft: TPanel
inherited lbSection: TORListBox
Tag = 60
TabOrder = 0
Caption = 'Patient Education Section'
end
inherited btnOther: TButton
Tag = 22
Caption = 'Other Education Topic...'
TabOrder = 1
end
end
end
object cboPatUnderstanding: TORComboBox
Tag = 40
Left = 490
Top = 280
Width = 121
Height = 21
Style = orcsDropDown
AutoSelect = True
Caption = 'Level Of Understanding'
Color = clWindow
DropDownCount = 8
Enabled = False
ItemHeight = 13
ItemTipColor = clWindow
ItemTipEnable = True
ListItemsOnly = False
LongList = False
MaxLength = 0
Pieces = '2'
Sorted = False
SynonymChars = '<>'
TabOrder = 4
OnChange = cboPatUnderstandingChange
end
end

123
CPRS-Chart/Encounter/fPatientEd.pas Normal file
View File

@ -0,0 +1,123 @@
unit fPatientEd;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
fPCEBase, StdCtrls, ORCtrls, CheckLst, ExtCtrls, Buttons, uPCE, rPCE, ORFn,
fPCELex, fPCEOther, ComCtrls, fPCEBaseMain;
type
TfrmPatientEd = class(TfrmPCEBaseMain)
lblUnderstanding: TLabel;
cboPatUnderstanding: TORComboBox;
procedure cboPatUnderstandingChange(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
protected
procedure UpdateNewItemStr(var x: string); override;
procedure UpdateControls; override;
public
end;
var
frmPatientEd: TfrmPatientEd;
implementation
{$R *.DFM}
uses
fEncounterFrame;
{///////////////////////////////////////////////////////////////////////////////
//Name:procedure tfrmPatientEd.cboPatUnderstandingChange(Sender: TObject);
//Created: Jan 1999
//By: Robert Bott
//Location: ISL
//Description:Change the level of understanding assigned to the education item.
///////////////////////////////////////////////////////////////////////////////}
procedure tfrmPatientEd.cboPatUnderstandingChange(Sender: TObject);
var
i: integer;
begin
if(NotUpdating) and (cboPatUnderstanding.Text <> '') then
begin
for i := 0 to lbGrid.Items.Count-1 do
if(lbGrid.Selected[i]) then
TPCEPat(lbGrid.Items.Objects[i]).Level := cboPatUnderstanding.ItemID;
GridChanged;
end;
end;
procedure TfrmPatientEd.FormCreate(Sender: TObject);
begin
inherited;
FTabName := CT_PedNm;
FPCEListCodesProc := ListPatientCodes;
FPCEItemClass := TPCEPat;
FPCECode := 'PED';
PCELoadORCombo(cboPatUnderstanding);
end;
procedure TfrmPatientEd.UpdateNewItemStr(var x: string);
begin
SetPiece(x, U, pnumPEDLevel, NoPCEValue);
end;
procedure TfrmPatientEd.UpdateControls;
var
ok, First: boolean;
SameLOU: boolean;
i: integer;
LOU: string;
Obj: TPCEPat;
begin
inherited;
if(NotUpdating) then
begin
BeginUpdate;
try
ok := (lbGrid.SelCount > 0);
lblUnderstanding.Enabled := ok;
cboPatUnderstanding.Enabled := ok;
if(ok) then
begin
First := TRUE;
SameLOU := TRUE;
LOU := NoPCEValue;
for i := 0 to lbGrid.Items.Count-1 do
begin
if lbGrid.Selected[i] then
begin
Obj := TPCEPat(lbGrid.Items.Objects[i]);
if(First) then
begin
First := FALSE;
LOU := Obj.Level;
end
else
begin
if(SameLOU) then
SameLOU := (LOU = Obj.Level);
end;
end;
end;
if(SameLOU) then
cboPatUnderstanding.SelectByID(LOU)
else
cboPatUnderstanding.Text := '';
end
else
begin
cboPatUnderstanding.Text := '';
end;
finally
EndUpdate;
end;
end;
end;
end.

202
CPRS-Chart/Encounter/fProcedure.dfm Normal file
View File

@ -0,0 +1,202 @@
inherited frmProcedures: TfrmProcedures
Left = 295
Top = 212
Caption = 'Encounter Procedure'
PixelsPerInch = 96
TextHeight = 13
object lblProcQty: TLabel [0]
Left = 240
Top = 375
Width = 39
Height = 13
Caption = 'Quantity'
end
inherited lblSection: TLabel
Width = 88
Caption = 'Procedure Section'
end
inherited lblList: TLabel
Left = 154
end
inherited bvlMain: TBevel
Top = 232
Width = 537
Height = 166
end
object lblMod: TLabel [5]
Left = 358
Top = 6
Width = 42
Height = 13
Hint = 'Modifiers'
Caption = 'Modifiers'
ParentShowHint = False
ShowHint = True
end
object lblProvider: TLabel [6]
Left = 6
Top = 376
Width = 42
Height = 13
Caption = 'Provider:'
end
inherited btnOK: TBitBtn
Left = 544
Top = 344
TabOrder = 8
end
inherited btnCancel: TBitBtn
Top = 371
TabOrder = 9
end
inherited pnlGrid: TPanel
Width = 523
TabOrder = 1
inherited lbGrid: TORListBox
Tag = 30
Width = 523
Caption = 'Selected Procedures'
Pieces = '1,2'
end
inherited hcGrid: THeaderControl
Width = 523
Sections = <
item
ImageIndex = -1
MinWidth = 52
Text = 'Quantity'
Width = 52
end
item
ImageIndex = -1
MinWidth = 112
Text = 'Selected Procedures'
Width = 112
end>
end
end
inherited edtComment: TCaptionEdit
TabOrder = 2
end
inherited btnRemove: TButton
Left = 454
Top = 371
TabOrder = 7
end
inherited btnSelectAll: TButton
Left = 374
Top = 371
Height = 21
TabOrder = 6
TabStop = True
end
inherited pnlMain: TPanel
TabOrder = 0
inherited splLeft: TSplitter
Left = 145
end
object splRight: TSplitter [1]
Left = 349
Top = 0
Width = 3
Height = 204
Cursor = crHSplit
Align = alRight
OnMoved = splRightMoved
end
inherited lbxSection: TORListBox
Tag = 30
Left = 148
Width = 201
ItemHeight = 14
Pieces = '2,3'
end
inherited pnlLeft: TPanel
Width = 145
inherited lbSection: TORListBox
Tag = 30
Width = 145
TabOrder = 0
end
inherited btnOther: TButton
Tag = 13
Left = 3
Caption = 'Other Procedure...'
TabOrder = 1
end
end
object lbMods: TORListBox
Left = 352
Top = 0
Width = 260
Height = 204
Style = lbOwnerDrawFixed
Align = alRight
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
ItemHeight = 14
ParentFont = False
ParentShowHint = False
ShowHint = True
TabOrder = 2
Caption = 'Modifiers'
ItemTipColor = clWindow
LongList = False
Pieces = '2,3'
TabPosInPixels = True
CheckBoxes = True
CheckEntireLine = True
OnClickCheck = lbModsClickCheck
end
end
object spnProcQty: TUpDown
Left = 348
Top = 371
Width = 15
Height = 21
Associate = txtProcQty
Min = 1
Position = 1
TabOrder = 5
Wrap = False
end
object txtProcQty: TCaptionEdit
Left = 288
Top = 371
Width = 60
Height = 21
Enabled = False
TabOrder = 4
Text = '1'
OnChange = txtProcQtyChange
Caption = 'Quantity'
end
object cboProvider: TORComboBox
Left = 56
Top = 371
Width = 177
Height = 21
Style = orcsDropDown
AutoSelect = True
Caption = 'Provider'
Color = clWindow
DropDownCount = 8
ItemHeight = 13
ItemTipColor = clWindow
ItemTipEnable = True
ListItemsOnly = True
LongList = True
LookupPiece = 2
MaxLength = 0
Pieces = '2,3'
Sorted = False
SynonymChars = '<>'
TabOrder = 3
TabStop = True
OnChange = cboProviderChange
OnNeedData = cboProviderNeedData
end
end

539
CPRS-Chart/Encounter/fProcedure.pas Normal file
View File

@ -0,0 +1,539 @@
unit fProcedure;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
fPCEBase, StdCtrls, ComCtrls, CheckLst, ORCtrls, ExtCtrls, Buttons, uPCE, rPCE, ORFn,
fPCELex, fPCEOther, fPCEBaseGrid, fPCEBaseMain;
type
TfrmProcedures = class(TfrmPCEBaseMain)
lblProcQty: TLabel;
spnProcQty: TUpDown;
txtProcQty: TCaptionEdit;
lbMods: TORListBox;
splRight: TSplitter;
lblMod: TLabel;
cboProvider: TORComboBox;
lblProvider: TLabel;
procedure txtProcQtyChange(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormResize(Sender: TObject); override;
procedure splRightMoved(Sender: TObject);
procedure clbListClick(Sender: TObject);
procedure lbGridSelect(Sender: TObject);
procedure btnSelectAllClick(Sender: TObject);
procedure lbModsClickCheck(Sender: TObject; Index: Integer);
procedure lbSectionClick(Sender: TObject);
procedure lbxSectionClickCheck(Sender: TObject; Index: Integer);
procedure btnOtherClick(Sender: TObject);
procedure btnRemoveClick(Sender: TObject);
procedure cboProviderNeedData(Sender: TObject; const StartFrom: String;
Direction, InsertAt: Integer);
procedure cboProviderChange(Sender: TObject);
private
FCheckingCode: boolean;
FCheckingMods: boolean;
FLastCPTCodes: string;
FModsReadOnly: boolean;
FModsROChecked: string;
function MissingProvider: boolean;
protected
procedure UpdateNewItemStr(var x: string); override;
procedure UpdateControls; override;
procedure ShowModifiers;
procedure CheckModifiers;
public
function OK2SaveProcedures: boolean;
procedure InitTab(ACopyProc: TCopyItemsMethod; AListProc: TListSectionsProc);
end;
var
frmProcedures: TfrmProcedures;
implementation
{$R *.DFM}
uses
fEncounterFrame, uConst, rCore;
const
TX_PROC_PROV = 'Each procedure requires selection of a Provider before it can be saved.';
TC_PROC_PROV = 'Missing Procedure Provider';
procedure TfrmProcedures.txtProcQtyChange(Sender: TObject);
var
i: integer;
begin
if(NotUpdating) then
begin
for i := 0 to lbGrid.Items.Count-1 do
if(lbGrid.Selected[i]) then
TPCEProc(lbGrid.Items.Objects[i]).Quantity := spnProcQty.Position;
GridChanged;
end;
end;
procedure TfrmProcedures.cboProviderChange(Sender: TObject);
var
i: integer;
begin
inherited;
if(NotUpdating) then
begin
for i := 0 to lbGrid.Items.Count-1 do
if(lbGrid.Selected[i]) then
TPCEProc(lbGrid.Items.Objects[i]).Provider := cboProvider.ItemIEN;
GridChanged;
end;
end;
procedure TfrmProcedures.FormCreate(Sender: TObject);
begin
inherited;
FTabName := CT_ProcNm;
FPCEListCodesProc := ListProcedureCodes;
cboProvider.InitLongList(uProviders.PCEProviderName);
FPCEItemClass := TPCEProc;
FPCECode := 'CPT';
FSectionTabCount := 1;
FormResize(Self);
end;
procedure TfrmProcedures.UpdateNewItemStr(var x: string);
begin
SetPiece(x, U, pnumProcQty, '1');
//x := x + U + '1';
end;
procedure TfrmProcedures.UpdateControls;
var
ok, First: boolean;
SameQty: boolean;
SameProv: boolean;
i: integer;
Qty: integer;
Prov: int64;
Obj: TPCEProc;
begin
inherited;
if(NotUpdating) then
begin
BeginUpdate;
try
ok := (lbGrid.SelCount > 0);
lblProcQty.Enabled := ok;
txtProcQty.Enabled := ok;
spnProcQty.Enabled := ok;
cboProvider.Enabled := ok;
lblProvider.Enabled := ok;
if(ok) then
begin
First := TRUE;
SameQty := TRUE;
SameProv := TRUE;
Prov := 0;
Qty := 1;
for i := 0 to lbGrid.Items.Count-1 do
begin
if lbGrid.Selected[i] then
begin
Obj := TPCEProc(lbGrid.Items.Objects[i]);
if(First) then
begin
First := FALSE;
Qty := Obj.Quantity;
Prov := Obj.Provider;
end
else
begin
if(SameQty) then
SameQty := (Qty = Obj.Quantity);
if(SameProv) then
SameProv := (Prov = Obj.Provider);
end;
end;
end;
if(SameQty) then
begin
spnProcQty.Position := Qty;
txtProcQty.Text := IntToStr(Qty);
txtProcQty.SelStart := length(txtProcQty.Text);
end
else
begin
spnProcQty.Position := 1;
txtProcQty.Text := '';
end;
if(SameProv) then
cboProvider.SetExactByIEN(Prov, ExternalName(Prov, 200))
else
cboProvider.SetExactByIEN(uProviders.PCEProvider, uProviders.PCEProviderName);
//cboProvider.ItemIndex := -1; v22.8 - RV
end
else
begin
txtProcQty.Text := '';
cboProvider.ItemIndex := -1;
end;
// ShowModifiers;
finally
EndUpdate;
end;
end;
end;
procedure TfrmProcedures.FormResize(Sender: TObject);
var
v, i: integer;
s: string;
begin
inherited;
FSectionTabs[0] := -(lbxSection.width - LBCheckWidthSpace - MainFontWidth - ScrollBarWidth);
UpdateTabPos;
v := (lbMods.width - LBCheckWidthSpace - (4*MainFontWidth) - ScrollBarWidth);
s := '';
for i := 1 to 20 do
begin
if s <> '' then s := s + ',';
s := s + inttostr(v);
if(v<0) then
dec(v,32)
else
inc(v,32);
end;
lbMods.TabPositions := s;
end;
procedure TfrmProcedures.splRightMoved(Sender: TObject);
begin
inherited;
lblMod.Left := lbMods.Left + pnlMain.Left;
FSplitterMove := TRUE;
FormResize(Sender);
end;
procedure TfrmProcedures.clbListClick(Sender: TObject);
begin
inherited;
Sync2Section;
UpdateControls;
ShowModifiers;
end;
procedure TfrmProcedures.lbGridSelect(Sender: TObject);
begin
inherited;
Sync2Grid;
ShowModifiers;
end;
procedure TfrmProcedures.btnSelectAllClick(Sender: TObject);
begin
inherited;
Sync2Grid;
ShowModifiers;
end;
procedure TfrmProcedures.ShowModifiers;
const
ModTxt = 'Modifiers';
ForTxt = ' for ';
Spaces = ' ';
CommonTxt = ' Common to Multiple Procedures';
var
i, TopIdx: integer;
// Needed,
Codes, ProcName, Hint, Msg: string;
Proc: TPCEProc;
begin
if(not NotUpdating) then exit;
Codes := '';
ProcName := '';
Hint := '';
// Needed := '';
for i := 0 to lbGrid.Items.Count-1 do
begin
if(lbGrid.Selected[i]) then
begin
Proc := TPCEProc(lbGrid.Items.Objects[i]);
Codes := Codes + Proc.Code + U;
if(ProcName = '') then
ProcName := Proc.Narrative
else
ProcName := CommonTxt;
if(Hint <> '') then
Hint := Hint + CRLF + Spaces;
Hint := Hint + Proc.Narrative;
// Needed := Needed + Proc.Modifiers;
end;
end;
if(Codes = '') and (lbxSection.ItemIndex >= 0) then
begin
Codes := piece(lbxSection.Items[lbxSection.ItemIndex],U,1) + U;
ProcName := piece(lbxSection.Items[lbxSection.ItemIndex],U,2);
Hint := ProcName;
// Needed := piece(lbxSection.Items[lbxSection.ItemIndex],U,4); Don't show expired codes!
end;
msg := ModTxt;
if(ProcName <> '') and (ProcName <> CommonTxt) then
msg := msg + ForTxt;
lblMod.Caption := msg + ProcName;
if(pos(CRLF,Hint)>0) then
Hint := ':' + CRLF + Spaces + Hint;
lblMod.Hint := msg + Hint;
if(FLastCPTCodes = Codes) then
TopIdx := lbMods.TopIndex
else
begin
TopIdx := 0;
FLastCPTCodes := Codes;
end;
ListCPTModifiers(lbMods.Items, Codes, ''); // Needed);
lbMods.TopIndex := TopIdx;
CheckModifiers;
end;
procedure TfrmProcedures.CheckModifiers;
var
i, idx, cnt, mcnt: integer;
Code, Mods: string;
state: TCheckBoxState;
begin
FModsReadOnly := TRUE;
if lbMods.Items.Count < 1 then exit;
FCheckingMods := TRUE;
try
cnt := 0;
Mods := ';';
for i := 0 to lbGrid.Items.Count-1 do
begin
if(lbGrid.Selected[i]) then
begin
inc(cnt);
Mods := Mods + TPCEProc(lbGrid.Items.Objects[i]).Modifiers;
FModsReadOnly := FALSE;
end;
end;
if(cnt = 0) and (lbxSection.ItemIndex >= 0) then
begin
Mods := ';' + UpdateModifierList(lbxSection.Items, lbxSection.ItemIndex);
cnt := 1;
end;
for i := 0 to lbMods.Items.Count-1 do
begin
state := cbUnchecked;
if(cnt > 0) then
begin
Code := ';' + piece(lbMods.Items[i], U, 1) + ';';
mcnt := 0;
repeat
idx := pos(Code, Mods);
if(idx > 0) then
begin
inc(mcnt);
delete(Mods, idx, length(Code) - 1);
end;
until (idx = 0);
if mcnt >= cnt then
State := cbChecked
else
if(mcnt > 0) then
State := cbGrayed;
end;
lbMods.CheckedState[i] := state;
end;
if FModsReadOnly then
begin
FModsROChecked := lbMods.CheckedString;
lbMods.Font.Color := clInactiveCaption;
end
else
lbMods.Font.Color := clWindowText;
finally
FCheckingMods := FALSE;
end;
end;
procedure TfrmProcedures.lbModsClickCheck(Sender: TObject; Index: Integer);
var
i, idx: integer;
PCEObj: TPCEProc;
ModIEN: string;
DoChk, Add: boolean;
begin
if FCheckingMods or (Index < 0) then exit;
if FModsReadOnly then
begin
lbMods.CheckedString := FModsROChecked;
exit;
end;
if(NotUpdating) then
begin
BeginUpdate;
try
DoChk := FALSE;
Add := (lbMods.Checked[Index]);
ModIEN := piece(lbMods.Items[Index],U,1) + ';';
for i := 0 to lbGrid.Items.Count-1 do
begin
if(lbGrid.Selected[i]) then
begin
PCEObj := TPCEProc(lbGrid.Items.Objects[i]);
idx := pos(';' + ModIEN, ';' + PCEObj.Modifiers);
if(idx > 0) then
begin
if not Add then
begin
delete(PCEObj.Modifiers, idx, length(ModIEN));
DoChk := TRUE;
end;
end
else
begin
if Add then
begin
PCEObj.Modifiers := PCEObj.Modifiers + ModIEN;
DoChk := TRUE;
end;
end;
end;
end;
finally
EndUpdate;
end;
if DoChk then
GridChanged;
end;
end;
procedure TfrmProcedures.lbSectionClick(Sender: TObject);
begin
inherited;
ShowModifiers;
end;
procedure TfrmProcedures.lbxSectionClickCheck(Sender: TObject;
Index: Integer);
var
i: integer;
begin
if FCheckingCode then exit;
FCheckingCode := TRUE;
try
inherited;
Sync2Grid;
if(lbxSection.ItemIndex >= 0) and (lbxSection.ItemIndex = Index) and
(lbxSection.Checked[Index]) then
begin
UpdateModifierList(lbxSection.Items, Index);
lbxSection.Checked[Index] := TRUE;
for i := 0 to lbGrid.Items.Count-1 do
begin
if(lbGrid.Selected[i]) then
with TPCEProc(lbGrid.Items.Objects[i]) do
begin
if(Category = GetCat) and
(Pieces(lbxSection.Items[Index], U, 1, 2) = Code + U + Narrative) then
begin
{ TODO -oRich V. -cEncounters : v21/22 - Added this block to default provider for procedures.}
if Provider = 0 then Provider := uProviders.PCEProvider;
{ uPCE.TPCEProviderList.PCEProvider function sorts this out automatically: }
{ 1. Current CPRS encounter provider, if present and has active person class as of encounter date. }
{ 2. Current user, if has active person class as of encounter date. }
{ 3. Primary provider for the visit, if defined. }
{ 4. No default. }
Modifiers := Piece(lbxSection.Items[lbxSection.ItemIndex], U, 4);
GridChanged;
exit;
end;
end;
end;
end;
finally
FCheckingCode := FALSE;
end;
end;
procedure TfrmProcedures.btnOtherClick(Sender: TObject);
begin
inherited;
Sync2Grid;
ShowModifiers;
end;
procedure TfrmProcedures.btnRemoveClick(Sender: TObject);
begin
inherited;
Sync2Grid;
ShowModifiers;
end;
procedure TfrmProcedures.cboProviderNeedData(Sender: TObject;
const StartFrom: String; Direction, InsertAt: Integer);
begin
inherited;
if(uEncPCEData.VisitCategory = 'E') then
cboProvider.ForDataUse(SubSetOfPersons(StartFrom, Direction))
else
cboProvider.ForDataUse(SubSetOfUsersWithClass(StartFrom, Direction,
FloatToStr(uEncPCEData.PersonClassDate)));
end;
function TfrmProcedures.OK2SaveProcedures: boolean;
begin
Result := TRUE;
if MissingProvider then
begin
InfoBox(TX_PROC_PROV, TC_PROC_PROV, MB_OK or MB_ICONWARNING);
Result := False;
end;
end;
function TfrmProcedures.MissingProvider: boolean;
var
i: integer;
AProc: TPCEProc;
begin
{ TODO -oRich V. -cEncounters : {v21 - Entry of a provider for each new CPT is now required}
{Existing CPTs on the encounter will NOT require entry of a provider}
{Monitor status of new service request #20020203.}
Result := False;
{ Comment out the block below (and the "var" block above) }
{ to allow but not require entry of a provider with each new CPT entered}
//------------------------------------------------
for i := 0 to lbGrid.Items.Count - 1 do
begin
AProc := TPCEProc(lbGrid.Items.Objects[i]);
if AProc.fIsOldProcedure then continue;
if (AProc.Provider = 0) then
begin
Result := True;
lbGrid.ItemIndex := i;
exit;
end;
end;
//-------------------------------------------------
end;
procedure TfrmProcedures.InitTab(ACopyProc: TCopyItemsMethod; AListProc: TListSectionsProc);
var
i: integer;
begin
inherited;
for i := 0 to lbGrid.Items.Count - 1 do
TPCEProc(lbGrid.Items.Objects[i]).fIsOldProcedure := True;
end;
end.

171
CPRS-Chart/Encounter/fSkinTest.dfm Normal file
View File

@ -0,0 +1,171 @@
inherited frmSkinTests: TfrmSkinTests
Left = 213
Top = 163
Caption = 'Encounter Skin Test form'
PixelsPerInch = 96
TextHeight = 13
object lblSkinResults: TLabel [0]
Left = 490
Top = 244
Width = 35
Height = 13
Caption = 'Results'
end
object lblDTRead: TLabel [1]
Left = 46
Top = 380
Width = 52
Height = 13
Caption = 'Date Read'
Visible = False
end
object lblReading: TLabel [2]
Left = 490
Top = 290
Width = 40
Height = 13
Caption = 'Reading'
end
object lblDTGiven: TLabel [3]
Left = 216
Top = 380
Width = 54
Height = 13
Caption = 'Date Given'
Visible = False
end
inherited lblSection: TLabel
Width = 84
Caption = 'Skin Test Section'
end
inherited btnOK: TBitBtn
TabOrder = 10
end
inherited btnCancel: TBitBtn
TabOrder = 11
end
inherited pnlGrid: TPanel
TabOrder = 1
inherited lbGrid: TORListBox
Tag = 50
Caption = 'Selected Skin Tests'
Pieces = '1,2,3'
end
inherited hcGrid: THeaderControl
Sections = <
item
ImageIndex = -1
MinWidth = 50
Text = 'Results'
Width = 55
end
item
ImageIndex = -1
MinWidth = 55
Text = 'Reading'
Width = 55
end
item
ImageIndex = -1
Text = 'Selected Skin Tests'
Width = 110
end>
end
end
inherited edtComment: TCaptionEdit
TabOrder = 3
end
inherited btnRemove: TButton
TabOrder = 7
end
inherited btnSelectAll: TButton
TabOrder = 2
TabStop = True
end
inherited pnlMain: TPanel
TabOrder = 0
inherited lbxSection: TORListBox
Tag = 50
end
inherited pnlLeft: TPanel
inherited lbSection: TORListBox
Tag = 50
TabOrder = 0
Caption = 'Skin Test Section'
end
inherited btnOther: TButton
Tag = 21
Caption = 'Other Skin Test...'
TabOrder = 1
end
end
end
object UpDnReading: TUpDown
Left = 531
Top = 304
Width = 15
Height = 21
Associate = EdtReading
Min = 0
Max = 40
Position = 0
TabOrder = 6
Wrap = False
OnChanging = UpDnReadingChanging
end
object EdtReading: TCaptionEdit
Left = 490
Top = 304
Width = 41
Height = 21
Enabled = False
TabOrder = 5
Text = '0'
OnChange = EdtReadingChange
Caption = 'Reading'
end
object edtDtRead: TCaptionEdit
Left = 104
Top = 376
Width = 97
Height = 21
TabOrder = 8
Text = 'edtDtRead'
Visible = False
Caption = 'Date Read'
end
object edtDTGiven: TCaptionEdit
Left = 280
Top = 376
Width = 81
Height = 21
TabOrder = 9
Text = 'edtDTGiven'
Visible = False
Caption = 'Date Given'
end
object cboSkinResults: TORComboBox
Tag = 30
Left = 490
Top = 260
Width = 121
Height = 21
Style = orcsDropDown
AutoSelect = True
Caption = 'Results'
Color = clWindow
DropDownCount = 8
Enabled = False
ItemHeight = 13
ItemTipColor = clWindow
ItemTipEnable = True
ListItemsOnly = False
LongList = False
MaxLength = 0
Pieces = '2'
Sorted = False
SynonymChars = '<>'
TabOrder = 4
OnChange = cboSkinResultsChange
end
end

248
CPRS-Chart/Encounter/fSkinTest.pas Normal file
View File

@ -0,0 +1,248 @@
unit fSkinTest;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
fPCEBase, ORCtrls, StdCtrls, ComCtrls, CheckLst, ExtCtrls, Buttons, uPCE, rPCE, ORFn,
fPCELex, fPCEOther, rCore, fPCEBaseMain;
type
TfrmSkinTests = class(TfrmPCEBaseMain)
lblSkinResults: TLabel;
lblDTRead: TLabel;
lblReading: TLabel;
lblDTGiven: TLabel;
UpDnReading: TUpDown;
EdtReading: TCaptionEdit;
edtDtRead: TCaptionEdit;
edtDTGiven: TCaptionEdit;
cboSkinResults: TORComboBox;
procedure cboSkinResultsChange(Sender: TObject);
procedure EdtReadingChange(Sender: TObject);
procedure edtDtReadChange(Sender: TObject);
procedure edtDTGivenChange(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure UpDnReadingChanging(Sender: TObject;
var AllowChange: Boolean);
private
protected
procedure UpdateNewItemStr(var x: string); override;
procedure UpdateControls; override;
public
end;
var
frmSkinTests: TfrmSkinTests;
implementation
{$R *.DFM}
uses
fEncounterFrame;
procedure TfrmSkinTests.cboSkinResultsChange(Sender: TObject);
var
i: integer;
begin
if(NotUpdating) and (cboSkinResults.Text <> '') then
begin
for i := 0 to lbGrid.Items.Count-1 do
if(lbGrid.Selected[i]) then
TPCESkin(lbGrid.Items.Objects[i]).Results := cboSkinResults.ItemID;
GridChanged;
end;
end;
{///////////////////////////////////////////////////////////////////////////////
//Name:procedure TfrmSkinTests.EdtReadingChange(Sender: TObject);
//Created: Jan 1999
//By: Robert Bott
//Location: ISL
//Description:Change the reading assigned to the skin test.
///////////////////////////////////////////////////////////////////////////////}
procedure TfrmSkinTests.EdtReadingChange(Sender: TObject);
var
x, i: integer;
begin
if(NotUpdating) then
begin
x := StrToIntDef(EdtReading.Text, 0);
for i := 0 to lbGrid.Items.Count-1 do
if(lbGrid.Selected[i]) then
TPCESkin(lbGrid.Items.Objects[i]).Reading := x;
GridChanged;
end;
end;
procedure TfrmSkinTests.edtDtReadChange(Sender: TObject);
begin
end;
(*
var
DtRead: TFMDateTime;
ASkinTest: TPCESkin;
begin
inherited;
if lstSkinSelect.ItemIndex < 0 then Exit;
with lstSkinSelect do ASkinTest := TPCESkin(Items.Objects[ItemIndex]);
DtRead := StrToFMDateTime(edtReading.text);
with lstSkinSelect do if (ItemIndex > -1) then
begin
ASkinTest.DTRead := DTRead;
Items[ItemIndex] := ASkinTest.ItemStr;
end;
end;
*)
procedure TfrmSkinTests.edtDTGivenChange(Sender: TObject);
begin
end;
(*
var
DtGiven: TFMDateTime;
ASkinTest: TPCESkin;
begin
inherited;
if lstSkinSelect.ItemIndex < 0 then Exit;
with lstSkinSelect do ASkinTest := TPCESkin(Items.Objects[ItemIndex]);
DtGiven := StrToFMDateTime(edtDTGiven.text);
with lstSkinSelect do if (ItemIndex > -1) then
begin
ASkinTest.DTGiven := DTGIven;
Items[ItemIndex] := ASkinTest.ItemStr;
end;
end;
*)
(*
procedure TfrmSkinTests.CheckSkinRules;
begin
//Results must be between 0 and 40
if StrToInt(EdtReading.Text) < 0 then EdtReading.text := '0';
if StrToInt(EdtReading.Text) > 40 then EdtReading.text := '40';
(* //if reading >10, result must be "positive"
if (StrToInt(EdtReading.Text) > 9) and
(CompareText(Piece(cboSkinResults.items[cboSkinResults.itemindex],U,1),'P') <> 0) then
begin
if (Piece(cboSkinResults.items[cboSkinResults.itemindex],U,1) = '@') then // not selected
begin
cboSkinResults.SelectById('P');
end
else
begin
Showmessage('If the reading is over 9, the results are required to be positive.');
cboSkinResults.SelectById('P');
end;
end;
end;
*)
procedure TfrmSkinTests.FormCreate(Sender: TObject);
begin
inherited;
FTabName := CT_SkinNm;
FPCEListCodesProc := ListSkinCodes;
FPCEItemClass := TPCESkin;
FPCECode := 'SK';
PCELoadORCombo(cboSkinResults);
end;
procedure TfrmSkinTests.UpdateNewItemStr(var x: string);
begin
SetPiece(x, U, pnumSkinResults, NoPCEValue);
SetPiece(x, U, pnumSkinReading, '0');
// SetPiece(x, U, pnumSkinDTRead);
// SetPiece(x, U, pnumSkinDTGiven);
end;
procedure TfrmSkinTests.UpdateControls;
var
ok, First: boolean;
SameRes, SameRead: boolean;
i: integer;
Res: string;
Read: integer;
Obj: TPCESkin;
begin
inherited;
if(NotUpdating) then
begin
BeginUpdate;
try
ok := (lbGrid.SelCount > 0);
lblSkinResults.Enabled := ok;
lblReading.Enabled := ok;
cboSkinResults.Enabled := ok;
EdtReading.Enabled := ok;
UpDnReading.Enabled := ok;
if(ok) then
begin
First := TRUE;
SameRes := TRUE;
SameRead := TRUE;
Res := NoPCEValue;
Read := 0;
for i := 0 to lbGrid.Items.Count-1 do
begin
if lbGrid.Selected[i] then
begin
Obj := TPCESkin(lbGrid.Items.Objects[i]);
if(First) then
begin
First := FALSE;
Res := Obj.Results;
Read := Obj.Reading;
end
else
begin
if(SameRes) then
SameRes := (Res = Obj.Results);
if(SameRead) then
SameRead := (Read = Obj.Reading);
end;
end;
end;
if(SameRes) then
cboSkinResults.SelectByID(Res)
else
cboSkinResults.Text := '';
if(SameRead) then
begin
UpDnReading.Position := Read;
EdtReading.Text := IntToStr(Read);
EdtReading.SelStart := length(EdtReading.Text);
end
else
begin
UpDnReading.Position := 0;
EdtReading.Text := '';
end;
end
else
begin
cboSkinResults.Text := '';
EdtReading.Text := '';
end;
finally
EndUpdate;
end;
end;
end;
procedure TfrmSkinTests.UpDnReadingChanging(Sender: TObject;
var AllowChange: Boolean);
begin
inherited;
if(UpDnReading.Position = 0) then
EdtReadingChange(Sender);
end;
end.

255
CPRS-Chart/Encounter/fVisitType.dfm Normal file
View File

@ -0,0 +1,255 @@
inherited frmVisitType: TfrmVisitType
Left = 255
Top = 186
Caption = 'Encounter VisitType'
ClientWidth = 620
OnCloseQuery = FormCloseQuery
OnResize = FormResize
PixelsPerInch = 96
TextHeight = 13
object lblVType: TLabel [0]
Left = 150
Top = 6
Width = 67
Height = 13
Caption = 'Section Name'
end
object lblSCDisplay: TLabel [1]
Left = 6
Top = 123
Width = 186
Height = 13
Caption = 'Service Connection && Rated Disabilities'
end
object lblVTypeSection: TLabel [2]
Left = 6
Top = 6
Width = 58
Height = 13
Caption = 'Type of Visit'
end
object lblCurrentProv: TLabel [3]
Left = 277
Top = 249
Width = 165
Height = 13
Caption = 'Current providers for this encounter'
end
object lblProvider: TLabel [4]
Left = 6
Top = 249
Width = 89
Height = 13
Caption = 'Available providers'
end
object lblMod: TLabel [5]
Left = 358
Top = 6
Width = 42
Height = 13
Hint = 'Modifiers'
Caption = 'Modifiers'
ParentShowHint = False
ShowHint = True
end
inherited btnOK: TBitBtn
Left = 463
Top = 377
TabOrder = 8
end
inherited btnCancel: TBitBtn
Left = 543
Top = 377
TabOrder = 9
end
object pnlMain: TPanel
Left = 2
Top = 19
Width = 615
Height = 92
BevelOuter = bvNone
TabOrder = 0
object splLeft: TSplitter
Left = 145
Top = 0
Width = 3
Height = 92
Cursor = crHSplit
OnMoved = splLeftMoved
end
object splRight: TSplitter
Left = 352
Top = 0
Width = 3
Height = 92
Cursor = crHSplit
Align = alRight
OnMoved = splRightMoved
end
object pnlLeft: TPanel
Left = 0
Top = 0
Width = 145
Height = 92
Align = alLeft
BevelOuter = bvNone
TabOrder = 0
object lstVTypeSection: TORListBox
Tag = 10
Left = 0
Top = 0
Width = 145
Height = 92
Align = alTop
ItemHeight = 13
ParentShowHint = False
ShowHint = True
TabOrder = 0
OnClick = lstVTypeSectionClick
Caption = 'Type of Visit'
ItemTipColor = clWindow
LongList = False
Pieces = '3'
CheckEntireLine = True
end
end
object lbxVisits: TORListBox
Tag = 10
Left = 148
Top = 0
Width = 204
Height = 92
Style = lbOwnerDrawFixed
Align = alClient
ItemHeight = 16
ParentShowHint = False
ShowHint = True
TabOrder = 1
OnClick = lbxVisitsClick
Caption = 'Section Name'
ItemTipColor = clWindow
LongList = False
Pieces = '3,4,5'
TabPosInPixels = True
CheckBoxes = True
CheckEntireLine = True
OnClickCheck = lbxVisitsClickCheck
end
object lbMods: TORListBox
Left = 355
Top = 0
Width = 260
Height = 92
Style = lbOwnerDrawFixed
Align = alRight
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
ItemHeight = 14
ParentFont = False
ParentShowHint = False
ShowHint = True
TabOrder = 2
Caption = 'Modifiers'
ItemTipColor = clWindow
LongList = False
Pieces = '2,3'
TabPosInPixels = True
CheckBoxes = True
CheckEntireLine = True
OnClickCheck = lbModsClickCheck
end
end
object memSCDisplay: TCaptionMemo
Left = 6
Top = 137
Width = 411
Height = 107
Color = clBtnFace
Lines.Strings = (
'')
ScrollBars = ssVertical
TabOrder = 1
Caption = 'Service Connection && Rated Disabilities'
end
object lbProviders: TORListBox
Left = 277
Top = 265
Width = 183
Height = 126
ItemHeight = 13
ParentShowHint = False
ShowHint = True
TabOrder = 7
OnDblClick = lbProvidersDblClick
Caption = 'Current providers for this encounter'
ItemTipColor = clWindow
LongList = False
Pieces = '2'
OnChange = lbProvidersChange
CheckEntireLine = True
end
object cboPtProvider: TORComboBox
Left = 6
Top = 265
Width = 183
Height = 126
Style = orcsSimple
AutoSelect = True
Caption = 'Available providers'
Color = clWindow
DropDownCount = 8
ItemHeight = 13
ItemTipColor = clWindow
ItemTipEnable = True
ListItemsOnly = True
LongList = True
LookupPiece = 2
MaxLength = 0
Pieces = '2,3'
Sorted = False
SynonymChars = '<>'
TabOrder = 3
TabStop = True
CheckEntireLine = True
OnChange = cboPtProviderChange
OnDblClick = cboPtProviderDblClick
OnNeedData = cboPtProviderNeedData
end
object btnAdd: TButton
Left = 196
Top = 275
Width = 75
Height = 21
Caption = 'Add'
TabOrder = 4
OnClick = btnAddClick
end
object btnDelete: TButton
Left = 196
Top = 307
Width = 75
Height = 21
Caption = 'Remove'
TabOrder = 5
OnClick = btnDeleteClick
end
object btnPrimary: TButton
Left = 196
Top = 355
Width = 75
Height = 21
Caption = 'Primary'
TabOrder = 6
OnClick = btnPrimaryClick
end
inline fraVisitRelated: TfraVisitRelated
Left = 426
Top = 112
Width = 192
Height = 137
TabOrder = 2
end
end

535
CPRS-Chart/Encounter/fVisitType.pas Normal file
View File

@ -0,0 +1,535 @@
unit fVisitType;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
fPCEBase, StdCtrls, CheckLst, ORCtrls, ExtCtrls, Buttons, uPCE, rPCE, ORFn, rCore,
ComCtrls, mVisitRelated;
type
TfrmVisitType = class(TfrmPCEBase)
lblVType: TLabel;
lblSCDisplay: TLabel;
lblVTypeSection: TLabel;
memSCDisplay: TCaptionMemo;
lbProviders: TORListBox;
lblCurrentProv: TLabel;
cboPtProvider: TORComboBox;
lblProvider: TLabel;
btnAdd: TButton;
btnDelete: TButton;
btnPrimary: TButton;
fraVisitRelated: TfraVisitRelated;
lstVTypeSection: TORListBox;
lbxVisits: TORListBox;
lbMods: TORListBox;
lblMod: TLabel;
pnlMain: TPanel;
pnlLeft: TPanel;
splLeft: TSplitter;
procedure lstVTypeSectionClick(Sender: TObject);
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
procedure FormCreate(Sender: TObject);
procedure btnAddClick(Sender: TObject);
procedure btnDeleteClick(Sender: TObject);
procedure btnPrimaryClick(Sender: TObject);
procedure cboPtProviderDblClick(Sender: TObject);
procedure cboPtProviderChange(Sender: TObject);
procedure cboPtProviderNeedData(Sender: TObject;
const StartFrom: String; Direction, InsertAt: Integer);
procedure lbProvidersChange(Sender: TObject);
procedure lbProvidersDblClick(Sender: TObject);
procedure FormResize(Sender: TObject);
procedure lbxVisitsClickCheck(Sender: TObject; Index: Integer);
procedure splLeftMoved(Sender: TObject);
procedure splRightMoved(Sender: TObject);
procedure lbModsClickCheck(Sender: TObject; Index: Integer);
procedure lbxVisitsClick(Sender: TObject);
protected
FSplitterMove: boolean;
procedure ShowModifiers;
procedure CheckModifiers;
private
FChecking: boolean;
FCheckingMods: boolean;
FLastCPTCodes: string;
FLastMods: string;
procedure RefreshProviders;
procedure UpdateProviderButtons;
public
procedure MatchVType;
end;
var
frmVisitType: TfrmVisitType;
USCchecked:boolean = false;
// PriProv: Int64;
PriProv: Int64;
const
LBCheckWidthSpace = 18;
implementation
{$R *.DFM}
uses
fEncounterFrame, uCore, uConst;
const
FN_NEW_PERSON = 200;
procedure TfrmVisitType.MatchVType;
var
i: Integer;
Found: Boolean;
begin
with uVisitType do
begin
if Code = '' then Exit;
Found := False;
with lstVTypeSection do for i := 0 to Items.Count - 1 do
if Piece(Items[i], U, 2) = Category then
begin
ItemIndex := i;
lstVTypeSectionClick(Self);
Found := True;
break;
end;
if Found then for i := 0 to lbxVisits.Items.Count - 1 do
if Pieces(lbxVisits.Items[i], U, 1, 2) = Code + U + Narrative then
begin
lbxVisits.ItemIndex := i;
FChecking := TRUE;
try
lbxVisits.Checked[i] := True;
lbxVisitsClickCheck(Self, i);
finally
FChecking := FALSE;
end;
end;
end;
end;
procedure TfrmVisitType.lstVTypeSectionClick(Sender: TObject);
var
i: Integer;
begin
inherited;
ListVisitTypeCodes(lbxVisits.Items, lstVTypeSection.ItemIEN);
with uVisitType do for i := 0 to lbxVisits.Items.Count - 1 do
begin
if ((uVisitType <> nil) and (Pieces(lbxVisits.Items[i], U, 1, 2) = Code + U + Narrative)) then
begin
FChecking := TRUE;
try
lbxVisits.Checked[i] := True;
lbxVisits.ItemIndex := i;
finally
FChecking := FALSE;
end;
end;
end;
lbxVisitsClick(Self);
end;
procedure TfrmVisitType.FormCloseQuery(Sender: TObject;
var CanClose: Boolean);
begin
inherited;
//process before closing
end;
(*function ExposureAnswered: Boolean;
begin
result := false;
//if SC answered set result = true
end;*)
procedure TfrmVisitType.RefreshProviders;
var
i: integer;
ProvData: TPCEProviderRec;
ProvEntry: string;
begin
lbProviders.Clear;
for i := 0 to uProviders.count-1 do
begin
ProvData := uProviders[i];
ProvEntry := IntToStr(ProvData.IEN) + U + ProvData.Name;
if(ProvData.Primary) then
ProvEntry := ProvEntry + ' (Primary)';
lbProviders.Items.Add(ProvEntry);
end;
UpdateProviderButtons;
end;
procedure TfrmVisitType.FormCreate(Sender: TObject);
var
AIEN: Int64;
begin
inherited;
FTabName := CT_VisitNm;
FSectionTabCount := 2;
FormResize(Self);
AIEN := uProviders.PendingIEN(TRUE);
if(AIEN = 0) then
begin
AIEN := uProviders.PendingIEN(FALSE);
if(AIEN = 0) then
begin
cboPtProvider.InitLongList(User.Name);
AIEN := User.DUZ;
end
else
cboPtProvider.InitLongList(uProviders.PendingName(FALSE));
cboPtProvider.SelectByIEN(AIEN);
end
else
begin
cboPtProvider.InitLongList(uProviders.PendingName(TRUE));
cboPtProvider.SelectByIEN(AIEN);
end;
RefreshProviders;
FLastMods := uEncPCEData.VisitType.Modifiers;
end;
(*procedure TfrmVisitType.SynchEncounterProvider;
// add the Encounter.Provider if this note is for the current encounter
var
ProviderFound, PrimaryFound: Boolean;
i: Integer;
AProvider: TPCEProvider;
begin
if (FloatToStrF(uEncPCEData.DateTime, ffFixed, 15, 4) = // compensate rounding errors
FloatToStrF(Encounter.DateTime, ffFixed, 15, 4)) and
(uEncPCEData.Location = Encounter.Location) and
(Encounter.Provider > 0) then
begin
ProviderFound := False;
PrimaryFound := False;
for i := 0 to ProviderLst.Count - 1 do
begin
AProvider := TPCEProvider(ProviderLst.Items[i]);
if AProvider.IEN = Encounter.Provider then ProviderFound := True;
if AProvider.Primary = '1' then PrimaryFound := True;
end;
if not ProviderFound then
begin
AProvider := TPCEProvider.Create;
AProvider.IEN := Encounter.Provider;
AProvider.Name := ExternalName(Encounter.Provider, FN_NEW_PERSON);
if not PrimaryFound then
begin
AProvider.Primary := '1';
uProvider := Encounter.Provider;
end
else AProvider.Primary := '0';
AProvider.Delete := False;
ProviderLst.Add(AProvider);
end;
end;
end;
*)
procedure TfrmVisitType.UpdateProviderButtons;
var
ok: boolean;
begin
ok := (lbProviders.ItemIndex >= 0);
btnDelete.Enabled := ok;
btnPrimary.Enabled := ok;
btnAdd.Enabled := (cboPtProvider.ItemIEN <> 0);
end;
procedure TfrmVisitType.btnAddClick(Sender: TObject);
begin
inherited;
uProviders.AddProvider(IntToStr(cboPTProvider.ItemIEN), cboPTProvider.Text, FALSE);
RefreshProviders;
lbProviders.SelectByIEN(cboPTProvider.ItemIEN);
end;
procedure TfrmVisitType.btnDeleteClick(Sender: TObject);
var
idx: integer;
begin
inherited;
If lbProviders.ItemIndex = -1 then exit;
idx := uProviders.IndexOfProvider(lbProviders.ItemID);
if(idx >= 0) then
uProviders.Delete(idx);
RefreshProviders;
end;
procedure TfrmVisitType.btnPrimaryClick(Sender: TObject);
var
idx: integer;
AIEN: Int64;
begin
inherited;
if lbProviders.ItemIndex = -1 then exit;
AIEN := lbProviders.ItemIEN;
idx := uProviders.IndexOfProvider(IntToStr(AIEN));
if(idx >= 0) then
uProviders.PrimaryIdx := idx;
RefreshProviders;
lbProviders.SelectByIEN(AIEN);
end;
procedure TfrmVisitType.cboPtProviderDblClick(Sender: TObject);
begin
inherited;
btnAddClick(Sender);
end;
procedure TfrmVisitType.cboPtProviderChange(Sender: TObject);
begin
inherited;
UpdateProviderButtons;
end;
procedure TfrmVisitType.cboPtProviderNeedData(Sender: TObject;
const StartFrom: String; Direction, InsertAt: Integer);
begin
inherited;
if(uEncPCEData.VisitCategory = 'E') then
cboPtProvider.ForDataUse(SubSetOfPersons(StartFrom, Direction))
else
cboPtProvider.ForDataUse(SubSetOfUsersWithClass(StartFrom, Direction,
FloatToStr(uEncPCEData.PersonClassDate)));
end;
procedure TfrmVisitType.lbProvidersChange(Sender: TObject);
begin
inherited;
UpdateProviderButtons;
end;
procedure TfrmVisitType.lbProvidersDblClick(Sender: TObject);
begin
inherited;
btnDeleteClick(Sender);
end;
procedure TfrmVisitType.FormResize(Sender: TObject);
var
v, i: integer;
s: string;
begin
if FSplitterMove then
FSplitterMove := FALSE
else
begin
inherited;
FSectionTabs[0] := -(lbxVisits.width - LBCheckWidthSpace - MainFontWidth - ScrollBarWidth);
FSectionTabs[1] := -(lbxVisits.width - (6*MainFontWidth) - ScrollBarWidth);
if(FSectionTabs[0] <= FSectionTabs[1]) then FSectionTabs[0] := FSectionTabs[1]+2;
lbxVisits.TabPositions := SectionString;
v := (lbMods.width - LBCheckWidthSpace - (4*MainFontWidth) - ScrollBarWidth);
s := '';
for i := 1 to 20 do
begin
if s <> '' then s := s + ',';
s := s + inttostr(v);
if(v<0) then
dec(v,32)
else
inc(v,32);
end;
lbMods.TabPositions := s;
end;
end;
procedure TfrmVisitType.lbxVisitsClickCheck(Sender: TObject;
Index: Integer);
var
i: Integer;
x, CurCategory: string;
begin
inherited;
if FChecking or FClosing then exit;
for i := 0 to lbxVisits.Items.Count - 1 do
if i <> lbxVisits.ItemIndex then
begin
FChecking := TRUE;
try
uVisitType.Modifiers := '';
lbxVisits.Checked[i] := False;
finally
FChecking := FALSE;
end;
end;
if lbxVisits.Checked[lbxVisits.ItemIndex] then with uVisitType do
begin
with lstVTypeSection do CurCategory := Piece(Items[ItemIndex], U, 2);
x := Pieces(lbxVisits.Items[lbxVisits.ItemIndex], U, 1, 2);
x := 'CPT' + U + Piece(x, U, 1) + U + CurCategory + U + Piece(x, U, 2) + U + '1' + U
+ IntToStr(uProviders.PrimaryIEN);
// + IntToStr(uProvider);
uVisitType.SetFromString(x);
end
else
begin
uVisitType.Clear;
//with lstVTypeSection do CurCategory := Piece(Items[ItemIndex], U, 2);
end;
end;
procedure TfrmVisitType.ShowModifiers;
const
ModTxt = 'Modifiers';
ForTxt = ' for ';
Spaces = ' ';
var
TopIdx: integer;
// Needed,
Codes, VstName, Hint, Msg: string;
begin
Codes := '';
VstName := '';
Hint := '';
if(Codes = '') and (lbxVisits.ItemIndex >= 0) then
begin
Codes := piece(lbxVisits.Items[lbxVisits.ItemIndex],U,1) + U;
VstName := piece(lbxVisits.Items[lbxVisits.ItemIndex],U,2);
Hint := VstName;
// Needed := piece(lbxVisit.Items[lbxVisit.ItemIndex],U,4); Don't show expired codes!
end;
msg := ModTxt;
if(VstName <> '') then
msg := msg + ForTxt;
lblMod.Caption := msg + VstName;
lbMods.Caption := lblMod.Caption;
if(pos(CRLF,Hint)>0) then
Hint := ':' + CRLF + Spaces + Hint;
lblMod.Hint := msg + Hint;
if(FLastCPTCodes = Codes) then
TopIdx := lbMods.TopIndex
else
begin
TopIdx := 0;
FLastCPTCodes := Codes;
end;
ListCPTModifiers(lbMods.Items, Codes, ''); // Needed);
lbMods.TopIndex := TopIdx;
CheckModifiers;
end;
procedure TfrmVisitType.CheckModifiers;
var
i, idx, cnt, mcnt: integer;
Code, Mods: string;
state: TCheckBoxState;
begin
if lbMods.Items.Count < 1 then exit;
FCheckingMods := TRUE;
try
cnt := 0;
Mods := ';';
if uVisitType.Modifiers <> '' then
begin
inc(cnt);
Mods := Mods + uVisitType.Modifiers;
end;
if(cnt = 0) and (lbxVisits.ItemIndex >= 0) then
begin
Mods := ';' + UpdateVisitTypeModifierList(lbxVisits.Items, lbxVisits.ItemIndex);
lbxVisits.Checked[lbxVisits.ItemIndex] := True;
cnt := 1;
end;
for i := 0 to lbMods.Items.Count-1 do
begin
state := cbUnchecked;
if(cnt > 0) then
begin
Code := ';' + piece(lbMods.Items[i], U, 1) + ';';
mcnt := 0;
repeat
idx := pos(Code, Mods);
if(idx > 0) then
begin
inc(mcnt);
delete(Mods, idx, length(Code) - 1);
end;
until (idx = 0);
if mcnt >= cnt then
State := cbChecked
else
if(mcnt > 0) then
State := cbGrayed;
end;
lbMods.CheckedState[i] := state;
end;
finally
FCheckingMods := FALSE;
end;
end;
procedure TfrmVisitType.splLeftMoved(Sender: TObject);
begin
inherited;
lblVType.Left := lbxVisits.Left + pnlMain.Left;
FSplitterMove := TRUE;
FormResize(Sender);
end;
procedure TfrmVisitType.splRightMoved(Sender: TObject);
begin
inherited;
lblMod.Left := lbMods.Left + pnlMain.Left;
FSplitterMove := TRUE;
FormResize(Sender);
end;
procedure TfrmVisitType.lbModsClickCheck(Sender: TObject; Index: Integer);
var
idx: integer;
ModIEN: string;
Add: boolean;
begin
if FCheckingMods or (Index < 0) then exit;
Add := (lbMods.Checked[Index]);
ModIEN := piece(lbMods.Items[Index],U,1) + ';';
idx := pos(';' + ModIEN, ';' + uVisitType.Modifiers);
if(idx > 0) then
begin
if not Add then
begin
delete(uVisitType.Modifiers, idx, length(ModIEN));
end;
end
else
begin
if Add then
begin
uVisitType.Modifiers := uVisitType.Modifiers + ModIEN;
end;
end;
end;
procedure TfrmVisitType.lbxVisitsClick(Sender: TObject);
begin
inherited;
ShowModifiers;
end;
initialization
//frmVisitType.CreateProviderList;
finalization
//frmVisitType.FreeProviderList;
end.

175
CPRS-Chart/Encounter/mVisitRelated.dfm Normal file
View File

@ -0,0 +1,175 @@
object fraVisitRelated: TfraVisitRelated
Left = 0
Top = 0
Width = 192
Height = 136
TabOrder = 0
object bvlSCFrame: TBevel
Left = 0
Top = 14
Width = 191
Height = 119
Shape = bsFrame
end
object lblSCYes: TStaticText
Left = 3
Top = 0
Width = 22
Height = 13
AutoSize = False
Caption = 'Yes'
TabOrder = 14
end
object lblSCNo: TStaticText
Left = 26
Top = 0
Width = 18
Height = 13
AutoSize = False
Caption = 'No'
TabOrder = 15
end
object lblSCSelect: TStaticText
Left = 44
Top = 0
Width = 131
Height = 13
Alignment = taCenter
AutoSize = False
Caption = 'Visit Related To'
TabOrder = 16
end
object chkSCYes: TCheckBox
Tag = 1
Left = 6
Top = 17
Width = 16
Height = 17
TabOrder = 0
OnClick = chkClick
end
object chkAOYes: TCheckBox
Tag = 2
Left = 6
Top = 49
Width = 16
Height = 17
TabOrder = 4
OnClick = chkClick
end
object chkIRYes: TCheckBox
Tag = 3
Left = 6
Top = 65
Width = 16
Height = 17
TabOrder = 6
OnClick = chkClick
end
object chkECYes: TCheckBox
Tag = 4
Left = 6
Top = 81
Width = 16
Height = 17
TabOrder = 8
OnClick = chkClick
end
object chkMSTYes: TCheckBox
Tag = 5
Left = 6
Top = 97
Width = 16
Height = 17
TabOrder = 10
OnClick = chkClick
end
object chkMSTNo: TCheckBox
Tag = 15
Left = 26
Top = 97
Width = 160
Height = 17
Caption = 'MST'
TabOrder = 11
OnClick = chkClick
end
object chkECNo: TCheckBox
Tag = 14
Left = 26
Top = 81
Width = 160
Height = 17
Caption = 'Environmental Contaminants'
TabOrder = 9
OnClick = chkClick
end
object chkIRNo: TCheckBox
Tag = 13
Left = 26
Top = 65
Width = 160
Height = 17
Caption = 'Ionizing Radiation Exposure'
TabOrder = 7
OnClick = chkClick
end
object chkAONo: TCheckBox
Tag = 12
Left = 26
Top = 49
Width = 160
Height = 17
Caption = 'Agent Orange Exposure'
TabOrder = 5
OnClick = chkClick
end
object chkSCNo: TCheckBox
Tag = 11
Left = 26
Top = 17
Width = 160
Height = 17
Caption = 'Service Connected Condition'
TabOrder = 1
OnClick = chkClick
end
object chkHNCYes: TCheckBox
Tag = 6
Left = 6
Top = 113
Width = 16
Height = 17
TabOrder = 12
OnClick = chkClick
end
object chkHNCNo: TCheckBox
Tag = 16
Left = 26
Top = 113
Width = 160
Height = 17
Caption = 'Head and/or Neck Cancer'
TabOrder = 13
OnClick = chkClick
end
object chkCVYes: TCheckBox
Tag = 7
Left = 6
Top = 33
Width = 16
Height = 17
TabOrder = 2
OnClick = chkClick
end
object chkCVNo: TCheckBox
Tag = 17
Left = 26
Top = 33
Width = 160
Height = 17
Caption = 'Combat Vet (Combat Related)'
TabOrder = 3
OnClick = chkClick
end
end

228
CPRS-Chart/Encounter/mVisitRelated.pas Normal file
View File

@ -0,0 +1,228 @@
unit mVisitRelated;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls, rPCE, uPCE;
type
TfraVisitRelated = class(TFrame)
lblSCYes: TStaticText;
lblSCNo: TStaticText;
lblSCSelect: TStaticText;
bvlSCFrame: TBevel;
chkSCYes: TCheckBox;
chkAOYes: TCheckBox;
chkIRYes: TCheckBox;
chkECYes: TCheckBox;
chkMSTYes: TCheckBox;
chkMSTNo: TCheckBox;
chkECNo: TCheckBox;
chkIRNo: TCheckBox;
chkAONo: TCheckBox;
chkSCNo: TCheckBox;
chkHNCYes: TCheckBox;
chkHNCNo: TCheckBox;
chkCVYes: TCheckBox;
chkCVNo: TCheckBox;
procedure chkClick(Sender: TObject);
private
FSCCond: TSCConditions;
procedure SetCheckEnable(CheckYes, CheckNo: TCheckBox; Allow: Boolean);
procedure SetCheckState(CheckYes, CheckNo: TCheckBox; CheckState: Integer);
function GetCheckState(CheckYes, CheckNo: TCheckBox): Integer;
public
constructor Create(AOwner: TComponent); override;
procedure GetRelated(PCEData: TPCEData); overload;
procedure GetRelated(var ASCRelated, AAORelated, AIRRelated,
AECRelated, AMSTRelated, AHNCRelated, ACVRelated: integer); overload;
procedure InitAllow(SCCond: TSCConditions);
procedure InitRelated(PCEData: TPCEData); overload;
procedure InitRelated(const ASCRelated, AAORelated, AIRRelated,
AECRelated, AMSTRelated, AHNCRelated, ACVRelated: integer); overload;
end;
implementation
{$R *.DFM}
const
TAG_SCYES = 1;
TAG_AOYES = 2;
TAG_IRYES = 3;
TAG_ECYES = 4;
TAG_MSTYES = 5;
TAG_HNCYES = 6;
TAG_CVYES = 7;
TAG_SCNO = 11;
TAG_AONO = 12;
TAG_IRNO = 13;
TAG_ECNO = 14;
TAG_MSTNO = 15;
TAG_HNCNO = 16;
TAG_CVNO = 17;
procedure TfraVisitRelated.chkClick(Sender: TObject);
procedure DisableCheck(ACheckBox: TCheckBox);
begin
ACheckBox.Checked := False; ACheckBox.Enabled := False;
end;
begin
inherited;
if Sender is TCheckBox then with TCheckBox(Sender) do case Tag of
TAG_SCYES: if Checked then chkSCNo.Checked := False;
TAG_AOYES: if Checked then chkAONo.Checked := False;
TAG_IRYES: if Checked then chkIRNo.Checked := False;
TAG_ECYES: if Checked then chkECNo.Checked := False;
TAG_MSTYES: if Checked then chkMSTNo.Checked := False;
TAG_HNCYES: if Checked then chkHNCNo.Checked := False;
TAG_CVYES: if Checked then chkCVNo.Checked := False;
TAG_SCNO: if Checked then chkSCYes.Checked := False;
TAG_AONO: if Checked then chkAOYes.Checked := False;
TAG_IRNO: if Checked then chkIRYes.Checked := False;
TAG_ECNO: if Checked then chkECYes.Checked := False;
TAG_MSTNO: if Checked then chkMSTYes.Checked := False;
TAG_HNCNO: if Checked then chkHNCYes.Checked := False;
TAG_CVNO: if Checked then chkCVYes.Checked := False;
end;
if chkSCYes.Checked then
begin
DisableCheck(chkAOYes);
DisableCheck(chkIRYes);
DisableCheck(chkECYes);
// DisableCheck(chkMSTYes);
DisableCheck(chkAONo);
DisableCheck(chkIRNo);
DisableCheck(chkECNo);
// DisableCheck(chkMSTNo);
end else
begin
SetCheckEnable(chkSCYes, chkSCNo, FSCCond.SCAllow);
SetCheckEnable(chkAOYes, chkAONo, FSCCond.AOAllow);
SetCheckEnable(chkIRYes, chkIRNo, FSCCond.IRAllow);
SetCheckEnable(chkECYes, chkECNo, FSCCond.ECAllow);
end;
SetCheckEnable(chkMSTYes, chkMSTNo, FSCCond.MSTAllow);
SetCheckEnable(chkHNCYes, chkHNCNo, FSCCond.HNCAllow);
SetCheckEnable(chkCVYes, chkCVNo, FSCCond.CVAllow);
if chkAOYes.Checked or chkIRYes.Checked or chkECYes.Checked then //or chkMSTYes.Checked then
begin
chkSCYes.Checked := False;
chkSCNo.Checked := True;
end;
end;
constructor TfraVisitRelated.Create(AOwner: TComponent);
begin
inherited;
lblSCYes.Height := 13;
lblSCNo.Height := 13;
// chkHNCYes.Visible := HNCOK;
// chkHNCNo.Visible := HNCOK;
// if not HNCOK then
// begin
// height := height - chkHNCYes.height + 1;
// bvlSCFrame.height := bvlSCFrame.height - chkHNCYes.height + 1;
// end;
end;
function TfraVisitRelated.GetCheckState(CheckYes, CheckNo: TCheckBox): Integer;
begin
Result := SCC_NA;
if CheckYes.Enabled and CheckYes.Checked then Result := SCC_YES;
if CheckNo.Enabled and CheckNo.Checked then Result := SCC_NO;
end;
procedure TfraVisitRelated.GetRelated(PCEData: TPCEData);
begin
PCEData.SCRelated := GetCheckState(chkSCYes, chkSCNo);
PCEData.AORelated := GetCheckState(chkAOYes, chkAONo);
PCEData.IRRelated := GetCheckState(chkIRYes, chkIRNo);
PCEData.ECRelated := GetCheckState(chkECYes, chkECNo);
PCEData.MSTRelated := GetCheckState(chkMSTYes, chkMSTNo);
PCEData.HNCRelated := GetCheckState(chkHNCYes, chkHNCNo);
PCEData.CVRelated := GetCheckState(chkCVYes, chkCVNo);
end;
procedure TfraVisitRelated.GetRelated(var ASCRelated, AAORelated,
AIRRelated, AECRelated, AMSTRelated, AHNCRelated, ACVRelated: integer);
begin
ASCRelated := GetCheckState(chkSCYes, chkSCNo);
AAORelated := GetCheckState(chkAOYes, chkAONo);
AIRRelated := GetCheckState(chkIRYes, chkIRNo);
AECRelated := GetCheckState(chkECYes, chkECNo);
AMSTRelated := GetCheckState(chkMSTYes, chkMSTNo);
AHNCRelated := GetCheckState(chkHNCYes, chkHNCNo);
ACVRelated := GetCheckState(chkCVYes, chkCVNo);
end;
procedure TfraVisitRelated.InitAllow(SCCond: TSCConditions);
begin
FSCCond := SCCond;
with FSCCond do
begin
SetCheckEnable(chkSCYes, chkSCNo, SCAllow);
SetCheckEnable(chkAOYes, chkAONo, AOAllow);
SetCheckEnable(chkIRYes, chkIRNo, IRAllow);
SetCheckEnable(chkECYes, chkECNo, ECAllow);
SetCheckEnable(chkMSTYes, chkMSTNo, MSTAllow);
SetCheckEnable(chkHNCYes, chkHNCNo, HNCAllow);
SetCheckEnable(chkCVYes, chkCVNo, CVAllow);
end;
end;
procedure TfraVisitRelated.InitRelated(PCEData: TPCEData);
begin
SetCheckState(chkSCYes, chkSCNo, PCEData.SCRelated);
SetCheckState(chkAOYes, chkAONo, PCEData.AORelated);
SetCheckState(chkIRYes, chkIRNo, PCEData.IRRelated);
SetCheckState(chkECYes, chkECNo, PCEData.ECRelated);
SetCheckState(chkMSTYes, chkMSTNo, PCEData.MSTRelated);
SetCheckState(chkHNCYes, chkHNCNo, PCEData.HNCRelated);
SetCheckState(chkCVYes, chkCVNo, PCEData.CVRelated);
end;
procedure TfraVisitRelated.InitRelated(const ASCRelated, AAORelated, AIRRelated,
AECRelated, AMSTRelated, AHNCRelated, ACVRelated: integer);
begin
SetCheckState(chkSCYes, chkSCNo, ASCRelated);
SetCheckState(chkAOYes, chkAONo, AAORelated);
SetCheckState(chkIRYes, chkIRNo, AIRRelated);
SetCheckState(chkECYes, chkECNo, AECRelated);
SetCheckState(chkMSTYes, chkMSTNo, AMSTRelated);
SetCheckState(chkHNCYes, chkHNCNo, AHNCRelated);
SetCheckState(chkCVYes, chkCVNo, ACVRelated);
end;
procedure TfraVisitRelated.SetCheckEnable(CheckYes, CheckNo: TCheckBox;
Allow: Boolean);
begin
CheckYes.Enabled := Allow;
CheckNo.Enabled := Allow;
end;
procedure TfraVisitRelated.SetCheckState(CheckYes, CheckNo: TCheckBox; CheckState: Integer);
begin
if CheckYes.Enabled then
case CheckState of
SCC_NA: begin
CheckYes.Checked := False;
CheckNo.Checked := False;
end;
SCC_NO: begin
CheckYes.Checked := False;
CheckNo.Checked := True;
end;
SCC_YES: begin
CheckYes.Checked := True;
CheckNo.Checked := False;
end;
end; {case}
chkClick(Self);
end;
end.

1492
CPRS-Chart/Encounter/rPCE.pas Normal file
View File

File diff suppressed because it is too large Load Diff

3548
CPRS-Chart/Encounter/uPCE.pas Normal file
View File

File diff suppressed because it is too large Load Diff

BIN
CPRS-Chart/Images/Alarm.bmp Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 310 B

Some files were not shown because too many files have changed in this diff Show More