BMXMBRK ; IHS/OIT/HMW - BMXNet MONITOR ;
;;4.0;BMX;;JUN 28, 2010
;
;
PRSP(P) ;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
S R=0,C=";",ERR=0,M=512 ;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(P) ;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
S U="^",R=1,C=";",ERR=0,M=512 ;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=512 ;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
S R=3,MAXP=+$E(P,1,5)
S P1=$E(P,6,MAXP+5) ;only param string
S ERR=0,F=3,M=512
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($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
. F D Q:+L=0
. . 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(A,P3,P4)
. . IF FL=2 D GINST
IF ERR Q P1
S P1=""
D Q 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_","
. . S P1=P1_"BMXZ("_R_",""P"","_I_")"
. . IF I'=K S P1=P1_","
IF '+ERR Q P1
Q ERR
;
BREAD(L) ;read tcp buffer, L is length
N E,X,DONE
S (E,DONE)=0
R X#L:BMXDTIME(1) ;IHS/OIT/HMW SAC Exemption Applied For
S E=X
IF $L(E)<L F D Q:'DONE
. IF $L(E)=L S DONE=1 Q
. R X#(L-$L(E)):BMXDTIME(1) ;IHS/OIT/HMW SAC Exemption Applied For
. S E=E_X
Q E
;
CALLP(BMXP,P,DEBUG) ;EP - make API call using Protocol string
N ERR,S
S ERR=0
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)
E D CLRBUF ;p10
IF 'DEBUG K BMXZ
IF $D(BMXARY) K @BMXARY,BMXARY
Q
;
LINST(A,X,BMXY) ;instantiate local array
IF BMXY=$C(1) S BMXY=""
S X=A_"("_X_")"
S @X=BMXY
Q
GINST ;instantiate global
N DONE,N,T,T1
S (DONE,I)=0
;find piece with global ref - recover $C(44)
S REF=$TR(REF,$C(23),$C(44))
F D Q:DONE
. S N=$NA(^TMP("BMXZ",$J,$P($H,",",2)))
. S BMXZ("FRM")=REF
. S BMXZ("TO")=N
. IF '$D(@N) S DONE=1 Q
;loop through all and instantiate
S DONE=0
F D Q:DONE
. S T=$E(@REF@(I),4,M)
. IF T="" S DONE=1 Q
. S @N@("BMXZ")="" ;set naked indicator
. S @T
. S I=I+1
K @N@("BMXZ")
Q
;
GETV(V) ;get value of V - reference parameter
N X
S X=V
IF $E(X,1,2)="$$" Q ""
IF $C(34,36)[$E(V) X "S V="_$$VCHK(V)
E S V=@V
Q V
;
VCHK(S) ;Parse string for first argument
N C,I,P
F I=1:1 S C=$E(S,I) D VCHKP:C="(",VCHKQ:C=$C(34) Q:" ,"[C
Q $E(S,1,I-1)
VCHKP S P=1 ;Find closing paren
F I=I+1:1 S C=$E(S,I) Q:P=0!(C="") I "()"""[C D VCHKQ:C=$C(34) S P=P+$S("("[C:1,")"[C:-1,1:0)
Q
VCHKQ ;Find closing quote
F I=I+1:1 S C=$E(S,I) Q:C=""!(C=$C(34))
Q
CLRBUF ;p10 Empties Input buffer
N %
F R %#1:BMXDTIME(1) Q:%="" ;IHS/OIT/HMW SAC Exemption Applied For
Q
BMXMBRK ; IHS/OIT/HMW - BMXNet MONITOR ;
+1 ;;4.0;BMX;;JUN 28, 2010
+2 ;
+3 ;
PRSP(P) ;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
+17 ;Maximum buffer input
SET R=0
SET C=";"
SET ERR=0
SET M=512
+18 ;drop out prefix
IF $EXTRACT(P,1,5)="{BMX}"
SET P=$EXTRACT(P,6,$LENGTH(P))
+19 IF '+$GET(P)
SET ERR="-1^Required input reference is NULL"
+20 IF +ERR=0
Begin DoDot:1
+21 SET BMXZ(R,"LENG")=+$EXTRACT(P,1,3)
+22 SET X=$EXTRACT(P,4,BMXZ(R,"LENG")+3)
+23 SET BMXZ(R,"MESG")=$EXTRACT(P,BMXZ(R,"LENG")+4,M)
+24 SET BMXZ(R,"WKID")=$PIECE(X,C)
+25 SET BMXZ(R,"WINH")=$PIECE(X,C,2)
+26 SET BMXZ(R,"PRCH")=$PIECE(X,C,3)
+27 SET BMXZ(R,"WISH")=$PIECE(X,C,4)
End DoDot:1
+28 QUIT ERR
+29 ;
PRSM(P) ;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
+13 ;Max buffer
SET U="^"
SET R=1
SET C=";"
SET ERR=0
SET M=512
+14 IF '+$GET(P)
SET ERR="-1^Required input reference is NULL"
+15 IF +ERR=0
Begin DoDot:1
+16 SET BMXZ(R,"LENG")=+$EXTRACT(P,1,5)
+17 SET BMXZ(R,"FLAG")=$EXTRACT(P,6,6)
+18 SET BMXZ(R,"TEXT")=$EXTRACT(P,7,M)
End DoDot:1
+19 QUIT ERR
+20 ;
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=512
+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 NEW A,ERR,F,FL,I,K,L,M,P1,P2,P3,P4,P5,MAXP,R
+12 SET R=3
SET MAXP=+$EXTRACT(P,1,5)
+13 ;only param string
SET P1=$EXTRACT(P,6,MAXP+5)
+14 SET ERR=0
SET F=3
SET M=512
+15 IF '+$DATA(P)
SET ERR="-1^Required input reference is NULL"
+16 SET FL=+$GET(BMXZ(1,"FLAG"))
+17 SET I=0
+18 IF '+ERR
Begin DoDot:1
+19 IF 'FL
IF +MAXP=0
SET P1=""
SET ERR=1
QUIT
+20 FOR
Begin DoDot:2
+21 IF P1=""
QUIT
+22 SET L=+$EXTRACT(P1,1,3)-1
+23 SET P3=+$EXTRACT(P1,4,4)
+24 SET P1=$EXTRACT(P1,5,MAXP)
+25 SET BMXZ(R,"P",I)=$SELECT(P3'=1:$EXTRACT(P1,1,L),1:$$GETV($EXTRACT(P1,1,L)))
+26 ;XWB*1.1*2
IF FL=1
IF P3=2
Begin DoDot:3
+27 SET A=$$OARY^BMXMBRK2
SET BMXARY=A
+28 SET BMXZ(R,"P",I)=$$CREF^BMXMBRK2(A,BMXZ(R,"P",I))
End DoDot:3
+29 SET P1=$EXTRACT(P1,L+1,MAXP)
+30 SET K=I
SET I=I+1
End DoDot:2
IF P1=""
QUIT
+31 IF 'FL
QUIT
+32 SET P3=P
+33 SET L=+$EXTRACT(P3,1,5)
+34 SET P1=$EXTRACT(P3,F+3,L+F)
+35 SET P2=$EXTRACT(P3,L+F+3,M)
+36 ;instantiate array
+37 FOR
Begin DoDot:2
+38 SET L=$$BREAD(3)
IF +L=0
QUIT
SET P3=$$BREAD(L)
+39 SET L=$$BREAD(3)
IF +L'=0
SET P4=$$BREAD(L)
+40 IF +L=0
QUIT
+41 IF P3=0
IF P4=0
SET L=0
QUIT
+42 IF FL=1
DO LINST(A,P3,P4)
+43 IF FL=2
DO GINST
End DoDot:2
IF +L=0
QUIT
End DoDot:1
+44 IF ERR
QUIT P1
+45 SET P1=""
+46 Begin DoDot:1
+47 FOR I=0:1:K
Begin DoDot:2
+48 ;XWB*1.1*2
IF FL
IF $EXTRACT(BMXZ(R,"P",I),1,5)=".BMXS"
Begin DoDot:3
+49 SET P1=P1_"."_$EXTRACT(BMXZ(R,"P",I),2,$LENGTH(BMXZ(R,"P",I)))
+50 IF I'=K
SET P1=P1_","
End DoDot:3
QUIT
+51 SET P1=P1_"BMXZ("_R_",""P"","_I_")"
+52 IF I'=K
SET P1=P1_","
End DoDot:2
End DoDot:1
QUIT P1
+53 IF '+ERR
QUIT P1
+54 QUIT ERR
+55 ;
BREAD(L) ;read tcp buffer, L is length
+1 NEW E,X,DONE
+2 SET (E,DONE)=0
+3 ;IHS/OIT/HMW SAC Exemption Applied For
READ X#L:BMXDTIME(1)
+4 SET E=X
+5 IF $LENGTH(E)<L
FOR
Begin DoDot:1
+6 IF $LENGTH(E)=L
SET DONE=1
QUIT
+7 ;IHS/OIT/HMW SAC Exemption Applied For
READ X#(L-$LENGTH(E)):BMXDTIME(1)
+8 SET E=E_X
End DoDot:1
IF 'DONE
QUIT
+9 QUIT E
+10 ;
CALLP(BMXP,P,DEBUG) ;EP - make API call using Protocol string
+1 NEW ERR,S
+2 SET ERR=0
+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 ;p10
IF '$TEST
DO CLRBUF
+17 IF 'DEBUG
KILL BMXZ
+18 IF $DATA(BMXARY)
KILL @BMXARY,BMXARY
+19 QUIT
+20 ;
LINST(A,X,BMXY) ;instantiate local array
+1 IF BMXY=$CHAR(1)
SET BMXY=""
+2 SET X=A_"("_X_")"
+3 SET @X=BMXY
+4 QUIT
GINST ;instantiate global
+1 NEW DONE,N,T,T1
+2 SET (DONE,I)=0
+3 ;find piece with global ref - recover $C(44)
+4 SET REF=$TRANSLATE(REF,$CHAR(23),$CHAR(44))
+5 FOR
Begin DoDot:1
+6 SET N=$NAME(^TMP("BMXZ",$JOB,$PIECE($HOROLOG,",",2)))
+7 SET BMXZ("FRM")=REF
+8 SET BMXZ("TO")=N
+9 IF '$DATA(@N)
SET DONE=1
QUIT
End DoDot:1
IF DONE
QUIT
+10 ;loop through all and instantiate
+11 SET DONE=0
+12 FOR
Begin DoDot:1
+13 SET T=$EXTRACT(@REF@(I),4,M)
+14 IF T=""
SET DONE=1
QUIT
+15 ;set naked indicator
SET @N@("BMXZ")=""
+16 SET @T
+17 SET I=I+1
End DoDot:1
IF DONE
QUIT
+18 KILL @N@("BMXZ")
+19 QUIT
+20 ;
GETV(V) ;get value of V - reference parameter
+1 NEW X
+2 SET X=V
+3 IF $EXTRACT(X,1,2)="$$"
QUIT ""
+4 IF $CHAR(34,36)[$EXTRACT(V)
XECUTE "S V="_$$VCHK(V)
+5 IF '$TEST
SET V=@V
+6 QUIT V
+7 ;
VCHK(S) ;Parse string for first argument
+1 NEW C,I,P
+2 FOR I=1:1
SET C=$EXTRACT(S,I)
IF C="("
DO VCHKP
IF C=$CHAR(34)
DO VCHKQ
IF " ,"[C
QUIT
+3 QUIT $EXTRACT(S,1,I-1)
VCHKP ;Find closing paren
SET P=1
+1 FOR I=I+1:1
SET C=$EXTRACT(S,I)
IF P=0!(C="")
QUIT
IF "()"""[C
IF C=$CHAR(34)
DO VCHKQ
SET P=P+$SELECT("("[C:1,")"[C:-1,1:0)
+2 QUIT
VCHKQ ;Find closing quote
+1 FOR I=I+1:1
SET C=$EXTRACT(S,I)
IF C=""!(C=$CHAR(34))
QUIT
+2 QUIT
CLRBUF ;p10 Empties Input buffer
+1 NEW %
+2 ;IHS/OIT/HMW SAC Exemption Applied For
FOR
READ %#1:BMXDTIME(1)
IF %=""
QUIT
+3 QUIT
