- 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 0
- ;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 2961 printed Feb 19, 2025@00:03:51 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 0
- +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