Summary Table

Categories Total Count
PII 0
URL 0
DNS 0
EKL 0
IP 0
PORT 0
VsID 0
CF 0
AI 0
VPD 0
PL 0
Other 0

File Content

unit ORNet;

interface

uses
SysUtils,
Windows,
Classes,
Forms,
Controls,
ORFn,
TRPCB,
RPCConf1;

procedure SetBrokerServer(const AName: string; APort: Integer; WantDebug: boolean);
function AuthorizedOption(const OptionName: string): boolean;
function ConnectToServer(const OptionName: string): boolean;
function MRef(glvn: string): string;
procedure CallV(const RPCName: string; const aParam: array of const);
function sCallV(const RPCName: string; const aParam: array of const): string;
procedure tCallV(ReturnData: TStrings; const RPCName: string; const aParam: array of const);
function UpdateContext(NewContext: string): boolean;
function IsBaseContext: boolean;
procedure CallBrokerInContext(aReturn: TStrings = nil);
procedure CallBroker(aReturn: TStrings = nil);
function RetainedRPCCount: Integer;
procedure SetRetainedRPCMax(Value: Integer);
function GetRPCMax: Integer;
procedure LoadRPCData(Dest: TStrings; ID: Integer);
function DottedIPStr: string;
procedure CallRPCWhenIdle(CallProc: TORIdleCallProc; Msg: string);
function ShowRPCList: boolean;
procedure EnsureBroker;

// =========== Backward Compatiable Code ===========//
procedure SetRPCFlaged(Value: string);
function GetRPCFlaged: string;
// ================================================//

function CallVistA(const aRPCName: string; const aParam: array of const): boolean; overload;
function CallVistA(const aRPCName: string; const aParam: array of const; aReturn: TStrings): boolean; overload;
function CallVistA(const aRPCName: string; const aParam: array of const; var aReturn: string; aDefault: string = ''): boolean; overload;
function CallVistA(const aRPCName: string; const aParam: array of const; var aReturn: Double; aDefault: Double = 0.0): boolean; overload;
function CallVistA(const aRPCName: string; const aParam: array of const; var aReturn: Integer; aDefault: Integer = 0): boolean; overload;

var
RPCBrokerV: TRPCBroker;
RPCLastCall: string;
AppStartedCursorForm: TForm = nil;

type
TAfterRPCEvent = procedure() of object;

procedure SetAfterRPCEvent(Value: TAfterRPCEvent);

implementation

uses
ORNetIntf,
Winsock;

const
// *** these are constants from RPCBErr.pas, will broker document them????
XWB_M_REJECT = 20000 + 2; // M error
XWB_BadSignOn = 20000 + 4; // SignOn 'Error' (happens when cancel pressed)
RPCBROKER_MUTEX_NAME = 'RPCBroker Mutex';

var
uCallList: TList;
uMaxCalls: Integer;
uShowRPCs: boolean;
uBaseContext: string = '';
uCurrentContext: string = '';
AfterRPCEvent: TAfterRPCEvent;

// =========== Backward Compatiable Code ===========//
fRPCFlaged: string;
// ================================================//

{ private procedures and functions ---------------------------------------------------------- }

procedure EnsureBroker;
{ ensures that a broker object has been created - creates & initializes it if necessary }
begin
if RPCBrokerV = nil then
begin
RPCBrokerV := TRPCBroker.Create(Application);
with RPCBrokerV do
begin
KernelLogIn := True;
Login.Mode := lmAppHandle;
ClearParameters := True;
ClearResults := True;
DebugMode := False;
AfterRPCEvent := nil;
end;
end;
end;

procedure SetList(AStringList: TStrings; ParamIndex: Integer);
{ places TStrings into RPCBrokerV.Mult[n], where n is a 1-based (not 0-based) index }
var
i: Integer;
aStr: string;
begin
with RPCBrokerV.Param[ParamIndex] do
begin
PType := list;
i := 1;
for aStr in AStringList do
begin
Mult[IntToStr(i)] := aStr;
inc(i);
end;
end;
end;

