source: FOIAVistA/trunk/r/RPC_BROKER-XWB/XWB2HL7.m@ 1801

Last change on this file since 1801 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 8.8 KB
Line 
1XWB2HL7 ;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 ;
14EN1(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
37DIRECT(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 ;
50SETUP(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 ;
74LD(%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
80V2S(V) ;Convert a value into L_value string
81 Q $E(1000+$L(V),2,4)_V
82 ;
83S2V(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 ;
88UD(%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
99REMOTE(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")
131REX ;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 ;
143CAPI(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 ;
156CAPIER ;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 ;
163RETURN ;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 ;
188REJECT ;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 ;
196PLACE(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 ;
201RPCGET(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
211PARAM() ;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 ;
219RPCCHK(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 ;
231GETNODE(%1,%2) ;Pass to XWBDRPC
232 Q $$GETNODE^XWBDRPC(%1,%2)
233 ;
234ETRAP ;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
Note: See TracBrowser for help on using the repository browser.