XOBSRAKJ.m

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 ---XOBSRAKJ   3828     printed  Apr 23, 2025@18:59:42                                                                                                                                                                                                    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