procedure SetParams(const RPCName: string; const aParam: array of const);
{ takes the params (array of const) passed to xCallV and sets them into RPCBrokerV.Param[i] }
const
BoolChar: array [boolean] of char = ('0', '1');
var
i: Integer;
TmpExt: Extended;
aORNetParam: IORNetParam;
begin
RPCLastCall := RPCName + ' (SetParam begin)';
if Length(RPCName) = 0 then raise Exception.Create('No RPC Name');
EnsureBroker;
with RPCBrokerV do
begin
ClearParameters := True;
RemoteProcedure := RPCName;
for i := 0 to high(aParam) do
with aParam[i] do
begin
Param[i].PType := literal;
case VType of
vtInteger: Param[i].Value := IntToStr(VInteger);
vtBoolean: Param[i].Value := BoolChar[VBoolean];
vtChar: if VChar = #0 then
Param[i].Value := ''
else
Param[i].Value := string(VChar);
vtExtended:
begin
TmpExt := VExtended^;
if (abs(TmpExt) < 0.0000000000001) then TmpExt := 0;
Param[i].Value := FloatToStr(TmpExt);
end;
vtString: with Param[i] do
begin
Value := string(VString^);
if (Length(Value) > 0) and (Value[1] = #1) then
begin
Value := Copy(Value, 2, Length(Value));
PType := reference;
end;
end;
vtPointer: if VPointer = nil then
begin
if i=0 then
ClearParameters := True
else
Param[i].PType := empty;
end
else
raise Exception.Create('Pointer type must be nil.');
vtPChar: Param[i].Value := string(AnsiChar(VPChar));

vtInterface:
if IInterface(VInterface).QueryInterface(IORNetParam, aORNetParam) = 0 then
aORNetParam.AssignToParamRecord(Param[i]);

vtObject:
begin
if VObject is TStrings then
SetList(TStrings(VObject), i)
else if VObject.GetInterface(IORNetParam, aORNetParam) then
aORNetParam.AssignToParamRecord(Param[i]);
end;

vtWideChar: if VChar = #0 then
Param[i].Value := ''
else
Param[i].Value := string(VWideChar);
vtAnsiString: with Param[i] do
begin
Value := string(VAnsiString);
if (Length(Value) > 0) and (Value[1] = #1) then
begin
Value := Copy(Value, 2, Length(Value));
PType := reference;
end;
end;
vtInt64: Param[i].Value := IntToStr(VInt64^);
vtUnicodeString: with Param[i] do
begin
Value := string(VUnicodeString);
if (Length(Value) > 0) and (Value[1] = #1) then
begin
Value := Copy(Value, 2, Length(Value));
PType := reference;
end;
end;
else
raise Exception.Create('RPC: ' + string(RemoteProcedure) + ' Unable to pass parameter type ' + IntToStr(VType) + ' to Broker.');
end; { case }
end; { for }
end; { with }
RPCLastCall := RPCName + ' (SetParam end)';
end;

{ public procedures and functions ----------------------------------------------------------- }

function CallVistA(const aRPCName: string; const aParam: array of const): boolean; overload;
{ Call Broker, no results. i.e. POST }
var
aLst: TStringList;
begin
aLst := TStringList.Create;
try
Result := CallVistA(aRPCName, aParam, aLst);
finally
FreeAndNil(aLst);
end;
end;

function CallVistA(const aRPCName: string; const aParam: array of const; var aReturn: Integer; aDefault: Integer = 0): boolean; overload;
{ Call Broker, Result[0] in aReturn as integer }
var
aStr: string;
begin
if CallVistA(aRPCName, aParam, aStr) then
begin
aReturn := StrToIntDef(aStr, aDefault);
Result := True;
end
else
Result := False;
end;

function CallVistA(const aRPCName: string; const aParam: array of const; var aReturn: Double; aDefault: Double = 0.0): boolean; overload;
{ Call Broker, Result[0] in aReturn as Double }
var
aStr: string;
begin
if CallVistA(aRPCName, aParam, aStr) then
begin
aReturn := StrToFloatDef(aStr, aDefault);
Result := True;
end
else
Result := False;
end;

function CallVistA(const aRPCName: string; const aParam: array of const; var aReturn: string; aDefault: string = ''): boolean; overload;
{ Call Broker, Result[0] in aReturn as string }
var
aLst: TStringList;
begin
aLst := TStringList.Create;
try
Result := CallVistA(aRPCName, aParam, aLst);
if aLst.Count > 0 then
aReturn := aLst[0]
else
aReturn := '';
Result := True;
finally
FreeAndNil(aLst);
end;
end;

function CallVistA(const aRPCName: string; const aParam: array of const; aReturn: TStrings): boolean; overload;
{ Call Broker, full results in aReturn }
begin
try
Result := False;
SetParams(aRPCName, aParam);
aReturn.Clear;
CallBroker(aReturn);
Result := True;
finally
RPCBrokerV.Results.Clear;
RPCBrokerV.Param.Clear;
end;
end;

function UpdateContext(NewContext: string): boolean;
begin
if NewContext = uCurrentContext then
Result := True
else
begin
Result := RPCBrokerV.CreateContext(NewContext);
if Result then
uCurrentContext := NewContext
else
if (NewContext <> uBaseContext) and RPCBrokerV.CreateContext(uBaseContext) then
uCurrentContext := uBaseContext
else
uCurrentContext := '';
end;
end;

function IsBaseContext: boolean;
begin
Result := ((uCurrentContext = uBaseContext) or (uCurrentContext = ''));
end;

procedure CallBrokerInContext(aReturn: TStrings = nil);
var
AStringList: TStringList;
i, j: Integer;
x, y, RunString: string;
RPCStart, RPCStop, fFrequency: TLargeInteger;
dt: TDateTime;
begin
RPCLastCall := string(RPCBrokerV.RemoteProcedure) + ' (CallBroker begin)';
if uShowRPCs then StatusText(string(RPCBrokerV.RemoteProcedure));
with RPCBrokerV do
if not Connected then // happens if broker connection is lost
begin
ClearResults := True;
Exit;
end;
if uCallList.Count = uMaxCalls then
begin
AStringList := uCallList.Items[0];
AStringList.Free;
uCallList.Delete(0);
end;
AStringList := TStringList.Create;
AStringList.Add(string(RPCBrokerV.RemoteProcedure));
AStringList.Add(''); // add to the second line
if uCurrentContext <> uBaseContext then
AStringList.Add('Context: ' + uCurrentContext);
AStringList.Add(' ');
AStringList.Add('Params ------------------------------------------------------------------');
with RPCBrokerV do
for i := 0 to Param.Count - 1 do
begin
case Param[i].PType of
// global: x := 'global';
list: x := 'list';
literal: x := 'literal';
// null: x := 'null';
reference: x := 'reference';
undefined: x := 'undefined';
// wordproc: x := 'wordproc';
end;
AStringList.Add(x + #9 + Param[i].Value);
if Param[i].PType = list then
begin
for j := 0 to Param[i].Mult.Count - 1 do
begin
x := Param[i].Mult.Subscript(j);
y := Param[i].Mult[x];
AStringList.Add(#9 + '(' + x + ')=' + y);
end;
end;
end; { with...for }
// RPCBrokerV.Call;

try
QueryPerformanceCounter(RPCStart);
if aReturn <> nil then
RPCBrokerV.lstCall(aReturn)
else
RPCBrokerV.Call;
QueryPerformanceCounter(RPCStop);
except
on E: EBrokerError do
begin
if not RPCBrokerV.Connected then
begin
Application.MessageBox('Application must shutdown due to lost VistA Connection.', 'Server Error', MB_OK);
Application.Terminate;
end
else
raise; // Still have connectivity, let the app try and sort it out :-)
end;
else
raise;
end;

RunString := 'Ran at:' + FormatDateTime('hh:nn:ss.z a/p', now);
QueryPerformanceFrequency(fFrequency);
dt := ((MSecsPerSec * (RPCStop - RPCStart)) div fFrequency) / MSecsPerSec / SecsPerDay;
RunString := RunString + #13#10 + 'Run time:' + FormatDateTime('hh:nn:ss.z', dt);
AStringList[1] := RunString;
AStringList.Add(' ');
AStringList.Add('Results -----------------------------------------------------------------');
if Assigned(aReturn) then
FastAddStrings(aReturn, AStringList)
else
FastAddStrings(RPCBrokerV.Results, AStringList);
uCallList.Add(AStringList);
if uShowRPCs then StatusText('');
RPCLastCall := string(RPCBrokerV.RemoteProcedure) + ' (completed)';

if Assigned(AfterRPCEvent) then
AfterRPCEvent();

end;

procedure CallBroker(aReturn: TStrings = nil);
begin
UpdateContext(uBaseContext);
CallBrokerInContext(aReturn);
end;

procedure SetBrokerServer(const AName: string; APort: Integer; WantDebug: boolean);
{ makes the initial connection to a server }
begin
EnsureBroker;
with RPCBrokerV do
begin
Server := AName;
if APort > 0 then ListenerPort := APort;
DebugMode := WantDebug;
Connected := True;
end;
end;

function AuthorizedOption(const OptionName: string): boolean;
{ checks to see if the user is authorized to use this application }
begin
EnsureBroker;
Result := RPCBrokerV.CreateContext(OptionName);
if Result then
begin
if (uBaseContext = '') then
uBaseContext := OptionName;
uCurrentContext := OptionName;
end;
end;

function ConnectToServer(const OptionName: string): boolean;
{ establish initial connection to server using optional command line parameters and check that
this application (option) is allowed for this user }
var
WantDebug: boolean;
AServer, APort, x: string;
i, ModalResult: Integer;
begin
Result := False;
WantDebug := False;
AServer := '';
APort := '';
for i := 1 to ParamCount do // params may be: S[ERVER]=hostname P[ORT]=port DEBUG
begin
if UpperCase(ParamStr(i)) = 'DEBUG' then WantDebug := True;
if UpperCase(ParamStr(i)) = 'SHOWRPCS' then uShowRPCs := True;
x := UpperCase(Piece(ParamStr(i), '=', 1));
if (x = 'S') or (x = 'SERVER') then AServer := Piece(ParamStr(i), '=', 2);
if (x = 'P') or (x = 'PORT') then APort := Piece(ParamStr(i), '=', 2);
end;
if (AServer = '') or (APort = '') then
begin
ModalResult := GetServerInfo(AServer, APort);
if ModalResult = mrCancel then Exit;
end;
// use try..except to work around errors in the Broker SignOn screen
try
SetBrokerServer(AServer, StrToIntDef(APort, 9200), WantDebug);
Result := AuthorizedOption(OptionName);
if Result then Result := RPCBrokerV.Connected;
RPCBrokerV.RPCTimeLimit := 300;
except
on E: EBrokerError do
begin
if E.Code <> XWB_BadSignOn then InfoBox(E.Message, 'Error', MB_OK or MB_ICONERROR);
Result := False;
end;
end;
end;

function MRef(glvn: string): string;
{ prepends ASCII 1 to string, allows SetParams to interpret as an M reference }
begin
Result := #1 + glvn;
end;

function GetRPCCursor: TCursor;
var
pt: TPoint;
begin
Result := crHourGlass;
if Assigned(AppStartedCursorForm) and (AppStartedCursorForm.Visible) then
begin
pt := Mouse.CursorPos;
if PtInRect(AppStartedCursorForm.BoundsRect, pt) then
Result := crAppStart;
end;
end;

procedure CallV(const RPCName: string; const aParam: array of const);
{ calls the broker leaving results in results property which must be read by caller }
var
SavedCursor: TCursor;
begin
SavedCursor := Screen.Cursor;
Screen.Cursor := GetRPCCursor;
SetParams(RPCName, aParam);
CallBroker; // RPCBrokerV.Call;
Screen.Cursor := SavedCursor;
end;

function sCallV(const RPCName: string; const aParam: array of const): string;
{ calls the broker and returns a scalar value. }
var
SavedCursor: TCursor;
begin
SavedCursor := Screen.Cursor;
Screen.Cursor := GetRPCCursor;
SetParams(RPCName, aParam);
CallBroker; // RPCBrokerV.Call;
if RPCBrokerV.Results.Count > 0 then Result := RPCBrokerV.Results[0]
else Result := '';
Screen.Cursor := SavedCursor;
end;

procedure tCallV(ReturnData: TStrings; const RPCName: string; const aParam: array of const);
{ calls the broker and returns TStrings data }
var
SavedCursor: TCursor;
begin
if ReturnData = nil then raise Exception.Create('TString not created');
SavedCursor := Screen.Cursor;
Screen.Cursor := GetRPCCursor;
SetParams(RPCName, aParam);
CallBroker; // RPCBrokerV.Call;
FastAssign(RPCBrokerV.Results, ReturnData);
Screen.Cursor := SavedCursor;
end;

(* uncomment if these are needed -

function pCallV(const RPCName: string; const AParam: array of const): PChar;
{ Calls the Broker. Result is a PChar containing raw Broker data. }
{ -- Caller must dispose the string that is returned -- }
var
SavedCursor: TCursor;
begin
SavedCursor := Screen.Cursor;
Screen.Cursor := GetRPCCursor;
SetParams(RPCName, AParam);
RPCBrokerV.Call;
pCallV := StrNew(RPCBrokerV.Results.GetText);
Screen.Cursor := SavedCursor;
end;

procedure wCallV(AControl: TControl; const RPCName: string; const AParam: array of const);
{ Calls the Broker. Places data into control (wrapped). }
var
BufPtr: PChar;
begin
BufPtr := pCallV(RPCName, AParam);
WrapWP(BufPtr);
AControl.SetTextBuf(BufPtr);
StrDispose(BufPtr);
end;

procedure WrapWP(Buf: pChar);
{ Iterates through Buf and wraps text in the same way that FM wraps text. }
var
PSub: PChar;
begin
PSub := StrScan(Buf, #13);
while PSub <> nil do
begin
if Ord(PSub[2]) > 32 then
begin
StrMove(PSub, PSub + SizeOf(Char), StrLen(PSub));
PSub[0] := #32;
end
else repeat Inc(PSub, SizeOf(Char)) until (Ord(PSub[0]) > 32) or (PSub = StrEnd(PSub));
PSub := StrScan(PSub, #13);
end;
end;

*)

function RetainedRPCCount: Integer;
begin
Result := uCallList.Count;
end;

procedure SetRetainedRPCMax(Value: Integer);
begin
if Value > 0 then uMaxCalls := Value;
end;

function GetRPCMax: Integer;
begin
Result := uMaxCalls;
end;

procedure SetAfterRPCEvent(Value: TAfterRPCEvent);
begin
AfterRPCEvent := Value;
end;

procedure LoadRPCData(Dest: TStrings; ID: Integer);
begin
if (ID > -1) and (ID < uCallList.Count) then FastAssign(TStringList(uCallList.Items[ID]), Dest);
end;

function DottedIPStr: string;
{ return the IP address of the local machine as a string in dotted form: nnn.nnn.nnn.nnn }
const
WINSOCK1_1 = $0101; // minimum required version of WinSock
SUCCESS = 0; // value returned by WinSock functions if no error
var
// WSAData: TWSAData; // structure to hold startup information
HostEnt: PHostEnt; // pointer to Host Info structure (see WinSock 1.1, page 60)
IPAddr: PInAddr; // pointer to IP address in network order (4 bytes)
LocalName: array [0 .. 255] of AnsiChar; // buffer for the name of the client machine
begin
Result := 'No IP Address';
// ensure the Winsock DLL has been loaded (should be if there is a broker connection)
// if WSAStartup(WINSOCK1_1, WSAData) <> SUCCESS then Exit;
// try
// get the name of the client machine
if gethostname(@LocalName, SizeOf(LocalName) - 1) <> SUCCESS then Exit;
// get information about the client machine (contained in a record of type THostEnt)
HostEnt := gethostbyname(@LocalName);
if HostEnt = nil then Exit;
// get a pointer to the four bytes that contain the IP address
// Dereference HostEnt to get the THostEnt record. In turn, dereference the h_addr_list
// field to get a pointer to the IP address. The pointer to the IP address is type PChar,
// so it needs to be typecast as PInAddr in order to make the call to inet_ntoa.
IPAddr := PInAddr(HostEnt^.h_addr_list^);
// Dereference IPAddr (which is a PChar typecast as PInAddr) to get the 4 bytes that need
// to be passed to inet_ntoa. A string with the IP address in dotted format is returned.
Result := string(AnsiString(inet_ntoa(IPAddr^)));
// finally
// causes the reference counter in Winsock (set by WSAStartup, above) to be decremented
// WSACleanup;
// end;
end;

procedure RPCIdleCallDone(Msg: string);
begin
RPCBrokerV.ClearResults := True;
end;

procedure CallRPCWhenIdle(CallProc: TORIdleCallProc; Msg: string);
begin
CallWhenIdleNotifyWhenDone(CallProc, RPCIdleCallDone, Msg);
end;

function ShowRPCList: boolean;
begin
if uShowRPCs then Result := True
else Result := False;
end;

// =========== Backward Compatiable Code ===========//
procedure SetRPCFlaged(Value: string);
begin
fRPCFlaged := Value;
end;

function GetRPCFlaged: string;
begin
Result := fRPCFlaged;
end;
// ===============================================//

initialization

RPCBrokerV := nil;
RPCLastCall := 'No RPCs called';
uCallList := TList.Create;
uMaxCalls := 100;
uShowRPCs := False;

finalization

while uCallList.Count > 0 do
begin
TStringList(uCallList.Items[0]).Free;
uCallList.Delete(0);
end;
uCallList.Free;

end.