BMXMBRK2 ;IHS/OIT/HMW - BMXNet MONITOR ;
;;4.0;BMX;**3**;JUN 28, 2010;Build 2
;
;
CAPI(BMXY,TAG,NAM,PAR) ;EP - make API call
N R,T,DX,DY
IF BMXZ(1,"FLAG")=2 D
. S PAR=$P(PAR,BMXZ("FRM"))_BMXZ("TO")_$P(PAR,BMXZ("FRM"),2)
S R=$S(PAR'=+PAR&(PAR=""):TAG_"^"_NAM_"(.BMXY)",1:TAG_"^"_NAM_"(.BMXY,"_PAR_")")
U IO
D @R
;
;Log Security Audit Entry
N X,STS S X="BUSARPC",STS="" X ^%ZOSF("TEST") S:$T STS=$$BMX^BUSARPC(.BMXZ) K X,STS
U $P
Q
;
BHDR(WKID,WINH,PRCH,WISH) ;Build a protocol header
N S,L
S S=""
S S=WKID_";"_WINH_";"_PRCH_";"_WISH_";"
S L=$L(S)
S S=$E("000"_L,$L(L)+1,$L(L)+3)_S
Q S
;
BARY(A,R,V) ;add array elements+values to storage array
IF A'["BMXS" Q "-1^ARRAY NAME MUST BE BMXS"
S @A@(R)=V
Q 0
;
BLDB(P) ;Build formatted string
N L
S L=$L(P)
Q $E("000"_L,$L(L)+1,$L(L)+3)_P
;
BLDA(N,P) ;Build API string
;M Extrinsic Function
;Inputs
;N API name
;P Comma delimited parameter string
;Outputs
;String API string if successful, "-1^Text" if error
;
N I,F,L,T,U,T1,T2
IF '+$D(N) Q "-1^Required input reference is NULL"
S U="^"
S (F,T,Y)=0
IF '$D(P) S P=""
IF P'="" D
. S L=$L(P)-$L($TR(P,$C(44)))+1
. IF L=0 S L=1
. F I=1:1:L D Q:T
. . S T1=$P(P,",",I)
. . S T2=$E(T1,1,1)="."
. . IF T1=+T1 Q
. . IF $E(T1,1,1)="^" S F=2,T=1 Q
. . IF T2&($E(T1,2,$L(T1))?.ANP) S F=1,T=1 Q
S P=$$BLDB(P)
S L=$L(P)+$L(P)-3
S P=F_N_U_P
S L=$L(P)
Q $E("000"_L,$L(L)+1,$L(L)+3)_P
;
BLDS(R) ;Build a parameter string from an array
N L,T,Y
S Y=""
F D Q:R=""
. S R=$Q(@R)
. IF R="" Q
. S L=$L(R)+$L(@R)+1
. S T=@R
. S T=$TR(T,$C(44),$C(23))
. S Y=Y_$E("000"_L,$L(L)+1,$L(L)+3)_R_"="_T
Q Y_"000"
;
BLDU(R) ;Build a parameter string from a scalar
N DONE,L,N,N1,P1
IF R=+R Q R
S N=$F(R,$C(34))
IF N=0 Q $C(34)_R_$C(34)
S P1=$E(R,1,N-2)
S (L,DONE)=0
F D Q:DONE
. S N1=$F(R,$C(34),N)
. IF N1=0 S L=$L(R)+2,N1=L
. S P1=P1_$C(34,34)_$E(R,N,N1-2)
. IF N1=L S DONE=1,P1=$C(34)_P1_$C(34) Q
. S N=N1
Q $TR(P1,$C(44),$C(23))
;
BLDG(R) ;build a parameter string from a global reference
N I,L,L1,M,T,T1,T2,Y
K ^TMP("BMXZ",$J)
IF '$D(R) Q "-1^Reference does not exist"
S Y=$NA(^TMP("BMXZ",$J,$P($H,",",2)))
S I=0
S M=512
S T1=$P(R,")")
S L1=$L($P(R,"("))
F D Q:R=""
. S R=$Q(@R)
. S T2=$F(R,"(")
. IF R=""!(R'[T1) Q
. S L=$L(R)+$L(@R)-L1
. S T=@R
. S T=$TR(T,$C(44),$C(23))
. S @Y@(I)=$E("000"_L,$L(L)+1,$L(L)+3)_U_"("_$E(R,T2,M)_"="_$$BLDU(T)
. S I=I+1
S @Y@(I)="000"
S Y=$TR(Y,$C(44),$C(23))
Q Y
;
OARY() ;EP - create storage array
N A,DONE,I
S (DONE,I)=0
F I=1:1 D Q:DONE
. S A="BMXS"_I
. K @A ;temp fix for single array
. IF '$D(@A) S DONE=1
S @A="" ;set naked
Q A
;
CREF(R,P) ;EP - Convert array contained in P to reference A
N I,X,DONE,F1,S
S DONE=0
S S=""
F I=1:1 D Q:DONE
. IF $P(P,",",I)="" S DONE=1 Q
. S X(I)=$P(P,",",I)
. IF X(I)?1"."1A.E D
. . S F1=$F(X(I),".")
. . S X(I)="."_R
. S S=S_X(I)_","
Q $E(S,1,$L(S)-1)
;
GETP(P) ;returns various parameters out of the Protocol string
N M,T,BMXZ
S M=512
S T=$$PRSP^BMXMBRK(P)
IF '+T D
. S T=$$PRSM^BMXMBRK(BMXZ(0,"MESG"))
. IF '+T S T=BMXZ(0,"WKID")_";"_BMXZ(0,"WINH")_";"_BMXZ(0,"PRCH")_";"_BMXZ(0,"WISH")_";"_$P(BMXZ(1,"TEXT"),"^")
Q T
;
CALLM(X,P,DEBUG) ;make call using Message string
N ERR,S
S X="",ERR=0
S ERR=$$PRSM^BMXMBRK(P)
IF '+ERR S ERR=$$PRSA^BMXMBRK(BMXZ(1,"TEXT"))
IF '+ERR S S=$$PRSB^BMXMBRK(BMXZ(2,"PARM"))
IF (+S=0)!(+S>0) D
. D CAPI(.X,BMXZ(2,"RTAG"),BMXZ(2,"RNAM"),S)
IF 'DEBUG K BMXZ
K @(X("BMXS")),X("BMXS")
Q
;
CALLA(X,P,DEBUG) ;make call using API string
N ERR,S
S X="",ERR=0
S ERR=$$PRSA^BMXMBRK(P)
IF '+ERR S S=$$PRSB^BMXMBRK(BMXZ(2,"PARM"))
IF (+S=0)!(+S>0) D
. D CAPI(.X,BMXZ(2,"RTAG"),BMXZ(2,"RNAM"),S)
IF 'DEBUG K BMXZ
K @(X("BMXS")),X("BMXS")
Q
;
TRANSPRT() ;Determine the Transport Method
;DDP is local :=0
;TCP/IP is remote :=1
;Serial/RS-232 is remote :=2
Q 1
;Q 0 ;Do DDP for Now
BMXMBRK2 ;IHS/OIT/HMW - BMXNet MONITOR ;
+1 ;;4.0;BMX;**3**;JUN 28, 2010;Build 2
+2 ;
+3 ;
CAPI(BMXY,TAG,NAM,PAR) ;EP - make API call
+1 NEW R,T,DX,DY
+2 IF BMXZ(1,"FLAG")=2
Begin DoDot:1
+3 SET PAR=$PIECE(PAR,BMXZ("FRM"))_BMXZ("TO")_$PIECE(PAR,BMXZ("FRM"),2)
End DoDot:1
+4 SET R=$SELECT(PAR'=+PAR&(PAR=""):TAG_"^"_NAM_"(.BMXY)",1:TAG_"^"_NAM_"(.BMXY,"_PAR_")")
+5 USE IO
+6 DO @R
+7 ;
+8 ;Log Security Audit Entry
+9 NEW X,STS
SET X="BUSARPC"
SET STS=""
XECUTE ^%ZOSF("TEST")
IF $TEST
SET STS=$$BMX^BUSARPC(.BMXZ)
KILL X,STS
+10 USE $PRINCIPAL
+11 QUIT
+12 ;
BHDR(WKID,WINH,PRCH,WISH) ;Build a protocol header
+1 NEW S,L
+2 SET S=""
+3 SET S=WKID_";"_WINH_";"_PRCH_";"_WISH_";"
+4 SET L=$LENGTH(S)
+5 SET S=$EXTRACT("000"_L,$LENGTH(L)+1,$LENGTH(L)+3)_S
+6 QUIT S
+7 ;
BARY(A,R,V) ;add array elements+values to storage array
+1 IF A'["BMXS"
QUIT "-1^ARRAY NAME MUST BE BMXS"
+2 SET @A@(R)=V
+3 QUIT 0
+4 ;
BLDB(P) ;Build formatted string
+1 NEW L
+2 SET L=$LENGTH(P)
+3 QUIT $EXTRACT("000"_L,$LENGTH(L)+1,$LENGTH(L)+3)_P
+4 ;
BLDA(N,P) ;Build API string
+1 ;M Extrinsic Function
+2 ;Inputs
+3 ;N API name
+4 ;P Comma delimited parameter string
+5 ;Outputs
+6 ;String API string if successful, "-1^Text" if error
+7 ;
+8 NEW I,F,L,T,U,T1,T2
+9 IF '+$DATA(N)
QUIT "-1^Required input reference is NULL"
+10 SET U="^"
+11 SET (F,T,Y)=0
+12 IF '$DATA(P)
SET P=""
+13 IF P'=""
Begin DoDot:1
+14 SET L=$LENGTH(P)-$LENGTH($TRANSLATE(P,$CHAR(44)))+1
+15 IF L=0
SET L=1
+16 FOR I=1:1:L
Begin DoDot:2
+17 SET T1=$PIECE(P,",",I)
+18 SET T2=$EXTRACT(T1,1,1)="."
+19 IF T1=+T1
QUIT
+20 IF $EXTRACT(T1,1,1)="^"
SET F=2
SET T=1
QUIT
+21 IF T2&($EXTRACT(T1,2,$LENGTH(T1))?.ANP)
SET F=1
SET T=1
QUIT
End DoDot:2
IF T
QUIT
End DoDot:1
+22 SET P=$$BLDB(P)
+23 SET L=$LENGTH(P)+$LENGTH(P)-3
+24 SET P=F_N_U_P
+25 SET L=$LENGTH(P)
+26 QUIT $EXTRACT("000"_L,$LENGTH(L)+1,$LENGTH(L)+3)_P
+27 ;
BLDS(R) ;Build a parameter string from an array
+1 NEW L,T,Y
+2 SET Y=""
+3 FOR
Begin DoDot:1
+4 SET R=$QUERY(@R)
+5 IF R=""
QUIT
+6 SET L=$LENGTH(R)+$LENGTH(@R)+1
+7 SET T=@R
+8 SET T=$TRANSLATE(T,$CHAR(44),$CHAR(23))
+9 SET Y=Y_$EXTRACT("000"_L,$LENGTH(L)+1,$LENGTH(L)+3)_R_"="_T
End DoDot:1
IF R=""
QUIT
+10 QUIT Y_"000"
+11 ;
BLDU(R) ;Build a parameter string from a scalar
+1 NEW DONE,L,N,N1,P1
+2 IF R=+R
QUIT R
+3 SET N=$FIND(R,$CHAR(34))
+4 IF N=0
QUIT $CHAR(34)_R_$CHAR(34)
+5 SET P1=$EXTRACT(R,1,N-2)
+6 SET (L,DONE)=0
+7 FOR
Begin DoDot:1
+8 SET N1=$FIND(R,$CHAR(34),N)
+9 IF N1=0
SET L=$LENGTH(R)+2
SET N1=L
+10 SET P1=P1_$CHAR(34,34)_$EXTRACT(R,N,N1-2)
+11 IF N1=L
SET DONE=1
SET P1=$CHAR(34)_P1_$CHAR(34)
QUIT
+12 SET N=N1
End DoDot:1
IF DONE
QUIT
+13 QUIT $TRANSLATE(P1,$CHAR(44),$CHAR(23))
+14 ;
BLDG(R) ;build a parameter string from a global reference
+1 NEW I,L,L1,M,T,T1,T2,Y
+2 KILL ^TMP("BMXZ",$JOB)
+3 IF '$DATA(R)
QUIT "-1^Reference does not exist"
+4 SET Y=$NAME(^TMP("BMXZ",$JOB,$PIECE($HOROLOG,",",2)))
+5 SET I=0
+6 SET M=512
+7 SET T1=$PIECE(R,")")
+8 SET L1=$LENGTH($PIECE(R,"("))
+9 FOR
Begin DoDot:1
+10 SET R=$QUERY(@R)
+11 SET T2=$FIND(R,"(")
+12 IF R=""!(R'[T1)
QUIT
+13 SET L=$LENGTH(R)+$LENGTH(@R)-L1
+14 SET T=@R
+15 SET T=$TRANSLATE(T,$CHAR(44),$CHAR(23))
+16 SET @Y@(I)=$EXTRACT("000"_L,$LENGTH(L)+1,$LENGTH(L)+3)_U_"("_$EXTRACT(R,T2,M)_"="_$$BLDU(T)
+17 SET I=I+1
End DoDot:1
IF R=""
QUIT
+18 SET @Y@(I)="000"
+19 SET Y=$TRANSLATE(Y,$CHAR(44),$CHAR(23))
+20 QUIT Y
+21 ;
OARY() ;EP - create storage array
+1 NEW A,DONE,I
+2 SET (DONE,I)=0
+3 FOR I=1:1
Begin DoDot:1
+4 SET A="BMXS"_I
+5 ;temp fix for single array
KILL @A
+6 IF '$DATA(@A)
SET DONE=1
End DoDot:1
IF DONE
QUIT
+7 ;set naked
SET @A=""
+8 QUIT A
+9 ;
CREF(R,P) ;EP - Convert array contained in P to reference A
+1 NEW I,X,DONE,F1,S
+2 SET DONE=0
+3 SET S=""
+4 FOR I=1:1
Begin DoDot:1
+5 IF $PIECE(P,",",I)=""
SET DONE=1
QUIT
+6 SET X(I)=$PIECE(P,",",I)
+7 IF X(I)?1"."1A.E
Begin DoDot:2
+8 SET F1=$FIND(X(I),".")
+9 SET X(I)="."_R
End DoDot:2
+10 SET S=S_X(I)_","
End DoDot:1
IF DONE
QUIT
+11 QUIT $EXTRACT(S,1,$LENGTH(S)-1)
+12 ;
GETP(P) ;returns various parameters out of the Protocol string
+1 NEW M,T,BMXZ
+2 SET M=512
+3 SET T=$$PRSP^BMXMBRK(P)
+4 IF '+T
Begin DoDot:1
+5 SET T=$$PRSM^BMXMBRK(BMXZ(0,"MESG"))
+6 IF '+T
SET T=BMXZ(0,"WKID")_";"_BMXZ(0,"WINH")_";"_BMXZ(0,"PRCH")_";"_BMXZ(0,"WISH")_";"_$PIECE(BMXZ(1,"TEXT"),"^")
End DoDot:1
+7 QUIT T
+8 ;
CALLM(X,P,DEBUG) ;make call using Message string
+1 NEW ERR,S
+2 SET X=""
SET ERR=0
+3 SET ERR=$$PRSM^BMXMBRK(P)
+4 IF '+ERR
SET ERR=$$PRSA^BMXMBRK(BMXZ(1,"TEXT"))
+5 IF '+ERR
SET S=$$PRSB^BMXMBRK(BMXZ(2,"PARM"))
+6 IF (+S=0)!(+S>0)
Begin DoDot:1
+7 DO CAPI(.X,BMXZ(2,"RTAG"),BMXZ(2,"RNAM"),S)
End DoDot:1
+8 IF 'DEBUG
KILL BMXZ
+9 KILL @(X("BMXS")),X("BMXS")
+10 QUIT
+11 ;
CALLA(X,P,DEBUG) ;make call using API string
+1 NEW ERR,S
+2 SET X=""
SET ERR=0
+3 SET ERR=$$PRSA^BMXMBRK(P)
+4 IF '+ERR
SET S=$$PRSB^BMXMBRK(BMXZ(2,"PARM"))
+5 IF (+S=0)!(+S>0)
Begin DoDot:1
+6 DO CAPI(.X,BMXZ(2,"RTAG"),BMXZ(2,"RNAM"),S)
End DoDot:1
+7 IF 'DEBUG
KILL BMXZ
+8 KILL @(X("BMXS")),X("BMXS")
+9 QUIT
+10 ;
TRANSPRT() ;Determine the Transport Method
+1 ;DDP is local :=0
+2 ;TCP/IP is remote :=1
+3 ;Serial/RS-232 is remote :=2
+4 QUIT 1
+5 ;Q 0 ;Do DDP for Now
