source: FOIAVistA/trunk/r/RPC_BROKER-XWB/XWB2HL7B.m@ 1607

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

initial load of FOIAVistA 6/30/08 version
File size: 7.7 KB
Line 
1XWB2HL7B ;ISF/AC - Remote RPCs via HL7. ;03/27/2003 17:46
2 ;;1.1;RPC BROKER;**12,22,39**;Mar 28, 1997
3RPCRECV ;Called from the XWB RPC CLIENT protocol
4 ;Called on the remote system
5 N I,I1,J,XWB2EMAP,XWB2IPRM,XWB2LPRM,XWB2MAP2,XWB2PEND,XWB2QTAG,XWB2RNAM,XWB2RFLD,CMPNTREM,XWB2RPCP,XWB2SPN,XWB2RSLT,XWB2Y,Y
6 F I=1:1 X HLNEXT Q:HLQUIT'>0 S XWB2Y(I)=HLNODE,J=0 F S J=$O(HLNODE(J)) Q:'J S XWB2Y(I,J)=HLNODE(J)
7 ;Define Encoding characters to map by order
8 S Y=""
9 F I=3,0,1,2,4 S Y=Y_$S(I:$E(HL("ECH"),I),1:HL("FS"))
10 S XWB2EMAP=Y,XWB2MAP2="EFSRT"
11 D PARSSPR G GENACK:$G(HLERR)]""
12 ;Merge into the parameter list the last of the remainder
13 ;nodes that have not been processed.
14 S I1=$O(XWB2RPCP("R",0)) I I1 D
15 .M XWB2RPCP(I1)=XWB2RPCP("R",I1)
16 .K XWB2RPCP("R")
17 D COMPRES(.XWB2RPCP)
18 ;Call to build and do rpc
19 D REMOTE^XWB2HL7(.XWB2RNAM,XWB2QTAG,XWB2SPN,.XWB2RPCP)
20GENACK ;Generate ack/nak
21 K ^TMP("HLA",$J)
22 S ^TMP("HLA",$J,1)="MSA"_HL("FS")_$S($G(HLERR)]"":"AE",1:"AA")_HL("FS")_HL("MID")_$S($G(HLERR)]"":HL("FS")_HLERR,1:"")
23 S ^TMP("HLA",$J,2)="QAK"_HL("FS")_XWB2QTAG_HL("FS")_$S($G(HLERR)]"":"AE",1:"OK")
24 S ^TMP("HLA",$J,3)="RDF"_HL("FS")_"1"_HL("FS")_"@DSP.3"_$E(HL("ECH"))_"TX"_$E(HL("ECH"))_"300"
25 D:$G(HLERR)']"" BLDRDT
26 D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"GM",1,.XWB2RSLT)
27RECVXIT ;Cleanup of receiver processing sub-routine
28 K ^TMP("HLA",$J)
29 Q
30 ;
31PARSSPR ;Parse SPR segment for paramaeters.
32 N %,%1
33 S I=2
34 ;Extract handle
35 S XWB2QTAG=$P(XWB2Y(I),HL("FS"),2)
36 ;Extract Stored Procedure Name
37 S XWB2SPN=$P(XWB2Y(I),HL("FS"),4)
38 ;Extract Input Parameters
39 S XWB2IPRM=$P(XWB2Y(I),HL("FS"),5)
40 ;Determine whether Input Parameters fit on one line of SPR segment.
41 ;XWB2LPRM=1 if parameters continue on overflow nodes.
42 ;XWB2LPRM=0 if parameters fit on a single node.
43 S XWB2LPRM=$S($L(XWB2Y(I),HL("FS"))=5:$S($O(XWB2Y(I,0)):1,1:0),1:0)
44 ;Format of
45 ;INPUT PARAMETERS:@SPR.4.2~PARAM1&PARAM2
46 ;
47 ;Short SPR segment
48 I 'XWB2LPRM S %=$P(XWB2Y(I),HL("FS"),5) D INPUTPRM(%,0) Q
49 ;Long SPR segment
50 S %=$P(XWB2Y(I),HL("FS"),5,9999)
51 F %1=0:0 S %1=$O(XWB2Y(I,%1)) D INPUTPRM(%,(%1>0)) Q:%1'>0!$G(XWB2PEND) S %=XWB2Y(I,%1)
52 ;
53 Q
54 ;
55INPUTPRM(X1,L1) ;Process Input Parameters
56 ;X1 contains an extract of Input Parameters
57 ;L1=0 if Parameters fit on a single SPR Segment node.
58 ;L1=1 if Parameters do not fit on a single SPR Segment node.
59 N I,IL,Y1
60 S IL=$L(X1,HL("FS"))
61 S Y1=$P(X1,HL("FS"),1)
62 I $G(L1),IL'>1 D REPEATLP(Y1,1) S:$G(HLERR)]"" XWB2PEND=1 Q
63 D REPEATLP(Y1)
64 I IL>1!($G(HLERR)]"") S XWB2PEND=1
65 Q
66REPEATLP(X2,L2) ;Loop through repeatable components.
67 ;X2 contains an extract of Input Parameters
68 ;$G(L2)>0 if component may extend onto overflow node.
69 N I,RL,Y2
70 S RL=$L(X2,$E(HL("ECH"),2))
71 F I=1:1:RL D Q:$G(HLERR)]""
72 .S Y2=$P(X2,$E(HL("ECH"),2),I)
73 .I $G(L2),I=RL D COMPONT(Y2,1) Q
74 .D COMPONT(Y2)
75 Q
76COMPONT(X3,L3) ;Loop through the two components.
77 ;X3 contains an extract of a component.
78 ;$G(L3)>0 if component may extend onto next overflow node.
79 N CL,I,Y3
80 S CL=$L(X3,$E(HL("ECH")))
81 I CL>2 S HLERR="Too many components!" Q
82 I CL=2 D Q
83 .S Y3=$P(X3,$E(HL("ECH")),1)
84 .;CHECK FLD REMAINDER,
85 .S I=$O(XWB2RFLD("R",0)) I I D Q:$G(HLERR)]""
86 ..I ($L(XWB2RFLD("R",+I))+$L(Y3))>255 S HLERR="Field name too long!" Q
87 ..S XWB2RFLD(+I)=XWB2RFLD("R",+I)_Y3
88 ..K XWB2RFLD("R",+I)
89 .S I=+$O(XWB2RFLD("@"),-1)+1
90 .S XWB2RFLD(I)=Y3
91 .;CLEAR FLD REMAINDER
92 .S Y3=$P(X3,$E(HL("ECH")),2)
93 .D SUBCMPNT(Y3,$G(L3))
94 .;SET COMPONENT REMAINDER FLAG.
95 .S CMPNTREM=$G(L3)
96 I CL=1 D Q
97 .S Y3=$P(X3,$E(HL("ECH")),1)
98 .I $G(CMPNTREM) D SUBCMPNT(Y3,$G(L3)) Q
99 .S I=$O(XWB2RFLD("R",0)) I I D Q
100 ..I ($L(XWB2RFLD("R",+I))+$L(Y3))>255 S HLERR="Field name too long!" Q
101 ..S XWB2RFLD(+I)=XWB2RFLD("R",+I)_Y3
102 ..K XWB2RFLD("R",+I)
103 ;
104 Q
105SUBCMPNT(X4,L4) ;Loop through sub-components.
106 ;X4 contains an extract of the subcomponent.
107 ;L4=0 if subcomponent does not extend onto next overflow node.
108 ;L4=1 if subcomponent does extend onto next overflow node.
109 N I,I1,I2,RMNDRLEN,SL,Y4
110 S SL=$L(X4,$E(HL("ECH"),4))
111 F I=1:1:SL D
112 .S Y4=$P(X4,$E(HL("ECH"),4),I)
113 .I $G(L4),I=SL D Q
114 ..;Long node, find last remainder
115 ..S I1=$O(XWB2RPCP("R",0))
116 ..I 'I1 D
117 ...;No remainder, create remainder for next parameter(subcomponent).
118 ...S I1=+$O(XWB2RPCP("@"),-1)+1
119 ...S XWB2RPCP("R",I1)=Y4 Q
120 ..E D
121 ...;Remainder exists, find last remainder overflow
122 ...S I2=+$O(XWB2RPCP("R",I1,"@"),-1)+1
123 ...;Length of last remainder
124 ...S RMNDRLEN=$S(I2=1:$L(XWB2RPCP("R",I1)),1:$L(XWB2RPCP("R",I1,I2-1)))
125 ...;If last remainder has space, squeeze more chars onto last remainder.
126 ...I RMNDRLEN<255 D
127 ....I I2=1 D Q
128 .....S XWB2RPCP("R",I1)=XWB2RPCP("R",I1)_$E(Y4,1,255-RMNDRLEN)
129 .....S Y4=$E(Y4,1+(255-RMNDRLEN),$L(Y4))
130 ....E D
131 .....S XWB2RPCP("R",I1,I2-1)=XWB2RPCP("R",I1,I2-1)_$E(Y4,1,255-RMNDRLEN)
132 .....S Y4=$E(Y4,1+(255-RMNDRLEN),$L(Y4))
133 ...;Save remaining chars in Y4 in current remainder node.
134 ...S XWB2RPCP("R",I1,I2)=Y4
135 .;Merge Remainder nodes into primary nodes.
136 .;then remove Remainder nodes.
137 .S I1=$O(XWB2RPCP("R",0)) I I1 D Q
138 ..S I2=+$O(XWB2RPCP("R",I1,"@"),-1)+1
139 ..S RMNDRLEN=$S(I2=1:$L(XWB2RPCP("R",I1)),1:$L(XWB2RPCP("R",I1,I2-1)))
140 ..I RMNDRLEN<255 D
141 ...I I2=1 D Q
142 ....S XWB2RPCP("R",I1)=XWB2RPCP("R",I1)_$E(Y4,1,255-RMNDRLEN)
143 ....S Y4=$E(Y4,1+(255-RMNDRLEN),$L(Y4))
144 ...E D
145 ....S XWB2RPCP("R",I1,I2-1)=XWB2RPCP("R",I1,I2-1)_$E(Y4,1,255-RMNDRLEN)
146 ....S Y4=$E(Y4,1+(255-RMNDRLEN),$L(Y4))
147 ..S:Y4]"" XWB2RPCP("R",I1,I2)=Y4
148 ..M XWB2RPCP(I1)=XWB2RPCP("R",I1)
149 ..K XWB2RPCP("R")
150 .S I1=+$O(XWB2RPCP("@"),-1)+1
151 .S XWB2RPCP(I1)=Y4
152 Q
153 ;
154BLDRDT ;Build RDT segments.
155 N RDTNODE,NODELEN,I,NODERDT
156 S RDTNODE=XWB2RNAM,NODERDT=$E(XWB2RNAM,1,$L(XWB2RNAM)-($E(XWB2RNAM,$L(XWB2RNAM))=")"))
157 I '($D(@RDTNODE)#2) D Q:RDTNODE'[NODERDT
158 .S RDTNODE=$Q(@RDTNODE)
159 F I=4:1 D S RDTNODE=$Q(@RDTNODE) Q:RDTNODE'[NODERDT
160 .S NODELEN=$L(@RDTNODE)
161 .I NODELEN'>241 S ^TMP("HLA",$J,I)="RDT"_HL("FS")_@RDTNODE Q
162 .S ^TMP("HLA",$J,I)="RDT"_HL("FS")_$E(@RDTNODE,1,241)
163 .S ^TMP("HLA",$J,I,1)=$E(@RDTNODE,242,9999)
164 Q
165 ;
166DXLATE(X,OVFL) ;TRANSLATE encoded characters back to there Formating codes.
167 ;Undoes the work of XLATE^XWB2HL7A, \F\ > ^
168 N D,I,I1,L,L1,X1,X2,Y
169 S D=$E(HL("ECH"),3),L=$F(X,D),OVFL=""
170 I 'L Q X
171 F D S L=$F(X,D,L) Q:'L
172 . S L1=$F(XWB2MAP2,$E(X,L))
173 . I L1'>1 D Q
174 . .I L1=1 S OVFL=$E(X,L-1),X=$E(X,1,$L(X)-1)
175 . I L=$L(X) S OVFL=$E(X,L-1,L),X=$E(X,1,L-2) Q
176 . S X2=$E(XWB2EMAP,L1-1)
177 . S $E(X,L-1,L+1)=X2,L=0
178 Q X ;Return the converted string
179 ;
180COMPRES(XWB2P) ;DXLATE AND COMPRESS ARRAY.
181 N CNODE,E,I,J,L,L1,NNODE,XWB2X1,XWB2X2
182 S E=$E(HL("ECH"),3)
183 F I=0:0 S I=$O(XWB2P(I)) Q:I'>0 D
184 .S CNODE=$NA(XWB2P(I))
185 .S @CNODE=$$DXLATE(@CNODE,.XWB2X1)
186 .S L=$L(@CNODE),NNODE=CNODE
187 .F S NNODE=$$NEXTNODE(NNODE) Q:NNODE']"" D
188 ..I $G(XWB2X1)]"" D
189 ...S L1=$L(XWB2X1)
190 ...S XWB2X2=$E(@NNODE,1,3-L1)
191 ...S Y=$$DXLATE(XWB2X1_XWB2X2)
192 ...I $L(Y)=1 D
193 ....S @CNODE=@CNODE_Y
194 ....S @NNODE=$E(@NNODE,3-L1+1,$L(@NNODE))
195 ...E S @CNODE=@CNODE_XWB2X1
196 ..S CNODE=NNODE
197 ..K XWB2X1 S @CNODE=$$DXLATE(@CNODE,.XWB2X1)
198 .I $G(XWB2X1)]"" S @CNODE=@CNODE_XWB2X1
199 ;Compress nodes
200 F I=0:0 S I=$O(XWB2P(I)) Q:I'>0 D
201 .S CNODE=$NA(XWB2P(I))
202 .S L=$L(@CNODE)
203 .S NNODE=CNODE
204 .F Q:NNODE']"" S NNODE=$$NEXTNODE(NNODE) Q:NNODE']"" D
205 ..I L'<255 S CNODE=NNODE,L=$L(@CNODE) Q
206 ..F S NNODE=$$NEXTNODE(NNODE) Q:NNODE']"" D I L=255 S NNODE=CNODE Q
207 ...S L1=$L(@NNODE)
208 ...I 'L1 Q
209 ...S $E(@CNODE,L+1,255)=$E(@NNODE,1,255-L)
210 ...S @NNODE=$E(@NNODE,255-L+1,255)
211 ...S L=$L(@CNODE)
212 .;Clean up excess nodes
213 .S NNODE=CNODE
214 .F S NNODE=$$NEXTNODE(NNODE) Q:NNODE']"" D
215 ..I '$L(@NNODE) K @NNODE
216 Q
217 ;
218NEXTNODE(%) ;Get next node from $NA reference.
219 N QL,QS,X1,Y
220 S QL=$QL($NA(@%))
221 I QL=1 S X1=$O(@%@(0)),Y=$S(X1:$NA(@%@(X1)),1:"") Q Y
222 I QL=2 D Q Y
223 .S X1=$O(@%),Y=$S(X1:$NA(@$NA(@%,1)@(X1)),1:"") Q
224 Q "" ;Error, should not have more than two nodes.
Note: See TracBrowser for help on using the repository browser.