source: BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXEHR.m@ 1181

Last change on this file since 1181 was 1147, checked in by Sam Habiel, 14 years ago

Mumps Routines 4 BMX4
File size: 7.4 KB
Line 
1BMXEHR ; IHS/OIT/GIS - ENCAPSULATE BMX CALLS FOR USE WITHIN THE EHR 14 Jan 2009 4:37 PM ; 04 Jun 2010 3:16 PM
2 ;;4.1000;BMX;;Apr 17, 2011
3 ;
4 ;
5 ;
6CIARPCD(XOUT,IN,A,B,C) ; EP - RPC: CIABMX - EHR WRAPER FOR BMX
7 ;
8 S A=$G(A),B=$G(B),C=$G(C)
9 ; D DEBUG^%Serenji("CIARPCD^BMXEHR(.XOUT,IN,A,B,C)")
10 Q
11CIARPC(XOUT,IN,A,B,C) ; EP - RPC: CIABMX - EHR WRAPER FOR BMX
12 ; INPUT = CF QUAD OR AN ADO RECORD SET
13 ; OUT = BMX DATA ARRAY IN "^TMP("BMX DATA",$J)
14 S XOUT=$NA(^TMP("BMX DATA",$J)),@XOUT@(1)=""
15 ; S BMXR=$NA(^TMP("BMX ADO",$J))
16 I $G(A)'="" S IN=IN_"^"_A
17 I $G(IN)'["{BMX}" Q
18 N X,Y,Z,BMXTBUF,BMXHTYP,BMXTLEN,L,BMXDTIME,BMXPLEN,STG,BMXTIME,BMXPTYPE,BMXWRAP,BMXR,I,SECURE,CTXT,DTSG,NODE,L
19 S CTXT="",BMXTBUF="",RESULT=""
20LONG D PARSE(IN,.CTXT,.BMXTBUF) I $L(BMXTBUF),$L(CTXT) G CALLPNOW ; INPUT STRING IS IN LONG FORMAT
21SHORT D PARSE1 I '$L(BMXTBUF)!('$L(CTXT)) Q ; LONG PARSE FAILED, SO INPUT STRING MUST BE IN SHORT FORMAT
22CALLPNOW D CRCONTXT^XWBSEC(.SECURE,CTXT) I 'SECURE Q ; CONFIRM THAT THE USER HAS CONTEXT SECURITY
23 D CALLP(.BMXR,BMXTBUF,.BMXSTR) ; RUN THE RPC
24 I BMXSTR="",$L($G(BMXR)) S BMXSTR=BMXR
25 S BMXPTYPE=$S('$D(BMXPTYPE):1,BMXPTYPE<1:1,BMXPTYPE>6:1,1:BMXPTYPE)
26 IF BMXPTYPE'=1,BMXPTYPE'=5,$L($G(BMXSEC))'>0
27 E S @XOUT@(1)=$G(BMXSTR) Q ; -- SIMPLE STRING
28ARR ; -- word processing or global array, or global instance
29 I $G(BMXR)="" S BMXR="BMXR"
30 I '$O(@BMXR@(0)) Q
31 S I="",NODE=1,L=0
32 F S I=$O(@BMXR@(I)) Q:I="" D
33 . S DSTG=@BMXR@(I)
34 . I '$L(DSTG) Q
35 . S %=$L(DSTG)+L I %<32000 S @XOUT@(NODE)=@XOUT@(NODE)_DSTG,L=% Q
36 . S NODE=NODE+1,L=$L(DSTG)
37 . S @XOUT@(NODE)=DSTG
38 . Q
39CLEANUP K @BMXR
40 Q
41 ;
42PARSE(IN,CTXT,STG1) ; EP - PARSE INPUT STRING, LONG FORMAT
43 S CTXT="",STG1=""
44 I $L($G(IN))
45 E Q
46 N A,B,C,X,Y,Z,%,L1,L2,L3,L4
47 S A=$E(IN,1,5) I A'="{BMX}" Q
48 S L1=+$E(IN,16,18) I 'L1 Q
49 S B=+$E(IN,18+L1+6) I B'=1 Q
50 S L2=+$E(IN,6,10) I 'L2 Q
51 S C=$E(IN,16,L2),D=$E(IN,L2+1,9999)
52 S L3=+$E(D,11,15)
53 S CTXT=$E(D,16,L3+15)
54 S E=$E(D,L3+16,9999)
55 S STG1=C_E
56 Q
57 ;
58PARSE1 ; PARSE INPUT STRING, SHORT FORMAT
59 S STG=IN,BMXTIME=$G(BMXTIME,60)
60 S BMXTBUF=$E(STG,1,11),STG=$E(STG,12,999)
61 S BMXHTYP=5
62 S BMXTLEN=$E(BMXTBUF,6,10)-15,L=$E(BMXTBUF,11,11)
63 S BMXTBUF=$E(STG,1,4),STG=$E(STG,5,999)
64 S BMXTBUF=L_BMXTBUF
65 S BMXPLEN=BMXTBUF
66 S BMXTBUF=$E(STG,1,BMXPLEN),STG=$E(STG,(BMXPLEN+1),999)
67 K BMXR,BMXARY
68 S BMXDTIME=9999,BMXDTIME(1)=0.5
69 I $L(IN,"{BMX}")>2 S CTXT=$E(IN,31+BMXPLEN,9999)
70 Q
71 ;
72PRSP(PARG) ;EP -Parse Protocol
73 ;M Extrinsic Function
74 ;
75 ;Inputs
76 ;P Protocol string with the form
77 ; Protocol := Protocol Header^Message where
78 ; Protocol Header := LLLWKID;WINH;PRCH;WISH;MESG
79 ; LLL := length of protocol header (3 numeric)
80 ; WKID := Workstation ID (ALPHA)
81 ; WINH := Window handle (ALPHA)
82 ; PRCH := Process handle (ALPHA)
83 ; WISH := Window server handle (ALPHA)
84 ; MESG := Unparsed message
85 ;Outputs
86 ;ERR 0 for success, "-1^Text" if error
87 ;
88 N ERR,C,M,R,X,P
89 S P=PARG
90 S R=0,C=";",ERR=0,M=99999 ;Maximum buffer input
91 IF $E(P,1,5)="{BMX}" S P=$E(P,6,$L(P)) ;drop out prefix
92 IF '+$G(P) S ERR="-1^Required input reference is NULL"
93 IF +ERR=0 D
94 . S BMXZ(R,"LENG")=+$E(P,1,3)
95 . S X=$E(P,4,BMXZ(R,"LENG")+3)
96 . S BMXZ(R,"MESG")=$E(P,BMXZ(R,"LENG")+4,M)
97 . S BMXZ(R,"WKID")=$P(X,C)
98 . S BMXZ(R,"WINH")=$P(X,C,2)
99 . S BMXZ(R,"PRCH")=$P(X,C,3)
100 . S BMXZ(R,"WISH")=$P(X,C,4)
101 Q ERR
102 ;
103PRSM(PARG) ;EP - Parse message
104 ;M Extrinsic Function
105 ;
106 ;Inputs
107 ;P Message string with the form
108 ; Message := Header^Content
109 ; Header := LLL;FLAG
110 ; LLL := length of entire message (3 numeric)
111 ; FLAG := 1 indicates variables follow
112 ; Content := Contains API call information
113 ;Outputs
114 ;ERR 0 for success, "-1^Text" if error
115 N C,ERR,M,R,X,U,P
116 S P=PARG
117 S U="^",R=1,C=";",ERR=0,M=99999 ;Max buffer
118 IF '+$G(P) S ERR="-1^Required input reference is NULL"
119 IF +ERR=0 D
120 . S BMXZ(R,"LENG")=+$E(P,1,5)
121 . S BMXZ(R,"FLAG")=$E(P,6,6)
122 . S BMXZ(R,"TEXT")=$E(P,7,M)
123 Q ERR
124 ;
125PRSA(P) ;EP - Parse API information, get calling info
126 ;M Extrinsic Function
127 ;Inputs
128 ;P Content := API Name^Param string
129 ; API := .01 field of API file
130 ; Param := Parameter information
131 ;Outputs
132 ;ERR 0 for success, "-1^Text" if error
133 ;
134 N C,DR,ERR,M,R,T,X,U
135 S U="^",R=2,C=";",ERR=0,M=99999 ;Max buffer
136 IF '+$L(P) S ERR="-1^Required input reference is NULL"
137 IF +ERR=0 D
138 . S BMXZ(R,"CAPI")=$P(P,U)
139 . S BMXZ(R,"PARM")=$E(P,$F(P,U),M)
140 . S T=$O(^XWB(8994,"B",BMXZ(R,"CAPI"),0))
141 . I '+T S ERR="-1^Remote Procedure '"_BMXZ(R,"CAPI")_"' doesn't exist on the server." Q ;P10 - dpc
142 . S T(0)=$G(^XWB(8994,T,0))
143 . I $P(T(0),U,6)=1!($P(T(0),U,6)=2) S ERR="-1^Remote Procedure '"_BMXZ(R,"CAPI")_"' cannot be run at this time." Q ;P10. Check INACTIVE field. - dpc.
144 . S BMXZ(R,"NAME")=$P(T(0),"^")
145 . S BMXZ(R,"RTAG")=$P(T(0),"^",2)
146 . S BMXZ(R,"RNAM")=$P(T(0),"^",3)
147 . S BMXPTYPE=$P(T(0),"^",4)
148 . S BMXWRAP=+$P(T(0),"^",8)
149 Q ERR
150 ;information
151PRSB(P) ;EP - Parse Parameter
152 ;M Extrinsic Function
153 ;Inputs
154 ;P Param := M parameter list
155 ; Param := LLL,Name,Value
156 ; LLL := length of variable name and value
157 ; Name := name of M variable
158 ; Value := a string
159 ;Outputs
160 ;ERR 0 for success, "-1^Text" if error
161 ;
162 ;
163 N A,ERR,F,FL,I,K,L,M,P1,P2,P3,P4,P5,MAXP,R,Z
164 S R=3,MAXP=+$E(P,1,5)
165 S P1=$E(P,6,MAXP+5) ;only param string
166 S ERR=0,F=3,M=99999
167 IF '+$D(P) S ERR="-1^Required input reference is NULL"
168 S FL=+$G(BMXZ(1,"FLAG"))
169 S I=0
170 IF '+ERR D
171 . IF 'FL,+MAXP=0 S P1="",ERR=1 Q
172 . F D Q:P1=""
173 . . Q:P1=""
174 . . S L=+$E(P1,1,3)-1
175 . . S P3=+$E(P1,4,4)
176 . . S P1=$E(P1,5,MAXP)
177 . . S BMXZ(R,"P",I)=$S(P3'=1:$E(P1,1,L),1:$$GETV^BMXMBRK($E(P1,1,L)))
178 . . IF FL=1,P3=2 D ;XWB*1.1*2
179 . . . S A=$$OARY^BMXMBRK2,BMXARY=A
180 . . . S BMXZ(R,"P",I)=$$CREF^BMXMBRK2(A,BMXZ(R,"P",I))
181 . . S P1=$E(P1,L+1,MAXP)
182 . . S K=I,I=I+1
183 . IF 'FL Q
184 . S P3=P
185 . S L=+$E(P3,1,5)
186 . S P1=$E(P3,F+3,L+F)
187 . S P2=$E(P3,L+F+3,M)
188 . ;instantiate array
189 . ;0011400
190 . S Z=$P(P,".x",2,99)
191 . F D Q:+L=0
192 . . S L=+$E(Z,1,3)
193 . . S P3=+$E(Z,4,3+L)
194 . . S L1=+$E(Z,L+4,L+6)
195 . . S P4=$E(Z,L+7,L+6+L1)
196 . . ; S L=$$BREAD(3) Q:+L=0 S P3=$$BREAD(L)
197 . . ; S L=$$BREAD(3) IF +L'=0 S P4=$$BREAD(L)
198 . . IF +L=0 Q
199 . . IF P3=0,P4=0 S L=0 Q
200 . . IF FL=1 D LINST^BMXMBRK(A,P3,P4)
201 . . S Z=$E(Z,L+7+L1,99999)
202 IF ERR Q P1
203 S P1=""
204 F I=0:1:K D
205 . IF FL,$E(BMXZ(R,"P",I),1,5)=".BMXS" D Q ;XWB*1.1*2
206 .. S P1=P1_"."_$E(BMXZ(R,"P",I),2,$L(BMXZ(R,"P",I)))
207 .. IF I'=K S P1=P1_","
208 .. Q
209 . S P1=P1_"BMXZ("_R_",""P"","_I_")"
210 . IF I'=K S P1=P1_","
211 . Q
212 IF '+ERR Q P1
213 Q ERR
214 ;
215CALLP(BMXP,P,BMXSTR,DEBUG) ;EP - make API call using Protocol string
216 N ERR,S
217 S ERR=0,BMXSTR=""
218 K BMXSEC
219 IF '$D(DEBUG) S DEBUG=0
220 S ERR=$$PRSP(P)
221 IF '+ERR S ERR=$$PRSM(BMXZ(0,"MESG"))
222 IF '+ERR S ERR=$$PRSA(BMXZ(1,"TEXT")) ;I $G(BMXZ(2,"CAPI"))="XUS SET SHARED" S XWBSHARE=1 Q
223 I +ERR S BMXSEC=$P(ERR,U,2) ;P10 -- dpc
224 IF '+ERR S S=$$PRSB(BMXZ(2,"PARM"))
225 ;IF (+S=0)!(+S>0) D
226 I '+ERR D CHKPRMIT^BMXMSEC(BMXZ(2,"CAPI")) ;checks if RPC allowed to run
227 S:$L($G(BMXSEC)) ERR="-1^"_BMXSEC
228 ;IF 'DEBUG S:$D(XRT0) XRTN="RPC BROKER READ/PARSE" D:$D(XRT0) T1^%ZOSV ;stop RTL
229 IF '+ERR,(+S=0)!(+S>0) D
230 . D CAPI^BMXMBRK2(.BMXP,BMXZ(2,"RTAG"),BMXZ(2,"RNAM"),S)
231 IF 'DEBUG K BMXZ
232 IF $D(BMXARY) K @BMXARY,BMXARY
233 Q
234 ;
235TEST(OUT,STG,RPT,DELAY) ;
236 I $L($G(STG))
237 E Q
238 S OUT=$NA(^TMP("BMX DATA",$J)),@OUT@(1)=""
239 S RPT=+$G(RPT)
240 I RPT F I=1:1:RPT S STG=STG_STG
241 H +$G(DELAY)
242 S OUT=STG
243 Q
244 ;
Note: See TracBrowser for help on using the repository browser.