| [613] | 1 | XWB2HL7 ;ISF/RWF - Remote RPC via HL7 ;04/30/2003 15:20
|
|---|
| 2 | ;;1.1;RPC BROKER;**12,18,20,22,27,32,39**;Mar 28, 1997
|
|---|
| 3 | ;
|
|---|
| 4 | Q
|
|---|
| 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 | ;
|
|---|
| 14 | EN1(RET,LOC,RPC,RPCVER,P1,P2,P3,P4,P5,P6,P7,P8,P9,P10) ; Call a remote RPC
|
|---|
| 15 | ; with 1-10 parameters. (This tag is called from EN1^XWB2HL7.
|
|---|
| 16 | ; This reworked EN1 call point replaces the original EN1 call point,
|
|---|
| 17 | ; which was renamed OLDEN1.)
|
|---|
| 18 | ;
|
|---|
| 19 | N I,INX,N,PMAX,RPCIEN,X,XWBDVER,XWBESSO,XWBHDL,XWBHL7,XWBMSG
|
|---|
| 20 | N XWBPAR,XWBPCNT,XWBSEC,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
|
|---|
| 21 | ;
|
|---|
| 22 | D SETUP(1) I $G(RET(1))'="" QUIT ;->
|
|---|
| 23 | ;
|
|---|
| 24 | ; Queue up request... (OLDEN1 used DIRECT call)
|
|---|
| 25 | S ZTSAVE("*")="",ZTRTN="DEQ^XWB2HL7C",ZTDTH=$H,ZTIO=""
|
|---|
| 26 | S ZTDESC="RPC Broker queued call from EN1~XWB2HL7"
|
|---|
| 27 | D ^%ZTLOAD
|
|---|
| 28 | ;
|
|---|
| 29 | ; What happened?
|
|---|
| 30 | I $G(ZTSK)'>0 S RET(0)="-1^Failed to task" QUIT ;->
|
|---|
| 31 | S RET(0)=XWBHDL
|
|---|
| 32 | D SETNODE^XWBDRPC(XWBHDL,"TASK",ZTSK)
|
|---|
| 33 | ;
|
|---|
| 34 | Q
|
|---|
| 35 | ;
|
|---|
| 36 | ;This is the Direct HL7 call point
|
|---|
| 37 | DIRECT(RET,LOC,RPC,RPCVER,P1,P2,P3,P4,P5,P6,P7,P8,P9,P10) ;Call a remote RPC
|
|---|
| 38 | N X,I,INX,N,XWBHL7,XWBPAR,XWBPCNT,XWBDVER,XWBESSO,XWBHDL,PMAX
|
|---|
| 39 | N XWBMSG,XWBSEC,RPCIEN
|
|---|
| 40 | ;Protect caller from HL7
|
|---|
| 41 | N HLMTIEN,HLDOM,HLECH,HLFS,HLINSTN,HLNEXT,HLNODE,HLPARAM,HLQ,HLQUIT
|
|---|
| 42 | D SETUP(1) I $G(RET(1))'="" Q
|
|---|
| 43 | ;(procedurename, query tag, error return, destination, Parameter array)
|
|---|
| 44 | D DIRECT^XWB2HL7A("ZREMOTE RPC",XWBHDL,.XWBMSG,LOC,.XWBPAR)
|
|---|
| 45 | I $P(XWBMSG,U,2) S RET(0)="-1^"_$P(XWBMSG,"^",3) Q
|
|---|
| 46 | I 'HLMTIEN S RET(0)="-1^No Message returned" Q
|
|---|
| 47 | D RETURN,RTNDATA^XWBDRPC(.RET,XWBHDL)
|
|---|
| 48 | Q
|
|---|
| 49 | ;
|
|---|
| 50 | SETUP(XWBDIR) ;Check/setup for HL7 call
|
|---|
| 51 | S RET="",(XWBPAR,RPCIEN)="",XWBPCNT=0,XWBDVER=1,RPCVER=$G(RPCVER),PMAX=10
|
|---|
| 52 | ;Check that user can access remote system with ESSO
|
|---|
| 53 | S XWBESSO=$$GET^XUESSO1 I +XWBESSO<0 S RET(0)="",RET(1)=XWBESSO Q
|
|---|
| 54 | ;Check that the link is setup.
|
|---|
| 55 | I 'XWBDIR,'$$STAT^HLCSLM S RET(0)="",RET(1)="-1^Link Manager not running" Q
|
|---|
| 56 | I '$$CHKLL^HLUTIL(LOC) S RET(0)="",RET(1)="-1^Link not setup" Q
|
|---|
| 57 | ;Find local RPC here
|
|---|
| 58 | S RPCIEN=$$RPCIEN^XWBLIB(RPC) I RPCIEN'>0 S RET(0)="",RET(1)="-1^No Local RPC" Q
|
|---|
| 59 | F I=1:1:PMAX Q:'$D(@("P"_I)) S XWBPCNT=I
|
|---|
| 60 | ;Get any security info.
|
|---|
| 61 | S XWBSEC=3.14
|
|---|
| 62 | ;Do parameter conversion
|
|---|
| 63 | ;F IX=1:1:XWBPCNT I $G(^XWB(8994,RPCIEN,2,IX,2))]"" S N="P"_IX,X=@N,@(N_"=^(2)")
|
|---|
| 64 | ;Build value to send
|
|---|
| 65 | K XWBPAR S INX=1
|
|---|
| 66 | F N="RPC","RPCVER","XWBPCNT","XWBESSO","XWBDVER","XWBSEC" D
|
|---|
| 67 | . S XWBPAR(INX)=$$V2S(N)_$$V2S(@N),INX=INX+1
|
|---|
| 68 | ;Load parameters into a string
|
|---|
| 69 | F I=1:1:PMAX S N="P"_I Q:'$D(@N) S X=$$LD(N),XWBPAR(INX)=X,INX=INX+1
|
|---|
| 70 | ;Build a handle to link request with return.
|
|---|
| 71 | S XWBHDL=$$HANDLE^XWBDRPC(),XWBMSG="" D ADDHDL^XWBDRPC(XWBHDL)
|
|---|
| 72 | Q
|
|---|
| 73 | ;
|
|---|
| 74 | LD(%V) ;Convert a var name into a transport string. Grabs from symbol table
|
|---|
| 75 | N %1,%2,%3,%4
|
|---|
| 76 | I $D(@%V)=1 Q $$V2S(%V)_$$V2S(@%V)
|
|---|
| 77 | S %1=$S($D(@%V)#2:$$V2S(N)_$$V2S(@N),1:"")
|
|---|
| 78 | 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
|
|---|
| 79 | Q %1
|
|---|
| 80 | V2S(V) ;Convert a value into L_value string
|
|---|
| 81 | Q $E(1000+$L(V),2,4)_V
|
|---|
| 82 | ;
|
|---|
| 83 | S2V(S) ;Convert a string L_value into a value
|
|---|
| 84 | N D,L S L=+$E(S,1,3),D=""
|
|---|
| 85 | S:L D=$E(S,4,3+L) S S=$E(S,4+L,999)
|
|---|
| 86 | Q D
|
|---|
| 87 | ;
|
|---|
| 88 | UD(%1) ;Unload strings into variables. Builds symbol table
|
|---|
| 89 | N %
|
|---|
| 90 | F Q:%1="" S %=$$S2V(.%1),@%=$$S2V(.%1)
|
|---|
| 91 | Q
|
|---|
| 92 | ;
|
|---|
| 93 | ;This is called by HL7 to process a RPC on the remote system.
|
|---|
| 94 | ;Call parameters
|
|---|
| 95 | ; 1. return the $NAME for the data
|
|---|
| 96 | ; 2. query tag
|
|---|
| 97 | ; 3. remote procedure name
|
|---|
| 98 | ; 4. parameter array
|
|---|
| 99 | REMOTE(XWBY,XWBQT,XWBSPN,XWBPAR) ;Entry point on Remote system
|
|---|
| 100 | ;XWBY is the return data
|
|---|
| 101 | ;DUZ is NEWed to protect HL7
|
|---|
| 102 | N %,I,X,Y,ERR,RPC,P1,P2,P3,P4,P5,P6,P7,P8,P9,P10,XWBPCNT,XWBDVER,XWBRPC
|
|---|
| 103 | N RPC,RPCVER,XWBESSO,DUZ,$ESTACK,$ETRAP
|
|---|
| 104 | N XWBA1,XWBA2,XWBA3,XWBA4,XWBA5,XWBA6,XWBA7,XWBA8,XWBA9,XWBA10
|
|---|
| 105 | ;Set local error trap
|
|---|
| 106 | S $ETRAP="D ETRAP^XWB2HL7"
|
|---|
| 107 | ;See that leftover data in XUTL won't cause problems with %ZIS & HOME
|
|---|
| 108 | K ^XUTL("XQ",$J,"IO")
|
|---|
| 109 | ;Expand parameters into values
|
|---|
| 110 | F I=1:1 Q:'$D(XWBPAR(I)) D UD(XWBPAR(I))
|
|---|
| 111 | I '$D(RPC) S XWBY(0)="-1^Bad Message" G REX ;Bad msg
|
|---|
| 112 | S XWBRPC=0,XWBRPC=$$RPCGET(RPC,.XWBRPC) I XWBRPC'>0 S XWBY(0)="-1^RPC name not found" G REX
|
|---|
| 113 | I '$$RPCAVAIL^XWBLIB(XWBRPC,"R",RPCVER) S XWBY(0)="-1^RPC Access Blocked/Wrong Version at Remote Site" G REX
|
|---|
| 114 | ;Check any security info.
|
|---|
| 115 | ;I $D(XWBSEC),XWBSEC'=3.14 S XWBY(0)="-1^Invalid security" G REX
|
|---|
| 116 | ;Check and Setup the user
|
|---|
| 117 | D I $G(XWBY(0))<0 G REX
|
|---|
| 118 | . I XWBRPC("USER")=1 S DUZ=.5,DUZ(0)="" Q
|
|---|
| 119 | . I '$$PUT^XUESSO1(XWBESSO) S XWBY(0)="-1^Bad User"
|
|---|
| 120 | ;Enter in Sign-on log
|
|---|
| 121 | 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))
|
|---|
| 122 | ;Do parameter conversion
|
|---|
| 123 | ;F IX=1:1:XWBPCNT I $G(^XWB(8994,XWBRPC,2,IX,3))]"" S N="P"_IX,X=@N,@(N_"=^(3)")
|
|---|
| 124 | S PAR=$$PARAM
|
|---|
| 125 | ;Save HL7 device
|
|---|
| 126 | I $L($G(IO)) S IO(1,IO)="",IO(0)=IO D SAVDEV^%ZISUTL("HL7HOME")
|
|---|
| 127 | ;Result returned in XWBY
|
|---|
| 128 | D CAPI(XWBRPC("RTAG"),XWBRPC("RNAM"),PAR)
|
|---|
| 129 | ;Restore HL7 Device
|
|---|
| 130 | D USE^%ZISUTL("HL7HOME"),RMDEV^%ZISUTL("HL7HOME")
|
|---|
| 131 | REX ;Exit from remote.
|
|---|
| 132 | ;What to do to data in XWBY for HL7 return.
|
|---|
| 133 | K ^TMP("XWBR",$J)
|
|---|
| 134 | I '$D(XWBY) S XWBY(0)="-1^Application failed to return any data"
|
|---|
| 135 | I $D(XWBY)>9 D
|
|---|
| 136 | . M ^TMP("XWBR",$J)=XWBY K XWBY S XWBY=$NA(^TMP("XWBR",$J))
|
|---|
| 137 | I $D(XWBY)=1,$E(XWBY)'="^" D
|
|---|
| 138 | . S ^TMP("XWBR",$J,0)=XWBY K XWBY S XWBY=$NA(^TMP("XWBR",$J))
|
|---|
| 139 | ;If XWBY is a $NA value just return it.
|
|---|
| 140 | I $D(XWBSTATE("SLOG")) D LOUT^XUSCLEAN(XWBSTATE("SLOG"))
|
|---|
| 141 | Q
|
|---|
| 142 | ;
|
|---|
| 143 | CAPI(TAG,NAM,PAR) ;make API call
|
|---|
| 144 | ;DUZ was setup in Remote
|
|---|
| 145 | N HL,HLA,HLERR,HLL,HLMTIENS,IO,R,$ES,$ET
|
|---|
| 146 | S $ET="D CAPIER^XWB2HL7"
|
|---|
| 147 | S R=TAG_"^"_NAM_"(.XWBY"_$S(PAR="":")",1:","_PAR_")")
|
|---|
| 148 | ;Ready to call RPC? Setup the Null device
|
|---|
| 149 | S IOP="NULL",%ZIS="H0N" D ^%ZIS
|
|---|
| 150 | D @R
|
|---|
| 151 | ;Close the NULL device
|
|---|
| 152 | S IO("C")=1 D ^%ZISC
|
|---|
| 153 | ;Return data is in XWBY.
|
|---|
| 154 | Q
|
|---|
| 155 | ;
|
|---|
| 156 | CAPIER ;Handle a error in called RPC
|
|---|
| 157 | S XWBY(0)="-1^Remote Error: "_$E($$EC^%ZOSV,1,200) ;Grab the error first
|
|---|
| 158 | D ^%ZTER ;record
|
|---|
| 159 | S IO("C")=1 D ^%ZISC ;Close the NULL device
|
|---|
| 160 | D UNWIND^%ZTER ;Unwind stack and return to HL7
|
|---|
| 161 | Q
|
|---|
| 162 | ;
|
|---|
| 163 | RETURN ;This tag is called by HL7 when the data returns from the remote system
|
|---|
| 164 | ;Need to get the MSG id that we added so we know where to place the
|
|---|
| 165 | ;results. Set in XWB RPC SERVER SEND protocol.
|
|---|
| 166 | N $ES,$ETRAP S $ETRAP="D ^%ZTER D UNWIND^%ZTER"
|
|---|
| 167 | N XWBHDL,XWB1,XWB2,I,J,X
|
|---|
| 168 | Q:'$D(HLNEXT)
|
|---|
| 169 | ;Now to find the MSA line
|
|---|
| 170 | F I=1:1 X HLNEXT Q:HLQUIT'>0 S X(I)=HLNODE Q:"MSA"=$E(HLNODE,1,3)
|
|---|
| 171 | I HLNODE'["MSA" Q ;Something wrong
|
|---|
| 172 | I $P(HLNODE,U,2)'="AA" G REJECT
|
|---|
| 173 | ;Now to find the QAK line
|
|---|
| 174 | F I=I+1:1 X HLNEXT Q:HLQUIT'>0 S X(I)=HLNODE Q:"QAK"=$E(HLNODE,1,3)
|
|---|
| 175 | I HLNODE'["QAK" Q ;Something wrong
|
|---|
| 176 | ;Get the handle
|
|---|
| 177 | S XWBHDL=$P(HLNODE,"^",2)
|
|---|
| 178 | Q:$$CHKHDL^XWBDRPC(XWBHDL)["-1" ;XTMP missing
|
|---|
| 179 | ;Now to place the data
|
|---|
| 180 | F I=1:1 X HLNEXT Q:HLQUIT'>0 D:$E(HLNODE,1,3)="RDT"
|
|---|
| 181 | . S X=$E(HLNODE,5,999),J=0 F S J=$O(HLNODE(J)) Q:'J S X=X_HLNODE(J)
|
|---|
| 182 | . D PLACE(XWBHDL,X)
|
|---|
| 183 | . Q
|
|---|
| 184 | ;
|
|---|
| 185 | S X=$$HDLSTA^XWBDRPC(XWBHDL,"1^Done")
|
|---|
| 186 | Q
|
|---|
| 187 | ;
|
|---|
| 188 | REJECT ;Handle some kind of reject on remote system
|
|---|
| 189 | N HDL,MID,MSG,X
|
|---|
| 190 | S HDL="XWBDRPC",MID=$P(HLNODE,U,3),MSG="-1^"_$P(HLNODE,U,4) ;Save reason
|
|---|
| 191 | F S HDL=$O(^XTMP(HDL)),X="" Q:HDL'["XWBDRPC" S X=$$GETNODE^XWBDRPC(HDL,"MSGID") Q:X=MID
|
|---|
| 192 | Q:X="" ;Didn't find Handle
|
|---|
| 193 | S X=$$HDLSTA^XWBDRPC(HDL,MSG)
|
|---|
| 194 | Q
|
|---|
| 195 | ;
|
|---|
| 196 | PLACE(HL,DATA) ;Called by HL7 to place each line of data.
|
|---|
| 197 | N IX
|
|---|
| 198 | S IX=+$G(^XTMP(HL,"CNT")),^XTMP(HL,"D",IX)=DATA,^XTMP(HL,"CNT")=IX+1
|
|---|
| 199 | Q
|
|---|
| 200 | ;
|
|---|
| 201 | RPCGET(N,R) ;Convert RPC name to IEN and parameters.
|
|---|
| 202 | N T,T0
|
|---|
| 203 | S T=$G(N) Q:T="" "-1^No RPC name"
|
|---|
| 204 | S T=$$RPCIEN^XWBLIB(T) Q:T'>0 "-1^Bad RPC name"
|
|---|
| 205 | Q:'$D(R) T
|
|---|
| 206 | S T0=$G(^XWB(8994,T,0)),R("IEN")=T,R("NAME")=$P(T0,"^")
|
|---|
| 207 | S R("RTAG")=$P(T0,"^",2),R("RNAM")=$P(T0,"^",3)
|
|---|
| 208 | S R("XWBPTYPE")=$P(T0,"^",4),R("XWBWRAP")=$P(T0,"^",8),R("USER")=$P(T0,"^",10)
|
|---|
| 209 | ;S XWBPCNT=0 F I=0:0 S I=$O(^XWB(8994,T,1,I)) Q:I'>0 S XWBPCNT=XWBPCNT+1
|
|---|
| 210 | Q T
|
|---|
| 211 | PARAM() ;Build remote parameter list
|
|---|
| 212 | N I,%,X,A S X=""
|
|---|
| 213 | F I=1:1:XWBPCNT S %="P"_I,A="XWBA"_I Q:'$D(@%) K @A D
|
|---|
| 214 | . I $D(@%)=1 S X=X_%_"," Q
|
|---|
| 215 | . S X=X_"."_A_"," M @A=@% Q
|
|---|
| 216 | Q $E(X,1,$L(X)-1)
|
|---|
| 217 | ;
|
|---|
| 218 | ;
|
|---|
| 219 | RPCCHK(RET,HDL) ;RPC call to check a handle status
|
|---|
| 220 | N S,M,Z
|
|---|
| 221 | I $G(HDL)="" S RET(0)="-1^Bad Handle" Q
|
|---|
| 222 | S RET(0)=$$CHKHDL^XWBDRPC(HDL),S=$$GETNODE(HDL,"MSGID")
|
|---|
| 223 | I RET(0)'["Done",$L(S) D S $P(RET(1),"^",3)=Z
|
|---|
| 224 | . S RET(1)=$$MSGSTAT^HLUTIL(S),M=+RET(1),Z=""
|
|---|
| 225 | . I M=1 S Z=$S($P(RET(1),"^",5)>1:"NOT first in queue",1:"First in queue")
|
|---|
| 226 | . I M=1.5 S Z="Opening connection"_$S($P(RET(1),"^",6):", open failed "_$P(RET(1),"^",6)_" times.",1:"")
|
|---|
| 227 | . I M=1.7 S Z="Sent, awaiting responce"
|
|---|
| 228 | . I M=2 S Z="Awaiting application ACK"
|
|---|
| 229 | Q
|
|---|
| 230 | ;
|
|---|
| 231 | GETNODE(%1,%2) ;Pass to XWBDRPC
|
|---|
| 232 | Q $$GETNODE^XWBDRPC(%1,%2)
|
|---|
| 233 | ;
|
|---|
| 234 | ETRAP ;Handle errors in the RPC at the remote site.
|
|---|
| 235 | K ^TMP("XWBR",$J),XWBY
|
|---|
| 236 | S ^TMP("XWBR",$J,0)="-1^Trapped Error at remote site. "_$$EC^%ZOSV,XWBY=$NA(^TMP("XWBR",$J))
|
|---|
| 237 | S XWBY=$NA(^TMP("XWBR",$J)) ;Setup the return data.
|
|---|
| 238 | ;Record the error, and exit to caller
|
|---|
| 239 | D ^%ZTER,UNWIND^%ZTER
|
|---|
| 240 | Q
|
|---|
