BMXMSEC ; IHS/OIT/HMW - BMXNet MONITOR ; 11 Jul 2011 10:44 AM
;;4.0;BMX;**1**;JUL 11, 2011;Build 12
;;
;
CHKPRMID(BMXRP) ;EP - checks to see if remote procedure is permited to run
;D DEBUG^%Serenji("CHKPRMID^BMXMSEC(BMXRP)")
Q
;
CHKPRMIT(BMXRP) ;EP - checks to see if remote procedure is permited to run
;Input: BMXRP - Remote procedure to check
Q:$$KCHK("XUPROGMODE")
N ERR,BMXALLOW
S U="^",BMXSEC="" ;clear
;
;In the beginning, when no DUZ is defined and no context exist, setup
;default signon context
S:'$G(DUZ) DUZ=0,XQY0="XUS SIGNON" ;set up default context
S:'$L($G(XQY0)) XQY0="BMXRPC"
;
S XWBSTATE("ALLCTX",XQY0)=1 ; LOCAL ARRAY REMEMBERING ALL APPCONTEXTS USED FOR THIS SESSION
I DUZ D ADDCTXT(DUZ,"BMXRPC") ; IN DIRECT MODE, CHECK USER APP CTXT PERMISSION AND, IF NECESSARY, APPEND THE RPC NODES IN ^TMP("XQCS",$J
;
I BMXRP'="XWB IM HERE",BMXRP'="XWB CREATE CONTEXT",BMXRP'="XUS AV CODE",BMXRP'="XWB RPC LIST",BMXRP'="BMX AV CODE" D ;check exemptions. new exemption for XWB*1.1*6 - dpc
. I $G(XQY0)'="" D
. . S BMXALLOW=$$CHK^XQCS(DUZ,$P(XQY0,U),BMXRP) ;do the check
. . S:'BMXALLOW BMXSEC=BMXALLOW
. E S BMXSEC="Application context has not been created!"
Q
;
OWNSKEY(RET,LIST) ;EP Does user have Key
N I,K S I=""
I $G(DUZ)'>0 S RET(0)=0 Q
I $O(LIST(""))="" S RET(0)=$$KCHK(LIST) Q
F S I=$O(LIST(I)) Q:I="" S RET(I)=$$KCHK(LIST(I))
Q
KCHK(%) Q $S($G(DUZ)>0:$D(^XUSEC(%,DUZ)),1:0) ;EP Key Check
;
;
SETUP(RET) ;EP - sets up environment for GUI signon
;
K ^TMP("XQCS",$J)
S IO("IP")=$$GETPEER^%ZOSV D ZIO^%ZIS4 ;IHS/OIT/HMW SAC Exemption Applied For ; Patched by GIS 6/1/2011
D SET1(0),SET^BMXMSEC("XUS XOPT",XOPT),SET^BMXMSEC("XUS CNT",0)
S %ZIS="0H",IOP="NULL" D ^%ZIS
;0=server name, 1=volume, 2=uci, 3=device, 4=# attempts, 5=skip signon-screen
S RET(0)=$P(XUENV,U,3),RET(1)=$P(XUVOL,U),RET(2)=XUCI
S RET(3)=$I,RET(4)=$P(XOPT,U,2),RET(5)=0 ;IHS/OIT/HMW SAC Exemption Applied For
I $$INHIBIT() Q
Q
;
SET1(FLAG) ;Setup parameters
D GETENV^%ZOSV S U="^",XUENV=Y,XUCI=$P(Y,U,1),XQVOL=$P(Y,U,2),XUEON=^%ZOSF("EON"),XUEOFF=^("EOFF")
S X=$O(^XTV(8989.3,1,4,"B",XQVOL,0)),XUVOL=$S(X>0:^XTV(8989.3,1,4,X,0),1:XQVOL_"^y^1") S:$P(XUVOL,U,6)="y" XRTL=XUCI_","_XQVOL
S XOPT=$S($D(^XTV(8989.3,1,"XUS")):^("XUS"),1:"") F I=2:1:15 I $P(XOPT,U,I)="" S $P(XOPT,U,I)=$P("^5^900^1^1^^^^1^300^^^^N^90",U,I)
Q
;
INHIBIT() ;Is Logon to this system Inhibited?
I $G(^%ZIS(14.5,"LOGON",XQVOL)) Q 1
I $D(^%ZOSF("ACTJ")) X ^("ACTJ") I $P(XUVOL,U,3),($P(XUVOL,U,3)'>Y) Q 2
Q 0
;
NOW S U="^",XUNOW=$$NOW^XLFDT(),DT=$P(XUNOW,"."),XUDEV=0
Q
;
STATE(%) ;Return a state value
;XWBSTATE is required by XUSRB
Q:'$L($G(%)) $G(XWBSTATE)
Q $G(XWBSTATE(%))
;
;
SET(%,VALUE) ;Set the state variable
I $G(%)="" S XWBSTATE=VALUE
S XWBSTATE(%)=VALUE
Q
KILL(%) ;Kill state variable
I $L($G(%)) K XWBSTATE(%)
Q
;
;
ADDCTXT(XQUSR,XCONTEXT) ; SUPPORTS DIRECT MODE IN BMX
N XQMES,XQRPC,X,Y,Z,%,XQOPT,TMP
S TMP=$NA(^TMP("XQCS",$J))
S XQOPT=$O(^DIC(19,"B",XCONTEXT,0)) I 'XQOPT Q
S XQRPC=$O(^DIC(19,XQOPT,"RPC","B",0)) I 'XQRPC Q
I $D(@TMP@(XQRPC)) Q ; ITS ALREADY IN THERE ; NOTHING MORE TO DO
S XQMES=1
D USER^XQCS I 'XQMES Q ; USER DOES NOT POSSES THIS APP CONTEXT
S XQRPC=0
F S XQRPC=$O(^DIC(19,XQOPT,"RPC","B",XQRPC)) Q:'XQRPC S @TMP@(XQRPC,0)=XQRPC
Q
;
BMXMSEC ; IHS/OIT/HMW - BMXNet MONITOR ; 11 Jul 2011 10:44 AM
+1 ;;4.0;BMX;**1**;JUL 11, 2011;Build 12
+2 ;;
+3 ;
CHKPRMID(BMXRP) ;EP - checks to see if remote procedure is permited to run
+1 ;D DEBUG^%Serenji("CHKPRMID^BMXMSEC(BMXRP)")
+2 QUIT
+3 ;
CHKPRMIT(BMXRP) ;EP - checks to see if remote procedure is permited to run
+1 ;Input: BMXRP - Remote procedure to check
+2 IF $$KCHK("XUPROGMODE")
QUIT
+3 NEW ERR,BMXALLOW
+4 ;clear
SET U="^"
SET BMXSEC=""
+5 ;
+6 ;In the beginning, when no DUZ is defined and no context exist, setup
+7 ;default signon context
+8 ;set up default context
IF '$GET(DUZ)
SET DUZ=0
SET XQY0="XUS SIGNON"
+9 IF '$LENGTH($GET(XQY0))
SET XQY0="BMXRPC"
+10 ;
+11 ; LOCAL ARRAY REMEMBERING ALL APPCONTEXTS USED FOR THIS SESSION
SET XWBSTATE("ALLCTX",XQY0)=1
+12 ; IN DIRECT MODE, CHECK USER APP CTXT PERMISSION AND, IF NECESSARY, APPEND THE RPC NODES IN ^TMP("XQCS",$J
IF DUZ
DO ADDCTXT(DUZ,"BMXRPC")
+13 ;
+14 ;check exemptions. new exemption for XWB*1.1*6 - dpc
IF BMXRP'="XWB IM HERE"
IF BMXRP'="XWB CREATE CONTEXT"
IF BMXRP'="XUS AV CODE"
IF BMXRP'="XWB RPC LIST"
IF BMXRP'="BMX AV CODE"
Begin DoDot:1
+15 IF $GET(XQY0)'=""
Begin DoDot:2
+16 ;do the check
SET BMXALLOW=$$CHK^XQCS(DUZ,$PIECE(XQY0,U),BMXRP)
+17 IF 'BMXALLOW
SET BMXSEC=BMXALLOW
End DoDot:2
+18 IF '$TEST
SET BMXSEC="Application context has not been created!"
End DoDot:1
+19 QUIT
+20 ;
OWNSKEY(RET,LIST) ;EP Does user have Key
+1 NEW I,K
SET I=""
+2 IF $GET(DUZ)'>0
SET RET(0)=0
QUIT
+3 IF $ORDER(LIST(""))=""
SET RET(0)=$$KCHK(LIST)
QUIT
+4 FOR
SET I=$ORDER(LIST(I))
IF I=""
QUIT
SET RET(I)=$$KCHK(LIST(I))
+5 QUIT
KCHK(%) ;EP Key Check
QUIT $SELECT($GET(DUZ)>0:$DATA(^XUSEC(%,DUZ)),1:0)
+1 ;
+2 ;
SETUP(RET) ;EP - sets up environment for GUI signon
+1 ;
+2 KILL ^TMP("XQCS",$JOB)
+3 ;IHS/OIT/HMW SAC Exemption Applied For ; Patched by GIS 6/1/2011
SET IO("IP")=$$GETPEER^%ZOSV
DO ZIO^%ZIS4
+4 DO SET1(0)
DO SET^BMXMSEC("XUS XOPT",XOPT)
DO SET^BMXMSEC("XUS CNT",0)
+5 SET %ZIS="0H"
SET IOP="NULL"
DO ^%ZIS
+6 ;0=server name, 1=volume, 2=uci, 3=device, 4=# attempts, 5=skip signon-screen
+7 SET RET(0)=$PIECE(XUENV,U,3)
SET RET(1)=$PIECE(XUVOL,U)
SET RET(2)=XUCI
+8 ;IHS/OIT/HMW SAC Exemption Applied For
SET RET(3)=$IO
SET RET(4)=$PIECE(XOPT,U,2)
SET RET(5)=0
+9 IF $$INHIBIT()
QUIT
+10 QUIT
+11 ;
SET1(FLAG) ;Setup parameters
+1 DO GETENV^%ZOSV
SET U="^"
SET XUENV=Y
SET XUCI=$PIECE(Y,U,1)
SET XQVOL=$PIECE(Y,U,2)
SET XUEON=^%ZOSF("EON")
SET XUEOFF=^("EOFF")
+2 SET X=$ORDER(^XTV(8989.3,1,4,"B",XQVOL,0))
SET XUVOL=$SELECT(X>0:^XTV(8989.3,1,4,X,0),1:XQVOL_"^y^1")
IF $PIECE(XUVOL,U,6)="y"
SET XRTL=XUCI_","_XQVOL
+3 SET XOPT=$SELECT($DATA(^XTV(8989.3,1,"XUS")):^("XUS"),1:"")
FOR I=2:1:15
IF $PIECE(XOPT,U,I)=""
SET $PIECE(XOPT,U,I)=$PIECE("^5^900^1^1^^^^1^300^^^^N^90",U,I)
+4 QUIT
+5 ;
INHIBIT() ;Is Logon to this system Inhibited?
+1 IF $GET(^%ZIS(14.5,"LOGON",XQVOL))
QUIT 1
+2 IF $DATA(^%ZOSF("ACTJ"))
XECUTE ^("ACTJ")
IF $PIECE(XUVOL,U,3)
IF ($PIECE(XUVOL,U,3)'>Y)
QUIT 2
+3 QUIT 0
+4 ;
NOW SET U="^"
SET XUNOW=$$NOW^XLFDT()
SET DT=$PIECE(XUNOW,".")
SET XUDEV=0
+1 QUIT
+2 ;
STATE(%) ;Return a state value
+1 ;XWBSTATE is required by XUSRB
+2 IF '$LENGTH($GET(%))
QUIT $GET(XWBSTATE)
+3 QUIT $GET(XWBSTATE(%))
+4 ;
+5 ;
SET(%,VALUE) ;Set the state variable
+1 IF $GET(%)=""
SET XWBSTATE=VALUE
+2 SET XWBSTATE(%)=VALUE
+3 QUIT
KILL(%) ;Kill state variable
+1 IF $LENGTH($GET(%))
KILL XWBSTATE(%)
+2 QUIT
+3 ;
+4 ;
ADDCTXT(XQUSR,XCONTEXT) ; SUPPORTS DIRECT MODE IN BMX
+1 NEW XQMES,XQRPC,X,Y,Z,%,XQOPT,TMP
+2 SET TMP=$NAME(^TMP("XQCS",$JOB))
+3 SET XQOPT=$ORDER(^DIC(19,"B",XCONTEXT,0))
IF 'XQOPT
QUIT
+4 SET XQRPC=$ORDER(^DIC(19,XQOPT,"RPC","B",0))
IF 'XQRPC
QUIT
+5 ; ITS ALREADY IN THERE ; NOTHING MORE TO DO
IF $DATA(@TMP@(XQRPC))
QUIT
+6 SET XQMES=1
+7 ; USER DOES NOT POSSES THIS APP CONTEXT
DO USER^XQCS
IF 'XQMES
QUIT
+8 SET XQRPC=0
+9 FOR
SET XQRPC=$ORDER(^DIC(19,XQOPT,"RPC","B",XQRPC))
IF 'XQRPC
QUIT
SET @TMP@(XQRPC,0)=XQRPC
+10 QUIT
+11 ;
