source: WorldVistAEHR/trunk/r/RPC_BROKER-XWB/XWB2HL7A.m@ 1076

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

initial load of WorldVistAEHR

File size: 4.8 KB
Line 
1XWB2HL7A ;;ISF/AC - Remote RPCs via HL7. ;03/14/2000 00:36
2 ;;1.1;RPC BROKER;**12**;Mar 28, 1997
3RPCINFO ;RPC Information
4 ;Msg Type: SPQ - stored procedure request (event Q01)
5 ;--------------
6 ;MSH Message Header
7 ;SPR Store Procedure Request
8 ; Query Tag^Query/Response Format Code^Stored Proc Name^Param List
9 ;[ RDF ] Table Row Definition
10 ; # of Columns per Row^Column Description
11 ;[ DSC ] Continuation Pointer
12 ;--------------
13 ;Response Msg Type: TBR - tabular data response
14 ;--------------
15 ;MSH Message Header
16 ;MSA Message Acknowledgment
17 ;[ERR] Error
18 ;QAK Query Acknowledgment
19 ;RDF Table Row Definition
20 ; # of Columns per Row^Column Description
21 ;{ RDT } Table Row Data
22 ; Column Value
23 ;[ DSC ] Continuation Pointer
24 ;-------------
25DIRECT(XWB2SPN,XWB2HNDL,XWB2RET,XWB2DEST,XWB2PRAM,XWB2PARY) ;DIR RPC CALL
26 N XWB2DRCT
27 S XWB2DRCT=1
28 G D2
29 ;
30 ;-------------
31 ;This is where the RPC calls to send the RPC to the remote system
32 ;(procedurename, query tag, error return, destination, Parameter array)
33CALL(XWB2SPN,XWB2HNDL,XWB2RET,XWB2DEST,XWB2PRAM,XWB2PARY) ;RPC CALL
34 ;
35D2 N I,J,HL,HLA,HLL,XWB2LSTI,HLERR,XWB2EMAP,XWB2FLD,XWB2LPRM,XWB2MAP2,XWB2PARM,XWB2QTAG,XWB2SPRL,XWB2SPR,XWB2X,XWB2EID,XWB2MIEN,XWB2OVFL,XWB2RSLT,Y
36 S XWB2QTAG=$G(XWB2HNDL)
37 S XWB2SPN=$G(XWB2SPN)
38 S XWB2FLD="@SPR.4.2"
39 S (XWB2RET,XWB2PARM)=""
40 D BLDDIST($G(XWB2DEST))
41 I '$O(HLL("LINKS",0)) S $P(XWB2RET,"^",2,3)="-1^Station # not found" Q
42 S XWB2EID=+$$FIND1^DIC(101,,"MX","XWB RPC EVENT")
43 I 'XWB2EID S $P(XWB2RET,"^",2,3)="-1^RPC Broker Protocol not setup" Q
44 D INIT^HLFNC2(.XWB2EID,.HL)
45 I $O(HL(""))']"" S $P(XWB2RET,"^",2,3)="-1^RPC Broker Params not setup" Q
46 ;XWB2EMAP=encoding characters to map by order.
47 ;XWB2MAP2=escaped characters used for mapping encoding characters.
48 S Y=""
49 F I=3,0,1,2,4 S Y=Y_$S(I:$E(HL("ECH"),I),1:HL("FS"))
50 S XWB2EMAP=Y,XWB2MAP2="EFSRT"
51 F I=0:0 S I=$O(XWB2PRAM(I)) Q:I'>0!$P(XWB2RET,"^",2) D
52 .I $L(XWB2PRAM(I))>255 S $P(XWB2RET,"^",2,3)="-1^RPC Parameter(s) exceed length of 255." Q
53 .S XWB2PRAM(I)=$$XLATE(XWB2PRAM(I),.XWB2OVFL)
54 .S J=0
55 .I $O(XWB2OVFL(0)) D K XWB2OVFL
56 ..F K=1,2 I $D(XWB2OVFL(K)) D
57 ...S XWB2PRAM(I,(K/10))=XWB2OVFL(1)
58 ...S J=(K/10) K XWB2OVFL(K)
59 .F S J=$O(XWB2PRAM(I,J)) Q:J'>0!$P(XWB2RET,"^",2) D
60 ..I $L(XWB2PRAM(I))>255 S $P(XWB2RET,"^",2,3)="-1^RPC Parameter(s) exceed length of 255." Q
61 ..S XWB2PRAM(I,J)=$$XLATE(XWB2PRAM(I,J),.XWB2OVFL)
62 ..I $O(XWB2OVFL(0)) D K XWB2OVFL
63 ...F K=1,2 I $D(XWB2OVFL(K)) D
64 ....S XWB2PRAM(I,J+(K/10))=XWB2OVFL(1)
65 ....S J=J+(K/10) K XWB2OVFL(K)
66 I $P(XWB2RET,"^",2) Q
67 D RPCSEND
68 M XWB2RET=XWB2RSLT ;Move the return info into return var.
69CALLXIT ;Cleanup before exit.
70 Q
71 ;
72RPCSEND ;
73 N I,J
74 S HLA("HLS",1)="SPR"_HL("FS")_XWB2QTAG_HL("FS")_"T"_HL("FS")_XWB2SPN_HL("FS")_XWB2FLD_$E(HL("ECH"))
75 S XWB2SPRL=$L(HLA("HLS",1)),XWB2SPR=$NA(HLA("HLS",1))
76 S I=$O(XWB2PRAM(0)) Q:I'>0 D
77 .S XWB2LSTI=I,XWB2X=XWB2PRAM(I)
78 .I (XWB2SPRL+$L(XWB2X))>255!$O(XWB2PRAM(I,0)) D NXTNODE
79 .S @XWB2SPR=@XWB2SPR_XWB2X,XWB2SPRL=$L(@XWB2SPR)
80 .F J=0:0 S J=$O(XWB2PRAM(I,J)) Q:J'>0 D
81 ..S XWB2X=XWB2PRAM(I,J)
82 ..D NXTNODE
83 ..S @XWB2SPR=@XWB2SPR_XWB2X,XWB2SPRL=$L(@XWB2SPR)
84 ..Q
85 F S I=$O(XWB2PRAM(I)) Q:I'>0 D
86 .S XWB2X=XWB2PRAM(I)
87 .I (XWB2SPRL+$L(XWB2X)+1)>255!$O(XWB2PRAM(I,0)) D NXTNODE
88 .S @XWB2SPR=@XWB2SPR_$E(HL("ECH"),4)_XWB2X,XWB2SPRL=$L(@XWB2SPR)
89 .F J=0:0 S J=$O(XWB2PRAM(I,J)) Q:J'>0 D
90 ..S XWB2X=XWB2PRAM(I,J)
91 ..D NXTNODE
92 ..S @XWB2SPR=@XWB2SPR_XWB2X,XWB2SPRL=$L(@XWB2SPR)
93 ..Q
94 S HLA("HLS",2)="RDF"_HL("FS")_"1"_HL("FS")_"@DSP.3"_$E(HL("ECH"))_"TX"_$E(HL("ECH"))_"300"
95 I $D(XWB2DRCT) D DIRECT^HLMA(XWB2EID,"LM",1,.XWB2RSLT) Q
96 D GENERATE^HLMA(XWB2EID,"LM",1,.XWB2RSLT,.XWB2MIEN)
97 Q
98 ;
99NXTNODE ;Get next node
100 N XWB2QL,XWB2QS
101 S XWB2QL=$QL($NA(@XWB2SPR))
102 I XWB2QL=2 S XWB2SPR=$NA(@XWB2SPR@(1)),@XWB2SPR="" Q
103 I XWB2QL=3 D Q
104 .S XWB2QS=+$QS($NA(@XWB2SPR),3)+1
105 .S XWB2SPR=$NA(@$NA(@XWB2SPR,2)@(XWB2QS)),@XWB2SPR=""
106 Q
107 ;
108 ;
109BLDDIST(X) ;Build distribution list -- HLL("LINKS") ARRAY.
110 N %,XWB2LIST
111 D LINK^HLUTIL3(X,.XWB2LIST,"I")
112 S %=+$O(XWB2LIST(0)) Q:'%
113 S HLL("LINKS",1)="XWB RPC SUBSCRIBER"_U_XWB2LIST(%)
114 Q
115XLATE(X,%) ;TRANSLATE FS and Encoding characters to Formating codes.
116 ;
117 N I,I1,I2,L,L1,L2,LCNT,LOVFL,LS,X1,X2,Y
118 S X(0)=X
119 F I=0:1:2 S L=0 D Q:L'>255
120 .S LS=$L(X(I))
121 .F I1=1:1:5 S X1=$E(XWB2EMAP,I1),X2=$E(XWB2MAP2,I1) S L=L+(($L(X(I),X1)-1)*2)
122 .S L=L+LS
123 .I L>255 D
124 ..S LOVFL=L-255
125 ..S L1=(LS+1)-$S(LOVFL<170:LOVFL,1:170)
126 ..S L1=$S(L1<86:86,1:L1)
127 ..S L2=LS-$S(LOVFL<170:LOVFL,1:170)
128 ..S L2=$S(L2>85:L2,1:85)
129 ..S X(I+1)=$E(X(I),L1,LS)
130 ..S X(I)=$E(X(I),1,L2)
131 ;
132 S %(0)=X(0)
133 F I2=0:1:2 Q:'$D(X(I2)) S X=X(I2) D
134 .S Y=""
135 .F I1=1:1:5 S X1=$E(XWB2EMAP,I1),X2=$E(XWB2MAP2,I1) D
136 ..S LS=$L(X)
137 ..S L=$L(X,X1)
138 ..I L>1 D
139 ...F I=1:1:L S Y=Y_$P(X,X1,I)_$S(I'=L:$$ECODE(X2),1:"")
140 ...S X=Y,Y=""
141 .S %(I2)=X
142 S Y=%(0) K %(0)
143 Q Y
144ECODE(X) ;
145 N Y
146 S Y=$E(HL("ECH"),3)_X_$E(HL("ECH"),3)
147 Q Y
148 ;
Note: See TracBrowser for help on using the repository browser.