XUSAML ;ISD/HGW - Kernel SAML Token Implementation ; Apr 18, 2022@15:39
;;8.0;KERNEL;**655,659,630,701,731,771,779**;Jul 10, 1995;Build 0
;Per VA Directive 6402, this routine should not be modified.
;
; Implements the Kernel SAML Token message framework for the Identification and
; Access Management (IAM) Single Sign-On (SSO) security model.
;
; External References:
; Reference to ^%DT in ICR #10003
; Reference to $$ATTRIB^MXMLDOM in ICR #3561
; Reference to $$CHILD^MXMLDOM in ICR #3561
; Reference to $$EN^MXMLDOM in ICR #3561
; Reference to $$NAME^MXMLDOM in ICR #3561
; Reference to $$SIBLING^MXMLDOM in ICR #3561
; Reference to $$TEXT^MXMLDOM in ICR #3561
; Reference to $$VALUE^MXMLDOM in ICR #3561
; Reference to DELETE^MXMLDOM in ICR #3561
; Reference to TEXT^MXMLDOM in ICR #3561
; Reference to $$FMADD^XLFDT in ICR #10103
; Reference to $$NOW^XLFDT in ICR #10103
; Reference to $$TZ^XLFDT in ICR #10103
; Reference to $$TITLE^XLFSTR in ICR #10104
; Reference to $$LOW^XLFSTR in ICR #10104
; Reference to $$INVERT^XLFSTR in ICR #10104
; Reference to $$UP^XLFSTR in ICR #10104
; Reference to $$VALIDATE^XUCERT Private (XU to XU)
; Reference to $$AUTH^XUESSO2 Private (XU to XU)
;
Q
EN(DOC) ;Function. Main entry point
;This function parses and processes the VA Identity and Access Management (IAM) STS SAML token
; (version 2.0) and returns the DUZ of the user, if found. It does not log the user into VistA.
; Input: DOC = Closed reference to global root containing XML document (loaded STS SAML Token)
; Example: S Y=$$EN^XUSAML($NA(^TMP($J,1)))
; Return: Fail = "-1^Error Message"
; Success = DUZ
;ZEXCEPT: XOBDATA ;environment variable
N HDL,XASSRT,XUPN,Y
K ^TMP("XUSAML",$J)
S Y="-1^Error parsing STS SAML Token",XUPN="",XASSRT=""
S XOBDATA("XOB RPC","SECURITY","STATE")="notauthenticated"
S XOBDATA("XOB RPC","SAML","ASSERTION")="notvalidated"
;--- Call parser
S HDL=$$EN^MXMLDOM(DOC,"W")
;p701 determine ultimate failure based on XUERR and record them
I HDL>0 D
. D ND(HDL,1,1,.XUPN,.XASSRT) ;Traverse and process document
. S Y="-1^Invalid SAML assertion"
. D VALASSRT(.XASSRT,DOC,.XUERR) ;Validate SAML assertion
. S Y=$$FINDUSER(.XUERR)
. D DELETE^MXMLDOM(HDL)
I $D(XUERR)>0 S DUZ("WARNINGS")=$$WARNINGS(.XUERR)
I +Y'>0!'$$TOKVALID(.DUZ,.XUERR) D LOGFAIL(Y,.DUZ) S Y="-1^Invalid SAML assertion"
I +Y>0 D
. S XOBDATA("XOB RPC","SAML","ASSERTION")="validated"
. S XOBDATA("XOB RPC","SECURITY","STATE")="authenticated"
K ^TMP("XUSAML",$J)
Q Y
ND(HDL,ND,FS,XUPN,XASSRT) ;SR. Traverse tree
N CH,SIB,TX
D SH(HDL,ND,.XUPN,.XASSRT)
S CH=0
S CH=$$CHILD^MXMLDOM(HDL,ND,CH)
I CH D ND(HDL,CH,1,.XUPN,.XASSRT)
Q:'FS ;Don't follow the siblings of siblings
S SIB=ND
F S SIB=$$SIBLING^MXMLDOM(HDL,SIB) Q:'SIB D ND(HDL,SIB,0,.XUPN,.XASSRT)
Q
SH(HDL,ND,XUPN,XASSRT) ;SR. Process node elements
;ZEXCEPT: XOBDATA ;environment variable
N ELE,I,NM,V,VV,XCHILD,XERR,XTEXT,XVALUE
S ELE=$$NAME^MXMLDOM(HDL,ND)
; -------------------- saml:Subject Event Processing ---------------------------
I (ELE="Subject")!(ELE="saml:Subject")!(ELE="ns2:Subject") D Q ;Subject element is required
. S XASSRT("Subject")="yes"
;
; -------------------- saml:Subject Confirmation Data Event Processing ----------
I (ELE="SubjectConfirmationData")!(ELE="saml:SubjectConfirmationData")!(ELE="ns2:SubjectConfirmationData") D Q
. D EL(HDL,ND,.NM,.XUPN)
. S XASSRT("Recipient")=$O(^TMP("XUSAML",$J,"Recipient",""))
. S XASSRT("Address")=$O(^TMP("XUSAML",$J,"Address",""))
;
; -------------------- saml:Conditions Event Processing -------------------------
I (ELE="Conditions")!(ELE="saml:Conditions")!(ELE="ns2:Conditions") D Q
. D EL(HDL,ND,.NM,.XUPN)
. S XASSRT("NotBefore")=$O(^TMP("XUSAML",$J,"NotBefore",""))
. S XASSRT("NotOnOrAfter")=$O(^TMP("XUSAML",$J,"NotOnOrAfter",""))
;
; -------------------- saml:AuthnStatement Event Processing ---------------------
I (ELE="AuthnStatement")!(ELE="saml:AuthnStatement")!(ELE="ns2:AuthnStatement") D Q
. D EL(HDL,ND,.NM,.XUPN)
. S XASSRT("AuthnInstant")=$O(^TMP("XUSAML",$J,"AuthnInstant",""))
I (ELE="AuthnContextClassRef")!(ELE="saml:AuthnContextClassRef")!(ELE="ns2:AuthnContextClassRef") D Q
. S XUPN="AuthnContextClassRef"
. D CH(HDL,ND,XUPN)
. S XASSRT("AuthnContextClassRef")=$G(^TMP("XUSAML",$J,"AuthnContextClassRef"))
;
; -------------------- saml:Attribute Event Processing --------------------------
I (ELE="Attribute")!(ELE="saml:Attribute")!(ELE="ns2:Attribute") D Q
. S XCHILD=$$CHILD^MXMLDOM(HDL,ND) ;Identify child (AttributeValue) of node ND
. S XTEXT="" S XERR=$$TEXT^MXMLDOM(HDL,XCHILD,$NA(VV)) ;Get text of AttributeValue
. I XERR=1 F I=1:1 Q:'$D(VV(I)) S XTEXT=XTEXT_VV(I)
. S NM=""
. F S NM=$$ATTRIB^MXMLDOM(HDL,ND,NM) Q:'$L(NM) D ;Get name of Attribute
. . I $G(NM)="Name" D
. . . S XVALUE=$$VALUE^MXMLDOM(HDL,ND,NM)
. . . S ^TMP("XUSAML",$J,NM,XVALUE)=XTEXT ;Set up the ^TMP global for the Attribute
Q
CH(HDL,ND,XUPN) ;SR. Process text node
N I,VV,Y
I $G(XUPN)'="" D
. S Y=""
. D TEXT^MXMLDOM(HDL,ND,$NA(VV))
. I $D(VV)>2 F I=1:1 Q:'$D(VV(I)) S Y=Y_VV(I)
. I $P(XUPN,"^",2)="" D
. . S ^TMP("XUSAML",$J,$P(XUPN,"^",1))=Y
. E D
. . S ^TMP("XUSAML",$J,$P(XUPN,"^",1),$P(XUPN,"^",2))=Y
Q
EL(HDL,ND,NM,XUPN) ;SR. Process element
K XUPN S (NM,XUPN)=""
F S NM=$$ATTRIB^MXMLDOM(HDL,ND,NM) Q:'$L(NM) D
. I $L(NM) S XUPN=NM_"^"_$$VALUE^MXMLDOM(HDL,ND,NM)
. I $P(XUPN,"^",2)="" D
. . S ^TMP("XUSAML",$J,$P(XUPN,"^",1))=""
. E D
. . S ^TMP("XUSAML",$J,$P(XUPN,"^",1),$P(XUPN,"^",2))=""
Q
FINDUSER(XUERR) ;Function. Identify user
;ZEXCEPT: XOBDATA ;environment variable
N VISTAID,X,XARRY,XAUTH,XCTXT,XDUZ,XEDIPI,XPASS,XC,XT,XUHOME,XUIAM,Z
I '$$AUTH^XUESSO2() S XUERR("CALL-RTN")="" Q "-1^Not an authorized calling routine"
S XDUZ="-1^User could not be identified"
S XERR=""
S DUZ("REMAPP")=""
S XUIAM=1 ;Do not trigger IAM updates
S XARRY(1)=$$TITLE^XLFSTR($E($G(^TMP("XUSAML",$J,"Name","urn:oasis:names:tc:xspa:1.0:subject:organization")),1,50)) ;Subject Organization
S XARRY(2)=$$LOW^XLFSTR($E($G(^TMP("XUSAML",$J,"Name","urn:oasis:names:tc:xspa:1.0:subject:organization-id")),1,50)) ;Subject Organization ID
S XARRY(3)=$G(^TMP("XUSAML",$J,"Name","uniqueUserId")) ;Unique User ID
S XARRY(4)=$G(^TMP("XUSAML",$J,"Name","urn:oasis:names:tc:xspa:1.0:subject:subject-id")) ;Subject ID
S:XARRY(4)'["," XARRY(4)=$P(XARRY(4)," ",2)_","_$P(XARRY(4)," ",1)_" "_$P(XARRY(4)," ",3,99) ;P701
S XPASS=$$IDPASS($G(XASSRT("Recipient"))) ;Application ID
I $G(XPASS)'="" D
. S XT=$$GETCNTXT^XUESSO2(XPASS)
. I +XT>0 D
. . S DUZ("REMAPP")=XT_"^"_$P($G(^XWB(8994.5,XT,0)),U) ;Identify remote application
. . S XCTXT=$P($G(^XWB(8994.5,XT,0)),U,2)
. . I $G(XCTXT)'="" S XARRY(5)=XPASS
E S XARRY(5)="" ;Application ID
S XARRY(6)=$G(^TMP("XUSAML",$J,"Name","urn:va:ad:samaccountname")) ;Network Username
S XARRY(7)=$G(^TMP("XUSAML",$J,"Name","urn:va:vrm:iam:secid")) ;SecID
S XARRY(8)=$G(^TMP("XUSAML",$J,"Name","urn:oasis:names:tc:xspa:2.0:subject:npi")) ;NPI
;S XARRY(9)=$G(^TMP("XUSAML",$J,"Name","SSN")) ;SSN is not part of STS Token specification v2.0
S XARRY(10)=$G(^TMP("XUSAML",$J,"Name","upn")) ;Active Directory User Principle Name (UPN)
S XARRY(11)=$G(^TMP("XUSAML",$J,"Name","email")) ;E-Mail Address
;S ???=$G(^TMP("XUSAML",$J,"Name","urn:oasis:names:tc:xacml:2.0:subject:role")) ;Role-based access is not yet implemented
S XAUTH=$$LOW^XLFSTR($G(^TMP("XUSAML",$J,"Name","authnsystem"))) ;SSOi, SSOe, or Other authentication
S XUHOME=$$LOW^XLFSTR($G(^TMP("XUSAML",$J,"Name","urn:nhin:names:saml:homeCommunityId"))) ;Home Community ID
S XEDIPI=$G(^TMP("XUSAML",$J,"Name","edipi")) ;DoD CAC card identifier
S DUZ("MVIICN")=$G(^TMP("XUSAML",$J,"Name","urn:va:vrn:iam:mviicn")) ;ICN
; p771 trim values and lock on XARRY(7) SECID or XARRY(3) unique id
S XARRY(3)=$TR($$LOW^XLFSTR($E($$TRIM^XLFSTR(XARRY(3)),1,40)),"^","%")
S XARRY(7)=$TR($E($$TRIM^XLFSTR(XARRY(7)),1,40),"^","%")
S XARRY(8)=$$TRIM^XLFSTR(XARRY(8))
S XEDIPI=$$TRIM^XLFSTR(XEDIPI)
S XARRY(11)=$$TRIM^XLFSTR(XARRY(11))
;
I (XUHOME=$P($G(^XTV(8989.3,1,200)),U,3))&(XAUTH="ssoi") D ;SSOi
. S XARRY(3)=XARRY(7) ;UID=SecID
. S DUZ("AUTHENTICATION")="SSOI"
. ; p731,p771 ensure user is found before adding new one and deal with concurrent queries from JLV
. L +^VA(200,"ASECID",XARRY(7)):$G(DILOCKTM,10) I '$T S XDUZ="-1^Could not obtain LOCK" Q
. S XDUZ=$$FINDUSER^XUESSO2(.XARRY) ;Identify existing user with SecID
. I XDUZ'>0 S XARRY(9)=$$MPISSN(.XARRY) ; retry with SSN from MPI
. I $G(XARRY(9))]"" S XDUZ=$$FINDUSER^XUESSO2(.XARRY)
. I XDUZ>0 L -^VA(200,"ASECID",XARRY(7)) Q ; user found
. ;Add new user on the fly
. I $G(XARRY(5))'="" D
. . I '$$TOKVALID(.DUZ,.XUERR) S XDUZ="-1^Cannot add untrusted token-data" Q
. . S XDUZ=$$ADDUSER^XUESSO2(.XARRY)
. L -^VA(200,"ASECID",XARRY(7)) ; end p731,p771
;
E I (XUHOME=$P($G(^XTV(8989.3,1,200)),U,3))&(XAUTH="ssoe") D ;SSOe
. I ($L($G(XARRY(1)))<3)!($L($G(XARRY(2)))<3) S XDUZ="-1^Invalid SORG or SORGID" Q
. S XARRY(3)=XARRY(7) ;UID=SecID
. I +DUZ("REMAPP")>0 D
. . S DUZ("AUTHENTICATION")="SSOE"
. . L +^VA(200,"ASECID",XARRY(7)):$G(DILOCKTM,10) I '$T S XDUZ="-1^Could not obtain LOCK" Q ; p731,p771
. . S XDUZ=$$FINDUSER^XUESSO2(.XARRY) ;Identify existing user with SecID
. . I XDUZ'>0 S XARRY(9)=$$MPISSN(.XARRY) ; retry with SSN from MPI
. . I $G(XARRY(9))]"" S XDUZ=$$FINDUSER^XUESSO2(.XARRY)
. . I (+XDUZ<0)&($G(XARRY(5))'="") D
. . . I '$$TOKVALID(.DUZ,.XUERR) S XDUZ="-1^Cannot add untrusted token-data" Q
. . . S XDUZ=$$ADDUSER^XUESSO2(.XARRY) ;Add new user on the fly
. . L -^VA(200,"ASECID",XARRY(7)) ; end p731,p771
;
E I (XARRY(2)["http://")!(XARRY(2)["https://")!((XARRY(2)["urn:oid:")&(XARRY(2)'=$P($G(^XTV(8989.3,1,200)),U,3))) D ; NHIN
. I (+DUZ("REMAPP")>0)&(XAUTH="nhin") D
. . I $G(XARRY(3))="" S XARRY(3)=XARRY(8) ;NHIN: UID is NPI if available (preferred)
. . I $G(XARRY(3))="" S XARRY(3)=XEDIPI ;NHIN: DoD CAC card identifier
. . I $G(XARRY(3))="" S XARRY(3)=XARRY(11) ;NHIN: UID is e-mail if available (alternative to NPI)
. . S DUZ("AUTHENTICATION")="NHIN"
. . L +^VA(200,"UID",XARRY(3)):$G(DILOCKTM,10) I '$T S XDUZ="-1^Could not obtain LOCK" Q ; p731,p771
. . S XDUZ=$$FINDUSER^XUESSO2(.XARRY) ;Identify user by NPI or Unique User ID
. . I +XDUZ<0 D
. . . S XARRY(8)=""
. . . S XDUZ=$$FINDUSER^XUESSO2(.XARRY) ;Identify user by Unique User ID only
. . . I XDUZ'>0 S XARRY(9)=$$MPISSN(.XARRY) ; retry with SSN from MPI
. . . I $G(XARRY(9))]"" S XDUZ=$$FINDUSER^XUESSO2(.XARRY)
. . . I (+XDUZ<0)&($G(XARRY(5))'="") D
. . . . I '$$TOKVALID(.DUZ,.XUERR) S XDUZ="-1^Cannot add untrusted token-data" Q
. . . . S XDUZ=$$ADDUSER^XUESSO2(.XARRY) ;Add new user on the fly
. . L -^VA(200,"UID",XARRY(3)) ; end p731
;
I XDUZ<0 D ; record NAME and SECID to error
. S XUERR("SECID")=""
. S $P(XDUZ,U,3)=XARRY(4),$P(XDUZ,U,4)=XARRY(7)
Q XDUZ
VALASSRT(XASSRT,DOC,XUERR) ;Intrinsic Subroutine. Validate SAML assertion
;ZEXCEPT: XOBDATA ;environment variable
N XAUTH,XD,XNOW,XPROOF
S XOBDATA("XOB RPC","SAML","AUTHENTICATION TYPE")=$G(^TMP("XUSAML",$J,"Name","authenticationtype"))
S XOBDATA("XOB RPC","SAML","PROOFING AUTHORITY")=$G(^TMP("XUSAML",$J,"Name","proofingauthority"))
S XAUTH=$$LOW^XLFSTR($G(^TMP("XUSAML",$J,"Name","authnsystem")))
S XPROOF=XOBDATA("XOB RPC","SAML","PROOFING AUTHORITY")
; Verify Level of Assurance (VA requires LOA-1 through LOA-3, but higher levels are accepted)
K XOBDATA("XOB RPC","SAML","ASSURANCE LEVEL")
S XD=$G(^TMP("XUSAML",$J,"Name","assurancelevel")) I (+XD<1)!(+XD="") S XD=1
S XOBDATA("XOB RPC","SAML","ASSURANCE LEVEL")=XD
S DUZ("LOA")=XD ;Set LOA environment variable for SIGN-ON log and permissions
;p701
;I (XAUTH'="nhin")&(XPROOF'="VA-JLV") D ;temporary for pre-SSOe JLV non-VA users
D
. ;Validate time stamps (e.g., NotBefore, NotOnOrAfter)
. S XNOW=$$NOW^XLFDT
. S XD=$$CONVTIME($G(XASSRT("AuthnInstant"))) I XD=-1 D ;invalid time stamp
. . S XUERR("AuthnI")=""
. S XD=$$CONVTIME($G(XASSRT("NotBefore"))) I (XD=-1)!(XD>XNOW) D ;token not valid yet
. . S XUERR("NotBefore")=""
. S XD=$$CONVTIME($G(XASSRT("NotOnOrAfter"))) D
. . ;N DIF1,HR,DAY
. . ;S HR=3600,DAY=86400
. . ;S DIF1=$$FMDIFF^XLFDT(XD,XNOW,2) ;DIF1=$$ABS^XLFMTH(DIF1)
. . ;I (XD=-1)!(DIF1>DAY) S XUERR("EXPIRED+")="" Q
. . I XD<XNOW S XUERR("EXPIRED")=""
. . ;
. I '$D(XASSRT("AuthnContextClassRef")) D
. . S XUERR("AuthnCCR")=""
. ;Validate Digital Signature
. D VALIDATE^XUCERT(DOC,.XUERR)
. ;Validate Token Issuer (Subject of X509 Certificate used to sign token)
. I '($G(XOBDATA("XOB RPC","SAML","ISSUER"))[$P($G(^XTV(8989.3,1,200)),U,1)) D
. . S XUERR("ISSUER")=""
. ;Token has been validated
Q
IDPASS(XUA) ;Intrinsic Function. Extract Application ID
N RETURN,XTD,XTE
S RETURN=$P($G(XUA),"/",4,99)
S XTD=$$DT^XLFDT
S XTE=$$FMADD^XLFDT(XTD,7)
I $G(RETURN)'="" D
. S ^XTMP("XUSAMLAPPID",0)=XTE_"^"_XTD_"^SAML Application ID" ;capture and log application ID from SAML token
. S ^XTMP("XUSAMLAPPID",0,RETURN)=""
;. S RETURN=$$LOW^XLFSTR(RETURN) p779
Q RETURN
CONVTIME(TIME) ;Intrinsic Function. Convert XML time to FileMan format
;ZEXCEPT: %DT ;environment variable
N X,XD,XOUT,XT,XZ,Y
S XZ=0 I $G(TIME)["Z" S XZ=1 ;Zulu time (GMT)
S XD=$P($G(TIME),"T",1) ;Date
S XD=$P(XD,"-",2)_"/"_$P(XD,"-",3)_"/"_$P(XD,"-",1) ;Convert date to MM/DD/YYYY
S XT=$P($G(TIME),"T",2) ;Time
I XZ=1 S XT=$P(XT,"Z",1) ;Strip "Z" from time
S X=XD_"@"_XT S %DT="RTS"
D ^%DT S XOUT=Y
I XOUT=-1 Q XOUT ;Invalid date/time
I XZ=1 S XOUT=$$FMADD^XLFDT(XOUT,0,+$E($$TZ^XLFDT,1,3),0,0) ;Adjust from GMT
K %DT(0)
Q XOUT
;
WARNINGS(XUERR) ;
N X,Y
S (X,Y)=""
F S X=$O(XUERR(X)) Q:X="" S Y=Y_X_";"
Q Y
;
TOKVALID(DUZ,XUERR) ;
N STRICT
;S STRICT=$P($G(^XTV(8989.3,1,"XUS")),"^",20)
S STRICT=+$P($G(XOPT),U,20)
I STRICT,$D(XUERR) Q 0
I $G(DUZ("AUTHENTICATION"))="NHIN" Q 1
I $D(XUERR("EXPIRED")) Q 0
;I $D(XUERR("DIGEST")),$D(XUERR("EXPIRED+")) Q 0
Q 1
;
LOGFAIL(IEN,DUZ) ; Record failed access
N STRICT,WARN,XUF
S STRICT=$P($G(XOPT),U,20)
S WARN=$S(+STRICT:"STRICT ",1:"NON-STRICT ")
I $G(DUZ("WARNINGS"))'="" S WARN=WARN_"Failed-verifications: "_$G(DUZ("WARNINGS"))
I $P(IEN,U,2)'="" S WARN=WARN_" ERROR:"_$P(IEN,U,2)
I $P(IEN,U,4)'="" S WARN=WARN_". SECID not linked to existing user, SECID:"_$P(IEN,U,4)_" NAME:"_$P(IEN,U,3)_" "
S IEN=+IEN
I IEN>0 S XUF(.3)=IEN S X=$P($G(^VA(200,IEN,1.1)),U,2)+1,$P(^(1.1),"^",2)=X
S XUF(.1)=$E($G(DUZ("AUTHENTICATION")))
S XUF(.2)=$G(XUF(.2))+1,XUF(XUF(.2))=WARN
S XUF=2
D FILE^XUSTZ
Q
;
MPISSN(XATR) ; Return SSN found in MPI
N SSN,XMPI,XOUT
S SSN=""
S:$G(XATR(7))]"" XMPI("secId")=XATR(7)
S:$G(XATR(6))]"" XMPI("samacctnm")=XATR(6)
S:$G(XATR(10))]"" XMPI("VAemail")=XATR(10)
N XI F XI="secId","samacctnm","VAemail" D Q:SSN]""
. N XIN
. I $G(XMPI(XI))]"" S XIN(XI)=XMPI(XI) D USER^XUIAMXML(.XOUT,.XIN) S SSN=$G(XOUT("pnid"))
Q SSN
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUSAML 15394 printed Sep 23, 2025@19:48:18 Page 2
XUSAML ;ISD/HGW - Kernel SAML Token Implementation ; Apr 18, 2022@15:39
+1 ;;8.0;KERNEL;**655,659,630,701,731,771,779**;Jul 10, 1995;Build 0
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; Implements the Kernel SAML Token message framework for the Identification and
+5 ; Access Management (IAM) Single Sign-On (SSO) security model.
+6 ;
+7 ; External References:
+8 ; Reference to ^%DT in ICR #10003
+9 ; Reference to $$ATTRIB^MXMLDOM in ICR #3561
+10 ; Reference to $$CHILD^MXMLDOM in ICR #3561
+11 ; Reference to $$EN^MXMLDOM in ICR #3561
+12 ; Reference to $$NAME^MXMLDOM in ICR #3561
+13 ; Reference to $$SIBLING^MXMLDOM in ICR #3561
+14 ; Reference to $$TEXT^MXMLDOM in ICR #3561
+15 ; Reference to $$VALUE^MXMLDOM in ICR #3561
+16 ; Reference to DELETE^MXMLDOM in ICR #3561
+17 ; Reference to TEXT^MXMLDOM in ICR #3561
+18 ; Reference to $$FMADD^XLFDT in ICR #10103
+19 ; Reference to $$NOW^XLFDT in ICR #10103
+20 ; Reference to $$TZ^XLFDT in ICR #10103
+21 ; Reference to $$TITLE^XLFSTR in ICR #10104
+22 ; Reference to $$LOW^XLFSTR in ICR #10104
+23 ; Reference to $$INVERT^XLFSTR in ICR #10104
+24 ; Reference to $$UP^XLFSTR in ICR #10104
+25 ; Reference to $$VALIDATE^XUCERT Private (XU to XU)
+26 ; Reference to $$AUTH^XUESSO2 Private (XU to XU)
+27 ;
+28 QUIT
EN(DOC) ;Function. Main entry point
+1 ;This function parses and processes the VA Identity and Access Management (IAM) STS SAML token
+2 ; (version 2.0) and returns the DUZ of the user, if found. It does not log the user into VistA.
+3 ; Input: DOC = Closed reference to global root containing XML document (loaded STS SAML Token)
+4 ; Example: S Y=$$EN^XUSAML($NA(^TMP($J,1)))
+5 ; Return: Fail = "-1^Error Message"
+6 ; Success = DUZ
+7 ;ZEXCEPT: XOBDATA ;environment variable
+8 NEW HDL,XASSRT,XUPN,Y
+9 KILL ^TMP("XUSAML",$JOB)
+10 SET Y="-1^Error parsing STS SAML Token"
SET XUPN=""
SET XASSRT=""
+11 SET XOBDATA("XOB RPC","SECURITY","STATE")="notauthenticated"
+12 SET XOBDATA("XOB RPC","SAML","ASSERTION")="notvalidated"
+13 ;--- Call parser
+14 SET HDL=$$EN^MXMLDOM(DOC,"W")
+15 ;p701 determine ultimate failure based on XUERR and record them
+16 IF HDL>0
Begin DoDot:1
+17 ;Traverse and process document
DO ND(HDL,1,1,.XUPN,.XASSRT)
+18 SET Y="-1^Invalid SAML assertion"
+19 ;Validate SAML assertion
DO VALASSRT(.XASSRT,DOC,.XUERR)
+20 SET Y=$$FINDUSER(.XUERR)
+21 DO DELETE^MXMLDOM(HDL)
End DoDot:1
+22 IF $DATA(XUERR)>0
SET DUZ("WARNINGS")=$$WARNINGS(.XUERR)
+23 IF +Y'>0!'$$TOKVALID(.DUZ,.XUERR)
DO LOGFAIL(Y,.DUZ)
SET Y="-1^Invalid SAML assertion"
+24 IF +Y>0
Begin DoDot:1
+25 SET XOBDATA("XOB RPC","SAML","ASSERTION")="validated"
+26 SET XOBDATA("XOB RPC","SECURITY","STATE")="authenticated"
End DoDot:1
+27 KILL ^TMP("XUSAML",$JOB)
+28 QUIT Y
ND(HDL,ND,FS,XUPN,XASSRT) ;SR. Traverse tree
+1 NEW CH,SIB,TX
+2 DO SH(HDL,ND,.XUPN,.XASSRT)
+3 SET CH=0
+4 SET CH=$$CHILD^MXMLDOM(HDL,ND,CH)
+5 IF CH
DO ND(HDL,CH,1,.XUPN,.XASSRT)
+6 ;Don't follow the siblings of siblings
if 'FS
QUIT
+7 SET SIB=ND
+8 FOR
SET SIB=$$SIBLING^MXMLDOM(HDL,SIB)
if 'SIB
QUIT
DO ND(HDL,SIB,0,.XUPN,.XASSRT)
+9 QUIT
SH(HDL,ND,XUPN,XASSRT) ;SR. Process node elements
+1 ;ZEXCEPT: XOBDATA ;environment variable
+2 NEW ELE,I,NM,V,VV,XCHILD,XERR,XTEXT,XVALUE
+3 SET ELE=$$NAME^MXMLDOM(HDL,ND)
+4 ; -------------------- saml:Subject Event Processing ---------------------------
+5 ;Subject element is required
IF (ELE="Subject")!(ELE="saml:Subject")!(ELE="ns2:Subject")
Begin DoDot:1
+6 SET XASSRT("Subject")="yes"
End DoDot:1
QUIT
+7 ;
+8 ; -------------------- saml:Subject Confirmation Data Event Processing ----------
+9 IF (ELE="SubjectConfirmationData")!(ELE="saml:SubjectConfirmationData")!(ELE="ns2:SubjectConfirmationData")
Begin DoDot:1
+10 DO EL(HDL,ND,.NM,.XUPN)
+11 SET XASSRT("Recipient")=$ORDER(^TMP("XUSAML",$JOB,"Recipient",""))
+12 SET XASSRT("Address")=$ORDER(^TMP("XUSAML",$JOB,"Address",""))
End DoDot:1
QUIT
+13 ;
+14 ; -------------------- saml:Conditions Event Processing -------------------------
+15 IF (ELE="Conditions")!(ELE="saml:Conditions")!(ELE="ns2:Conditions")
Begin DoDot:1
+16 DO EL(HDL,ND,.NM,.XUPN)
+17 SET XASSRT("NotBefore")=$ORDER(^TMP("XUSAML",$JOB,"NotBefore",""))
+18 SET XASSRT("NotOnOrAfter")=$ORDER(^TMP("XUSAML",$JOB,"NotOnOrAfter",""))
End DoDot:1
QUIT
+19 ;
+20 ; -------------------- saml:AuthnStatement Event Processing ---------------------
+21 IF (ELE="AuthnStatement")!(ELE="saml:AuthnStatement")!(ELE="ns2:AuthnStatement")
Begin DoDot:1
+22 DO EL(HDL,ND,.NM,.XUPN)
+23 SET XASSRT("AuthnInstant")=$ORDER(^TMP("XUSAML",$JOB,"AuthnInstant",""))
End DoDot:1
QUIT
+24 IF (ELE="AuthnContextClassRef")!(ELE="saml:AuthnContextClassRef")!(ELE="ns2:AuthnContextClassRef")
Begin DoDot:1
+25 SET XUPN="AuthnContextClassRef"
+26 DO CH(HDL,ND,XUPN)
+27 SET XASSRT("AuthnContextClassRef")=$GET(^TMP("XUSAML",$JOB,"AuthnContextClassRef"))
End DoDot:1
QUIT
+28 ;
+29 ; -------------------- saml:Attribute Event Processing --------------------------
+30 IF (ELE="Attribute")!(ELE="saml:Attribute")!(ELE="ns2:Attribute")
Begin DoDot:1
+31 ;Identify child (AttributeValue) of node ND
SET XCHILD=$$CHILD^MXMLDOM(HDL,ND)
+32 ;Get text of AttributeValue
SET XTEXT=""
SET XERR=$$TEXT^MXMLDOM(HDL,XCHILD,$NAME(VV))
+33 IF XERR=1
FOR I=1:1
if '$DATA(VV(I))
QUIT
SET XTEXT=XTEXT_VV(I)
+34 SET NM=""
+35 ;Get name of Attribute
FOR
SET NM=$$ATTRIB^MXMLDOM(HDL,ND,NM)
if '$LENGTH(NM)
QUIT
Begin DoDot:2
+36 IF $GET(NM)="Name"
Begin DoDot:3
+37 SET XVALUE=$$VALUE^MXMLDOM(HDL,ND,NM)
+38 ;Set up the ^TMP global for the Attribute
SET ^TMP("XUSAML",$JOB,NM,XVALUE)=XTEXT
End DoDot:3
End DoDot:2
End DoDot:1
QUIT
+39 QUIT
CH(HDL,ND,XUPN) ;SR. Process text node
+1 NEW I,VV,Y
+2 IF $GET(XUPN)'=""
Begin DoDot:1
+3 SET Y=""
+4 DO TEXT^MXMLDOM(HDL,ND,$NAME(VV))
+5 IF $DATA(VV)>2
FOR I=1:1
if '$DATA(VV(I))
QUIT
SET Y=Y_VV(I)
+6 IF $PIECE(XUPN,"^",2)=""
Begin DoDot:2
+7 SET ^TMP("XUSAML",$JOB,$PIECE(XUPN,"^",1))=Y
End DoDot:2
+8 IF '$TEST
Begin DoDot:2
+9 SET ^TMP("XUSAML",$JOB,$PIECE(XUPN,"^",1),$PIECE(XUPN,"^",2))=Y
End DoDot:2
End DoDot:1
+10 QUIT
EL(HDL,ND,NM,XUPN) ;SR. Process element
+1 KILL XUPN
SET (NM,XUPN)=""
+2 FOR
SET NM=$$ATTRIB^MXMLDOM(HDL,ND,NM)
if '$LENGTH(NM)
QUIT
Begin DoDot:1
+3 IF $LENGTH(NM)
SET XUPN=NM_"^"_$$VALUE^MXMLDOM(HDL,ND,NM)
+4 IF $PIECE(XUPN,"^",2)=""
Begin DoDot:2
+5 SET ^TMP("XUSAML",$JOB,$PIECE(XUPN,"^",1))=""
End DoDot:2
+6 IF '$TEST
Begin DoDot:2
+7 SET ^TMP("XUSAML",$JOB,$PIECE(XUPN,"^",1),$PIECE(XUPN,"^",2))=""
End DoDot:2
End DoDot:1
+8 QUIT
FINDUSER(XUERR) ;Function. Identify user
+1 ;ZEXCEPT: XOBDATA ;environment variable
+2 NEW VISTAID,X,XARRY,XAUTH,XCTXT,XDUZ,XEDIPI,XPASS,XC,XT,XUHOME,XUIAM,Z
+3 IF '$$AUTH^XUESSO2()
SET XUERR("CALL-RTN")=""
QUIT "-1^Not an authorized calling routine"
+4 SET XDUZ="-1^User could not be identified"
+5 SET XERR=""
+6 SET DUZ("REMAPP")=""
+7 ;Do not trigger IAM updates
SET XUIAM=1
+8 ;Subject Organization
SET XARRY(1)=$$TITLE^XLFSTR($EXTRACT($GET(^TMP("XUSAML",$JOB,"Name","urn:oasis:names:tc:xspa:1.0:subject:organization")),1,50))
+9 ;Subject Organization ID
SET XARRY(2)=$$LOW^XLFSTR($EXTRACT($GET(^TMP("XUSAML",$JOB,"Name","urn:oasis:names:tc:xspa:1.0:subject:organization-id")),1,50))
+10 ;Unique User ID
SET XARRY(3)=$GET(^TMP("XUSAML",$JOB,"Name","uniqueUserId"))
+11 ;Subject ID
SET XARRY(4)=$GET(^TMP("XUSAML",$JOB,"Name","urn:oasis:names:tc:xspa:1.0:subject:subject-id"))
+12 ;P701
if XARRY(4)'[","
SET XARRY(4)=$PIECE(XARRY(4)," ",2)_","_$PIECE(XARRY(4)," ",1)_" "_$PIECE(XARRY(4)," ",3,99)
+13 ;Application ID
SET XPASS=$$IDPASS($GET(XASSRT("Recipient")))
+14 IF $GET(XPASS)'=""
Begin DoDot:1
+15 SET XT=$$GETCNTXT^XUESSO2(XPASS)
+16 IF +XT>0
Begin DoDot:2
+17 ;Identify remote application
SET DUZ("REMAPP")=XT_"^"_$PIECE($GET(^XWB(8994.5,XT,0)),U)
+18 SET XCTXT=$PIECE($GET(^XWB(8994.5,XT,0)),U,2)
+19 IF $GET(XCTXT)'=""
SET XARRY(5)=XPASS
End DoDot:2
End DoDot:1
+20 ;Application ID
IF '$TEST
SET XARRY(5)=""
+21 ;Network Username
SET XARRY(6)=$GET(^TMP("XUSAML",$JOB,"Name","urn:va:ad:samaccountname"))
+22 ;SecID
SET XARRY(7)=$GET(^TMP("XUSAML",$JOB,"Name","urn:va:vrm:iam:secid"))
+23 ;NPI
SET XARRY(8)=$GET(^TMP("XUSAML",$JOB,"Name","urn:oasis:names:tc:xspa:2.0:subject:npi"))
+24 ;S XARRY(9)=$G(^TMP("XUSAML",$J,"Name","SSN")) ;SSN is not part of STS Token specification v2.0
+25 ;Active Directory User Principle Name (UPN)
SET XARRY(10)=$GET(^TMP("XUSAML",$JOB,"Name","upn"))
+26 ;E-Mail Address
SET XARRY(11)=$GET(^TMP("XUSAML",$JOB,"Name","email"))
+27 ;S ???=$G(^TMP("XUSAML",$J,"Name","urn:oasis:names:tc:xacml:2.0:subject:role")) ;Role-based access is not yet implemented
+28 ;SSOi, SSOe, or Other authentication
SET XAUTH=$$LOW^XLFSTR($GET(^TMP("XUSAML",$JOB,"Name","authnsystem")))
+29 ;Home Community ID
SET XUHOME=$$LOW^XLFSTR($GET(^TMP("XUSAML",$JOB,"Name","urn:nhin:names:saml:homeCommunityId")))
+30 ;DoD CAC card identifier
SET XEDIPI=$GET(^TMP("XUSAML",$JOB,"Name","edipi"))
+31 ;ICN
SET DUZ("MVIICN")=$GET(^TMP("XUSAML",$JOB,"Name","urn:va:vrn:iam:mviicn"))
+32 ; p771 trim values and lock on XARRY(7) SECID or XARRY(3) unique id
+33 SET XARRY(3)=$TRANSLATE($$LOW^XLFSTR($EXTRACT($$TRIM^XLFSTR(XARRY(3)),1,40)),"^","%")
+34 SET XARRY(7)=$TRANSLATE($EXTRACT($$TRIM^XLFSTR(XARRY(7)),1,40),"^","%")
+35 SET XARRY(8)=$$TRIM^XLFSTR(XARRY(8))
+36 SET XEDIPI=$$TRIM^XLFSTR(XEDIPI)
+37 SET XARRY(11)=$$TRIM^XLFSTR(XARRY(11))
+38 ;
+39 ;SSOi
IF (XUHOME=$PIECE($GET(^XTV(8989.3,1,200)),U,3))&(XAUTH="ssoi")
Begin DoDot:1
+40 ;UID=SecID
SET XARRY(3)=XARRY(7)
+41 SET DUZ("AUTHENTICATION")="SSOI"
+42 ; p731,p771 ensure user is found before adding new one and deal with concurrent queries from JLV
+43 LOCK +^VA(200,"ASECID",XARRY(7)):$GET(DILOCKTM,10)
IF '$TEST
SET XDUZ="-1^Could not obtain LOCK"
QUIT
+44 ;Identify existing user with SecID
SET XDUZ=$$FINDUSER^XUESSO2(.XARRY)
+45 ; retry with SSN from MPI
IF XDUZ'>0
SET XARRY(9)=$$MPISSN(.XARRY)
+46 IF $GET(XARRY(9))]""
SET XDUZ=$$FINDUSER^XUESSO2(.XARRY)
+47 ; user found
IF XDUZ>0
LOCK -^VA(200,"ASECID",XARRY(7))
QUIT
+48 ;Add new user on the fly
+49 IF $GET(XARRY(5))'=""
Begin DoDot:2
+50 IF '$$TOKVALID(.DUZ,.XUERR)
SET XDUZ="-1^Cannot add untrusted token-data"
QUIT
+51 SET XDUZ=$$ADDUSER^XUESSO2(.XARRY)
End DoDot:2
+52 ; end p731,p771
LOCK -^VA(200,"ASECID",XARRY(7))
End DoDot:1
+53 ;
+54 ;SSOe
IF '$TEST
IF (XUHOME=$PIECE($GET(^XTV(8989.3,1,200)),U,3))&(XAUTH="ssoe")
Begin DoDot:1
+55 IF ($LENGTH($GET(XARRY(1)))<3)!($LENGTH($GET(XARRY(2)))<3)
SET XDUZ="-1^Invalid SORG or SORGID"
QUIT
+56 ;UID=SecID
SET XARRY(3)=XARRY(7)
+57 IF +DUZ("REMAPP")>0
Begin DoDot:2
+58 SET DUZ("AUTHENTICATION")="SSOE"
+59 ; p731,p771
LOCK +^VA(200,"ASECID",XARRY(7)):$GET(DILOCKTM,10)
IF '$TEST
SET XDUZ="-1^Could not obtain LOCK"
QUIT
+60 ;Identify existing user with SecID
SET XDUZ=$$FINDUSER^XUESSO2(.XARRY)
+61 ; retry with SSN from MPI
IF XDUZ'>0
SET XARRY(9)=$$MPISSN(.XARRY)
+62 IF $GET(XARRY(9))]""
SET XDUZ=$$FINDUSER^XUESSO2(.XARRY)
+63 IF (+XDUZ<0)&($GET(XARRY(5))'="")
Begin DoDot:3
+64 IF '$$TOKVALID(.DUZ,.XUERR)
SET XDUZ="-1^Cannot add untrusted token-data"
QUIT
+65 ;Add new user on the fly
SET XDUZ=$$ADDUSER^XUESSO2(.XARRY)
End DoDot:3
+66 ; end p731,p771
LOCK -^VA(200,"ASECID",XARRY(7))
End DoDot:2
End DoDot:1
+67 ;
+68 ; NHIN
IF '$TEST
IF (XARRY(2)["http://")!(XARRY(2)["https://")!((XARRY(2)["urn:oid:")&(XARRY(2)'=$PIECE($GET(^XTV(8989.3,1,200)),U,3)))
Begin DoDot:1
+69 IF (+DUZ("REMAPP")>0)&(XAUTH="nhin")
Begin DoDot:2
+70 ;NHIN: UID is NPI if available (preferred)
IF $GET(XARRY(3))=""
SET XARRY(3)=XARRY(8)
+71 ;NHIN: DoD CAC card identifier
IF $GET(XARRY(3))=""
SET XARRY(3)=XEDIPI
+72 ;NHIN: UID is e-mail if available (alternative to NPI)
IF $GET(XARRY(3))=""
SET XARRY(3)=XARRY(11)
+73 SET DUZ("AUTHENTICATION")="NHIN"
+74 ; p731,p771
LOCK +^VA(200,"UID",XARRY(3)):$GET(DILOCKTM,10)
IF '$TEST
SET XDUZ="-1^Could not obtain LOCK"
QUIT
+75 ;Identify user by NPI or Unique User ID
SET XDUZ=$$FINDUSER^XUESSO2(.XARRY)
+76 IF +XDUZ<0
Begin DoDot:3
+77 SET XARRY(8)=""
+78 ;Identify user by Unique User ID only
SET XDUZ=$$FINDUSER^XUESSO2(.XARRY)
+79 ; retry with SSN from MPI
IF XDUZ'>0
SET XARRY(9)=$$MPISSN(.XARRY)
+80 IF $GET(XARRY(9))]""
SET XDUZ=$$FINDUSER^XUESSO2(.XARRY)
+81 IF (+XDUZ<0)&($GET(XARRY(5))'="")
Begin DoDot:4
+82 IF '$$TOKVALID(.DUZ,.XUERR)
SET XDUZ="-1^Cannot add untrusted token-data"
QUIT
+83 ;Add new user on the fly
SET XDUZ=$$ADDUSER^XUESSO2(.XARRY)
End DoDot:4
End DoDot:3
+84 ; end p731
LOCK -^VA(200,"UID",XARRY(3))
End DoDot:2
End DoDot:1
+85 ;
+86 ; record NAME and SECID to error
IF XDUZ<0
Begin DoDot:1
+87 SET XUERR("SECID")=""
+88 SET $PIECE(XDUZ,U,3)=XARRY(4)
SET $PIECE(XDUZ,U,4)=XARRY(7)
End DoDot:1
+89 QUIT XDUZ
VALASSRT(XASSRT,DOC,XUERR) ;Intrinsic Subroutine. Validate SAML assertion
+1 ;ZEXCEPT: XOBDATA ;environment variable
+2 NEW XAUTH,XD,XNOW,XPROOF
+3 SET XOBDATA("XOB RPC","SAML","AUTHENTICATION TYPE")=$GET(^TMP("XUSAML",$JOB,"Name","authenticationtype"))
+4 SET XOBDATA("XOB RPC","SAML","PROOFING AUTHORITY")=$GET(^TMP("XUSAML",$JOB,"Name","proofingauthority"))
+5 SET XAUTH=$$LOW^XLFSTR($GET(^TMP("XUSAML",$JOB,"Name","authnsystem")))
+6 SET XPROOF=XOBDATA("XOB RPC","SAML","PROOFING AUTHORITY")
+7 ; Verify Level of Assurance (VA requires LOA-1 through LOA-3, but higher levels are accepted)
+8 KILL XOBDATA("XOB RPC","SAML","ASSURANCE LEVEL")
+9 SET XD=$GET(^TMP("XUSAML",$JOB,"Name","assurancelevel"))
IF (+XD<1)!(+XD="")
SET XD=1
+10 SET XOBDATA("XOB RPC","SAML","ASSURANCE LEVEL")=XD
+11 ;Set LOA environment variable for SIGN-ON log and permissions
SET DUZ("LOA")=XD
+12 ;p701
+13 ;I (XAUTH'="nhin")&(XPROOF'="VA-JLV") D ;temporary for pre-SSOe JLV non-VA users
+14 Begin DoDot:1
+15 ;Validate time stamps (e.g., NotBefore, NotOnOrAfter)
+16 SET XNOW=$$NOW^XLFDT
+17 ;invalid time stamp
SET XD=$$CONVTIME($GET(XASSRT("AuthnInstant")))
IF XD=-1
Begin DoDot:2
+18 SET XUERR("AuthnI")=""
End DoDot:2
+19 ;token not valid yet
SET XD=$$CONVTIME($GET(XASSRT("NotBefore")))
IF (XD=-1)!(XD>XNOW)
Begin DoDot:2
+20 SET XUERR("NotBefore")=""
End DoDot:2
+21 SET XD=$$CONVTIME($GET(XASSRT("NotOnOrAfter")))
Begin DoDot:2
+22 ;N DIF1,HR,DAY
+23 ;S HR=3600,DAY=86400
+24 ;S DIF1=$$FMDIFF^XLFDT(XD,XNOW,2) ;DIF1=$$ABS^XLFMTH(DIF1)
+25 ;I (XD=-1)!(DIF1>DAY) S XUERR("EXPIRED+")="" Q
+26 IF XD<XNOW
SET XUERR("EXPIRED")=""
+27 ;
End DoDot:2
+28 IF '$DATA(XASSRT("AuthnContextClassRef"))
Begin DoDot:2
+29 SET XUERR("AuthnCCR")=""
End DoDot:2
+30 ;Validate Digital Signature
+31 DO VALIDATE^XUCERT(DOC,.XUERR)
+32 ;Validate Token Issuer (Subject of X509 Certificate used to sign token)
+33 IF '($GET(XOBDATA("XOB RPC","SAML","ISSUER"))[$PIECE($GET(^XTV(8989.3,1,200)),U,1))
Begin DoDot:2
+34 SET XUERR("ISSUER")=""
End DoDot:2
+35 ;Token has been validated
End DoDot:1
+36 QUIT
IDPASS(XUA) ;Intrinsic Function. Extract Application ID
+1 NEW RETURN,XTD,XTE
+2 SET RETURN=$PIECE($GET(XUA),"/",4,99)
+3 SET XTD=$$DT^XLFDT
+4 SET XTE=$$FMADD^XLFDT(XTD,7)
+5 IF $GET(RETURN)'=""
Begin DoDot:1
+6 ;capture and log application ID from SAML token
SET ^XTMP("XUSAMLAPPID",0)=XTE_"^"_XTD_"^SAML Application ID"
+7 SET ^XTMP("XUSAMLAPPID",0,RETURN)=""
End DoDot:1
+8 ;. S RETURN=$$LOW^XLFSTR(RETURN) p779
+9 QUIT RETURN
CONVTIME(TIME) ;Intrinsic Function. Convert XML time to FileMan format
+1 ;ZEXCEPT: %DT ;environment variable
+2 NEW X,XD,XOUT,XT,XZ,Y
+3 ;Zulu time (GMT)
SET XZ=0
IF $GET(TIME)["Z"
SET XZ=1
+4 ;Date
SET XD=$PIECE($GET(TIME),"T",1)
+5 ;Convert date to MM/DD/YYYY
SET XD=$PIECE(XD,"-",2)_"/"_$PIECE(XD,"-",3)_"/"_$PIECE(XD,"-",1)
+6 ;Time
SET XT=$PIECE($GET(TIME),"T",2)
+7 ;Strip "Z" from time
IF XZ=1
SET XT=$PIECE(XT,"Z",1)
+8 SET X=XD_"@"_XT
SET %DT="RTS"
+9 DO ^%DT
SET XOUT=Y
+10 ;Invalid date/time
IF XOUT=-1
QUIT XOUT
+11 ;Adjust from GMT
IF XZ=1
SET XOUT=$$FMADD^XLFDT(XOUT,0,+$EXTRACT($$TZ^XLFDT,1,3),0,0)
+12 KILL %DT(0)
+13 QUIT XOUT
+14 ;
WARNINGS(XUERR) ;
+1 NEW X,Y
+2 SET (X,Y)=""
+3 FOR
SET X=$ORDER(XUERR(X))
if X=""
QUIT
SET Y=Y_X_";"
+4 QUIT Y
+5 ;
TOKVALID(DUZ,XUERR) ;
+1 NEW STRICT
+2 ;S STRICT=$P($G(^XTV(8989.3,1,"XUS")),"^",20)
+3 SET STRICT=+$PIECE($GET(XOPT),U,20)
+4 IF STRICT
IF $DATA(XUERR)
QUIT 0
+5 IF $GET(DUZ("AUTHENTICATION"))="NHIN"
QUIT 1
+6 IF $DATA(XUERR("EXPIRED"))
QUIT 0
+7 ;I $D(XUERR("DIGEST")),$D(XUERR("EXPIRED+")) Q 0
+8 QUIT 1
+9 ;
LOGFAIL(IEN,DUZ) ; Record failed access
+1 NEW STRICT,WARN,XUF
+2 SET STRICT=$PIECE($GET(XOPT),U,20)
+3 SET WARN=$SELECT(+STRICT:"STRICT ",1:"NON-STRICT ")
+4 IF $GET(DUZ("WARNINGS"))'=""
SET WARN=WARN_"Failed-verifications: "_$GET(DUZ("WARNINGS"))
+5 IF $PIECE(IEN,U,2)'=""
SET WARN=WARN_" ERROR:"_$PIECE(IEN,U,2)
+6 IF $PIECE(IEN,U,4)'=""
SET WARN=WARN_". SECID not linked to existing user, SECID:"_$PIECE(IEN,U,4)_" NAME:"_$PIECE(IEN,U,3)_" "
+7 SET IEN=+IEN
+8 IF IEN>0
SET XUF(.3)=IEN
SET X=$PIECE($GET(^VA(200,IEN,1.1)),U,2)+1
SET $PIECE(^(1.1),"^",2)=X
+9 SET XUF(.1)=$EXTRACT($GET(DUZ("AUTHENTICATION")))
+10 SET XUF(.2)=$GET(XUF(.2))+1
SET XUF(XUF(.2))=WARN
+11 SET XUF=2
+12 DO FILE^XUSTZ
+13 QUIT
+14 ;
MPISSN(XATR) ; Return SSN found in MPI
+1 NEW SSN,XMPI,XOUT
+2 SET SSN=""
+3 if $GET(XATR(7))]""
SET XMPI("secId")=XATR(7)
+4 if $GET(XATR(6))]""
SET XMPI("samacctnm")=XATR(6)
+5 if $GET(XATR(10))]""
SET XMPI("VAemail")=XATR(10)
+6 NEW XI
FOR XI="secId","samacctnm","VAemail"
Begin DoDot:1
+7 NEW XIN
+8 IF $GET(XMPI(XI))]""
SET XIN(XI)=XMPI(XI)
DO USER^XUIAMXML(.XOUT,.XIN)
SET SSN=$GET(XOUT("pnid"))
End DoDot:1
if SSN]""
QUIT
+9 QUIT SSN
+10 ;
