source: FOIAVistA/trunk/r/RPC_BROKER-XWB/XWBBRK2.m@ 775

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

initial load of FOIAVistA 6/30/08 version
File size: 4.1 KB
Line 
1XWBBRK2 ;ISC-SF/EG - DHCP BROKER PROTOYPE -
2 ;;1.1;RPC BROKER;**5**;Mar 28, 1997
3CAPI(XWBY,TAG,NAM,PAR) ;make API call
4 N R,T,DX,DY
5 IF XWB(1,"FLAG")=2 D
6 . S PAR=$P(PAR,XWB("FRM"))_XWB("TO")_$P(PAR,XWB("FRM"),2)
7 S R=$S(PAR'=+PAR&(PAR=""):TAG_"^"_NAM_"(.XWBY)",1:TAG_"^"_NAM_"(.XWBY,"_PAR_")")
8 D:$D(XRTL) T0^%ZOSV ;start RTL
9 U XWBNULL
10 ;
11 ;start RUM for RPC
12 I $G(XWB(2,"CAPI"))]"" D LOGRSRC^%ZOSV(XWB(2,"CAPI"),2,1)
13 ;
14 D @R
15 ;
16 ;restart RUM for handler
17 D LOGRSRC^%ZOSV("$BROKER HANDLER$",2,1)
18 ;
19 S:$D(XRT0) XRTN=XWB(2,"NAME") D:$D(XRT0) T1^%ZOSV ;stop RTL
20 ;once call is completed, write buffer should be empty, make it so!
21 U XWBNULL S DX=0,DY=0 X ^%ZOSF("XY")
22 U XWBTDEV
23 Q
24 ;
25BHDR(WKID,WINH,PRCH,WISH) ;Build a protocol header
26 N S,L
27 S S=""
28 S S=WKID_";"_WINH_";"_PRCH_";"_WISH_";"
29 S L=$L(S)
30 S S=$E("000"_L,$L(L)+1,$L(L)+3)_S
31 Q S
32 ;
33BARY(A,R,V) ;add array elements+values to storage array
34 IF A'["XWBS" Q "-1^ARRAY NAME MUST BE XWBS"
35 S @A@(R)=V
36 Q 0
37 ;
38BLDB(P) ;Build formatted string
39 N L
40 S L=$L(P)
41 Q $E("000"_L,$L(L)+1,$L(L)+3)_P
42 ;
43BLDA(N,P) ;Build API string
44 ;M Extrinsic Function
45 ;Inputs
46 ;N API name
47 ;P Comma delimited parameter string
48 ;Outputs
49 ;String API string if successful, "-1^Text" if error
50 ;
51 N I,F,L,T,U,T1,T2
52 IF '+$D(N) Q "-1^Required input reference is NULL"
53 S U="^"
54 S (F,T,Y)=0
55 IF '$D(P) S P=""
56 IF P'="" D
57 . S L=$L(P)-$L($TR(P,$C(44)))+1
58 . IF L=0 S L=1
59 . F I=1:1:L D Q:T
60 . . S T1=$P(P,",",I)
61 . . S T2=$E(T1,1,1)="."
62 . . IF T1=+T1 Q
63 . . IF $E(T1,1,1)="^" S F=2,T=1 Q
64 . . ;IF $E(T1,1,5)="$NA(^" S F=2,T=1 Q
65 . . IF T2&($E(T1,2,$L(T1))?.ANP) S F=1,T=1 Q
66 ;IF P?.ANP1"."1A.ANP S F=1
67 S P=$$BLDB(P)
68 S L=$L(P)+$L(P)-3
69 S P=F_N_U_P
70 S L=$L(P)
71 Q $E("000"_L,$L(L)+1,$L(L)+3)_P
72 ;
73BLDS(R) ;Build a parameter string from an array
74 N L,T,Y
75 S Y=""
76 F D Q:R=""
77 . S R=$Q(@R)
78 . IF R="" Q
79 . S L=$L(R)+$L(@R)+1
80 . S T=@R
81 . S T=$TR(T,$C(44),$C(23))
82 . S Y=Y_$E("000"_L,$L(L)+1,$L(L)+3)_R_"="_T
83 Q Y_"000"
84 ;
85BLDU(R) ;Build a parameter string from a scalar
86 N DONE,L,N,N1,P1
87 IF R=+R Q R
88 S N=$F(R,$C(34))
89 IF N=0 Q $C(34)_R_$C(34)
90 S P1=$E(R,1,N-2)
91 S (L,DONE)=0
92 F D Q:DONE
93 . S N1=$F(R,$C(34),N)
94 . IF N1=0 S L=$L(R)+2,N1=L
95 . S P1=P1_$C(34,34)_$E(R,N,N1-2)
96 . IF N1=L S DONE=1,P1=$C(34)_P1_$C(34) Q
97 . S N=N1
98 Q $TR(P1,$C(44),$C(23))
99 ;
100BLDG(R) ;build a parameter string from a global reference
101 N I,L,L1,M,T,T1,T2,Y
102 K ^TMP("XWB",$J)
103 IF '$D(R) Q "-1^Reference does not exist"
104 S Y=$NA(^TMP("XWB",$J,$P($H,",",2)))
105 S I=0
106 S M=512
107 S T1=$P(R,")")
108 S L1=$L($P(R,"("))
109 F D Q:R=""
110 . S R=$Q(@R)
111 . S T2=$F(R,"(")
112 . IF R=""!(R'[T1) Q
113 . S L=$L(R)+$L(@R)-L1
114 . S T=@R
115 . S T=$TR(T,$C(44),$C(23))
116 . S @Y@(I)=$E("000"_L,$L(L)+1,$L(L)+3)_"^("_$E(R,T2,M)_"="_$$BLDU(T)
117 . S I=I+1
118 S @Y@(I)="000"
119 S Y=$TR(Y,$C(44),$C(23))
120 Q Y
121 ;
122OARY() ;create storage array
123 N A,DONE,I
124 S (DONE,I)=0
125 F I=1:1 D Q:DONE
126 . S A="XWBS"_I
127 . K @A ;temp fix for single array
128 . IF '$D(@A) S DONE=1
129 ;S Y("XWBS")=A
130 S @A="" ;set naked
131 Q A
132 ;
133CREF(R,P) ;Convert array contained in P to reference A
134 N I,X,DONE,F1,S
135 S DONE=0
136 S S=""
137 F I=1:1 D Q:DONE
138 . IF $P(P,",",I)="" S DONE=1 Q
139 . S X(I)=$P(P,",",I)
140 . IF X(I)?1"."1A.E D
141 . . S F1=$F(X(I),".")
142 . . S X(I)="."_R
143 . S S=S_X(I)_","
144 Q $E(S,1,$L(S)-1)
145 ;
146GETP(P) ;returns various parameters out of the Protocol string
147 N M,T,XWB
148 S M=512
149 S T=$$PRSP^XWBBRK(P)
150 IF '+T D
151 . S T=$$PRSM^XWBBRK(XWB(0,"MESG"))
152 . IF '+T S T=XWB(0,"WKID")_";"_XWB(0,"WINH")_";"_XWB(0,"PRCH")_";"_XWB(0,"WISH")_";"_$P(XWB(1,"TEXT"),"^")
153 Q T
154 ;
155CALLM(X,P,DEBUG) ;make call using Message string
156 N ERR,S
157 S X="",ERR=0
158 S ERR=$$PRSM^XWBBRK(P)
159 IF '+ERR S ERR=$$PRSA^XWBBRK(XWB(1,"TEXT"))
160 IF '+ERR S S=$$PRSB^XWBBRK(XWB(2,"PARM"))
161 IF (+S=0)!(+S>0) D
162 . D CAPI(.X,XWB(2,"RTAG"),XWB(2,"RNAM"),S)
163 IF 'DEBUG K XWB
164 K @(X("XWBS")),X("XWBS")
165 Q
166 ;
167CALLA(X,P,DEBUG) ;make call using API string
168 N ERR,S
169 S X="",ERR=0
170 S ERR=$$PRSA^XWBBRK(P)
171 IF '+ERR S S=$$PRSB^XWBBRK(XWB(2,"PARM"))
172 IF (+S=0)!(+S>0) D
173 . D CAPI(.X,XWB(2,"RTAG"),XWB(2,"RNAM"),S)
174 IF 'DEBUG K XWB
175 K @(X("XWBS")),X("XWBS")
176 Q
177 ;
178TRANSPRT() ;Determine the Transport Method
179 ;DDP is local :=0
180 ;TCP/IP is remote :=1
181 ;Serial/RS-232 is remote :=2
182 Q 1
183 ;Q 0 ;Do DDP for Now
Note: See TracBrowser for help on using the repository browser.