XWB2HL7 ;ISF/RWF - Remote RPC via HL7 ;08/24/09 14:32
;;1.1;RPC BROKER;**12,18,20,22,27,32,39,54**;Mar 28, 1997;Build 6
;Per VHA Directive 2004-038, this routine should not be modified.
;
Q
;
; EN1^XLWB2HL7 is the entry point used by the Broker.
;
; Patch XWB*1.1*27 modified the EN1^XWB2HL7 call point. However,
; the code associated with the original pre-modification version
; of the EN1 call point still exists in the XWB2HL7C routine.
; Please note that when the original EN1 code was moved to XWB2HL7C
; it was renamed OLDEN1.
;
EN1(RET,LOC,RPC,RPCVER,P1,P2,P3,P4,P5,P6,P7,P8,P9,P10) ; Call a remote RPC
; with 1-10 parameters.
; (This reworked EN1 emtry point replaces the original EN1 entry point,
; which was renamed OLDEN1.)
;
N I,INX,N,PMAX,RPCIEN,X,XWBDVER,XWBESSO,XWBHDL,XWBHL7,XWBMSG
N XWBPAR,XWBPCNT,XWBSEC,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
;
D SETUP(1) I $G(RET(1))'="" QUIT ;->
;
; Queue up request... (OLDEN1 used DIRECT call)
S ZTSAVE("*")="",ZTRTN="DEQ^XWB2HL7C",ZTDTH=$H,ZTIO=""
S ZTDESC="RPC Broker queued call from EN1~XWB2HL7"
D ^%ZTLOAD
;
; What happened?
I $G(ZTSK)'>0 S RET(0)="-1^Failed to task" QUIT ;->
S RET(0)=XWBHDL
D SETNODE^XWBDRPC(XWBHDL,"TASK",ZTSK)
;
Q
;
;This is the Direct HL7 call point
DIRECT(RET,LOC,RPC,RPCVER,P1,P2,P3,P4,P5,P6,P7,P8,P9,P10) ;Call a remote RPC
N X,I,INX,N,XWBHL7,XWBPAR,XWBPCNT,XWBDVER,XWBESSO,XWBHDL,PMAX
N XWBMSG,XWBSEC,RPCIEN
;Protect caller from HL7
N HLMTIEN,HLDOM,HLECH,HLFS,HLINSTN,HLNEXT,HLNODE,HLPARAM,HLQ,HLQUIT
D SETUP(1) I $G(RET(1))'="" Q
;(procedurename, query tag, error return, destination, Parameter array)
D DIRECT^XWB2HL7A("ZREMOTE RPC",XWBHDL,.XWBMSG,LOC,.XWBPAR)
I $P(XWBMSG,U,2) S RET(0)="-1^"_$P(XWBMSG,"^",3) Q
I 'HLMTIEN S RET(0)="-1^No Message returned" Q
D RETURN,RTNDATA^XWBDRPC(.RET,XWBHDL)
Q
;
SETUP(XWBDIR) ;Check/setup for HL7 call
S RET="",(XWBPAR,RPCIEN)="",XWBPCNT=0,XWBDVER=1,RPCVER=$G(RPCVER),PMAX=10
;Check that user can access remote system with ESSO
S XWBESSO=$$GET^XUESSO1 I +XWBESSO<0 S RET(0)="",RET(1)=XWBESSO Q
;Check that the link is setup.
I 'XWBDIR,'$$STAT^HLCSLM S RET(0)="",RET(1)="-1^Link Manager not running" Q
I '$$CHKLL^HLUTIL(LOC) S RET(0)="",RET(1)="-1^Link not setup" Q
;Find local RPC here
S RPCIEN=$$RPCIEN^XWBLIB(RPC) I RPCIEN'>0 S RET(0)="",RET(1)="-1^No Local RPC" Q
F I=1:1:PMAX Q:'$D(@("P"_I)) S XWBPCNT=I
;Get any security info.
S XWBSEC=3.14
;Do parameter conversion
;F IX=1:1:XWBPCNT I $G(^XWB(8994,RPCIEN,2,IX,2))]"" S N="P"_IX,X=@N,@(N_"=^(2)")
;Build value to send
K XWBPAR S INX=1
F N="RPC","RPCVER","XWBPCNT","XWBESSO","XWBDVER","XWBSEC" D
. S XWBPAR(INX)=$$V2S(N)_$$V2S(@N),INX=INX+1
;Load parameters into a string
F I=1:1:PMAX S N="P"_I Q:'$D(@N) S X=$$LD(N),XWBPAR(INX)=X,INX=INX+1
;Build a handle to link request with return.
S XWBHDL=$$HANDLE^XWBDRPC(),XWBMSG="" D ADDHDL^XWBDRPC(XWBHDL)
Q
;
LD(%V) ;Convert a var name into a transport string. Grabs from symbol table
N %1,%2,%3,%4
I $D(@%V)=1 Q $$V2S(%V)_$$V2S(@%V)
S %1=$S($D(@%V)#2:$$V2S(N)_$$V2S(@N),1:"")
F S %V=$Q(@%V) Q:%V="" S %3=$$V2S(%V),%4=$$V2S(@%V) S:$L(%1)+$L(%3)+$L(%4)>245 XWBPAR(INX)=%1,INX=INX+1,%1="" S %1=%1_%3_%4
Q %1
V2S(V) ;Convert a value into L_value string
Q $E(1000+$L(V),2,4)_V
;
S2V(S) ;Convert a string L_value into a value
N D,L S L=+$E(S,1,3),D=""
S:L D=$E(S,4,3+L) S S=$E(S,4+L,999)
Q D
;
UD(%1) ;Unload strings into variables. Builds symbol table
N %
F Q:%1="" S %=$$S2V(.%1),@%=$$S2V(.%1)
Q
;
;This is called by HL7 to process a RPC on the remote system.
;Call parameters
; 1. return the $NAME for the data
; 2. query tag
; 3. remote procedure name
; 4. parameter array
REMOTE(XWBY,XWBQT,XWBSPN,XWBPAR) ;Entry point on Remote system
;XWBY is the return data
;DUZ is NEWed to protect HL7
N %,I,X,Y,ERR,RPC,P1,P2,P3,P4,P5,P6,P7,P8,P9,P10,XWBPCNT,XWBDVER,XWBRPC
N RPC,RPCVER,XWBESSO,DUZ,$ESTACK,$ETRAP
N XWBA1,XWBA2,XWBA3,XWBA4,XWBA5,XWBA6,XWBA7,XWBA8,XWBA9,XWBA10
;Set local error trap
S $ETRAP="D ETRAP^XWB2HL7"
;See that leftover data in XUTL won't cause problems with %ZIS & HOME
K ^XUTL("XQ",$J,"IO")
;Expand parameters into values
F I=1:1 Q:'$D(XWBPAR(I)) D UD(XWBPAR(I)_$G(XWBPAR(I,1))) ;p54
I '$D(RPC) S XWBY(0)="-1^Bad Message" G REX ;Bad msg
S XWBRPC=0,XWBRPC=$$RPCGET(RPC,.XWBRPC) I XWBRPC'>0 S XWBY(0)="-1^RPC name not found" G REX
I '$$RPCAVAIL^XWBLIB(XWBRPC,"R",RPCVER) S XWBY(0)="-1^RPC Access Blocked/Wrong Version at Remote Site" G REX
;Check any security info.
;I $D(XWBSEC),XWBSEC'=3.14 S XWBY(0)="-1^Invalid security" G REX
;Check and Setup the user
D I $G(XWBY(0))<0 G REX
. I XWBRPC("USER")=1 S DUZ=.5,DUZ(0)="" Q
. I '$$PUT^XUESSO1(XWBESSO) S XWBY(0)="-1^Bad User"
;Enter in Sign-on log
D GETENV^%ZOSV S XWBSTATE("SLOG")=$$SLOG^XUS1($P(Y,U,2),,"",$P(Y,U),$P(Y,U,3),$P(XWBESSO,U,3),$P(XWBESSO,U,5))
;Do parameter conversion
;F IX=1:1:XWBPCNT I $G(^XWB(8994,XWBRPC,2,IX,3))]"" S N="P"_IX,X=@N,@(N_"=^(3)")
S PAR=$$PARAM
;Save HL7 device
I $L($G(IO)) S IO(1,IO)="",IO(0)=IO D SAVDEV^%ZISUTL("HL7HOME")
;Result returned in XWBY
D CAPI(XWBRPC("RTAG"),XWBRPC("RNAM"),PAR)
;Restore HL7 Device
D USE^%ZISUTL("HL7HOME"),RMDEV^%ZISUTL("HL7HOME")
REX ;Exit from remote.
;What to do to data in XWBY for HL7 return.
K ^TMP("XWBR",$J)
I '$D(XWBY) S XWBY(0)="-1^Application failed to return any data"
I $D(XWBY)>9 D
. M ^TMP("XWBR",$J)=XWBY K XWBY S XWBY=$NA(^TMP("XWBR",$J))
I $D(XWBY)=1,$E(XWBY)'="^" D
. S ^TMP("XWBR",$J,0)=XWBY K XWBY S XWBY=$NA(^TMP("XWBR",$J))
;If XWBY is a $NA value just return it.
I $D(XWBSTATE("SLOG")) D LOUT^XUSCLEAN(XWBSTATE("SLOG"))
Q
;
CAPI(TAG,NAM,PAR) ;make API call
;DUZ was setup in Remote
N HL,HLA,HLERR,HLL,HLMTIENS,IO,R,$ES,$ET ;p39
S $ET="D CAPIER^XWB2HL7"
S R=TAG_"^"_NAM_"(.XWBY"_$S(PAR="":")",1:","_PAR_")")
;Ready to call RPC? Setup the Null device
S IOP="NULL",%ZIS="H0N" D ^%ZIS
D @R
;Close the NULL device
S IO("C")=1 D ^%ZISC
;Return data is in XWBY.
Q
;
CAPIER ;Handle a error in called RPC
S XWBY(0)="-1^Remote Error: "_$E($$EC^%ZOSV,1,200) ;Grab the error first
D ^%ZTER ;record
S IO("C")=1 D ^%ZISC ;Close the NULL device
D UNWIND^%ZTER ;Unwind stack and return to HL7
Q
;
RETURN ;This tag is called by HL7 when the data returns from the remote system
;Need to get the MSG id that we added so we know where to place the
;results. Set in XWB RPC SERVER SEND protocol.
N $ES,$ETRAP S $ETRAP="D ^%ZTER D UNWIND^%ZTER"
N XWBHDL,XWB1,XWB2,I,J,X
Q:'$D(HLNEXT)
;Now to find the MSA line
F I=1:1 X HLNEXT Q:HLQUIT'>0 S X(I)=HLNODE Q:"MSA"=$E(HLNODE,1,3)
I HLNODE'["MSA" Q ;Something wrong
I $P(HLNODE,U,2)'="AA" G REJECT
;Now to find the QAK line
F I=I+1:1 X HLNEXT Q:HLQUIT'>0 S X(I)=HLNODE Q:"QAK"=$E(HLNODE,1,3)
I HLNODE'["QAK" Q ;Something wrong
;Get the handle
S XWBHDL=$P(HLNODE,"^",2)
Q:$$CHKHDL^XWBDRPC(XWBHDL)["-1" ;XTMP missing
;Now to place the data
F I=1:1 X HLNEXT Q:HLQUIT'>0 D:$E(HLNODE,1,3)="RDT"
. S X=$E(HLNODE,5,999),J=0 F S J=$O(HLNODE(J)) Q:'J S X=X_HLNODE(J)
. D PLACE(XWBHDL,X)
. Q
;
S X=$$HDLSTA^XWBDRPC(XWBHDL,"1^Done")
Q
;
REJECT ;Handle some kind of reject on remote system
N HDL,MID,MSG,X
S HDL="XWBDRPC",MID=$P(HLNODE,U,3),MSG="-1^"_$P(HLNODE,U,4) ;Save reason
F S HDL=$O(^XTMP(HDL)),X="" Q:HDL'["XWBDRPC" S X=$$GETNODE^XWBDRPC(HDL,"MSGID") Q:X=MID
Q:X="" ;Didn't find Handle
S X=$$HDLSTA^XWBDRPC(HDL,MSG)
Q
;
PLACE(HL,DATA) ;Called by HL7 to place each line of data.
N IX
S IX=+$G(^XTMP(HL,"CNT")),^XTMP(HL,"D",IX)=DATA,^XTMP(HL,"CNT")=IX+1 ;p32
Q
;
RPCGET(N,R) ;Convert RPC name to IEN and parameters.
N T,T0
S T=$G(N) Q:T="" "-1^No RPC name"
S T=$$RPCIEN^XWBLIB(T) Q:T'>0 "-1^Bad RPC name"
Q:'$D(R) T
S T0=$G(^XWB(8994,T,0)),R("IEN")=T,R("NAME")=$P(T0,"^")
S R("RTAG")=$P(T0,"^",2),R("RNAM")=$P(T0,"^",3)
S R("XWBPTYPE")=$P(T0,"^",4),R("XWBWRAP")=$P(T0,"^",8),R("USER")=$P(T0,"^",10)
;S XWBPCNT=0 F I=0:0 S I=$O(^XWB(8994,T,1,I)) Q:I'>0 S XWBPCNT=XWBPCNT+1
Q T
PARAM() ;Build remote parameter list
N I,%,X,A S X=""
F I=1:1:XWBPCNT S %="P"_I,A="XWBA"_I Q:'$D(@%) K @A D
. I $D(@%)=1 S X=X_%_"," Q
. S X=X_"."_A_"," M @A=@% Q
Q $E(X,1,$L(X)-1)
;
;
RPCCHK(RET,HDL) ;RPC call to check a handle status
N S,M,Z
I $G(HDL)="" S RET(0)="-1^Bad Handle" Q
S RET(0)=$$CHKHDL^XWBDRPC(HDL),S=$$GETNODE(HDL,"MSGID")
I RET(0)'["Done",$L(S) D S $P(RET(1),"^",3)=Z
. S RET(1)=$$MSGSTAT^HLUTIL(S),M=+RET(1),Z=""
. I M=1 S Z=$S($P(RET(1),"^",5)>1:"NOT first in queue",1:"First in queue")
. I M=1.5 S Z="Opening connection"_$S($P(RET(1),"^",6):", open failed "_$P(RET(1),"^",6)_" times.",1:"")
. I M=1.7 S Z="Sent, awaiting responce"
. I M=2 S Z="Awaiting application ACK"
Q
;
GETNODE(%1,%2) ;Pass to XWBDRPC
Q $$GETNODE^XWBDRPC(%1,%2)
;
ETRAP ;Handle errors in the RPC at the remote site.
K ^TMP("XWBR",$J),XWBY
S ^TMP("XWBR",$J,0)="-1^Trapped Error at remote site. "_$$EC^%ZOSV,XWBY=$NA(^TMP("XWBR",$J))
S XWBY=$NA(^TMP("XWBR",$J)) ;Setup the return data.
;Record the error, and exit to caller
D ^%ZTER,UNWIND^%ZTER
Q
XWB2HL7 ;ISF/RWF - Remote RPC via HL7 ;08/24/09 14:32
+1 ;;1.1;RPC BROKER;**12,18,20,22,27,32,39,54**;Mar 28, 1997;Build 6
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 QUIT
+5 ;
+6 ; EN1^XLWB2HL7 is the entry point used by the Broker.
+7 ;
+8 ; Patch XWB*1.1*27 modified the EN1^XWB2HL7 call point. However,
+9 ; the code associated with the original pre-modification version
+10 ; of the EN1 call point still exists in the XWB2HL7C routine.
+11 ; Please note that when the original EN1 code was moved to XWB2HL7C
+12 ; it was renamed OLDEN1.
+13 ;
EN1(RET,LOC,RPC,RPCVER,P1,P2,P3,P4,P5,P6,P7,P8,P9,P10) ; Call a remote RPC
+1 ; with 1-10 parameters.
+2 ; (This reworked EN1 emtry point replaces the original EN1 entry point,
+3 ; which was renamed OLDEN1.)
+4 ;
+5 NEW I,INX,N,PMAX,RPCIEN,X,XWBDVER,XWBESSO,XWBHDL,XWBHL7,XWBMSG
+6 NEW XWBPAR,XWBPCNT,XWBSEC,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
+7 ;
+8 ;->
DO SETUP(1)
IF $GET(RET(1))'=""
QUIT
+9 ;
+10 ; Queue up request... (OLDEN1 used DIRECT call)
+11 SET ZTSAVE("*")=""
SET ZTRTN="DEQ^XWB2HL7C"
SET ZTDTH=$HOROLOG
SET ZTIO=""
+12 SET ZTDESC="RPC Broker queued call from EN1~XWB2HL7"
+13 DO ^%ZTLOAD
+14 ;
+15 ; What happened?
+16 ;->
IF $GET(ZTSK)'>0
SET RET(0)="-1^Failed to task"
QUIT
+17 SET RET(0)=XWBHDL
+18 DO SETNODE^XWBDRPC(XWBHDL,"TASK",ZTSK)
+19 ;
+20 QUIT
+21 ;
+22 ;This is the Direct HL7 call point
DIRECT(RET,LOC,RPC,RPCVER,P1,P2,P3,P4,P5,P6,P7,P8,P9,P10) ;Call a remote RPC
+1 NEW X,I,INX,N,XWBHL7,XWBPAR,XWBPCNT,XWBDVER,XWBESSO,XWBHDL,PMAX
+2 NEW XWBMSG,XWBSEC,RPCIEN
+3 ;Protect caller from HL7
+4 NEW HLMTIEN,HLDOM,HLECH,HLFS,HLINSTN,HLNEXT,HLNODE,HLPARAM,HLQ,HLQUIT
+5 DO SETUP(1)
IF $GET(RET(1))'=""
QUIT
+6 ;(procedurename, query tag, error return, destination, Parameter array)
+7 DO DIRECT^XWB2HL7A("ZREMOTE RPC",XWBHDL,.XWBMSG,LOC,.XWBPAR)
+8 IF $PIECE(XWBMSG,U,2)
SET RET(0)="-1^"_$PIECE(XWBMSG,"^",3)
QUIT
+9 IF 'HLMTIEN
SET RET(0)="-1^No Message returned"
QUIT
+10 DO RETURN
DO RTNDATA^XWBDRPC(.RET,XWBHDL)
+11 QUIT
+12 ;
SETUP(XWBDIR) ;Check/setup for HL7 call
+1 SET RET=""
SET (XWBPAR,RPCIEN)=""
SET XWBPCNT=0
SET XWBDVER=1
SET RPCVER=$GET(RPCVER)
SET PMAX=10
+2 ;Check that user can access remote system with ESSO
+3 SET XWBESSO=$$GET^XUESSO1
IF +XWBESSO<0
SET RET(0)=""
SET RET(1)=XWBESSO
QUIT
+4 ;Check that the link is setup.
+5 IF 'XWBDIR
IF '$$STAT^HLCSLM
SET RET(0)=""
SET RET(1)="-1^Link Manager not running"
QUIT
+6 IF '$$CHKLL^HLUTIL(LOC)
SET RET(0)=""
SET RET(1)="-1^Link not setup"
QUIT
+7 ;Find local RPC here
+8 SET RPCIEN=$$RPCIEN^XWBLIB(RPC)
IF RPCIEN'>0
SET RET(0)=""
SET RET(1)="-1^No Local RPC"
QUIT
+9 FOR I=1:1:PMAX
IF '$DATA(@("P"_I))
QUIT
SET XWBPCNT=I
+10 ;Get any security info.
+11 SET XWBSEC=3.14
+12 ;Do parameter conversion
+13 ;F IX=1:1:XWBPCNT I $G(^XWB(8994,RPCIEN,2,IX,2))]"" S N="P"_IX,X=@N,@(N_"=^(2)")
+14 ;Build value to send
+15 KILL XWBPAR
SET INX=1
+16 FOR N="RPC","RPCVER","XWBPCNT","XWBESSO","XWBDVER","XWBSEC"
Begin DoDot:1
+17 SET XWBPAR(INX)=$$V2S(N)_$$V2S(@N)
SET INX=INX+1
End DoDot:1
+18 ;Load parameters into a string
+19 FOR I=1:1:PMAX
SET N="P"_I
IF '$DATA(@N)
QUIT
SET X=$$LD(N)
SET XWBPAR(INX)=X
SET INX=INX+1
+20 ;Build a handle to link request with return.
+21 SET XWBHDL=$$HANDLE^XWBDRPC()
SET XWBMSG=""
DO ADDHDL^XWBDRPC(XWBHDL)
+22 QUIT
+23 ;
LD(%V) ;Convert a var name into a transport string. Grabs from symbol table
+1 NEW %1,%2,%3,%4
+2 IF $DATA(@%V)=1
QUIT $$V2S(%V)_$$V2S(@%V)
+3 SET %1=$SELECT($DATA(@%V)#2:$$V2S(N)_$$V2S(@N),1:"")
+4 FOR
SET %V=$QUERY(@%V)
IF %V=""
QUIT
SET %3=$$V2S(%V)
SET %4=$$V2S(@%V)
IF $LENGTH(%1)+$LENGTH(%3)+$LENGTH(%4)>245
SET XWBPAR(INX)=%1
SET INX=INX+1
SET %1=""
SET %1=%1_%3_%4
+5 QUIT %1
V2S(V) ;Convert a value into L_value string
+1 QUIT $EXTRACT(1000+$LENGTH(V),2,4)_V
+2 ;
S2V(S) ;Convert a string L_value into a value
+1 NEW D,L
SET L=+$EXTRACT(S,1,3)
SET D=""
+2 IF L
SET D=$EXTRACT(S,4,3+L)
SET S=$EXTRACT(S,4+L,999)
+3 QUIT D
+4 ;
UD(%1) ;Unload strings into variables. Builds symbol table
+1 NEW %
+2 FOR
IF %1=""
QUIT
SET %=$$S2V(.%1)
SET @%=$$S2V(.%1)
+3 QUIT
+4 ;
+5 ;This is called by HL7 to process a RPC on the remote system.
+6 ;Call parameters
+7 ; 1. return the $NAME for the data
+8 ; 2. query tag
+9 ; 3. remote procedure name
+10 ; 4. parameter array
REMOTE(XWBY,XWBQT,XWBSPN,XWBPAR) ;Entry point on Remote system
+1 ;XWBY is the return data
+2 ;DUZ is NEWed to protect HL7
+3 NEW %,I,X,Y,ERR,RPC,P1,P2,P3,P4,P5,P6,P7,P8,P9,P10,XWBPCNT,XWBDVER,XWBRPC
+4 NEW RPC,RPCVER,XWBESSO,DUZ,$ESTACK,$ETRAP
+5 NEW XWBA1,XWBA2,XWBA3,XWBA4,XWBA5,XWBA6,XWBA7,XWBA8,XWBA9,XWBA10
+6 ;Set local error trap
+7 SET $ETRAP="D ETRAP^XWB2HL7"
+8 ;See that leftover data in XUTL won't cause problems with %ZIS & HOME
+9 KILL ^XUTL("XQ",$JOB,"IO")
+10 ;Expand parameters into values
+11 ;p54
FOR I=1:1
IF '$DATA(XWBPAR(I))
QUIT
DO UD(XWBPAR(I)_$GET(XWBPAR(I,1)))
+12 ;Bad msg
IF '$DATA(RPC)
SET XWBY(0)="-1^Bad Message"
GOTO REX
+13 SET XWBRPC=0
SET XWBRPC=$$RPCGET(RPC,.XWBRPC)
IF XWBRPC'>0
SET XWBY(0)="-1^RPC name not found"
GOTO REX
+14 IF '$$RPCAVAIL^XWBLIB(XWBRPC,"R",RPCVER)
SET XWBY(0)="-1^RPC Access Blocked/Wrong Version at Remote Site"
GOTO REX
+15 ;Check any security info.
+16 ;I $D(XWBSEC),XWBSEC'=3.14 S XWBY(0)="-1^Invalid security" G REX
+17 ;Check and Setup the user
+18 Begin DoDot:1
+19 IF XWBRPC("USER")=1
SET DUZ=.5
SET DUZ(0)=""
QUIT
+20 IF '$$PUT^XUESSO1(XWBESSO)
SET XWBY(0)="-1^Bad User"
End DoDot:1
IF $GET(XWBY(0))<0
GOTO REX
+21 ;Enter in Sign-on log
+22 DO GETENV^%ZOSV
SET XWBSTATE("SLOG")=$$SLOG^XUS1($PIECE(Y,U,2),,"",$PIECE(Y,U),$PIECE(Y,U,3),$PIECE(XWBESSO,U,3),$PIECE(XWBESSO,U,5))
+23 ;Do parameter conversion
+24 ;F IX=1:1:XWBPCNT I $G(^XWB(8994,XWBRPC,2,IX,3))]"" S N="P"_IX,X=@N,@(N_"=^(3)")
+25 SET PAR=$$PARAM
+26 ;Save HL7 device
+27 IF $LENGTH($GET(IO))
SET IO(1,IO)=""
SET IO(0)=IO
DO SAVDEV^%ZISUTL("HL7HOME")
+28 ;Result returned in XWBY
+29 DO CAPI(XWBRPC("RTAG"),XWBRPC("RNAM"),PAR)
+30 ;Restore HL7 Device
+31 DO USE^%ZISUTL("HL7HOME")
DO RMDEV^%ZISUTL("HL7HOME")
REX ;Exit from remote.
+1 ;What to do to data in XWBY for HL7 return.
+2 KILL ^TMP("XWBR",$JOB)
+3 IF '$DATA(XWBY)
SET XWBY(0)="-1^Application failed to return any data"
+4 IF $DATA(XWBY)>9
Begin DoDot:1
+5 MERGE ^TMP("XWBR",$JOB)=XWBY
KILL XWBY
SET XWBY=$NAME(^TMP("XWBR",$JOB))
End DoDot:1
+6 IF $DATA(XWBY)=1
IF $EXTRACT(XWBY)'="^"
Begin DoDot:1
+7 SET ^TMP("XWBR",$JOB,0)=XWBY
KILL XWBY
SET XWBY=$NAME(^TMP("XWBR",$JOB))
End DoDot:1
+8 ;If XWBY is a $NA value just return it.
+9 IF $DATA(XWBSTATE("SLOG"))
DO LOUT^XUSCLEAN(XWBSTATE("SLOG"))
+10 QUIT
+11 ;
CAPI(TAG,NAM,PAR) ;make API call
+1 ;DUZ was setup in Remote
+2 ;p39
NEW HL,HLA,HLERR,HLL,HLMTIENS,IO,R,$ESTACK,$ETRAP
+3 SET $ETRAP="D CAPIER^XWB2HL7"
+4 SET R=TAG_"^"_NAM_"(.XWBY"_$SELECT(PAR="":")",1:","_PAR_")")
+5 ;Ready to call RPC? Setup the Null device
+6 SET IOP="NULL"
SET %ZIS="H0N"
DO ^%ZIS
+7 DO @R
+8 ;Close the NULL device
+9 SET IO("C")=1
DO ^%ZISC
+10 ;Return data is in XWBY.
+11 QUIT
+12 ;
CAPIER ;Handle a error in called RPC
+1 ;Grab the error first
SET XWBY(0)="-1^Remote Error: "_$EXTRACT($$EC^%ZOSV,1,200)
+2 ;record
DO ^%ZTER
+3 ;Close the NULL device
SET IO("C")=1
DO ^%ZISC
+4 ;Unwind stack and return to HL7
DO UNWIND^%ZTER
+5 QUIT
+6 ;
RETURN ;This tag is called by HL7 when the data returns from the remote system
+1 ;Need to get the MSG id that we added so we know where to place the
+2 ;results. Set in XWB RPC SERVER SEND protocol.
+3 NEW $ESTACK,$ETRAP
SET $ETRAP="D ^%ZTER D UNWIND^%ZTER"
+4 NEW XWBHDL,XWB1,XWB2,I,J,X
+5 IF '$DATA(HLNEXT)
QUIT
+6 ;Now to find the MSA line
+7 FOR I=1:1
XECUTE HLNEXT
IF HLQUIT'>0
QUIT
SET X(I)=HLNODE
IF "MSA"=$EXTRACT(HLNODE,1,3)
QUIT
+8 ;Something wrong
IF HLNODE'["MSA"
QUIT
+9 IF $PIECE(HLNODE,U,2)'="AA"
GOTO REJECT
+10 ;Now to find the QAK line
+11 FOR I=I+1:1
XECUTE HLNEXT
IF HLQUIT'>0
QUIT
SET X(I)=HLNODE
IF "QAK"=$EXTRACT(HLNODE,1,3)
QUIT
+12 ;Something wrong
IF HLNODE'["QAK"
QUIT
+13 ;Get the handle
+14 SET XWBHDL=$PIECE(HLNODE,"^",2)
+15 ;XTMP missing
IF $$CHKHDL^XWBDRPC(XWBHDL)["-1"
QUIT
+16 ;Now to place the data
+17 FOR I=1:1
XECUTE HLNEXT
IF HLQUIT'>0
QUIT
IF $EXTRACT(HLNODE,1,3)="RDT"
Begin DoDot:1
+18 SET X=$EXTRACT(HLNODE,5,999)
SET J=0
FOR
SET J=$ORDER(HLNODE(J))
IF 'J
QUIT
SET X=X_HLNODE(J)
+19 DO PLACE(XWBHDL,X)
+20 QUIT
End DoDot:1
+21 ;
+22 SET X=$$HDLSTA^XWBDRPC(XWBHDL,"1^Done")
+23 QUIT
+24 ;
REJECT ;Handle some kind of reject on remote system
+1 NEW HDL,MID,MSG,X
+2 ;Save reason
SET HDL="XWBDRPC"
SET MID=$PIECE(HLNODE,U,3)
SET MSG="-1^"_$PIECE(HLNODE,U,4)
+3 FOR
SET HDL=$ORDER(^XTMP(HDL))
SET X=""
IF HDL'["XWBDRPC"
QUIT
SET X=$$GETNODE^XWBDRPC(HDL,"MSGID")
IF X=MID
QUIT
+4 ;Didn't find Handle
IF X=""
QUIT
+5 SET X=$$HDLSTA^XWBDRPC(HDL,MSG)
+6 QUIT
+7 ;
PLACE(HL,DATA) ;Called by HL7 to place each line of data.
+1 NEW IX
+2 ;p32
SET IX=+$GET(^XTMP(HL,"CNT"))
SET ^XTMP(HL,"D",IX)=DATA
SET ^XTMP(HL,"CNT")=IX+1
+3 QUIT
+4 ;
RPCGET(N,R) ;Convert RPC name to IEN and parameters.
+1 NEW T,T0
+2 SET T=$GET(N)
IF T=""
QUIT "-1^No RPC name"
+3 SET T=$$RPCIEN^XWBLIB(T)
IF T'>0
QUIT "-1^Bad RPC name"
+4 IF '$DATA(R)
QUIT T
+5 SET T0=$GET(^XWB(8994,T,0))
SET R("IEN")=T
SET R("NAME")=$PIECE(T0,"^")
+6 SET R("RTAG")=$PIECE(T0,"^",2)
SET R("RNAM")=$PIECE(T0,"^",3)
+7 SET R("XWBPTYPE")=$PIECE(T0,"^",4)
SET R("XWBWRAP")=$PIECE(T0,"^",8)
SET R("USER")=$PIECE(T0,"^",10)
+8 ;S XWBPCNT=0 F I=0:0 S I=$O(^XWB(8994,T,1,I)) Q:I'>0 S XWBPCNT=XWBPCNT+1
+9 QUIT T
PARAM() ;Build remote parameter list
+1 NEW I,%,X,A
SET X=""
+2 FOR I=1:1:XWBPCNT
SET %="P"_I
SET A="XWBA"_I
IF '$DATA(@%)
QUIT
KILL @A
Begin DoDot:1
+3 IF $DATA(@%)=1
SET X=X_%_","
QUIT
+4 SET X=X_"."_A_","
MERGE @A=@%
QUIT
End DoDot:1
+5 QUIT $EXTRACT(X,1,$LENGTH(X)-1)
+6 ;
+7 ;
RPCCHK(RET,HDL) ;RPC call to check a handle status
+1 NEW S,M,Z
+2 IF $GET(HDL)=""
SET RET(0)="-1^Bad Handle"
QUIT
+3 SET RET(0)=$$CHKHDL^XWBDRPC(HDL)
SET S=$$GETNODE(HDL,"MSGID")
+4 IF RET(0)'["Done"
IF $LENGTH(S)
Begin DoDot:1
+5 SET RET(1)=$$MSGSTAT^HLUTIL(S)
SET M=+RET(1)
SET Z=""
+6 IF M=1
SET Z=$SELECT($PIECE(RET(1),"^",5)>1:"NOT first in queue",1:"First in queue")
+7 IF M=1.5
SET Z="Opening connection"_$SELECT($PIECE(RET(1),"^",6):", open failed "_$PIECE(RET(1),"^",6)_" times.",1:"")
+8 IF M=1.7
SET Z="Sent, awaiting responce"
+9 IF M=2
SET Z="Awaiting application ACK"
End DoDot:1
SET $PIECE(RET(1),"^",3)=Z
+10 QUIT
+11 ;
GETNODE(%1,%2) ;Pass to XWBDRPC
+1 QUIT $$GETNODE^XWBDRPC(%1,%2)
+2 ;
ETRAP ;Handle errors in the RPC at the remote site.
+1 KILL ^TMP("XWBR",$JOB),XWBY
+2 SET ^TMP("XWBR",$JOB,0)="-1^Trapped Error at remote site. "_$$EC^%ZOSV
SET XWBY=$NAME(^TMP("XWBR",$JOB))
+3 ;Setup the return data.
SET XWBY=$NAME(^TMP("XWBR",$JOB))
+4 ;Record the error, and exit to caller
+5 DO ^%ZTER
DO UNWIND^%ZTER
+6 QUIT
