XWBSEC ;ISF/VYD,ISD/HGW - RPC BROKER ; 7/21/16 4:34pm
;;1.1;RPC BROKER;**3,6,10,35,53,64**;Mar 28, 1997;Build 12
;Per VA Directive 6402, this routine should not be modified.
;
CHKPRMIT(XWBRP) ;checks to see if remote procedure is permitted to run
;Input: XWBRP - Remote procedure to check
;Output: XWBSEC - Error message if RPC cannot be run
; ZEXCEPT: XQY0,XWBSEC - Kernel exemption for global variables
N ERR,XWBPRMIT,XWBALLOW
S U="^",XWBSEC="" ;Return XWBSEC="" if OK to run RPC
Q:$$KCHK^XUSRB("XUPROGMODE")
;
;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
;
;These RPC's are allowed in any context, so we can just quit
I "^XWB IM HERE^XWB CREATE CONTEXT^XWB RPC LIST^XWB IS RPC AVAILABLE^XUS GET USER INFO^XUS GET TOKEN^XUS SET VISITOR^"[(U_XWBRP_U) Q ;p53
I "^XUS IAM BIND USER^XUS CVC^XUS KEY CHECK^XUS BSE TOKEN^"[(U_XWBRP_U) Q ;p64
;VistAlink RPC's that are always allowed.
I "^XUS KAAJEE GET USER INFO^XUS KAAJEE LOGOUT^"[(U_XWBRP_U) Q
;
;If in Signon context, only allow XUS and XWB rpc's
I $G(XQY0)="XUS SIGNON","^XUS^XWB^"'[(U_$E(XWBRP,1,3)_U) S XWBSEC="Application context has not been created!" Q
;XQCS allows all users access to the XUS SIGNON context.
;Also to any context in the XUCOMMAND menu.
;
I $G(XQY0)'="" D ;1.1*6. XQY0="" after XUS SIGNON context deleted.
. S XWBALLOW=$$CHK^XQCS(DUZ,$P(XQY0,U),XWBRP) ;do the check
. I 'XWBALLOW S XWBSEC=XWBALLOW ;no access to RPC
E S XWBSEC="Application context has not been created!"
Q
;
CRCONTXT(RESULT,OPTION,APPLCODE) ;creates context for the passed in option
; ZEXCEPT: XQY,XQY0,XWBSEC - Kernel exemption for global variables
K XQY0,XQY
N XWB1,XWB2,XABPGMOD,XWBPGMOD,XWBCODE
S RESULT=0
I $D(APPLCODE) D ;Assign an optional secondary menu option for user (SSOi, SSOe)
. S XWBCODE=$$AESDECR^XUSHSH($$B64DECD^XUSHSH(APPLCODE),"tHiZZfnmYjkFinis")
. S XWB2=$$SETCNTXT^XUESSO2(DUZ,XWBCODE)
S OPTION=$$DECRYP^XUSRB1(OPTION)
I OPTION="" S XQY=0,XQY0="",RESULT=1 Q ;delete context if "" passed in.
S XWB1=$$OPTLK^XQCS(OPTION)
I XWB1="" S (XWBSEC,RESULT)="The context '"_OPTION_"' does not exist on server." Q ;P10
;Check Access (User with XUPROGMODE security key always has access)
S RESULT=$$CHK^XQCS(DUZ,XWB1)
S XWBPGMOD=$$KCHK^XUSRB("XUPROGMODE")
I RESULT!XWBPGMOD S XQY0=OPTION,XQY=XWB1,RESULT=1
E S XWBSEC=RESULT
Q
;
STATE(%) ;Return a state value
; ZEXCEPT: XWBSTATE - Kernel exemption for global variable
Q:'$L($G(%)) $G(XWBSTATE)
Q $G(XWBSTATE(%))
;
SET(%,VALUE) ;Set the state variable
; ZEXCEPT: XWBSTATE - Kernel exemption for global variable
I $G(%)="" S XWBSTATE=VALUE
S XWBSTATE(%)=VALUE
Q
;
KILL(%) ;Kill state variable
; ZEXCEPT: XWBSTATE - Kernel exemption for global variable
I $L($G(%)) K XWBSTATE(%)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXWBSEC 2962 printed Dec 13, 2024@02:37:26 Page 2
XWBSEC ;ISF/VYD,ISD/HGW - RPC BROKER ; 7/21/16 4:34pm
+1 ;;1.1;RPC BROKER;**3,6,10,35,53,64**;Mar 28, 1997;Build 12
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
CHKPRMIT(XWBRP) ;checks to see if remote procedure is permitted to run
+1 ;Input: XWBRP - Remote procedure to check
+2 ;Output: XWBSEC - Error message if RPC cannot be run
+3 ; ZEXCEPT: XQY0,XWBSEC - Kernel exemption for global variables
+4 NEW ERR,XWBPRMIT,XWBALLOW
+5 ;Return XWBSEC="" if OK to run RPC
SET U="^"
SET XWBSEC=""
+6 if $$KCHK^XUSRB("XUPROGMODE")
QUIT
+7 ;
+8 ;In the beginning, when no DUZ is defined and no context exist, setup
+9 ;default signon context
+10 ;set up default context
if '$GET(DUZ)
SET DUZ=0
SET XQY0="XUS SIGNON"
+11 ;
+12 ;These RPC's are allowed in any context, so we can just quit
+13 ;p53
IF "^XWB IM HERE^XWB CREATE CONTEXT^XWB RPC LIST^XWB IS RPC AVAILABLE^XUS GET USER INFO^XUS GET TOKEN^XUS SET VISITOR^"[(U_XWBRP_U)
QUIT
+14 ;p64
IF "^XUS IAM BIND USER^XUS CVC^XUS KEY CHECK^XUS BSE TOKEN^"[(U_XWBRP_U)
QUIT
+15 ;VistAlink RPC's that are always allowed.
+16 IF "^XUS KAAJEE GET USER INFO^XUS KAAJEE LOGOUT^"[(U_XWBRP_U)
QUIT
+17 ;
+18 ;If in Signon context, only allow XUS and XWB rpc's
+19 IF $GET(XQY0)="XUS SIGNON"
IF "^XUS^XWB^"'[(U_$EXTRACT(XWBRP,1,3)_U)
SET XWBSEC="Application context has not been created!"
QUIT
+20 ;XQCS allows all users access to the XUS SIGNON context.
+21 ;Also to any context in the XUCOMMAND menu.
+22 ;
+23 ;1.1*6. XQY0="" after XUS SIGNON context deleted.
IF $GET(XQY0)'=""
Begin DoDot:1
+24 ;do the check
SET XWBALLOW=$$CHK^XQCS(DUZ,$PIECE(XQY0,U),XWBRP)
+25 ;no access to RPC
IF 'XWBALLOW
SET XWBSEC=XWBALLOW
End DoDot:1
+26 IF '$TEST
SET XWBSEC="Application context has not been created!"
+27 QUIT
+28 ;
CRCONTXT(RESULT,OPTION,APPLCODE) ;creates context for the passed in option
+1 ; ZEXCEPT: XQY,XQY0,XWBSEC - Kernel exemption for global variables
+2 KILL XQY0,XQY
+3 NEW XWB1,XWB2,XABPGMOD,XWBPGMOD,XWBCODE
+4 SET RESULT=0
+5 ;Assign an optional secondary menu option for user (SSOi, SSOe)
IF $DATA(APPLCODE)
Begin DoDot:1
+6 SET XWBCODE=$$AESDECR^XUSHSH($$B64DECD^XUSHSH(APPLCODE),"tHiZZfnmYjkFinis")
+7 SET XWB2=$$SETCNTXT^XUESSO2(DUZ,XWBCODE)
End DoDot:1
+8 SET OPTION=$$DECRYP^XUSRB1(OPTION)
+9 ;delete context if "" passed in.
IF OPTION=""
SET XQY=0
SET XQY0=""
SET RESULT=1
QUIT
+10 SET XWB1=$$OPTLK^XQCS(OPTION)
+11 ;P10
IF XWB1=""
SET (XWBSEC,RESULT)="The context '"_OPTION_"' does not exist on server."
QUIT
+12 ;Check Access (User with XUPROGMODE security key always has access)
+13 SET RESULT=$$CHK^XQCS(DUZ,XWB1)
+14 SET XWBPGMOD=$$KCHK^XUSRB("XUPROGMODE")
+15 IF RESULT!XWBPGMOD
SET XQY0=OPTION
SET XQY=XWB1
SET RESULT=1
+16 IF '$TEST
SET XWBSEC=RESULT
+17 QUIT
+18 ;
STATE(%) ;Return a state value
+1 ; ZEXCEPT: XWBSTATE - Kernel exemption for global variable
+2 if '$LENGTH($GET(%))
QUIT $GET(XWBSTATE)
+3 QUIT $GET(XWBSTATE(%))
+4 ;
SET(%,VALUE) ;Set the state variable
+1 ; ZEXCEPT: XWBSTATE - Kernel exemption for global variable
+2 IF $GET(%)=""
SET XWBSTATE=VALUE
+3 SET XWBSTATE(%)=VALUE
+4 QUIT
+5 ;
KILL(%) ;Kill state variable
+1 ; ZEXCEPT: XWBSTATE - Kernel exemption for global variable
+2 IF $LENGTH($GET(%))
KILL XWBSTATE(%)
+3 QUIT
