BMXEHR ; IHS/OIT/GIS - ENCAPSULATE BMX CALLS FOR USE WITHIN THE EHR 14 Jan 2009 4:37 PM ; 04 Jun 2010 3:16 PM
;;4.0;BMX;;JUN 28, 2010
;
;
;
CIARPCD(XOUT,IN,A,B,C) ; EP - RPC: CIABMX - EHR WRAPER FOR BMX
;
S A=$G(A),B=$G(B),C=$G(C)
; D DEBUG^%Serenji("CIARPCD^BMXEHR(.XOUT,IN,A,B,C)")
Q
CIARPC(XOUT,IN,A,B,C) ; EP - RPC: CIABMX - EHR WRAPER FOR BMX
; INPUT = CF QUAD OR AN ADO RECORD SET
; OUT = BMX DATA ARRAY IN "^TMP("BMX DATA",$J)
S XOUT=$NA(^TMP("BMX DATA",$J)),@XOUT@(1)=""
; S BMXR=$NA(^TMP("BMX ADO",$J))
I $G(A)'="" S IN=IN_"^"_A
I $G(IN)'["{BMX}" Q
N X,Y,Z,BMXTBUF,BMXHTYP,BMXTLEN,L,BMXDTIME,BMXPLEN,STG,BMXTIME,BMXPTYPE,BMXWRAP,BMXR,I,SECURE,CTXT,DTSG,NODE,L
S CTXT="",BMXTBUF="",RESULT=""
LONG D PARSE(IN,.CTXT,.BMXTBUF) I $L(BMXTBUF),$L(CTXT) G CALLPNOW ; INPUT STRING IS IN LONG FORMAT
SHORT D PARSE1 I '$L(BMXTBUF)!('$L(CTXT)) Q ; LONG PARSE FAILED, SO INPUT STRING MUST BE IN SHORT FORMAT
CALLPNOW D CRCONTXT^XWBSEC(.SECURE,CTXT) I 'SECURE Q ; CONFIRM THAT THE USER HAS CONTEXT SECURITY
D CALLP(.BMXR,BMXTBUF,.BMXSTR) ; RUN THE RPC
I BMXSTR="",$L($G(BMXR)) S BMXSTR=BMXR
S BMXPTYPE=$S('$D(BMXPTYPE):1,BMXPTYPE<1:1,BMXPTYPE>6:1,1:BMXPTYPE)
IF BMXPTYPE'=1,BMXPTYPE'=5,$L($G(BMXSEC))'>0
E S @XOUT@(1)=$G(BMXSTR) Q ; -- SIMPLE STRING
ARR ; -- word processing or global array, or global instance
I $G(BMXR)="" S BMXR="BMXR"
I '$O(@BMXR@(0)) Q
S I="",NODE=1,L=0
F S I=$O(@BMXR@(I)) Q:I="" D
. S DSTG=@BMXR@(I)
. I '$L(DSTG) Q
. S %=$L(DSTG)+L I %<32000 S @XOUT@(NODE)=@XOUT@(NODE)_DSTG,L=% Q
. S NODE=NODE+1,L=$L(DSTG)
. S @XOUT@(NODE)=DSTG
. Q
CLEANUP K @BMXR
Q
;
PARSE(IN,CTXT,STG1) ; EP - PARSE INPUT STRING, LONG FORMAT
S CTXT="",STG1=""
I $L($G(IN))
E Q
N A,B,C,X,Y,Z,%,L1,L2,L3,L4
S A=$E(IN,1,5) I A'="{BMX}" Q
S L1=+$E(IN,16,18) I 'L1 Q
S B=+$E(IN,18+L1+6) I B'=1 Q
S L2=+$E(IN,6,10) I 'L2 Q
S C=$E(IN,16,L2),D=$E(IN,L2+1,9999)
S L3=+$E(D,11,15)
S CTXT=$E(D,16,L3+15)
S E=$E(D,L3+16,9999)
S STG1=C_E
Q
;
PARSE1 ; PARSE INPUT STRING, SHORT FORMAT
S STG=IN,BMXTIME=$G(BMXTIME,60)
S BMXTBUF=$E(STG,1,11),STG=$E(STG,12,999)
S BMXHTYP=5
S BMXTLEN=$E(BMXTBUF,6,10)-15,L=$E(BMXTBUF,11,11)
S BMXTBUF=$E(STG,1,4),STG=$E(STG,5,999)
S BMXTBUF=L_BMXTBUF
S BMXPLEN=BMXTBUF
S BMXTBUF=$E(STG,1,BMXPLEN),STG=$E(STG,(BMXPLEN+1),999)
K BMXR,BMXARY
S BMXDTIME=9999,BMXDTIME(1)=0.5
I $L(IN,"{BMX}")>2 S CTXT=$E(IN,31+BMXPLEN,9999)
Q
;
PRSP(PARG) ;EP -Parse Protocol
;M Extrinsic Function
;
;Inputs
;P Protocol string with the form
; Protocol := Protocol Header^Message where
; Protocol Header := LLLWKID;WINH;PRCH;WISH;MESG
; LLL := length of protocol header (3 numeric)
; WKID := Workstation ID (ALPHA)
; WINH := Window handle (ALPHA)
; PRCH := Process handle (ALPHA)
; WISH := Window server handle (ALPHA)
; MESG := Unparsed message
;Outputs
;ERR 0 for success, "-1^Text" if error
;
N ERR,C,M,R,X,P
S P=PARG
S R=0,C=";",ERR=0,M=99999 ;Maximum buffer input
IF $E(P,1,5)="{BMX}" S P=$E(P,6,$L(P)) ;drop out prefix
IF '+$G(P) S ERR="-1^Required input reference is NULL"
IF +ERR=0 D
. S BMXZ(R,"LENG")=+$E(P,1,3)
. S X=$E(P,4,BMXZ(R,"LENG")+3)
. S BMXZ(R,"MESG")=$E(P,BMXZ(R,"LENG")+4,M)
. S BMXZ(R,"WKID")=$P(X,C)
. S BMXZ(R,"WINH")=$P(X,C,2)
. S BMXZ(R,"PRCH")=$P(X,C,3)
. S BMXZ(R,"WISH")=$P(X,C,4)
Q ERR
;
PRSM(PARG) ;EP - Parse message
;M Extrinsic Function
;
;Inputs
;P Message string with the form
; Message := Header^Content
; Header := LLL;FLAG
; LLL := length of entire message (3 numeric)
; FLAG := 1 indicates variables follow
; Content := Contains API call information
;Outputs
;ERR 0 for success, "-1^Text" if error
N C,ERR,M,R,X,U,P
S P=PARG
S U="^",R=1,C=";",ERR=0,M=99999 ;Max buffer
IF '+$G(P) S ERR="-1^Required input reference is NULL"
IF +ERR=0 D
. S BMXZ(R,"LENG")=+$E(P,1,5)
. S BMXZ(R,"FLAG")=$E(P,6,6)
. S BMXZ(R,"TEXT")=$E(P,7,M)
Q ERR
;
PRSA(P) ;EP - Parse API information, get calling info
;M Extrinsic Function
;Inputs
;P Content := API Name^Param string
; API := .01 field of API file
; Param := Parameter information
;Outputs
;ERR 0 for success, "-1^Text" if error
;
N C,DR,ERR,M,R,T,X,U
S U="^",R=2,C=";",ERR=0,M=99999 ;Max buffer
IF '+$L(P) S ERR="-1^Required input reference is NULL"
IF +ERR=0 D
. S BMXZ(R,"CAPI")=$P(P,U)
. S BMXZ(R,"PARM")=$E(P,$F(P,U),M)
. S T=$O(^XWB(8994,"B",BMXZ(R,"CAPI"),0))
. I '+T S ERR="-1^Remote Procedure '"_BMXZ(R,"CAPI")_"' doesn't exist on the server." Q ;P10 - dpc
. S T(0)=$G(^XWB(8994,T,0))
. 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.
. S BMXZ(R,"NAME")=$P(T(0),"^")
. S BMXZ(R,"RTAG")=$P(T(0),"^",2)
. S BMXZ(R,"RNAM")=$P(T(0),"^",3)
. S BMXPTYPE=$P(T(0),"^",4)
. S BMXWRAP=+$P(T(0),"^",8)
Q ERR
;information
PRSB(P) ;EP - Parse Parameter
;M Extrinsic Function
;Inputs
;P Param := M parameter list
; Param := LLL,Name,Value
; LLL := length of variable name and value
; Name := name of M variable
; Value := a string
;Outputs
;ERR 0 for success, "-1^Text" if error
;
;
N A,ERR,F,FL,I,K,L,M,P1,P2,P3,P4,P5,MAXP,R,Z
S R=3,MAXP=+$E(P,1,5)
S P1=$E(P,6,MAXP+5) ;only param string
S ERR=0,F=3,M=99999
IF '+$D(P) S ERR="-1^Required input reference is NULL"
S FL=+$G(BMXZ(1,"FLAG"))
S I=0
IF '+ERR D
. IF 'FL,+MAXP=0 S P1="",ERR=1 Q
. F D Q:P1=""
. . Q:P1=""
. . S L=+$E(P1,1,3)-1
. . S P3=+$E(P1,4,4)
. . S P1=$E(P1,5,MAXP)
. . S BMXZ(R,"P",I)=$S(P3'=1:$E(P1,1,L),1:$$GETV^BMXMBRK($E(P1,1,L)))
. . IF FL=1,P3=2 D ;XWB*1.1*2
. . . S A=$$OARY^BMXMBRK2,BMXARY=A
. . . S BMXZ(R,"P",I)=$$CREF^BMXMBRK2(A,BMXZ(R,"P",I))
. . S P1=$E(P1,L+1,MAXP)
. . S K=I,I=I+1
. IF 'FL Q
. S P3=P
. S L=+$E(P3,1,5)
. S P1=$E(P3,F+3,L+F)
. S P2=$E(P3,L+F+3,M)
. ;instantiate array
. ;0011400
. S Z=$P(P,".x",2,99)
. F D Q:+L=0
. . S L=+$E(Z,1,3)
. . S P3=+$E(Z,4,3+L)
. . S L1=+$E(Z,L+4,L+6)
. . S P4=$E(Z,L+7,L+6+L1)
. . ; S L=$$BREAD(3) Q:+L=0 S P3=$$BREAD(L)
. . ; S L=$$BREAD(3) IF +L'=0 S P4=$$BREAD(L)
. . IF +L=0 Q
. . IF P3=0,P4=0 S L=0 Q
. . IF FL=1 D LINST^BMXMBRK(A,P3,P4)
. . S Z=$E(Z,L+7+L1,99999)
IF ERR Q P1
S P1=""
F I=0:1:K D
. IF FL,$E(BMXZ(R,"P",I),1,5)=".BMXS" D Q ;XWB*1.1*2
.. S P1=P1_"."_$E(BMXZ(R,"P",I),2,$L(BMXZ(R,"P",I)))
.. IF I'=K S P1=P1_","
.. Q
. S P1=P1_"BMXZ("_R_",""P"","_I_")"
. IF I'=K S P1=P1_","
. Q
IF '+ERR Q P1
Q ERR
;
CALLP(BMXP,P,BMXSTR,DEBUG) ;EP - make API call using Protocol string
N ERR,S
S ERR=0,BMXSTR=""
K BMXSEC
IF '$D(DEBUG) S DEBUG=0
S ERR=$$PRSP(P)
IF '+ERR S ERR=$$PRSM(BMXZ(0,"MESG"))
IF '+ERR S ERR=$$PRSA(BMXZ(1,"TEXT")) ;I $G(BMXZ(2,"CAPI"))="XUS SET SHARED" S XWBSHARE=1 Q
I +ERR S BMXSEC=$P(ERR,U,2) ;P10 -- dpc
IF '+ERR S S=$$PRSB(BMXZ(2,"PARM"))
;IF (+S=0)!(+S>0) D
I '+ERR D CHKPRMIT^BMXMSEC(BMXZ(2,"CAPI")) ;checks if RPC allowed to run
S:$L($G(BMXSEC)) ERR="-1^"_BMXSEC
;IF 'DEBUG S:$D(XRT0) XRTN="RPC BROKER READ/PARSE" D:$D(XRT0) T1^%ZOSV ;stop RTL
IF '+ERR,(+S=0)!(+S>0) D
. D CAPI^BMXMBRK2(.BMXP,BMXZ(2,"RTAG"),BMXZ(2,"RNAM"),S)
IF 'DEBUG K BMXZ
IF $D(BMXARY) K @BMXARY,BMXARY
Q
;
TEST(OUT,STG,RPT,DELAY) ;
I $L($G(STG))
E Q
S OUT=$NA(^TMP("BMX DATA",$J)),@OUT@(1)=""
S RPT=+$G(RPT)
I RPT F I=1:1:RPT S STG=STG_STG
H +$G(DELAY)
S OUT=STG
Q
;
BMXEHR ; IHS/OIT/GIS - ENCAPSULATE BMX CALLS FOR USE WITHIN THE EHR 14 Jan 2009 4:37 PM ; 04 Jun 2010 3:16 PM
+1 ;;4.0;BMX;;JUN 28, 2010
+2 ;
+3 ;
+4 ;
CIARPCD(XOUT,IN,A,B,C) ; EP - RPC: CIABMX - EHR WRAPER FOR BMX
+1 ;
+2 SET A=$GET(A)
SET B=$GET(B)
SET C=$GET(C)
+3 ; D DEBUG^%Serenji("CIARPCD^BMXEHR(.XOUT,IN,A,B,C)")
+4 QUIT
CIARPC(XOUT,IN,A,B,C) ; EP - RPC: CIABMX - EHR WRAPER FOR BMX
+1 ; INPUT = CF QUAD OR AN ADO RECORD SET
+2 ; OUT = BMX DATA ARRAY IN "^TMP("BMX DATA",$J)
+3 SET XOUT=$NAME(^TMP("BMX DATA",$JOB))
SET @XOUT@(1)=""
+4 ; S BMXR=$NA(^TMP("BMX ADO",$J))
+5 IF $GET(A)'=""
SET IN=IN_"^"_A
+6 IF $GET(IN)'["{BMX}"
QUIT
+7 NEW X,Y,Z,BMXTBUF,BMXHTYP,BMXTLEN,L,BMXDTIME,BMXPLEN,STG,BMXTIME,BMXPTYPE,BMXWRAP,BMXR,I,SECURE,CTXT,DTSG,NODE,L
+8 SET CTXT=""
SET BMXTBUF=""
SET RESULT=""
LONG ; INPUT STRING IS IN LONG FORMAT
DO PARSE(IN,.CTXT,.BMXTBUF)
IF $LENGTH(BMXTBUF)
IF $LENGTH(CTXT)
GOTO CALLPNOW
SHORT ; LONG PARSE FAILED, SO INPUT STRING MUST BE IN SHORT FORMAT
DO PARSE1
IF '$LENGTH(BMXTBUF)!('$LENGTH(CTXT))
QUIT
CALLPNOW ; CONFIRM THAT THE USER HAS CONTEXT SECURITY
DO CRCONTXT^XWBSEC(.SECURE,CTXT)
IF 'SECURE
QUIT
+1 ; RUN THE RPC
DO CALLP(.BMXR,BMXTBUF,.BMXSTR)
+2 IF BMXSTR=""
IF $LENGTH($GET(BMXR))
SET BMXSTR=BMXR
+3 SET BMXPTYPE=$SELECT('$DATA(BMXPTYPE):1,BMXPTYPE<1:1,BMXPTYPE>6:1,1:BMXPTYPE)
+4 IF BMXPTYPE'=1
IF BMXPTYPE'=5
IF $LENGTH($GET(BMXSEC))'>0
+5 ; -- SIMPLE STRING
IF '$TEST
SET @XOUT@(1)=$GET(BMXSTR)
QUIT
ARR ; -- word processing or global array, or global instance
+1 IF $GET(BMXR)=""
SET BMXR="BMXR"
+2 IF '$ORDER(@BMXR@(0))
QUIT
+3 SET I=""
SET NODE=1
SET L=0
+4 FOR
SET I=$ORDER(@BMXR@(I))
IF I=""
QUIT
Begin DoDot:1
+5 SET DSTG=@BMXR@(I)
+6 IF '$LENGTH(DSTG)
QUIT
+7 SET %=$LENGTH(DSTG)+L
IF %<32000
SET @XOUT@(NODE)=@XOUT@(NODE)_DSTG
SET L=%
QUIT
+8 SET NODE=NODE+1
SET L=$LENGTH(DSTG)
+9 SET @XOUT@(NODE)=DSTG
+10 QUIT
End DoDot:1
CLEANUP KILL @BMXR
+1 QUIT
+2 ;
PARSE(IN,CTXT,STG1) ; EP - PARSE INPUT STRING, LONG FORMAT
+1 SET CTXT=""
SET STG1=""
+2 IF $LENGTH($GET(IN))
+3 IF '$TEST
QUIT
+4 NEW A,B,C,X,Y,Z,%,L1,L2,L3,L4
+5 SET A=$EXTRACT(IN,1,5)
IF A'="{BMX}"
QUIT
+6 SET L1=+$EXTRACT(IN,16,18)
IF 'L1
QUIT
+7 SET B=+$EXTRACT(IN,18+L1+6)
IF B'=1
QUIT
+8 SET L2=+$EXTRACT(IN,6,10)
IF 'L2
QUIT
+9 SET C=$EXTRACT(IN,16,L2)
SET D=$EXTRACT(IN,L2+1,9999)
+10 SET L3=+$EXTRACT(D,11,15)
+11 SET CTXT=$EXTRACT(D,16,L3+15)
+12 SET E=$EXTRACT(D,L3+16,9999)
+13 SET STG1=C_E
+14 QUIT
+15 ;
PARSE1 ; PARSE INPUT STRING, SHORT FORMAT
+1 SET STG=IN
SET BMXTIME=$GET(BMXTIME,60)
+2 SET BMXTBUF=$EXTRACT(STG,1,11)
SET STG=$EXTRACT(STG,12,999)
+3 SET BMXHTYP=5
+4 SET BMXTLEN=$EXTRACT(BMXTBUF,6,10)-15
SET L=$EXTRACT(BMXTBUF,11,11)
+5 SET BMXTBUF=$EXTRACT(STG,1,4)
SET STG=$EXTRACT(STG,5,999)
+6 SET BMXTBUF=L_BMXTBUF
+7 SET BMXPLEN=BMXTBUF
+8 SET BMXTBUF=$EXTRACT(STG,1,BMXPLEN)
SET STG=$EXTRACT(STG,(BMXPLEN+1),999)
+9 KILL BMXR,BMXARY
+10 SET BMXDTIME=9999
SET BMXDTIME(1)=0.5
+11 IF $LENGTH(IN,"{BMX}")>2
SET CTXT=$EXTRACT(IN,31+BMXPLEN,9999)
+12 QUIT
+13 ;
PRSP(PARG) ;EP -Parse Protocol
+1 ;M Extrinsic Function
+2 ;
+3 ;Inputs
+4 ;P Protocol string with the form
+5 ; Protocol := Protocol Header^Message where
+6 ; Protocol Header := LLLWKID;WINH;PRCH;WISH;MESG
+7 ; LLL := length of protocol header (3 numeric)
+8 ; WKID := Workstation ID (ALPHA)
+9 ; WINH := Window handle (ALPHA)
+10 ; PRCH := Process handle (ALPHA)
+11 ; WISH := Window server handle (ALPHA)
+12 ; MESG := Unparsed message
+13 ;Outputs
+14 ;ERR 0 for success, "-1^Text" if error
+15 ;
+16 NEW ERR,C,M,R,X,P
+17 SET P=PARG
+18 ;Maximum buffer input
SET R=0
SET C=";"
SET ERR=0
SET M=99999
+19 ;drop out prefix
IF $EXTRACT(P,1,5)="{BMX}"
SET P=$EXTRACT(P,6,$LENGTH(P))
+20 IF '+$GET(P)
SET ERR="-1^Required input reference is NULL"
+21 IF +ERR=0
Begin DoDot:1
+22 SET BMXZ(R,"LENG")=+$EXTRACT(P,1,3)
+23 SET X=$EXTRACT(P,4,BMXZ(R,"LENG")+3)
+24 SET BMXZ(R,"MESG")=$EXTRACT(P,BMXZ(R,"LENG")+4,M)
+25 SET BMXZ(R,"WKID")=$PIECE(X,C)
+26 SET BMXZ(R,"WINH")=$PIECE(X,C,2)
+27 SET BMXZ(R,"PRCH")=$PIECE(X,C,3)
+28 SET BMXZ(R,"WISH")=$PIECE(X,C,4)
End DoDot:1
+29 QUIT ERR
+30 ;
PRSM(PARG) ;EP - Parse message
+1 ;M Extrinsic Function
+2 ;
+3 ;Inputs
+4 ;P Message string with the form
+5 ; Message := Header^Content
+6 ; Header := LLL;FLAG
+7 ; LLL := length of entire message (3 numeric)
+8 ; FLAG := 1 indicates variables follow
+9 ; Content := Contains API call information
+10 ;Outputs
+11 ;ERR 0 for success, "-1^Text" if error
+12 NEW C,ERR,M,R,X,U,P
+13 SET P=PARG
+14 ;Max buffer
SET U="^"
SET R=1
SET C=";"
SET ERR=0
SET M=99999
+15 IF '+$GET(P)
SET ERR="-1^Required input reference is NULL"
+16 IF +ERR=0
Begin DoDot:1
+17 SET BMXZ(R,"LENG")=+$EXTRACT(P,1,5)
+18 SET BMXZ(R,"FLAG")=$EXTRACT(P,6,6)
+19 SET BMXZ(R,"TEXT")=$EXTRACT(P,7,M)
End DoDot:1
+20 QUIT ERR
+21 ;
PRSA(P) ;EP - Parse API information, get calling info
+1 ;M Extrinsic Function
+2 ;Inputs
+3 ;P Content := API Name^Param string
+4 ; API := .01 field of API file
+5 ; Param := Parameter information
+6 ;Outputs
+7 ;ERR 0 for success, "-1^Text" if error
+8 ;
+9 NEW C,DR,ERR,M,R,T,X,U
+10 ;Max buffer
SET U="^"
SET R=2
SET C=";"
SET ERR=0
SET M=99999
+11 IF '+$LENGTH(P)
SET ERR="-1^Required input reference is NULL"
+12 IF +ERR=0
Begin DoDot:1
+13 SET BMXZ(R,"CAPI")=$PIECE(P,U)
+14 SET BMXZ(R,"PARM")=$EXTRACT(P,$FIND(P,U),M)
+15 SET T=$ORDER(^XWB(8994,"B",BMXZ(R,"CAPI"),0))
+16 ;P10 - dpc
IF '+T
SET ERR="-1^Remote Procedure '"_BMXZ(R,"CAPI")_"' doesn't exist on the server."
QUIT
+17 SET T(0)=$GET(^XWB(8994,T,0))
+18 ;P10. Check INACTIVE field. - dpc.
IF $PIECE(T(0),U,6)=1!($PIECE(T(0),U,6)=2)
SET ERR="-1^Remote Procedure '"_BMXZ(R,"CAPI")_"' cannot be run at this time."
QUIT
+19 SET BMXZ(R,"NAME")=$PIECE(T(0),"^")
+20 SET BMXZ(R,"RTAG")=$PIECE(T(0),"^",2)
+21 SET BMXZ(R,"RNAM")=$PIECE(T(0),"^",3)
+22 SET BMXPTYPE=$PIECE(T(0),"^",4)
+23 SET BMXWRAP=+$PIECE(T(0),"^",8)
End DoDot:1
+24 QUIT ERR
+25 ;information
PRSB(P) ;EP - Parse Parameter
+1 ;M Extrinsic Function
+2 ;Inputs
+3 ;P Param := M parameter list
+4 ; Param := LLL,Name,Value
+5 ; LLL := length of variable name and value
+6 ; Name := name of M variable
+7 ; Value := a string
+8 ;Outputs
+9 ;ERR 0 for success, "-1^Text" if error
+10 ;
+11 ;
+12 NEW A,ERR,F,FL,I,K,L,M,P1,P2,P3,P4,P5,MAXP,R,Z
+13 SET R=3
SET MAXP=+$EXTRACT(P,1,5)
+14 ;only param string
SET P1=$EXTRACT(P,6,MAXP+5)
+15 SET ERR=0
SET F=3
SET M=99999
+16 IF '+$DATA(P)
SET ERR="-1^Required input reference is NULL"
+17 SET FL=+$GET(BMXZ(1,"FLAG"))
+18 SET I=0
+19 IF '+ERR
Begin DoDot:1
+20 IF 'FL
IF +MAXP=0
SET P1=""
SET ERR=1
QUIT
+21 FOR
Begin DoDot:2
+22 IF P1=""
QUIT
+23 SET L=+$EXTRACT(P1,1,3)-1
+24 SET P3=+$EXTRACT(P1,4,4)
+25 SET P1=$EXTRACT(P1,5,MAXP)
+26 SET BMXZ(R,"P",I)=$SELECT(P3'=1:$EXTRACT(P1,1,L),1:$$GETV^BMXMBRK($EXTRACT(P1,1,L)))
+27 ;XWB*1.1*2
IF FL=1
IF P3=2
Begin DoDot:3
+28 SET A=$$OARY^BMXMBRK2
SET BMXARY=A
+29 SET BMXZ(R,"P",I)=$$CREF^BMXMBRK2(A,BMXZ(R,"P",I))
End DoDot:3
+30 SET P1=$EXTRACT(P1,L+1,MAXP)
+31 SET K=I
SET I=I+1
End DoDot:2
IF P1=""
QUIT
+32 IF 'FL
QUIT
+33 SET P3=P
+34 SET L=+$EXTRACT(P3,1,5)
+35 SET P1=$EXTRACT(P3,F+3,L+F)
+36 SET P2=$EXTRACT(P3,L+F+3,M)
+37 ;instantiate array
+38 ;0011400
+39 SET Z=$PIECE(P,".x",2,99)
+40 FOR
Begin DoDot:2
+41 SET L=+$EXTRACT(Z,1,3)
+42 SET P3=+$EXTRACT(Z,4,3+L)
+43 SET L1=+$EXTRACT(Z,L+4,L+6)
+44 SET P4=$EXTRACT(Z,L+7,L+6+L1)
+45 ; S L=$$BREAD(3) Q:+L=0 S P3=$$BREAD(L)
+46 ; S L=$$BREAD(3) IF +L'=0 S P4=$$BREAD(L)
+47 IF +L=0
QUIT
+48 IF P3=0
IF P4=0
SET L=0
QUIT
+49 IF FL=1
DO LINST^BMXMBRK(A,P3,P4)
+50 SET Z=$EXTRACT(Z,L+7+L1,99999)
End DoDot:2
IF +L=0
QUIT
End DoDot:1
+51 IF ERR
QUIT P1
+52 SET P1=""
+53 FOR I=0:1:K
Begin DoDot:1
+54 ;XWB*1.1*2
IF FL
IF $EXTRACT(BMXZ(R,"P",I),1,5)=".BMXS"
Begin DoDot:2
+55 SET P1=P1_"."_$EXTRACT(BMXZ(R,"P",I),2,$LENGTH(BMXZ(R,"P",I)))
+56 IF I'=K
SET P1=P1_","
+57 QUIT
End DoDot:2
QUIT
+58 SET P1=P1_"BMXZ("_R_",""P"","_I_")"
+59 IF I'=K
SET P1=P1_","
+60 QUIT
End DoDot:1
+61 IF '+ERR
QUIT P1
+62 QUIT ERR
+63 ;
CALLP(BMXP,P,BMXSTR,DEBUG) ;EP - make API call using Protocol string
+1 NEW ERR,S
+2 SET ERR=0
SET BMXSTR=""
+3 KILL BMXSEC
+4 IF '$DATA(DEBUG)
SET DEBUG=0
+5 SET ERR=$$PRSP(P)
+6 IF '+ERR
SET ERR=$$PRSM(BMXZ(0,"MESG"))
+7 ;I $G(BMXZ(2,"CAPI"))="XUS SET SHARED" S XWBSHARE=1 Q
IF '+ERR
SET ERR=$$PRSA(BMXZ(1,"TEXT"))
+8 ;P10 -- dpc
IF +ERR
SET BMXSEC=$PIECE(ERR,U,2)
+9 IF '+ERR
SET S=$$PRSB(BMXZ(2,"PARM"))
+10 ;IF (+S=0)!(+S>0) D
+11 ;checks if RPC allowed to run
IF '+ERR
DO CHKPRMIT^BMXMSEC(BMXZ(2,"CAPI"))
+12 IF $LENGTH($GET(BMXSEC))
SET ERR="-1^"_BMXSEC
+13 ;IF 'DEBUG S:$D(XRT0) XRTN="RPC BROKER READ/PARSE" D:$D(XRT0) T1^%ZOSV ;stop RTL
+14 IF '+ERR
IF (+S=0)!(+S>0)
Begin DoDot:1
+15 DO CAPI^BMXMBRK2(.BMXP,BMXZ(2,"RTAG"),BMXZ(2,"RNAM"),S)
End DoDot:1
+16 IF 'DEBUG
KILL BMXZ
+17 IF $DATA(BMXARY)
KILL @BMXARY,BMXARY
+18 QUIT
+19 ;
TEST(OUT,STG,RPT,DELAY) ;
+1 IF $LENGTH($GET(STG))
+2 IF '$TEST
QUIT
+3 SET OUT=$NAME(^TMP("BMX DATA",$JOB))
SET @OUT@(1)=""
+4 SET RPT=+$GET(RPT)
+5 IF RPT
FOR I=1:1:RPT
SET STG=STG_STG
+6 HANG +$GET(DELAY)
+7 SET OUT=STG
+8 QUIT
+9 ;
