Routine: XWB2HL7

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.

 ; 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)

 ;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)

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)

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)

 ;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"))

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.

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

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")

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)

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

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"

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

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

XWB2HL7.m