XOBSRAKJ ;kc/oak - VistALink Reauthentication Code, SSO/UC KAAJEE ; 03/02/2004 07:00
;;1.6;VistALink Security;;May 08, 2009;Build 15
;Per VHA directive 2004-038, this routine should not be modified.
QUIT
;
; ------------------------------------------------------------------------
; RPC Server: Reauthentication subroutines for SSO/UC KAAJEE
; ------------------------------------------------------------------------
;
CCOW(XOBID,XOBERR) ; -- CCOW connection type
NEW XOBOUT,T,HDL
SET XOBID=0
;
;get DUZ using Kernel CCOW Token xref
SET HDL=$GET(XOBDATA("XOB RPC","SECURITY","TYPE","CCOW"))
SET HDL=$$DECRYP^XUSRB1(HDL)
;
IF $EXTRACT(HDL,1,2)'="~2" DO QUIT
. SET XOBERR=182301_U_"CCOW"_U_"[token does not match CCOW handle format.]"
. SET XOBID=0
;
; TODO: need IP address, then need to do $$IPLOCKED(IP)?
;
; since bypassing CHKCCOW^XUSRB4, need to extract true handle, expiry here
SET HDL=$$UP^XLFSTR($EXTRACT(HDL,3,99)),T=$PIECE($GET(^XTV(8989.3,1,30),5400),U)
; call Kernel to resolve CCOW handle into user ID
SET XOBOUT=$$CHECK^XUSRB4(HDL,T)
IF (+XOBOUT)<1 DO QUIT
. SET XOBERR=182301_U_"CCOW"_U_"["_$PIECE(XOBOUT,U,2)_"]"
. SET XOBID=0
;
; need to get set XOBID=DUZ, save off DUZ(2) and anything else held in the token for XOBSRA
SET XOBID=+XOBOUT
;
; Save the division station# into $GET(XOBDATA("XOB RPC","SECURITY","DIV")) -- that
; is where the XOBSRA division check is looking for it
SET:+DUZ(2) XOBDATA("XOB RPC","SECURITY","DIV")=$$STA^XUAF4(DUZ(2))
;
IF XOBID<1 DO QUIT
. SET XOBERR=182305_U_"CCOW"
. SET XOBID=0
;
; probably can run MORECHKS as is?
; SET XOBERR=$$MORECHKS(XOBID)
;
IF XOBERR SET XOBID=0 QUIT
;
; TODO: POST(IP)
;
QUIT
;
AV(XOBID,XOBERR) ; -- AV connection type
NEW AC,AVCODE,VC,X,XOBCLIP,XOBTYPE
SET XOBID=0
;
; -- get DUZ using access and verify codes
SET AVCODE=$GET(XOBDATA("XOB RPC","SECURITY","TYPE","AVCODE"))
;
SET AVCODE=$$DECRYP^XUSRB1(AVCODE)
SET AC=$PIECE(AVCODE,";",1),VC=$PIECE(AVCODE,";",2),XOBCLIP=$PIECE(AVCODE,";",3)
;
; -- convert AC, VC into hashed versions
SET X=AC,AC=$$EN^XUSHSH($$UP^XLFSTR(X))
SET X=VC,VC=$$EN^XUSHSH($$UP^XLFSTR(X))
;
; -- check if exceeded multiple signon attempts
SET XOBERR=$$IPLOCKED(XOBCLIP) IF XOBERR SET XOBID=0 QUIT
;
; -- look up AC
SET XOBID=+$ORDER(^VA(200,"A",AC,0))
IF XOBID<1 DO QUIT
. SET XOBERR=182305_U_"AV"
. SET XOBID=0
;
; -- check VC
IF $PIECE($GET(^VA(200,XOBID,.1)),U,2)'=VC DO QUIT
. SET XOBERR=182305_U_"AV"
. SET XOBID=0
;
; -- check user access and whether verify code needs changing
SET XOBERR=$$MORECHKS(XOBID)
IF XOBERR SET XOBID=0 QUIT
;
; login succeeded
DO POST(XOBCLIP)
;
; NOTE: AV doesn't need to check $$PERSON for AV because our source was file 200, not a separate index
;
QUIT
;
MORECHKS(XOBID) ; -- More separate checks
NEW XOBERR
SET XOBERR=0
;
; -- check user access
SET XOBERR=$$NOACCESS^XOBSRA(XOBID)
IF XOBERR SET XOBID=0 QUIT XOBERR
;
; -- check if verify code needs changing
SET XOBERR=$$VCHG^XOBSRA(XOBID)
IF XOBERR SET XOBID=0 QUIT XOBERR
;
QUIT XOBERR
;
IPLOCKED(XOBCLIP) ; -- check if IP address is locked, increment if not
;
; Implements the script-inhibiting lock-by-IP-address Kernel function.
; Does not lock user out for long, but does slow down scripts.
;
; Return:
; 182306^XOBID : if too many invalid login attempts
; 0 : not too many login attempts
;
IF $$LKCHECK^XUSTZIP(XOBCLIP) DO QUIT XOBERR
. SET XOBERR="182306^Too many invalid signon attempts."
;
NEW XOBERR,XUFAC SET XOBERR=0
;
IF $$FAIL^XUS3(XOBCLIP) SET XOBERR="182306^"_$$RA^XUSTZ(XOBCLIP)
QUIT XOBERR
;
POST(XOBCLIP) ; post-successful tasks
DO CLRFAC^XUS3(XOBCLIP)
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXOBSRAKJ 3828 printed Oct 16, 2024@18:45:25 Page 2
XOBSRAKJ ;kc/oak - VistALink Reauthentication Code, SSO/UC KAAJEE ; 03/02/2004 07:00
+1 ;;1.6;VistALink Security;;May 08, 2009;Build 15
+2 ;Per VHA directive 2004-038, this routine should not be modified.
+3 QUIT
+4 ;
+5 ; ------------------------------------------------------------------------
+6 ; RPC Server: Reauthentication subroutines for SSO/UC KAAJEE
+7 ; ------------------------------------------------------------------------
+8 ;
CCOW(XOBID,XOBERR) ; -- CCOW connection type
+1 NEW XOBOUT,T,HDL
+2 SET XOBID=0
+3 ;
+4 ;get DUZ using Kernel CCOW Token xref
+5 SET HDL=$GET(XOBDATA("XOB RPC","SECURITY","TYPE","CCOW"))
+6 SET HDL=$$DECRYP^XUSRB1(HDL)
+7 ;
+8 IF $EXTRACT(HDL,1,2)'="~2"
Begin DoDot:1
+9 SET XOBERR=182301_U_"CCOW"_U_"[token does not match CCOW handle format.]"
+10 SET XOBID=0
End DoDot:1
QUIT
+11 ;
+12 ; TODO: need IP address, then need to do $$IPLOCKED(IP)?
+13 ;
+14 ; since bypassing CHKCCOW^XUSRB4, need to extract true handle, expiry here
+15 SET HDL=$$UP^XLFSTR($EXTRACT(HDL,3,99))
SET T=$PIECE($GET(^XTV(8989.3,1,30),5400),U)
+16 ; call Kernel to resolve CCOW handle into user ID
+17 SET XOBOUT=$$CHECK^XUSRB4(HDL,T)
+18 IF (+XOBOUT)<1
Begin DoDot:1
+19 SET XOBERR=182301_U_"CCOW"_U_"["_$PIECE(XOBOUT,U,2)_"]"
+20 SET XOBID=0
End DoDot:1
QUIT
+21 ;
+22 ; need to get set XOBID=DUZ, save off DUZ(2) and anything else held in the token for XOBSRA
+23 SET XOBID=+XOBOUT
+24 ;
+25 ; Save the division station# into $GET(XOBDATA("XOB RPC","SECURITY","DIV")) -- that
+26 ; is where the XOBSRA division check is looking for it
+27 if +DUZ(2)
SET XOBDATA("XOB RPC","SECURITY","DIV")=$$STA^XUAF4(DUZ(2))
+28 ;
+29 IF XOBID<1
Begin DoDot:1
+30 SET XOBERR=182305_U_"CCOW"
+31 SET XOBID=0
End DoDot:1
QUIT
+32 ;
+33 ; probably can run MORECHKS as is?
+34 ; SET XOBERR=$$MORECHKS(XOBID)
+35 ;
+36 IF XOBERR
SET XOBID=0
QUIT
+37 ;
+38 ; TODO: POST(IP)
+39 ;
+40 QUIT
+41 ;
AV(XOBID,XOBERR) ; -- AV connection type
+1 NEW AC,AVCODE,VC,X,XOBCLIP,XOBTYPE
+2 SET XOBID=0
+3 ;
+4 ; -- get DUZ using access and verify codes
+5 SET AVCODE=$GET(XOBDATA("XOB RPC","SECURITY","TYPE","AVCODE"))
+6 ;
+7 SET AVCODE=$$DECRYP^XUSRB1(AVCODE)
+8 SET AC=$PIECE(AVCODE,";",1)
SET VC=$PIECE(AVCODE,";",2)
SET XOBCLIP=$PIECE(AVCODE,";",3)
+9 ;
+10 ; -- convert AC, VC into hashed versions
+11 SET X=AC
SET AC=$$EN^XUSHSH($$UP^XLFSTR(X))
+12 SET X=VC
SET VC=$$EN^XUSHSH($$UP^XLFSTR(X))
+13 ;
+14 ; -- check if exceeded multiple signon attempts
+15 SET XOBERR=$$IPLOCKED(XOBCLIP)
IF XOBERR
SET XOBID=0
QUIT
+16 ;
+17 ; -- look up AC
+18 SET XOBID=+$ORDER(^VA(200,"A",AC,0))
+19 IF XOBID<1
Begin DoDot:1
+20 SET XOBERR=182305_U_"AV"
+21 SET XOBID=0
End DoDot:1
QUIT
+22 ;
+23 ; -- check VC
+24 IF $PIECE($GET(^VA(200,XOBID,.1)),U,2)'=VC
Begin DoDot:1
+25 SET XOBERR=182305_U_"AV"
+26 SET XOBID=0
End DoDot:1
QUIT
+27 ;
+28 ; -- check user access and whether verify code needs changing
+29 SET XOBERR=$$MORECHKS(XOBID)
+30 IF XOBERR
SET XOBID=0
QUIT
+31 ;
+32 ; login succeeded
+33 DO POST(XOBCLIP)
+34 ;
+35 ; NOTE: AV doesn't need to check $$PERSON for AV because our source was file 200, not a separate index
+36 ;
+37 QUIT
+38 ;
MORECHKS(XOBID) ; -- More separate checks
+1 NEW XOBERR
+2 SET XOBERR=0
+3 ;
+4 ; -- check user access
+5 SET XOBERR=$$NOACCESS^XOBSRA(XOBID)
+6 IF XOBERR
SET XOBID=0
QUIT XOBERR
+7 ;
+8 ; -- check if verify code needs changing
+9 SET XOBERR=$$VCHG^XOBSRA(XOBID)
+10 IF XOBERR
SET XOBID=0
QUIT XOBERR
+11 ;
+12 QUIT XOBERR
+13 ;
IPLOCKED(XOBCLIP) ; -- check if IP address is locked, increment if not
+1 ;
+2 ; Implements the script-inhibiting lock-by-IP-address Kernel function.
+3 ; Does not lock user out for long, but does slow down scripts.
+4 ;
+5 ; Return:
+6 ; 182306^XOBID : if too many invalid login attempts
+7 ; 0 : not too many login attempts
+8 ;
+9 IF $$LKCHECK^XUSTZIP(XOBCLIP)
Begin DoDot:1
+10 SET XOBERR="182306^Too many invalid signon attempts."
End DoDot:1
QUIT XOBERR
+11 ;
+12 NEW XOBERR,XUFAC
SET XOBERR=0
+13 ;
+14 IF $$FAIL^XUS3(XOBCLIP)
SET XOBERR="182306^"_$$RA^XUSTZ(XOBCLIP)
+15 QUIT XOBERR
+16 ;
POST(XOBCLIP) ; post-successful tasks
+1 DO CLRFAC^XUS3(XOBCLIP)
+2 QUIT
