XOBSRA ;MJK/ESD/ALB - VistALink Reauthentication Code ; 05/22/2003 07:00
;;1.6;VistALink Security;**2,6**;May 08, 2009;Build 4
;;Per VA Directive 6402, this routine should not be modified
;;BACKUP FROM 3251208
QUIT
;
; ------------------------------------------------------------------------
; RPC Server: Reauthentication based on VPID, DUZ, and AV
; ------------------------------------------------------------------------
;
SAML(XOBID,XOBERR) ; rtw ADDED FOR XOBS*1.6*6
;The RTN array must be preserved to return to VistaLink
S XOBID=0
S SAML=$G(XOBDATA("XOB RPC","SECURITY","TYPE","SAML"))
D SETUP^XUSRB
D SAML^XOBVSAML(.RTN,SAML)
I $G(RTN(0)) S XOBID=RTN(0)
E I $D(RTN(3)),RTN(3)'="" S XOBERR=RTN(3) D
. D GETDUZ(SAML,.XOBERR)
. I XOBERR[182308 D FINAL S DUZ=$G(XOBOK) Q
. I XOBERR["No access allowed for this user" S XOBID=0,XOBERR=182304_"^"_DUZ_"^"_"DISUSERED" D FINAL S DUZ=$G(XOBOK) Q
K SAML,^TMP("DUZ_XUS",$J)
Q XOBID
;
;
SETUPDUZ() ; -- get DUZ context and division
;
NEW XOBERR,XOBID,XOBTYPE
SET (XOBERR,XOBID)=0
;
; -- if already authenticated quit
IF $GET(XOBDATA("XOB RPC","SECURITY","STATE"))="authenticated" D KILL^XOBSRA1 GOTO SUDQ ;*2
; -- switch to null device
DO NULL
; -- initialize partition
DO INIT
;
; -- check if logons are enabled
SET XOBERR=$$LOGINH()
IF XOBERR DO SOCKET GOTO SUDQ
;
; -- reauthenticate user based on type
SET XOBTYPE=$GET(XOBDATA("XOB RPC","SECURITY","TYPE")),XOBTYPE=$$UP^XLFSTR(XOBTYPE)
IF XOBTYPE="DUZ"!(XOBTYPE="AV")!(XOBTYPE="VPID")!(XOBTYPE="CCOW")!(XOBTYPE="APPPROXY")!(XOBTYPE="SAML") DO ;RTW ADD SAML XOBS*1.6*6
. DO @(XOBTYPE_"(.XOBID,.XOBERR)")
ELSE DO
. SET XOBERR=182301_U_XOBTYPE_U_" [Erroneous reauthentication type]"
;
; -- check division
IF XOBID SET XOBERR=$$DUZENV(XOBID,XOBTYPE)
;
; -- switch back to socket device
DO SOCKET
SUDQ ;
;LOG:: Log error in trap or elsewhere if appropriate. May want to log 'no match' event for security reasons.
IF 'XOBERR DO FINAL
QUIT XOBERR
;
NULL ; switch to null device
USE XOBNULL
QUIT
;
SOCKET ; -- switch back to socket device
; -- empty write buffer of null device
USE XOBNULL SET DX=0,DY=0 XECUTE ^%ZOSF("XY")
; -- reset to use tcp port device to send results
USE XOBPORT
QUIT
;
AV(XOBID,XOBERR) ; -- AV (SSO/UC KAAJEE) reauth type
;
; More checks performed here; assume this would be called ONCE when user authenticates
; to application via KAAJEE or FatKAAT
;
DO AV^XOBSRAKJ(.XOBID,.XOBERR)
QUIT
;
DUZ(XOBID,XOBERR) ; -- DUZ reauth type
;
NEW XOBCTYPE
SET XOBCTYPE="DUZ"
SET XOBID=$GET(XOBDATA("XOB RPC","SECURITY","TYPE","VALUE"))
;
; Active user status check performed here; assume heavier-duty checks done by application
; when user authenticated to application via KAAJEE, FatKAAT or equivalent.
;
DO ACTUSR(.XOBID,.XOBERR,XOBCTYPE)
QUIT
;
VPID(XOBID,XOBERR) ; -- VPID reauth type
NEW VPID,XOBCTYPE
SET XOBID=0
SET XOBCTYPE="VPID"
;
SET VPID=$GET(XOBDATA("XOB RPC","SECURITY","TYPE","VALUE"))
IF VPID]"" SET XOBID=$$IEN^XUPS(VPID)
;
IF '+XOBID DO QUIT
. SET XOBERR=182301_U_XOBTYPE_U_"["_XOBCTYPE_" Value: '"_VPID_"']"
. SET XOBID=0
;
; Active user status check performed here; assume heavier-duty checks done by application
; when user authenticated to application via KAAJEE, FatKAAT or equivalent.
;
DO ACTUSR(.XOBID,.XOBERR,XOBCTYPE)
QUIT
;
APPPROXY(XOBID,XOBERR) ; -- application proxy reauth type
;
NEW XOBANAME,XOBCTYPE,XOBAPFND
SET XOBID=0,XOBCTYPE="APPPROXY"
SET XOBANAME=$GET(XOBDATA("XOB RPC","SECURITY","TYPE","VALUE"))
;
; APFIND^XUSAP(name) -> returns ien^vpid, or (failure) -int^reason
IF XOBANAME]"" SET XOBAPFND=$$APFIND^XUSAP(XOBANAME),XOBID=$PIECE(XOBAPFND,U)
; file #200 division mult checking not necessary for app proxy user
IF (+XOBID)<1 DO
. SET XOBERR=182307_U_XOBANAME_U_"["_$P(XOBAPFND,U,2)_"]",XOBID=0
QUIT
;
CCOW(XOBID,XOBERR) ; -- CCOW reauth type
;
; Very few checks performed here; assume heavier duty checks done by application when originally
; authenticated and created Kernel CCOW token. User would need to be reauthenticated (and perform
; heavier-duty checks) upon Kernel CCOW token expiration.
;
DO CCOW^XOBSRAKJ(.XOBID,.XOBERR)
QUIT
;
ACTUSR(XOBID,XOBERR,XOBCTYPE) ; -- user active status check & error processing
;
NEW XOBACTIV
SET XOBACTIV=0
SET XOBID=$GET(XOBID),XOBCTYPE=$GET(XOBCTYPE)
;
;-- returns active status indicator of user
SET XOBACTIV=$$ACTIVE^XUSER(XOBID)
IF +XOBACTIV<1 DO
. ;
. ;-- get dialog entry for error
. SET XOBERR=$$GETERR(XOBACTIV,XOBID,XOBCTYPE)
. SET XOBID=0
QUIT
;
DUZENV(XOBDUZ,XOBTYPE) ; -- build DUZ and check division
;
; QUIT 0 if OK, DialogErrorNumber^DialogErrorParameter1^... if bad
;
NEW XOBDVARY,XOBDIV,XOBDIVEX,XOBDIVRQ,XOBDUZSV,XOBERR,XOBI,XOBOK
SET XOBOK=0,(XOBERR,XOBDIVEX)=""
;
; -- preserve previous DUZ value, restore if needed
MERGE XOBDUZSV=DUZ KILL DUZ
;
; -- set up info on passed in user
SET DUZ=XOBDUZ
SET XOBDIVRQ("STATIONNUMBER")=$GET(XOBDATA("XOB RPC","SECURITY","DIV"))
;
DO ; checks
.;
.; -- if no division passed in
. IF XOBDIVRQ("STATIONNUMBER")']"" DO QUIT
. . SET XOBERR=182308_U_"no division passed"_U_XOBTYPE_U_XOBDUZ_U_"null"
. ;
. ; -- is division supported at the site?
. SET XOBDIVRQ("IEN")=$$SITECHK(XOBDIVRQ("STATIONNUMBER"))
. IF '+XOBDIVRQ("IEN") DO QUIT
. . SET XOBERR=182308_U_$P(XOBDIVRQ("IEN"),U,2)_U_XOBTYPE_U_XOBDUZ_U_XOBDIVRQ("STATIONNUMBER")
. . KILL XOBDIVRQ("IEN")
.;
.; -- build DUZ
. DO DUZ^XUP(DUZ)
.;
.; -- don't do user-based checks if reauth type is APPPROXY
.IF XOBTYPE="APPPROXY" SET XOBOK=1 QUIT
.;
.; -- do check for user-permitted divisions
. DO DIVGET^XUSRB2(.XOBDIV,DUZ)
.;
.; -- DIVGET^XUSRB2 return value: if no divisions or one (matching) division, it's good
. IF '$GET(XOBDIV(0)) DO QUIT
.. IF $GET(DUZ(2))=XOBDIVRQ("IEN") SET XOBOK=1 QUIT ; OK
..;
..; -- if got here, did not match division
.. SET XOBERR=182302_U_XOBTYPE_U_XOBDUZ_U_XOBDIVRQ("STATIONNUMBER")
.;
.; -- DIVGET^XUSRB2 return value: if >1 divisions to select, attempt to set DUZ(2) to div passed in
. DO DIVSET^XUSRB2(.XOBOK,"`"_XOBDIVRQ("IEN")) I 'XOBOK DO
.. SET XOBERR=182302_U_XOBTYPE_U_XOBDUZ_U_XOBDIVRQ("STATIONNUMBER")
;
IF 'XOBOK DO ; A check failed. Clean up partition.
.;
.; -- reset DUZ
. KILL DUZ
. MERGE DUZ=XOBDUZSV
;
; -- send back error
QUIT $SELECT(XOBOK:0,1:XOBERR)
;
LOGINH() ; -- Check if system is currently allowing logins
; Return:
; 181004 : if logins are disabled
; 0 : if logins are allowed
;
NEW XQVOL,XUCI,XUENV,XUVOL,X,Y
;
; -- Setup XUENV, XUCI,XQVOL,XUVOL
DO XUVOL^XUS
;
; -- Check whether logins are disabled
QUIT $SELECT($$INHIB1^XUSRB():181004,1:0)
;
NOACCESS(XOBID) ; -- Determine if user is allowed access via user active status & prohibited times checks
;
NEW XOBERR,XOBNOACC,XOBRANGE
SET (XOBERR,XOBNOACC)=0
;
; -- user active status check & error processing
DO ACTUSR(.XOBID,.XOBERR)
;
; -- check if sign-on is attempted during prohibited times
IF 'XOBERR DO
. SET XOBRANGE=$$GET1^DIQ(200,XOBID,15)
. IF XOBRANGE DO
.. SET XOBNOACC=$$PROHIBIT^XUS1A($P($HOROLOG,",",2),XOBRANGE)
.. IF XOBNOACC SET XOBERR=182304_U_XOBID_U_"Prohibited time: "_$PIECE(XOBNOACC,U,2)
QUIT XOBERR
;
VCHG(XOBID) ; -- Check if verify code needs to be changed
; Return:
; 182303^XOBID : if verify code is undefined or expired
; 0 : verify code is current
NEW DUZ,I,VCHG,XOPT
SET DUZ=+$GET(XOBID),VCHG=0
;
; -- set up XOPT
DO XOPT^XUS
;
; -- check if verify code is current
IF $$VCVALID^XUSRB() DO
. SET VCHG=182303_U_DUZ
QUIT VCHG
;
INIT ; -- VL-specific or general partition setup before reauthentication process starts
;
LOCK
SET:$DATA(IO)[0 IO=$IO SET IO(0)=IO
KILL ^UTILITY($JOB),^TMP($JOB)
KILL ^XUTL("XQ",$JOB)
; -- clean up partition's local symbol table
DO KILL^XOBSRA1
QUIT
;
FINAL ; -- Final setup needed after a re-authentication is performed successfully.
; -- Save DUZ and IO variables in ^XUTL("XQ",$JOB)
DO SAVE^XUS1
;
; Change in XUSRB: calls POST2^XUSRB calls CLRFAC^XUS3 to clear Failed Signon Attempts
; file of entry with given IP. Need IO("IP") obtained from ZIO^%ZIS4.
;
K XQY,XQY0 ;*2
QUIT
;
GETERR(XOBACT,XOBID,XOBCONN) ;-- Get appropriate DIALOG file error
;
NEW XOBERR
SET XOBERR=0
SET XOBACT=$GET(XOBACT),XOBID=$GET(XOBID),XOBCONN=$GET(XOBCONN)
;
;- error indicates that user can't sign on, is DISUSER'd, or is TERMINATED
IF $PIECE(XOBACT,U)=0 SET XOBERR=182304_U_XOBID_U_$SELECT($PIECE(XOBACT,U,2)'="":$PIECE(XOBACT,U,2),1:"Unable to Sign On")
;
;- error indicates no user record found
IF $PIECE(XOBACT,U)="" DO
. SET:XOBCONN="" XOBCONN="Unknown Reauthentication Type"
. SET XOBERR=182301_U_XOBCONN_U_" ["_XOBCONN_" reauthentication type, DUZ Value: '"_XOBID_"']"
QUIT XOBERR
;
SITECHK(XOBSTATN) ; check if valid division for this site
; input: station#
; output: IEN of station# in institution file (if valid for this site)
; 0^error message (if not valid for this site)
N XOBSTIEN,XOBSTRIP
SET XOBSTRIP=$$STRPSUFF^XOBSCAV1(XOBSTATN)
; note: AAC 200M truncated to 200 in both sides of comparison below
QUIT:(XOBSTRIP'=XOBSYS("PRIMARY STATION#")) "0^STATION '"_XOBSTATN_"' is not supported by this M system."
S XOBSTIEN=$$IEN^XUAF4(XOBSTATN)
QUIT:'+XOBSTIEN "0^STATION '"_XOBSTATN_"' is not a known station number."
QUIT:'$$ACTIVE^XUAF4(XOBSTIEN) "0^STATION '"_XOBSTATN_"' is not active on this M system."
QUIT XOBSTIEN
GETDUZ(SAML,XOBERR) ; if new SAML user is disusered give the DUZ to complete the return information
N I,IEND,ISTART,ISTOP,DOC
;K RTN
K ^TMP("DUZ_XUS",$J)
S ISTOP=$L(SAML),IEND=0
F I=1:1 Q:IEND>ISTOP D
. S ISTART=IEND+1
. S IEND=IEND+200
. S ^TMP("DUZ_XUS",$J,I)=$E(SAML,ISTART,IEND)
.Q
D SECID(SAML,.XOBERR,.DUZ)
I '$G(DUZ) S XOBERR=182308_U_1_U_"SAML"_U_XOBERR_"SECID NOT FOUND IN UCI"
;K X,XQVOL,XUCI,XUENV,XUOSVER,Y
Q XOBERR
SECID(SAML,XOBERR,DUZ) ;TO CHECK IF a SECID exists in the UCI
N SECID,SECIDL
S SECIDL=0,DUZ=""
S ^XTMP("SAML CHECK",$J)=SAML
S SECID=$P($P(^XTMP("SAML CHECK",$J),"urn:va:vrm:iam:secid"">",2),"<",1) D
. F S SECIDL=$O(^VA(200,"ASECID",SECIDL)) Q:'SECIDL D
. . I SECID=SECIDL S DUZ=$O(^VA(200,"ASECID",SECID,"")) Q
Q XOBERR
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXOBSRA 10588 printed Apr 22, 2026@14:42:11 Page 2
XOBSRA ;MJK/ESD/ALB - VistALink Reauthentication Code ; 05/22/2003 07:00
+1 ;;1.6;VistALink Security;**2,6**;May 08, 2009;Build 4
+2 ;;Per VA Directive 6402, this routine should not be modified
+3 ;;BACKUP FROM 3251208
+4 QUIT
+5 ;
+6 ; ------------------------------------------------------------------------
+7 ; RPC Server: Reauthentication based on VPID, DUZ, and AV
+8 ; ------------------------------------------------------------------------
+9 ;
SAML(XOBID,XOBERR) ; rtw ADDED FOR XOBS*1.6*6
+1 ;The RTN array must be preserved to return to VistaLink
+2 SET XOBID=0
+3 SET SAML=$GET(XOBDATA("XOB RPC","SECURITY","TYPE","SAML"))
+4 DO SETUP^XUSRB
+5 DO SAML^XOBVSAML(.RTN,SAML)
+6 IF $GET(RTN(0))
SET XOBID=RTN(0)
+7 IF '$TEST
IF $DATA(RTN(3))
IF RTN(3)'=""
SET XOBERR=RTN(3)
Begin DoDot:1
+8 DO GETDUZ(SAML,.XOBERR)
+9 IF XOBERR[182308
DO FINAL
SET DUZ=$GET(XOBOK)
QUIT
+10 IF XOBERR["No access allowed for this user"
SET XOBID=0
SET XOBERR=182304_"^"_DUZ_"^"_"DISUSERED"
DO FINAL
SET DUZ=$GET(XOBOK)
QUIT
End DoDot:1
+11 KILL SAML,^TMP("DUZ_XUS",$JOB)
+12 QUIT XOBID
+13 ;
+14 ;
SETUPDUZ() ; -- get DUZ context and division
+1 ;
+2 NEW XOBERR,XOBID,XOBTYPE
+3 SET (XOBERR,XOBID)=0
+4 ;
+5 ; -- if already authenticated quit
+6 ;*2
IF $GET(XOBDATA("XOB RPC","SECURITY","STATE"))="authenticated"
DO KILL^XOBSRA1
GOTO SUDQ
+7 ; -- switch to null device
+8 DO NULL
+9 ; -- initialize partition
+10 DO INIT
+11 ;
+12 ; -- check if logons are enabled
+13 SET XOBERR=$$LOGINH()
+14 IF XOBERR
DO SOCKET
GOTO SUDQ
+15 ;
+16 ; -- reauthenticate user based on type
+17 SET XOBTYPE=$GET(XOBDATA("XOB RPC","SECURITY","TYPE"))
SET XOBTYPE=$$UP^XLFSTR(XOBTYPE)
+18 ;RTW ADD SAML XOBS*1.6*6
IF XOBTYPE="DUZ"!(XOBTYPE="AV")!(XOBTYPE="VPID")!(XOBTYPE="CCOW")!(XOBTYPE="APPPROXY")!(XOBTYPE="SAML")
Begin DoDot:1
+19 DO @(XOBTYPE_"(.XOBID,.XOBERR)")
End DoDot:1
+20 IF '$TEST
Begin DoDot:1
+21 SET XOBERR=182301_U_XOBTYPE_U_" [Erroneous reauthentication type]"
End DoDot:1
+22 ;
+23 ; -- check division
+24 IF XOBID
SET XOBERR=$$DUZENV(XOBID,XOBTYPE)
+25 ;
+26 ; -- switch back to socket device
+27 DO SOCKET
SUDQ ;
+1 ;LOG:: Log error in trap or elsewhere if appropriate. May want to log 'no match' event for security reasons.
+2 IF 'XOBERR
DO FINAL
+3 QUIT XOBERR
+4 ;
NULL ; switch to null device
+1 USE XOBNULL
+2 QUIT
+3 ;
SOCKET ; -- switch back to socket device
+1 ; -- empty write buffer of null device
+2 USE XOBNULL
SET DX=0
SET DY=0
XECUTE ^%ZOSF("XY")
+3 ; -- reset to use tcp port device to send results
+4 USE XOBPORT
+5 QUIT
+6 ;
AV(XOBID,XOBERR) ; -- AV (SSO/UC KAAJEE) reauth type
+1 ;
+2 ; More checks performed here; assume this would be called ONCE when user authenticates
+3 ; to application via KAAJEE or FatKAAT
+4 ;
+5 DO AV^XOBSRAKJ(.XOBID,.XOBERR)
+6 QUIT
+7 ;
DUZ(XOBID,XOBERR) ; -- DUZ reauth type
+1 ;
+2 NEW XOBCTYPE
+3 SET XOBCTYPE="DUZ"
+4 SET XOBID=$GET(XOBDATA("XOB RPC","SECURITY","TYPE","VALUE"))
+5 ;
+6 ; Active user status check performed here; assume heavier-duty checks done by application
+7 ; when user authenticated to application via KAAJEE, FatKAAT or equivalent.
+8 ;
+9 DO ACTUSR(.XOBID,.XOBERR,XOBCTYPE)
+10 QUIT
+11 ;
VPID(XOBID,XOBERR) ; -- VPID reauth type
+1 NEW VPID,XOBCTYPE
+2 SET XOBID=0
+3 SET XOBCTYPE="VPID"
+4 ;
+5 SET VPID=$GET(XOBDATA("XOB RPC","SECURITY","TYPE","VALUE"))
+6 IF VPID]""
SET XOBID=$$IEN^XUPS(VPID)
+7 ;
+8 IF '+XOBID
Begin DoDot:1
+9 SET XOBERR=182301_U_XOBTYPE_U_"["_XOBCTYPE_" Value: '"_VPID_"']"
+10 SET XOBID=0
End DoDot:1
QUIT
+11 ;
+12 ; Active user status check performed here; assume heavier-duty checks done by application
+13 ; when user authenticated to application via KAAJEE, FatKAAT or equivalent.
+14 ;
+15 DO ACTUSR(.XOBID,.XOBERR,XOBCTYPE)
+16 QUIT
+17 ;
APPPROXY(XOBID,XOBERR) ; -- application proxy reauth type
+1 ;
+2 NEW XOBANAME,XOBCTYPE,XOBAPFND
+3 SET XOBID=0
SET XOBCTYPE="APPPROXY"
+4 SET XOBANAME=$GET(XOBDATA("XOB RPC","SECURITY","TYPE","VALUE"))
+5 ;
+6 ; APFIND^XUSAP(name) -> returns ien^vpid, or (failure) -int^reason
+7 IF XOBANAME]""
SET XOBAPFND=$$APFIND^XUSAP(XOBANAME)
SET XOBID=$PIECE(XOBAPFND,U)
+8 ; file #200 division mult checking not necessary for app proxy user
+9 IF (+XOBID)<1
Begin DoDot:1
+10 SET XOBERR=182307_U_XOBANAME_U_"["_$PIECE(XOBAPFND,U,2)_"]"
SET XOBID=0
End DoDot:1
+11 QUIT
+12 ;
CCOW(XOBID,XOBERR) ; -- CCOW reauth type
+1 ;
+2 ; Very few checks performed here; assume heavier duty checks done by application when originally
+3 ; authenticated and created Kernel CCOW token. User would need to be reauthenticated (and perform
+4 ; heavier-duty checks) upon Kernel CCOW token expiration.
+5 ;
+6 DO CCOW^XOBSRAKJ(.XOBID,.XOBERR)
+7 QUIT
+8 ;
ACTUSR(XOBID,XOBERR,XOBCTYPE) ; -- user active status check & error processing
+1 ;
+2 NEW XOBACTIV
+3 SET XOBACTIV=0
+4 SET XOBID=$GET(XOBID)
SET XOBCTYPE=$GET(XOBCTYPE)
+5 ;
+6 ;-- returns active status indicator of user
+7 SET XOBACTIV=$$ACTIVE^XUSER(XOBID)
+8 IF +XOBACTIV<1
Begin DoDot:1
+9 ;
+10 ;-- get dialog entry for error
+11 SET XOBERR=$$GETERR(XOBACTIV,XOBID,XOBCTYPE)
+12 SET XOBID=0
End DoDot:1
+13 QUIT
+14 ;
DUZENV(XOBDUZ,XOBTYPE) ; -- build DUZ and check division
+1 ;
+2 ; QUIT 0 if OK, DialogErrorNumber^DialogErrorParameter1^... if bad
+3 ;
+4 NEW XOBDVARY,XOBDIV,XOBDIVEX,XOBDIVRQ,XOBDUZSV,XOBERR,XOBI,XOBOK
+5 SET XOBOK=0
SET (XOBERR,XOBDIVEX)=""
+6 ;
+7 ; -- preserve previous DUZ value, restore if needed
+8 MERGE XOBDUZSV=DUZ
KILL DUZ
+9 ;
+10 ; -- set up info on passed in user
+11 SET DUZ=XOBDUZ
+12 SET XOBDIVRQ("STATIONNUMBER")=$GET(XOBDATA("XOB RPC","SECURITY","DIV"))
+13 ;
+14 ; checks
Begin DoDot:1
+15 ;
+16 ; -- if no division passed in
+17 IF XOBDIVRQ("STATIONNUMBER")']""
Begin DoDot:2
+18 SET XOBERR=182308_U_"no division passed"_U_XOBTYPE_U_XOBDUZ_U_"null"
End DoDot:2
QUIT
+19 ;
+20 ; -- is division supported at the site?
+21 SET XOBDIVRQ("IEN")=$$SITECHK(XOBDIVRQ("STATIONNUMBER"))
+22 IF '+XOBDIVRQ("IEN")
Begin DoDot:2
+23 SET XOBERR=182308_U_$PIECE(XOBDIVRQ("IEN"),U,2)_U_XOBTYPE_U_XOBDUZ_U_XOBDIVRQ("STATIONNUMBER")
+24 KILL XOBDIVRQ("IEN")
End DoDot:2
QUIT
+25 ;
+26 ; -- build DUZ
+27 DO DUZ^XUP(DUZ)
+28 ;
+29 ; -- don't do user-based checks if reauth type is APPPROXY
+30 IF XOBTYPE="APPPROXY"
SET XOBOK=1
QUIT
+31 ;
+32 ; -- do check for user-permitted divisions
+33 DO DIVGET^XUSRB2(.XOBDIV,DUZ)
+34 ;
+35 ; -- DIVGET^XUSRB2 return value: if no divisions or one (matching) division, it's good
+36 IF '$GET(XOBDIV(0))
Begin DoDot:2
+37 ; OK
IF $GET(DUZ(2))=XOBDIVRQ("IEN")
SET XOBOK=1
QUIT
+38 ;
+39 ; -- if got here, did not match division
+40 SET XOBERR=182302_U_XOBTYPE_U_XOBDUZ_U_XOBDIVRQ("STATIONNUMBER")
End DoDot:2
QUIT
+41 ;
+42 ; -- DIVGET^XUSRB2 return value: if >1 divisions to select, attempt to set DUZ(2) to div passed in
+43 DO DIVSET^XUSRB2(.XOBOK,"`"_XOBDIVRQ("IEN"))
IF 'XOBOK
Begin DoDot:2
+44 SET XOBERR=182302_U_XOBTYPE_U_XOBDUZ_U_XOBDIVRQ("STATIONNUMBER")
End DoDot:2
End DoDot:1
+45 ;
+46 ; A check failed. Clean up partition.
IF 'XOBOK
Begin DoDot:1
+47 ;
+48 ; -- reset DUZ
+49 KILL DUZ
+50 MERGE DUZ=XOBDUZSV
End DoDot:1
+51 ;
+52 ; -- send back error
+53 QUIT $SELECT(XOBOK:0,1:XOBERR)
+54 ;
LOGINH() ; -- Check if system is currently allowing logins
+1 ; Return:
+2 ; 181004 : if logins are disabled
+3 ; 0 : if logins are allowed
+4 ;
+5 NEW XQVOL,XUCI,XUENV,XUVOL,X,Y
+6 ;
+7 ; -- Setup XUENV, XUCI,XQVOL,XUVOL
+8 DO XUVOL^XUS
+9 ;
+10 ; -- Check whether logins are disabled
+11 QUIT $SELECT($$INHIB1^XUSRB():181004,1:0)
+12 ;
NOACCESS(XOBID) ; -- Determine if user is allowed access via user active status & prohibited times checks
+1 ;
+2 NEW XOBERR,XOBNOACC,XOBRANGE
+3 SET (XOBERR,XOBNOACC)=0
+4 ;
+5 ; -- user active status check & error processing
+6 DO ACTUSR(.XOBID,.XOBERR)
+7 ;
+8 ; -- check if sign-on is attempted during prohibited times
+9 IF 'XOBERR
Begin DoDot:1
+10 SET XOBRANGE=$$GET1^DIQ(200,XOBID,15)
+11 IF XOBRANGE
Begin DoDot:2
+12 SET XOBNOACC=$$PROHIBIT^XUS1A($PIECE($HOROLOG,",",2),XOBRANGE)
+13 IF XOBNOACC
SET XOBERR=182304_U_XOBID_U_"Prohibited time: "_$PIECE(XOBNOACC,U,2)
End DoDot:2
End DoDot:1
+14 QUIT XOBERR
+15 ;
VCHG(XOBID) ; -- Check if verify code needs to be changed
+1 ; Return:
+2 ; 182303^XOBID : if verify code is undefined or expired
+3 ; 0 : verify code is current
+4 NEW DUZ,I,VCHG,XOPT
+5 SET DUZ=+$GET(XOBID)
SET VCHG=0
+6 ;
+7 ; -- set up XOPT
+8 DO XOPT^XUS
+9 ;
+10 ; -- check if verify code is current
+11 IF $$VCVALID^XUSRB()
Begin DoDot:1
+12 SET VCHG=182303_U_DUZ
End DoDot:1
+13 QUIT VCHG
+14 ;
INIT ; -- VL-specific or general partition setup before reauthentication process starts
+1 ;
+2 LOCK
+3 if $DATA(IO)[0
SET IO=$IO
SET IO(0)=IO
+4 KILL ^UTILITY($JOB),^TMP($JOB)
+5 KILL ^XUTL("XQ",$JOB)
+6 ; -- clean up partition's local symbol table
+7 DO KILL^XOBSRA1
+8 QUIT
+9 ;
FINAL ; -- Final setup needed after a re-authentication is performed successfully.
+1 ; -- Save DUZ and IO variables in ^XUTL("XQ",$JOB)
+2 DO SAVE^XUS1
+3 ;
+4 ; Change in XUSRB: calls POST2^XUSRB calls CLRFAC^XUS3 to clear Failed Signon Attempts
+5 ; file of entry with given IP. Need IO("IP") obtained from ZIO^%ZIS4.
+6 ;
+7 ;*2
KILL XQY,XQY0
+8 QUIT
+9 ;
GETERR(XOBACT,XOBID,XOBCONN) ;-- Get appropriate DIALOG file error
+1 ;
+2 NEW XOBERR
+3 SET XOBERR=0
+4 SET XOBACT=$GET(XOBACT)
SET XOBID=$GET(XOBID)
SET XOBCONN=$GET(XOBCONN)
+5 ;
+6 ;- error indicates that user can't sign on, is DISUSER'd, or is TERMINATED
+7 IF $PIECE(XOBACT,U)=0
SET XOBERR=182304_U_XOBID_U_$SELECT($PIECE(XOBACT,U,2)'="":$PIECE(XOBACT,U,2),1:"Unable to Sign On")
+8 ;
+9 ;- error indicates no user record found
+10 IF $PIECE(XOBACT,U)=""
Begin DoDot:1
+11 if XOBCONN=""
SET XOBCONN="Unknown Reauthentication Type"
+12 SET XOBERR=182301_U_XOBCONN_U_" ["_XOBCONN_" reauthentication type, DUZ Value: '"_XOBID_"']"
End DoDot:1
+13 QUIT XOBERR
+14 ;
SITECHK(XOBSTATN) ; check if valid division for this site
+1 ; input: station#
+2 ; output: IEN of station# in institution file (if valid for this site)
+3 ; 0^error message (if not valid for this site)
+4 NEW XOBSTIEN,XOBSTRIP
+5 SET XOBSTRIP=$$STRPSUFF^XOBSCAV1(XOBSTATN)
+6 ; note: AAC 200M truncated to 200 in both sides of comparison below
+7 if (XOBSTRIP'=XOBSYS("PRIMARY STATION#"))
QUIT "0^STATION '"_XOBSTATN_"' is not supported by this M system."
+8 SET XOBSTIEN=$$IEN^XUAF4(XOBSTATN)
+9 if '+XOBSTIEN
QUIT "0^STATION '"_XOBSTATN_"' is not a known station number."
+10 if '$$ACTIVE^XUAF4(XOBSTIEN)
QUIT "0^STATION '"_XOBSTATN_"' is not active on this M system."
+11 QUIT XOBSTIEN
GETDUZ(SAML,XOBERR) ; if new SAML user is disusered give the DUZ to complete the return information
+1 NEW I,IEND,ISTART,ISTOP,DOC
+2 ;K RTN
+3 KILL ^TMP("DUZ_XUS",$JOB)
+4 SET ISTOP=$LENGTH(SAML)
SET IEND=0
+5 FOR I=1:1
if IEND>ISTOP
QUIT
Begin DoDot:1
+6 SET ISTART=IEND+1
+7 SET IEND=IEND+200
+8 SET ^TMP("DUZ_XUS",$JOB,I)=$EXTRACT(SAML,ISTART,IEND)
+9 QUIT
End DoDot:1
+10 DO SECID(SAML,.XOBERR,.DUZ)
+11 IF '$GET(DUZ)
SET XOBERR=182308_U_1_U_"SAML"_U_XOBERR_"SECID NOT FOUND IN UCI"
+12 ;K X,XQVOL,XUCI,XUENV,XUOSVER,Y
+13 QUIT XOBERR
SECID(SAML,XOBERR,DUZ) ;TO CHECK IF a SECID exists in the UCI
+1 NEW SECID,SECIDL
+2 SET SECIDL=0
SET DUZ=""
+3 SET ^XTMP("SAML CHECK",$JOB)=SAML
+4 SET SECID=$PIECE($PIECE(^XTMP("SAML CHECK",$JOB),"urn:va:vrm:iam:secid"">",2),"<",1)
Begin DoDot:1
+5 FOR
SET SECIDL=$ORDER(^VA(200,"ASECID",SECIDL))
if 'SECIDL
QUIT
Begin DoDot:2
+6 IF SECID=SECIDL
SET DUZ=$ORDER(^VA(200,"ASECID",SECID,""))
QUIT
End DoDot:2
End DoDot:1
+7 QUIT XOBERR
