XUESSO2 ;ISD/HGW - Enhanced Single Sign-On Utilities ; Apr 19, 2022@14:57
;;8.0;KERNEL;**655,659,630,701,731,771,779**;Jul 10, 1995;Build 5
;Per VA Directive 6402, this routine should not be modified.
;
; This utility will identify a VistA user for auditing and HIPAA requirements.
; NONE of the fields listed below can contain a caret (^) character as it is used as a delimiter in VistA!
;
; $$FINDUSER() - At least one of the following attributes is required to uniquely identify an existing user in the
; NEW PERSON file (#200):
;
; XATR(7) = unique Security ID [SecID, assigned by Identity and Access Management]
; XATR(8) = unique National Provider Identifier [assigned by Centers for Medicare and Medicaid Services (CMS)]
; XATR(9) = unique Social Security (SSN) or Taxpayer Identification Number (TIN) [assigned by the Social Security Administration]
; XATR(2) and XATR(3) = combination of a unique Subject Organization ID (OID) with a Unique User ID (UID) [see below]
;
; $$ADDUSER() - If an existing user is not found in the NEW PERSON file (#200), then the following minimum attributes
; are required to provision a new user:
;
; XATR(1) = Subject Organization [free text, 3-50 characters]
; XATR(2) = Subject Organization ID [free text, 1-50 characters, unique to Subject Organization]
; XATR(3) = Unique User ID [free text, 1-40 characters, unique within OID]
; XATR(4) = Subject ID [person's name, to be entered into the NAME field (#.01) of the NEW PERSON file (#200)]
;
; The following attributes are optional for adding or updating a user, but may be required by a particular VistA application
; for further Identity and Access Management:
;
; XATR(5) = Application ID [Security Phrase to identify and authenticate the client application and establish the context option]
; XATR(6) = Network Username [Active Directory Login]
; XATR(9) = unique Social Security (SSN) or Taxpayer Identification Number (TIN) [assigned by the Social Security Administration]
; XATR(10)= AD UPN [Active Directory User Principle Name (UPN)]
; XATR(11)= E-Mail Address
Q
;
FINDUSER(XATR) ;Function. Find user using minimum attributes for user identification
; Input: XATR = Array containing user attributes (see above).
; Return: Fail = "-1^Error Message"
; Success = IEN of NEW PERSON file (#200) entry (Note: this routine will NOT set DUZ to the identified IEN)
;
N TODAY,DT,IEN,DIC,XUNAME,ERRMSG
S U="^",TODAY=$$HTFM^XLFDT($H),DT=$P(TODAY,"."),ERRMSG=""
; Check for unique identifier (SecID, NPI, SSN, or OID+UID)
I ($G(XATR(7))="")&($G(XATR(8))="")&($G(XATR(9))="")&(($G(XATR(2))="")&($G(XATR(3))="")) Q "-1^Array does not contain a unique identifier"
; Format user attributes to match FileMan fields
S XATR(1)=$$TITLE^XLFSTR($E($G(XATR(1)),1,50)) ;Subject Organization
S XATR(2)=$$LOW^XLFSTR($E($G(XATR(2)),1,50)) ;Subject Organization ID
S XATR(3)=$TR($$LOW^XLFSTR($E($G(XATR(3)),1,40)),"^","%") ;Unique User ID
;p701
;I $G(XATR(4))'="" D Q:ERRMSG'="" ERRMSG
;. S XUNAME=XATR(4) S XATR(4)=$$FORMAT^XLFNAME7(.XUNAME,3,35,,0,,,2) ;Subject ID converted to standard format
;. I $G(XATR(4))'?1U.E1","1U.E S ERRMSG="-1^Subject ID could not be converted to 'LAST,FIRST MIDDLE SUFFIX' VistA standard format"
S XATR(6)=$$UP^XLFSTR($E($G(XATR(6)),1,50)) ;AD Network Username
S XATR(7)=$TR($E($G(XATR(7)),1,40),"^","%") ;SecID
Q $$TALL(.XATR)
;
TALL(XATR) ;Function. Find an existing user.
N OID,UID,SECID,NPI,SSN,NEWDUZ,ERRMSG,AOIUID,X,Y,Z
S $ECODE="" ;look at current stack, not error stack
S X=$ST($ST-1,"PLACE"),Y=$P(X,"+"),Z=$P(X,"^",2),X=Y_"^"_$P(Z," ")
I X'="FINDUSER^XUESSO2" Q "-1^Not authorized"
I $G(DUZ("LOA"))<2 Q "-1^Not authorized"
S OID=$G(XATR(2))
S UID=$G(XATR(3))
S SECID=$G(XATR(7))
S NPI=$G(XATR(8))
S SSN=$G(XATR(9))
S ERRMSG="",NEWDUZ=0,Y=0
;See if match SECID, to be assigned by Identification and Access Management (IAM) services.
I $L(SECID)>0 D Q:ERRMSG'="" ERRMSG
. S Y=$$SECMATCH(SECID) Q:Y<1
. ;I NPI'="" D Q:ERRMSG'=""
. ;. I NPI'=$P($G(^VA(200,Y,"NPI")),U) S ERRMSG="-1^NPI mismatch for user ID'd by SecID" Q
. ;I SSN'="" D Q:ERRMSG'=""
. ;. I SSN'=$P($G(^VA(200,Y,1)),U,9) S ERRMSG="-1^SSN mismatch for user ID'd by SecID" Q
. S NEWDUZ=Y
. S ERRMSG=$$UPDU(.XATR,NEWDUZ) ; Update fields if changes are needed
. Q
I NEWDUZ>0 Q NEWDUZ ;Quit here if we found a match on SECID
;See if match NPI
I $L(NPI)>0 D Q:ERRMSG'="" ERRMSG
. S Y=+$O(^VA(200,"ANPI",NPI,0)) Q:Y<1
. ;I SECID'="" D Q:ERRMSG'=""
. ;. I $$SECMATCH(SECID)<1 S ERRMSG="-1^SecID mismatch for user ID'd by NPI" Q
. ;I SSN'="" D Q:ERRMSG'=""
. ;. I SSN'=$P($G(^VA(200,Y,1)),U,9) S ERRMSG="-1^SSN mismatch for user ID'd by NPI" Q
. S NEWDUZ=Y
. S ERRMSG=$$UPDU(.XATR,NEWDUZ) ; Update fields if changes are needed
. Q
I NEWDUZ>0 Q NEWDUZ ;Quit here if we found a match on NPI
;See if match SSN
I $L(SSN)>0 D Q:ERRMSG'="" ERRMSG
. S Y=+$O(^VA(200,"SSN",SSN,0)) Q:Y<1
. ;I SECID'="" D Q:ERRMSG'=""
. ;. I $$SECMATCH(SECID)<1 S ERRMSG="-1^SecID mismatch for user ID'd by SSN" Q
. ;I NPI'="" D Q:ERRMSG'=""
. ;. I NPI'=$P($G(^VA(200,Y,"NPI")),U) S ERRMSG="-1^NPI mismatch for user ID'd by SSN" Q
. S NEWDUZ=Y
. S ERRMSG=$$UPDU(.XATR,NEWDUZ) ; Update fields if changes are needed
. Q
I NEWDUZ>0 Q NEWDUZ ;Quit here if we found a match on SSN
;See if match OID+UID ("AOIUID" cross-reference).
S Y=$$AOIUID(OID,UID) I Y>0 D Q:ERRMSG'="" ERRMSG
. ;I SECID'="" D Q:ERRMSG'=""
. ;. I $$SECMATCH(SECID)<1 S ERRMSG="-1^SecID mismatch for user ID'd by OID+UID" Q
. ;I NPI'="" D Q:ERRMSG'=""
. ;. I NPI'=$P($G(^VA(200,Y,"NPI")),U) S ERRMSG="-1^NPI mismatch for user ID'd by OID+UID" Q
. ;I SSN'="" D Q:ERRMSG'=""
. ;. I SSN'=$P($G(^VA(200,Y,1)),U,9) S ERRMSG="-1^SSN mismatch for user ID'd by OID+UID" Q
. S NEWDUZ=Y
. S ERRMSG=$$UPDU(.XATR,NEWDUZ) ; Update fields if changes are needed
. Q
I NEWDUZ>0 Q NEWDUZ ;Quit here if we found a match on OID+UID
Q "-1^User not found"
;
ADDUSER(XATR) ;Function. Add user using minimum attributes for user identification
; Input: XATR = Array containing user attributes (see above).
; Return: Fail = "-1^Error Message"
; Success = IEN of NEW PERSON file (#200) entry (Note: this routine will NOT set DUZ to the identified IEN)
;
N SID,NEWDUZ,ERRMSG
I '$$AUTH() Q "-1^Not an authorized calling routine"
I $G(DUZ("LOA"))<2 Q "-1^Not authorized"
S ERRMSG=""
;Minimum 4 Attributes are required to add a new user
I ($G(XATR(1))="")!($L($G(XATR(1)))<4) Q "-1^Subject Organization is required to add a new user"
I ($G(XATR(2))="")!($L($G(XATR(2)))<4) Q "-1^Subject Organization ID is required to add a new user"
I $G(XATR(3))="" Q "-1^Unique User ID is required to add a new user"
I $G(XATR(4))="" Q "-1^Subject ID is required to add a new user"
; Format user attributes to match FileMan fields
S XATR(1)=$$TITLE^XLFSTR($E($G(XATR(1)),1,50)) ;Subject Organization
S XATR(2)=$$LOW^XLFSTR($E($G(XATR(2)),1,50)) ;Subject Organization ID
S XATR(3)=$TR($$LOW^XLFSTR($E($G(XATR(3)),1,40)),"^","%") ;Unique User ID
I $G(XATR(4))'="" D Q:ERRMSG'="" ERRMSG ;
. S SID=XATR(4) S XATR(4)=$$FORMAT^XLFNAME7(.SID,3,35,,0,,,2) ; Subject ID converted to standard format
. I $G(XATR(4))'?1U.E1","1U.E S ERRMSG="-1^Subject ID could not be converted to VistA standard format"
S XATR(6)=$$UP^XLFSTR($E($G(XATR(6)),1,15)) ;AD Network Username
S XATR(7)=$TR($E($G(XATR(7)),1,40),"^","%") ;SecID
S NEWDUZ=$$ADDU(XATR(4)) ;Put the name in the .01 field first
I +NEWDUZ<1 Q "-1^Create of new user record failed"
S ERRMSG=$$UPDU(.XATR,NEWDUZ) ;Then update the remaining fields
I +ERRMSG<0 D CLEAN(NEWDUZ) Q ERRMSG ;Delete the added user if update fails (incomplete record)
I +NEWDUZ<1 Q "-1^Create or update of user record failed"
I ($G(DUZ("REMAPP"))'="") D SETREMAP(NEWDUZ,$P(DUZ("REMAPP"),"^"))
Q NEWDUZ ;Every thing OK
;
SECMATCH(SECID) ;Function. Find match for SECID.
N Y,Z
I $G(SECID)="" Q ""
S Y=0,Z=0
F D Q:Y=""
. S Y=$O(^VA(200,"ASECID",$E(SECID,1,40),Y)) ; p771
. I Y>0 D Q
. . I SECID=$P($G(^VA(200,Y,205)),U,1) S Z=Y,Y=""
Q Z
;
UPNMATCH(ADUPN) ;Function. Find match for ADUPN.
N W,Y,Z
I $G(ADUPN)="" Q ""
S W=$E(ADUPN,1,30),Y=0,Z=0
F D Q:Y=""
. S Y=$O(^VA(200,"ADUPN",$G(ADUPN),Y))
. I Y>0 D Q
. . I ADUPN=$P($G(^VA(200,Y,205)),U,5) S Z=Y,Y=""
Q Z
;
AOIUID(OID,UID) ;Function. Find match for OID+UID cross-reference.
N W,X,Y,Z
I ($G(OID)="")!($G(UID)="") Q ""
S W=$E(OID,1,30),X=$E(UID,1,30),Y=0,Z=0
F D Q:Y=""
. S Y=$O(^VA(200,"AOIUID",W,X,Y))
. I Y>0 D Q
. . I (OID=$P($G(^VA(200,Y,205)),U,3))&(UID=$P($G(^VA(200,Y,205)),U,4)) S Z=Y,Y=""
Q Z
;
NETMAIL(NETNAME,MAIL) ;Function. Find match for NETWORK USERNAME and EMAIL ADDRESS
N L1,L2,N,Y,Z
S NETNAME=$G(NETNAME),MAIL=$G(MAIL)
S L1=$L(NETNAME),L2=$L(MAIL)
Q:(L1=0)&(L2=0) 0
S Y=0,Z=0,N=0
F D Q:Y=""
. S Y=$O(^VA(200,Y))
. S N=N+1
. I (N#10000)=0 H 1
. I Y>0 D
. . I L1,NETNAME=$P($G(^VA(200,Y,501)),U,1) S Z=Y,Y="" Q
. . I L2,MAIL=$P($G(^VA(200,Y,.15)),U,1) S Z=Y,Y="" Q
Q Z
;
ADDU(XUNAME) ;Function. Add a new name to the NPF
N DD,DO,DIC,DA,X,Y,DUZZERO
K ^TMP("DIERR",$J)
S DIC="^VA(200,",DIC(0)="F",X=XUNAME
; Get a LOCK. Block if can't get.
L +^VA(200,"HL7"):10 Q:'$T "-1^Addition of new users is blocked"
S DUZZERO=DUZ(0),DUZ(0)="@" ;Make sure we can add the entry
D FILE^DICN
S DUZ(0)=DUZZERO ;Restore original FM access
L -^VA(200,"HL7")
Q +Y
;
UPDU(XATR,NEWDUZ) ;Function. Update user in the NPF
N DUZZERO,DIC,ERRMSG,FDR,IEN,XUCODE,XUENTRY
K ^TMP("DIERR",$J)
S DIC(0)="",ERRMSG=""
S IEN=NEWDUZ_","
I ($G(XATR(1))'=""),(XATR(1)'=$P($G(^VA(200,NEWDUZ,205)),U,2)) S FDR(200,IEN,205.2)=$$TITLE^XLFSTR($E($G(XATR(1)),1,50)) ;SORG
I ($G(XATR(2))'=""),(XATR(2)'=$P($G(^VA(200,NEWDUZ,205)),U,3)) S FDR(200,IEN,205.3)=$$LOW^XLFSTR($E($G(XATR(2)),1,50)) ;OID
I ($G(XATR(3))'=""),(XATR(3)'=$P($G(^VA(200,NEWDUZ,205)),U,4)) S FDR(200,IEN,205.4)=$TR($$LOW^XLFSTR($E($G(XATR(3)),1,40)),"^","%") ;UID
I ($G(XATR(6))'=""),(XATR(6)'=$P($G(^VA(200,NEWDUZ,501)),U,1)) S FDR(200,IEN,501.1)=$$UP^XLFSTR($E($G(XATR(6)),1,15)) ;NETWORK USERNAME
I ($G(XATR(7))'=""),(XATR(7)'=$P($G(^VA(200,NEWDUZ,205)),U,1)) S FDR(200,IEN,205.1)=$TR($E($G(XATR(7)),1,40),"^","%") ;SecID
I ($G(XATR(8))'=""),(XATR(8)'=$P($G(^VA(200,NEWDUZ,"NPI")),U,1)) S FDR(200,IEN,41.99)=$G(XATR(8)) ;NPI
I ($G(XATR(9))'=""),(XATR(9)'=$P($G(^VA(200,NEWDUZ,1)),U,9)) S ERRMSG=$$ADDS(.FDR,NEWDUZ,$G(XATR(9))) I ERRMSG'="" Q ERRMSG ;SSN
I ($G(XATR(10))'=""),(XATR(10)'=$P($G(^VA(200,NEWDUZ,205)),U,5)) S FDR(200,IEN,205.5)=$$LOW^XLFSTR($G(XATR(10))) ;ADUPN
I ($G(XATR(11))'=""),(XATR(11)'=$P($G(^VA(200,NEWDUZ,.15)),U,1)) S FDR(200,IEN,.151)=$$LOW^XLFSTR($G(XATR(11))) ;e-mail
I $G(XATR(5))'="" S ERRMSG=$$SETCNTXT(NEWDUZ,$G(XATR(5))) I ERRMSG'="" Q ERRMSG ;Assign Context Option
; Apply all the changes
S DUZZERO=DUZ(0),DUZ(0)="@" ;Make sure we can update the entry
I $D(FDR) K IEN D UPDATE^DIE("E","FDR","IEN") ;File all the data
S DUZ(0)=DUZZERO ;Restore original FM access
I $D(^TMP("DIERR",$J)) Q "-1^FileMan error" ;FileMan Error
I +ERRMSG<1 Q ERRMSG ;Couldn't update user
I +NEWDUZ<1 Q "-1^Update of user record failed"
Q ""
;
ADDS(FDR,NEWDUZ,SSN) ;Function. Add a SSN to the NPF
N IEN,ERRMSG
S IEN=NEWDUZ_",",ERRMSG=""
I '$$SSNCHECK^XUESSO1(SSN) Q "-1^SSN is not valid per SSA criteria"
S FDR(200,IEN,9)=SSN
Q ERRMSG
;
CLEAN(Y) ;Subroutine. Clean up (delete) incomplete record in NPF
; ZEXCEPT: DA,DIK
N DUZZERO
S DUZZERO=DUZ(0),DUZ(0)="@" ;Make sure we can update the entry
I +Y>0 D
. K DA,DIK S DIK="^VA(200,",DA=+Y D ^DIK
S DUZ(0)=DUZZERO ;Restore original FM access
Q
;
SETCNTXT(NEWDUZ,XAPHRASE) ;Function. Assign Context Option to user Secondary Menu Options
N OPT,XUENTRY,XOPT,XUCONTXT,X
S XUENTRY=$$GETCNTXT(XAPHRASE) I +XUENTRY<0 Q XUENTRY
S DUZ("REMAPP")=XUENTRY_U_$$GET1^DIQ(8994.5,XUENTRY_",",.01)
S XOPT=$P($G(^XWB(8994.5,XUENTRY,0)),U,2)
I XOPT'>0 Q "-1^Context Option must be identified in the REMOTE APPLICATION file"
S XUCONTXT="`"_XOPT
I $$FIND1^DIC(19,"","X",XUCONTXT)'>0 Q "-1^Context Option not in OPTION file"
;Have to use $D because of screen in 200.03 keeps FIND1^DIC from working.
I '$D(^VA(200,NEWDUZ,203,"B",XOPT)) D
. ; Have to give the user a delegated option
. N XARR S XARR(200.19,"+1,"_NEWDUZ_",",.01)=XUCONTXT
. D UPDATE^DIE("E","XARR")
. ; And now user can give self the context option
. K XARR S XARR(200.03,"+1,"_NEWDUZ_",",.01)=XUCONTXT
. D UPDATE^DIE("E","XARR") ; Give context option as a secondary menu item
. ; But now we have to remove the delegated option
. S OPT=$$FIND1^DIC(200.19,","_NEWDUZ_",","X",XUCONTXT)
. I OPT>0 D
. . K XARR S XARR(200.19,(OPT_","_NEWDUZ_","),.01)="@"
. . D FILE^DIE("E","XARR")
. . Q
. Q
Q ""
;
GETCNTXT(XAPHRASE) ;Function. Identify the REMOTE APPLICATION
N XUCODE,XUENTRY
;Identify Remote Application with SHA256 hash
S XUCODE=$$SHAHASH^XUSHSH(256,$G(XAPHRASE),"B") ; ICR #6189
S XUENTRY=$$FIND1^DIC(8994.5,"","X",XUCODE,"ACODE")
;If not found, check with old hash and replace with SHA256 hash if found
I XUENTRY'>0 D
. S XUCODE=$$EN^XUSHSH($G(XAPHRASE)) ; IA #10045
. S XUENTRY=$$FIND1^DIC(8994.5,"","X",XUCODE,"ACODE")
. I XUENTRY>0 D
. . S XUCODE=$$SHAHASH^XUSHSH(256,$G(XAPHRASE),"B") ; ICR #6189
. . N FDR
. . S FDR(8994.5,XUENTRY_",",.03)=XUCODE
. . D FILE^DIE("E","FDR")
;If not found, check with lowercase hash (called by ^XUSAML) p779
I XUENTRY'>0 D
. S XUCODE=$$SHAHASH^XUSHSH(256,$$LOW^XLFSTR($G(XAPHRASE)),"B") ; ICR #6189
. S XUENTRY=$$FIND1^DIC(8994.5,"","X",XUCODE,"ACODE")
;If not found, check with old hash (using lowercase) and replace with SHA256 hash if found p779
I XUENTRY'>0 D
. S XUCODE=$$EN^XUSHSH($$LOW^XLFSTR($G(XAPHRASE))) ; IA #10045
. S XUENTRY=$$FIND1^DIC(8994.5,"","X",XUCODE,"ACODE")
. I XUENTRY>0 D
. . S XUCODE=$$SHAHASH^XUSHSH(256,$$LOW^XLFSTR($G(XAPHRASE)),"B") ; ICR #6189
. . N FDR
. . S FDR(8994.5,XUENTRY_",",.03)=XUCODE
. . D FILE^DIE("E","FDR")
I XUENTRY'>0 Q "-1^Application ID must be registered in the REMOTE APPLICATION file"
Q XUENTRY
;
AUTH() ;Function. Check if calling routine is authorized
; ^XUESSO2 does not address the security issue of user authentication, so a restriction is placed on the calling routine.
N X,Z
S $ECODE="" ;look at current stack, not error stack
S X=$ST($ST-2,"PLACE"),Z=$P(X,"^",2),X="^"_$P(Z," ")
I $E(X,1,3)="^XU" Q 1 ;Authorized Kernel access
Q 0
;
SETREMAP(USER,REMAPP) ; user created by remote application
N IEN,FDR
Q:$G(USER)<1
S IEN=USER_","
S FDR(200,IEN,202.06)=$G(REMAPP) K IEN D UPDATE^DIE("","FDR","IEN")
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUESSO2 15210 printed Apr 09, 2024@21:05:16 Page 2
XUESSO2 ;ISD/HGW - Enhanced Single Sign-On Utilities ; Apr 19, 2022@14:57
+1 ;;8.0;KERNEL;**655,659,630,701,731,771,779**;Jul 10, 1995;Build 5
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; This utility will identify a VistA user for auditing and HIPAA requirements.
+5 ; NONE of the fields listed below can contain a caret (^) character as it is used as a delimiter in VistA!
+6 ;
+7 ; $$FINDUSER() - At least one of the following attributes is required to uniquely identify an existing user in the
+8 ; NEW PERSON file (#200):
+9 ;
+10 ; XATR(7) = unique Security ID [SecID, assigned by Identity and Access Management]
+11 ; XATR(8) = unique National Provider Identifier [assigned by Centers for Medicare and Medicaid Services (CMS)]
+12 ; XATR(9) = unique Social Security (SSN) or Taxpayer Identification Number (TIN) [assigned by the Social Security Administration]
+13 ; XATR(2) and XATR(3) = combination of a unique Subject Organization ID (OID) with a Unique User ID (UID) [see below]
+14 ;
+15 ; $$ADDUSER() - If an existing user is not found in the NEW PERSON file (#200), then the following minimum attributes
+16 ; are required to provision a new user:
+17 ;
+18 ; XATR(1) = Subject Organization [free text, 3-50 characters]
+19 ; XATR(2) = Subject Organization ID [free text, 1-50 characters, unique to Subject Organization]
+20 ; XATR(3) = Unique User ID [free text, 1-40 characters, unique within OID]
+21 ; XATR(4) = Subject ID [person's name, to be entered into the NAME field (#.01) of the NEW PERSON file (#200)]
+22 ;
+23 ; The following attributes are optional for adding or updating a user, but may be required by a particular VistA application
+24 ; for further Identity and Access Management:
+25 ;
+26 ; XATR(5) = Application ID [Security Phrase to identify and authenticate the client application and establish the context option]
+27 ; XATR(6) = Network Username [Active Directory Login]
+28 ; XATR(9) = unique Social Security (SSN) or Taxpayer Identification Number (TIN) [assigned by the Social Security Administration]
+29 ; XATR(10)= AD UPN [Active Directory User Principle Name (UPN)]
+30 ; XATR(11)= E-Mail Address
+31 QUIT
+32 ;
FINDUSER(XATR) ;Function. Find user using minimum attributes for user identification
+1 ; Input: XATR = Array containing user attributes (see above).
+2 ; Return: Fail = "-1^Error Message"
+3 ; Success = IEN of NEW PERSON file (#200) entry (Note: this routine will NOT set DUZ to the identified IEN)
+4 ;
+5 NEW TODAY,DT,IEN,DIC,XUNAME,ERRMSG
+6 SET U="^"
SET TODAY=$$HTFM^XLFDT($HOROLOG)
SET DT=$PIECE(TODAY,".")
SET ERRMSG=""
+7 ; Check for unique identifier (SecID, NPI, SSN, or OID+UID)
+8 IF ($GET(XATR(7))="")&($GET(XATR(8))="")&($GET(XATR(9))="")&(($GET(XATR(2))="")&($GET(XATR(3))=""))
QUIT "-1^Array does not contain a unique identifier"
+9 ; Format user attributes to match FileMan fields
+10 ;Subject Organization
SET XATR(1)=$$TITLE^XLFSTR($EXTRACT($GET(XATR(1)),1,50))
+11 ;Subject Organization ID
SET XATR(2)=$$LOW^XLFSTR($EXTRACT($GET(XATR(2)),1,50))
+12 ;Unique User ID
SET XATR(3)=$TRANSLATE($$LOW^XLFSTR($EXTRACT($GET(XATR(3)),1,40)),"^","%")
+13 ;p701
+14 ;I $G(XATR(4))'="" D Q:ERRMSG'="" ERRMSG
+15 ;. S XUNAME=XATR(4) S XATR(4)=$$FORMAT^XLFNAME7(.XUNAME,3,35,,0,,,2) ;Subject ID converted to standard format
+16 ;. I $G(XATR(4))'?1U.E1","1U.E S ERRMSG="-1^Subject ID could not be converted to 'LAST,FIRST MIDDLE SUFFIX' VistA standard format"
+17 ;AD Network Username
SET XATR(6)=$$UP^XLFSTR($EXTRACT($GET(XATR(6)),1,50))
+18 ;SecID
SET XATR(7)=$TRANSLATE($EXTRACT($GET(XATR(7)),1,40),"^","%")
+19 QUIT $$TALL(.XATR)
+20 ;
TALL(XATR) ;Function. Find an existing user.
+1 NEW OID,UID,SECID,NPI,SSN,NEWDUZ,ERRMSG,AOIUID,X,Y,Z
+2 ;look at current stack, not error stack
SET $ECODE=""
+3 SET X=$STACK($STACK-1,"PLACE")
SET Y=$PIECE(X,"+")
SET Z=$PIECE(X,"^",2)
SET X=Y_"^"_$PIECE(Z," ")
+4 IF X'="FINDUSER^XUESSO2"
QUIT "-1^Not authorized"
+5 IF $GET(DUZ("LOA"))<2
QUIT "-1^Not authorized"
+6 SET OID=$GET(XATR(2))
+7 SET UID=$GET(XATR(3))
+8 SET SECID=$GET(XATR(7))
+9 SET NPI=$GET(XATR(8))
+10 SET SSN=$GET(XATR(9))
+11 SET ERRMSG=""
SET NEWDUZ=0
SET Y=0
+12 ;See if match SECID, to be assigned by Identification and Access Management (IAM) services.
+13 IF $LENGTH(SECID)>0
Begin DoDot:1
+14 SET Y=$$SECMATCH(SECID)
if Y<1
QUIT
+15 ;I NPI'="" D Q:ERRMSG'=""
+16 ;. I NPI'=$P($G(^VA(200,Y,"NPI")),U) S ERRMSG="-1^NPI mismatch for user ID'd by SecID" Q
+17 ;I SSN'="" D Q:ERRMSG'=""
+18 ;. I SSN'=$P($G(^VA(200,Y,1)),U,9) S ERRMSG="-1^SSN mismatch for user ID'd by SecID" Q
+19 SET NEWDUZ=Y
+20 ; Update fields if changes are needed
SET ERRMSG=$$UPDU(.XATR,NEWDUZ)
+21 QUIT
End DoDot:1
if ERRMSG'=""
QUIT ERRMSG
+22 ;Quit here if we found a match on SECID
IF NEWDUZ>0
QUIT NEWDUZ
+23 ;See if match NPI
+24 IF $LENGTH(NPI)>0
Begin DoDot:1
+25 SET Y=+$ORDER(^VA(200,"ANPI",NPI,0))
if Y<1
QUIT
+26 ;I SECID'="" D Q:ERRMSG'=""
+27 ;. I $$SECMATCH(SECID)<1 S ERRMSG="-1^SecID mismatch for user ID'd by NPI" Q
+28 ;I SSN'="" D Q:ERRMSG'=""
+29 ;. I SSN'=$P($G(^VA(200,Y,1)),U,9) S ERRMSG="-1^SSN mismatch for user ID'd by NPI" Q
+30 SET NEWDUZ=Y
+31 ; Update fields if changes are needed
SET ERRMSG=$$UPDU(.XATR,NEWDUZ)
+32 QUIT
End DoDot:1
if ERRMSG'=""
QUIT ERRMSG
+33 ;Quit here if we found a match on NPI
IF NEWDUZ>0
QUIT NEWDUZ
+34 ;See if match SSN
+35 IF $LENGTH(SSN)>0
Begin DoDot:1
+36 SET Y=+$ORDER(^VA(200,"SSN",SSN,0))
if Y<1
QUIT
+37 ;I SECID'="" D Q:ERRMSG'=""
+38 ;. I $$SECMATCH(SECID)<1 S ERRMSG="-1^SecID mismatch for user ID'd by SSN" Q
+39 ;I NPI'="" D Q:ERRMSG'=""
+40 ;. I NPI'=$P($G(^VA(200,Y,"NPI")),U) S ERRMSG="-1^NPI mismatch for user ID'd by SSN" Q
+41 SET NEWDUZ=Y
+42 ; Update fields if changes are needed
SET ERRMSG=$$UPDU(.XATR,NEWDUZ)
+43 QUIT
End DoDot:1
if ERRMSG'=""
QUIT ERRMSG
+44 ;Quit here if we found a match on SSN
IF NEWDUZ>0
QUIT NEWDUZ
+45 ;See if match OID+UID ("AOIUID" cross-reference).
+46 SET Y=$$AOIUID(OID,UID)
IF Y>0
Begin DoDot:1
+47 ;I SECID'="" D Q:ERRMSG'=""
+48 ;. I $$SECMATCH(SECID)<1 S ERRMSG="-1^SecID mismatch for user ID'd by OID+UID" Q
+49 ;I NPI'="" D Q:ERRMSG'=""
+50 ;. I NPI'=$P($G(^VA(200,Y,"NPI")),U) S ERRMSG="-1^NPI mismatch for user ID'd by OID+UID" Q
+51 ;I SSN'="" D Q:ERRMSG'=""
+52 ;. I SSN'=$P($G(^VA(200,Y,1)),U,9) S ERRMSG="-1^SSN mismatch for user ID'd by OID+UID" Q
+53 SET NEWDUZ=Y
+54 ; Update fields if changes are needed
SET ERRMSG=$$UPDU(.XATR,NEWDUZ)
+55 QUIT
End DoDot:1
if ERRMSG'=""
QUIT ERRMSG
+56 ;Quit here if we found a match on OID+UID
IF NEWDUZ>0
QUIT NEWDUZ
+57 QUIT "-1^User not found"
+58 ;
ADDUSER(XATR) ;Function. Add user using minimum attributes for user identification
+1 ; Input: XATR = Array containing user attributes (see above).
+2 ; Return: Fail = "-1^Error Message"
+3 ; Success = IEN of NEW PERSON file (#200) entry (Note: this routine will NOT set DUZ to the identified IEN)
+4 ;
+5 NEW SID,NEWDUZ,ERRMSG
+6 IF '$$AUTH()
QUIT "-1^Not an authorized calling routine"
+7 IF $GET(DUZ("LOA"))<2
QUIT "-1^Not authorized"
+8 SET ERRMSG=""
+9 ;Minimum 4 Attributes are required to add a new user
+10 IF ($GET(XATR(1))="")!($LENGTH($GET(XATR(1)))<4)
QUIT "-1^Subject Organization is required to add a new user"
+11 IF ($GET(XATR(2))="")!($LENGTH($GET(XATR(2)))<4)
QUIT "-1^Subject Organization ID is required to add a new user"
+12 IF $GET(XATR(3))=""
QUIT "-1^Unique User ID is required to add a new user"
+13 IF $GET(XATR(4))=""
QUIT "-1^Subject ID is required to add a new user"
+14 ; Format user attributes to match FileMan fields
+15 ;Subject Organization
SET XATR(1)=$$TITLE^XLFSTR($EXTRACT($GET(XATR(1)),1,50))
+16 ;Subject Organization ID
SET XATR(2)=$$LOW^XLFSTR($EXTRACT($GET(XATR(2)),1,50))
+17 ;Unique User ID
SET XATR(3)=$TRANSLATE($$LOW^XLFSTR($EXTRACT($GET(XATR(3)),1,40)),"^","%")
+18 ;
IF $GET(XATR(4))'=""
Begin DoDot:1
+19 ; Subject ID converted to standard format
SET SID=XATR(4)
SET XATR(4)=$$FORMAT^XLFNAME7(.SID,3,35,,0,,,2)
+20 IF $GET(XATR(4))'?1U.E1","1U.E
SET ERRMSG="-1^Subject ID could not be converted to VistA standard format"
End DoDot:1
if ERRMSG'=""
QUIT ERRMSG
+21 ;AD Network Username
SET XATR(6)=$$UP^XLFSTR($EXTRACT($GET(XATR(6)),1,15))
+22 ;SecID
SET XATR(7)=$TRANSLATE($EXTRACT($GET(XATR(7)),1,40),"^","%")
+23 ;Put the name in the .01 field first
SET NEWDUZ=$$ADDU(XATR(4))
+24 IF +NEWDUZ<1
QUIT "-1^Create of new user record failed"
+25 ;Then update the remaining fields
SET ERRMSG=$$UPDU(.XATR,NEWDUZ)
+26 ;Delete the added user if update fails (incomplete record)
IF +ERRMSG<0
DO CLEAN(NEWDUZ)
QUIT ERRMSG
+27 IF +NEWDUZ<1
QUIT "-1^Create or update of user record failed"
+28 IF ($GET(DUZ("REMAPP"))'="")
DO SETREMAP(NEWDUZ,$PIECE(DUZ("REMAPP"),"^"))
+29 ;Every thing OK
QUIT NEWDUZ
+30 ;
SECMATCH(SECID) ;Function. Find match for SECID.
+1 NEW Y,Z
+2 IF $GET(SECID)=""
QUIT ""
+3 SET Y=0
SET Z=0
+4 FOR
Begin DoDot:1
+5 ; p771
SET Y=$ORDER(^VA(200,"ASECID",$EXTRACT(SECID,1,40),Y))
+6 IF Y>0
Begin DoDot:2
+7 IF SECID=$PIECE($GET(^VA(200,Y,205)),U,1)
SET Z=Y
SET Y=""
End DoDot:2
QUIT
End DoDot:1
if Y=""
QUIT
+8 QUIT Z
+9 ;
UPNMATCH(ADUPN) ;Function. Find match for ADUPN.
+1 NEW W,Y,Z
+2 IF $GET(ADUPN)=""
QUIT ""
+3 SET W=$EXTRACT(ADUPN,1,30)
SET Y=0
SET Z=0
+4 FOR
Begin DoDot:1
+5 SET Y=$ORDER(^VA(200,"ADUPN",$GET(ADUPN),Y))
+6 IF Y>0
Begin DoDot:2
+7 IF ADUPN=$PIECE($GET(^VA(200,Y,205)),U,5)
SET Z=Y
SET Y=""
End DoDot:2
QUIT
End DoDot:1
if Y=""
QUIT
+8 QUIT Z
+9 ;
AOIUID(OID,UID) ;Function. Find match for OID+UID cross-reference.
+1 NEW W,X,Y,Z
+2 IF ($GET(OID)="")!($GET(UID)="")
QUIT ""
+3 SET W=$EXTRACT(OID,1,30)
SET X=$EXTRACT(UID,1,30)
SET Y=0
SET Z=0
+4 FOR
Begin DoDot:1
+5 SET Y=$ORDER(^VA(200,"AOIUID",W,X,Y))
+6 IF Y>0
Begin DoDot:2
+7 IF (OID=$PIECE($GET(^VA(200,Y,205)),U,3))&(UID=$PIECE($GET(^VA(200,Y,205)),U,4))
SET Z=Y
SET Y=""
End DoDot:2
QUIT
End DoDot:1
if Y=""
QUIT
+8 QUIT Z
+9 ;
NETMAIL(NETNAME,MAIL) ;Function. Find match for NETWORK USERNAME and EMAIL ADDRESS
+1 NEW L1,L2,N,Y,Z
+2 SET NETNAME=$GET(NETNAME)
SET MAIL=$GET(MAIL)
+3 SET L1=$LENGTH(NETNAME)
SET L2=$LENGTH(MAIL)
+4 if (L1=0)&(L2=0)
QUIT 0
+5 SET Y=0
SET Z=0
SET N=0
+6 FOR
Begin DoDot:1
+7 SET Y=$ORDER(^VA(200,Y))
+8 SET N=N+1
+9 IF (N#10000)=0
HANG 1
+10 IF Y>0
Begin DoDot:2
+11 IF L1
IF NETNAME=$PIECE($GET(^VA(200,Y,501)),U,1)
SET Z=Y
SET Y=""
QUIT
+12 IF L2
IF MAIL=$PIECE($GET(^VA(200,Y,.15)),U,1)
SET Z=Y
SET Y=""
QUIT
End DoDot:2
End DoDot:1
if Y=""
QUIT
+13 QUIT Z
+14 ;
ADDU(XUNAME) ;Function. Add a new name to the NPF
+1 NEW DD,DO,DIC,DA,X,Y,DUZZERO
+2 KILL ^TMP("DIERR",$JOB)
+3 SET DIC="^VA(200,"
SET DIC(0)="F"
SET X=XUNAME
+4 ; Get a LOCK. Block if can't get.
+5 LOCK +^VA(200,"HL7"):10
if '$TEST
QUIT "-1^Addition of new users is blocked"
+6 ;Make sure we can add the entry
SET DUZZERO=DUZ(0)
SET DUZ(0)="@"
+7 DO FILE^DICN
+8 ;Restore original FM access
SET DUZ(0)=DUZZERO
+9 LOCK -^VA(200,"HL7")
+10 QUIT +Y
+11 ;
UPDU(XATR,NEWDUZ) ;Function. Update user in the NPF
+1 NEW DUZZERO,DIC,ERRMSG,FDR,IEN,XUCODE,XUENTRY
+2 KILL ^TMP("DIERR",$JOB)
+3 SET DIC(0)=""
SET ERRMSG=""
+4 SET IEN=NEWDUZ_","
+5 ;SORG
IF ($GET(XATR(1))'="")
IF (XATR(1)'=$PIECE($GET(^VA(200,NEWDUZ,205)),U,2))
SET FDR(200,IEN,205.2)=$$TITLE^XLFSTR($EXTRACT($GET(XATR(1)),1,50))
+6 ;OID
IF ($GET(XATR(2))'="")
IF (XATR(2)'=$PIECE($GET(^VA(200,NEWDUZ,205)),U,3))
SET FDR(200,IEN,205.3)=$$LOW^XLFSTR($EXTRACT($GET(XATR(2)),1,50))
+7 ;UID
IF ($GET(XATR(3))'="")
IF (XATR(3)'=$PIECE($GET(^VA(200,NEWDUZ,205)),U,4))
SET FDR(200,IEN,205.4)=$TRANSLATE($$LOW^XLFSTR($EXTRACT($GET(XATR(3)),1,40)),"^","%")
+8 ;NETWORK USERNAME
IF ($GET(XATR(6))'="")
IF (XATR(6)'=$PIECE($GET(^VA(200,NEWDUZ,501)),U,1))
SET FDR(200,IEN,501.1)=$$UP^XLFSTR($EXTRACT($GET(XATR(6)),1,15))
+9 ;SecID
IF ($GET(XATR(7))'="")
IF (XATR(7)'=$PIECE($GET(^VA(200,NEWDUZ,205)),U,1))
SET FDR(200,IEN,205.1)=$TRANSLATE($EXTRACT($GET(XATR(7)),1,40),"^","%")
+10 ;NPI
IF ($GET(XATR(8))'="")
IF (XATR(8)'=$PIECE($GET(^VA(200,NEWDUZ,"NPI")),U,1))
SET FDR(200,IEN,41.99)=$GET(XATR(8))
+11 ;SSN
IF ($GET(XATR(9))'="")
IF (XATR(9)'=$PIECE($GET(^VA(200,NEWDUZ,1)),U,9))
SET ERRMSG=$$ADDS(.FDR,NEWDUZ,$GET(XATR(9)))
IF ERRMSG'=""
QUIT ERRMSG
+12 ;ADUPN
IF ($GET(XATR(10))'="")
IF (XATR(10)'=$PIECE($GET(^VA(200,NEWDUZ,205)),U,5))
SET FDR(200,IEN,205.5)=$$LOW^XLFSTR($GET(XATR(10)))
+13 ;e-mail
IF ($GET(XATR(11))'="")
IF (XATR(11)'=$PIECE($GET(^VA(200,NEWDUZ,.15)),U,1))
SET FDR(200,IEN,.151)=$$LOW^XLFSTR($GET(XATR(11)))
+14 ;Assign Context Option
IF $GET(XATR(5))'=""
SET ERRMSG=$$SETCNTXT(NEWDUZ,$GET(XATR(5)))
IF ERRMSG'=""
QUIT ERRMSG
+15 ; Apply all the changes
+16 ;Make sure we can update the entry
SET DUZZERO=DUZ(0)
SET DUZ(0)="@"
+17 ;File all the data
IF $DATA(FDR)
KILL IEN
DO UPDATE^DIE("E","FDR","IEN")
+18 ;Restore original FM access
SET DUZ(0)=DUZZERO
+19 ;FileMan Error
IF $DATA(^TMP("DIERR",$JOB))
QUIT "-1^FileMan error"
+20 ;Couldn't update user
IF +ERRMSG<1
QUIT ERRMSG
+21 IF +NEWDUZ<1
QUIT "-1^Update of user record failed"
+22 QUIT ""
+23 ;
ADDS(FDR,NEWDUZ,SSN) ;Function. Add a SSN to the NPF
+1 NEW IEN,ERRMSG
+2 SET IEN=NEWDUZ_","
SET ERRMSG=""
+3 IF '$$SSNCHECK^XUESSO1(SSN)
QUIT "-1^SSN is not valid per SSA criteria"
+4 SET FDR(200,IEN,9)=SSN
+5 QUIT ERRMSG
+6 ;
CLEAN(Y) ;Subroutine. Clean up (delete) incomplete record in NPF
+1 ; ZEXCEPT: DA,DIK
+2 NEW DUZZERO
+3 ;Make sure we can update the entry
SET DUZZERO=DUZ(0)
SET DUZ(0)="@"
+4 IF +Y>0
Begin DoDot:1
+5 KILL DA,DIK
SET DIK="^VA(200,"
SET DA=+Y
DO ^DIK
End DoDot:1
+6 ;Restore original FM access
SET DUZ(0)=DUZZERO
+7 QUIT
+8 ;
SETCNTXT(NEWDUZ,XAPHRASE) ;Function. Assign Context Option to user Secondary Menu Options
+1 NEW OPT,XUENTRY,XOPT,XUCONTXT,X
+2 SET XUENTRY=$$GETCNTXT(XAPHRASE)
IF +XUENTRY<0
QUIT XUENTRY
+3 SET DUZ("REMAPP")=XUENTRY_U_$$GET1^DIQ(8994.5,XUENTRY_",",.01)
+4 SET XOPT=$PIECE($GET(^XWB(8994.5,XUENTRY,0)),U,2)
+5 IF XOPT'>0
QUIT "-1^Context Option must be identified in the REMOTE APPLICATION file"
+6 SET XUCONTXT="`"_XOPT
+7 IF $$FIND1^DIC(19,"","X",XUCONTXT)'>0
QUIT "-1^Context Option not in OPTION file"
+8 ;Have to use $D because of screen in 200.03 keeps FIND1^DIC from working.
+9 IF '$DATA(^VA(200,NEWDUZ,203,"B",XOPT))
Begin DoDot:1
+10 ; Have to give the user a delegated option
+11 NEW XARR
SET XARR(200.19,"+1,"_NEWDUZ_",",.01)=XUCONTXT
+12 DO UPDATE^DIE("E","XARR")
+13 ; And now user can give self the context option
+14 KILL XARR
SET XARR(200.03,"+1,"_NEWDUZ_",",.01)=XUCONTXT
+15 ; Give context option as a secondary menu item
DO UPDATE^DIE("E","XARR")
+16 ; But now we have to remove the delegated option
+17 SET OPT=$$FIND1^DIC(200.19,","_NEWDUZ_",","X",XUCONTXT)
+18 IF OPT>0
Begin DoDot:2
+19 KILL XARR
SET XARR(200.19,(OPT_","_NEWDUZ_","),.01)="@"
+20 DO FILE^DIE("E","XARR")
+21 QUIT
End DoDot:2
+22 QUIT
End DoDot:1
+23 QUIT ""
+24 ;
GETCNTXT(XAPHRASE) ;Function. Identify the REMOTE APPLICATION
+1 NEW XUCODE,XUENTRY
+2 ;Identify Remote Application with SHA256 hash
+3 ; ICR #6189
SET XUCODE=$$SHAHASH^XUSHSH(256,$GET(XAPHRASE),"B")
+4 SET XUENTRY=$$FIND1^DIC(8994.5,"","X",XUCODE,"ACODE")
+5 ;If not found, check with old hash and replace with SHA256 hash if found
+6 IF XUENTRY'>0
Begin DoDot:1
+7 ; IA #10045
SET XUCODE=$$EN^XUSHSH($GET(XAPHRASE))
+8 SET XUENTRY=$$FIND1^DIC(8994.5,"","X",XUCODE,"ACODE")
+9 IF XUENTRY>0
Begin DoDot:2
+10 ; ICR #6189
SET XUCODE=$$SHAHASH^XUSHSH(256,$GET(XAPHRASE),"B")
+11 NEW FDR
+12 SET FDR(8994.5,XUENTRY_",",.03)=XUCODE
+13 DO FILE^DIE("E","FDR")
End DoDot:2
End DoDot:1
+14 ;If not found, check with lowercase hash (called by ^XUSAML) p779
+15 IF XUENTRY'>0
Begin DoDot:1
+16 ; ICR #6189
SET XUCODE=$$SHAHASH^XUSHSH(256,$$LOW^XLFSTR($GET(XAPHRASE)),"B")
+17 SET XUENTRY=$$FIND1^DIC(8994.5,"","X",XUCODE,"ACODE")
End DoDot:1
+18 ;If not found, check with old hash (using lowercase) and replace with SHA256 hash if found p779
+19 IF XUENTRY'>0
Begin DoDot:1
+20 ; IA #10045
SET XUCODE=$$EN^XUSHSH($$LOW^XLFSTR($GET(XAPHRASE)))
+21 SET XUENTRY=$$FIND1^DIC(8994.5,"","X",XUCODE,"ACODE")
+22 IF XUENTRY>0
Begin DoDot:2
+23 ; ICR #6189
SET XUCODE=$$SHAHASH^XUSHSH(256,$$LOW^XLFSTR($GET(XAPHRASE)),"B")
+24 NEW FDR
+25 SET FDR(8994.5,XUENTRY_",",.03)=XUCODE
+26 DO FILE^DIE("E","FDR")
End DoDot:2
End DoDot:1
+27 IF XUENTRY'>0
QUIT "-1^Application ID must be registered in the REMOTE APPLICATION file"
+28 QUIT XUENTRY
+29 ;
AUTH() ;Function. Check if calling routine is authorized
+1 ; ^XUESSO2 does not address the security issue of user authentication, so a restriction is placed on the calling routine.
+2 NEW X,Z
+3 ;look at current stack, not error stack
SET $ECODE=""
+4 SET X=$STACK($STACK-2,"PLACE")
SET Z=$PIECE(X,"^",2)
SET X="^"_$PIECE(Z," ")
+5 ;Authorized Kernel access
IF $EXTRACT(X,1,3)="^XU"
QUIT 1
+6 QUIT 0
+7 ;
SETREMAP(USER,REMAPP) ; user created by remote application
+1 NEW IEN,FDR
+2 if $GET(USER)<1
QUIT
+3 SET IEN=USER_","
+4 SET FDR(200,IEN,202.06)=$GET(REMAPP)
KILL IEN
DO UPDATE^DIE("","FDR","IEN")
+5 QUIT
+6 ;
