Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: XUESSO2

XUESSO2.m

Go to the documentation of this file.
  1. 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
  1. ;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. ; This utility will identify a VistA user for auditing and HIPAA requirements.
  1. ; NONE of the fields listed below can contain a caret (^) character as it is used as a delimiter in VistA!
  1. ;
  1. ; $$FINDUSER() - At least one of the following attributes is required to uniquely identify an existing user in the
  1. ; NEW PERSON file (#200):
  1. ;
  1. ; XATR(7) = unique Security ID [SecID, assigned by Identity and Access Management]
  1. ; XATR(8) = unique National Provider Identifier [assigned by Centers for Medicare and Medicaid Services (CMS)]
  1. ; XATR(9) = unique Social Security (SSN) or Taxpayer Identification Number (TIN) [assigned by the Social Security Administration]
  1. ; XATR(2) and XATR(3) = combination of a unique Subject Organization ID (OID) with a Unique User ID (UID) [see below]
  1. ;
  1. ; $$ADDUSER() - If an existing user is not found in the NEW PERSON file (#200), then the following minimum attributes
  1. ; are required to provision a new user:
  1. ;
  1. ; XATR(1) = Subject Organization [free text, 3-50 characters]
  1. ; XATR(2) = Subject Organization ID [free text, 1-50 characters, unique to Subject Organization]
  1. ; XATR(3) = Unique User ID [free text, 1-40 characters, unique within OID]
  1. ; XATR(4) = Subject ID [person's name, to be entered into the NAME field (#.01) of the NEW PERSON file (#200)]
  1. ;
  1. ; The following attributes are optional for adding or updating a user, but may be required by a particular VistA application
  1. ; for further Identity and Access Management:
  1. ;
  1. ; XATR(5) = Application ID [Security Phrase to identify and authenticate the client application and establish the context option]
  1. ; XATR(6) = Network Username [Active Directory Login]
  1. ; XATR(9) = unique Social Security (SSN) or Taxpayer Identification Number (TIN) [assigned by the Social Security Administration]
  1. ; XATR(10)= AD UPN [Active Directory User Principle Name (UPN)]
  1. ; XATR(11)= E-Mail Address
  1. Q
  1. ;
  1. FINDUSER(XATR) ;Function. Find user using minimum attributes for user identification
  1. ; Input: XATR = Array containing user attributes (see above).
  1. ; Return: Fail = "-1^Error Message"
  1. ; Success = IEN of NEW PERSON file (#200) entry (Note: this routine will NOT set DUZ to the identified IEN)
  1. ;
  1. N TODAY,DT,IEN,DIC,XUNAME,ERRMSG
  1. S U="^",TODAY=$$HTFM^XLFDT($H),DT=$P(TODAY,"."),ERRMSG=""
  1. ; Check for unique identifier (SecID, NPI, SSN, or OID+UID)
  1. 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"
  1. ; Format user attributes to match FileMan fields
  1. S XATR(1)=$$TITLE^XLFSTR($E($G(XATR(1)),1,50)) ;Subject Organization
  1. S XATR(2)=$$LOW^XLFSTR($E($G(XATR(2)),1,50)) ;Subject Organization ID
  1. S XATR(3)=$TR($$LOW^XLFSTR($E($G(XATR(3)),1,40)),"^","%") ;Unique User ID
  1. ;p701
  1. ;I $G(XATR(4))'="" D Q:ERRMSG'="" ERRMSG
  1. ;. S XUNAME=XATR(4) S XATR(4)=$$FORMAT^XLFNAME7(.XUNAME,3,35,,0,,,2) ;Subject ID converted to standard format
  1. ;. 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"
  1. S XATR(6)=$$UP^XLFSTR($E($G(XATR(6)),1,50)) ;AD Network Username
  1. S XATR(7)=$TR($E($G(XATR(7)),1,40),"^","%") ;SecID
  1. Q $$TALL(.XATR)
  1. ;
  1. TALL(XATR) ;Function. Find an existing user.
  1. N OID,UID,SECID,NPI,SSN,NEWDUZ,ERRMSG,AOIUID,X,Y,Z
  1. S $ECODE="" ;look at current stack, not error stack
  1. S X=$ST($ST-1,"PLACE"),Y=$P(X,"+"),Z=$P(X,"^",2),X=Y_"^"_$P(Z," ")
  1. I X'="FINDUSER^XUESSO2" Q "-1^Not authorized"
  1. I $G(DUZ("LOA"))<2 Q "-1^Not authorized"
  1. S OID=$G(XATR(2))
  1. S UID=$G(XATR(3))
  1. S SECID=$G(XATR(7))
  1. S NPI=$G(XATR(8))
  1. S SSN=$G(XATR(9))
  1. S ERRMSG="",NEWDUZ=0,Y=0
  1. ;See if match SECID, to be assigned by Identification and Access Management (IAM) services.
  1. I $L(SECID)>0 D Q:ERRMSG'="" ERRMSG
  1. . S Y=$$SECMATCH(SECID) Q:Y<1
  1. . ;I NPI'="" D Q:ERRMSG'=""
  1. . ;. I NPI'=$P($G(^VA(200,Y,"NPI")),U) S ERRMSG="-1^NPI mismatch for user ID'd by SecID" Q
  1. . ;I SSN'="" D Q:ERRMSG'=""
  1. . ;. I SSN'=$P($G(^VA(200,Y,1)),U,9) S ERRMSG="-1^SSN mismatch for user ID'd by SecID" Q
  1. . S NEWDUZ=Y
  1. . S ERRMSG=$$UPDU(.XATR,NEWDUZ) ; Update fields if changes are needed
  1. . Q
  1. I NEWDUZ>0 Q NEWDUZ ;Quit here if we found a match on SECID
  1. ;See if match NPI
  1. I $L(NPI)>0 D Q:ERRMSG'="" ERRMSG
  1. . S Y=+$O(^VA(200,"ANPI",NPI,0)) Q:Y<1
  1. . ;I SECID'="" D Q:ERRMSG'=""
  1. . ;. I $$SECMATCH(SECID)<1 S ERRMSG="-1^SecID mismatch for user ID'd by NPI" Q
  1. . ;I SSN'="" D Q:ERRMSG'=""
  1. . ;. I SSN'=$P($G(^VA(200,Y,1)),U,9) S ERRMSG="-1^SSN mismatch for user ID'd by NPI" Q
  1. . S NEWDUZ=Y
  1. . S ERRMSG=$$UPDU(.XATR,NEWDUZ) ; Update fields if changes are needed
  1. . Q
  1. I NEWDUZ>0 Q NEWDUZ ;Quit here if we found a match on NPI
  1. ;See if match SSN
  1. I $L(SSN)>0 D Q:ERRMSG'="" ERRMSG
  1. . S Y=+$O(^VA(200,"SSN",SSN,0)) Q:Y<1
  1. . ;I SECID'="" D Q:ERRMSG'=""
  1. . ;. I $$SECMATCH(SECID)<1 S ERRMSG="-1^SecID mismatch for user ID'd by SSN" Q
  1. . ;I NPI'="" D Q:ERRMSG'=""
  1. . ;. I NPI'=$P($G(^VA(200,Y,"NPI")),U) S ERRMSG="-1^NPI mismatch for user ID'd by SSN" Q
  1. . S NEWDUZ=Y
  1. . S ERRMSG=$$UPDU(.XATR,NEWDUZ) ; Update fields if changes are needed
  1. . Q
  1. I NEWDUZ>0 Q NEWDUZ ;Quit here if we found a match on SSN
  1. ;See if match OID+UID ("AOIUID" cross-reference).
  1. S Y=$$AOIUID(OID,UID) I Y>0 D Q:ERRMSG'="" ERRMSG
  1. . ;I SECID'="" D Q:ERRMSG'=""
  1. . ;. I $$SECMATCH(SECID)<1 S ERRMSG="-1^SecID mismatch for user ID'd by OID+UID" Q
  1. . ;I NPI'="" D Q:ERRMSG'=""
  1. . ;. I NPI'=$P($G(^VA(200,Y,"NPI")),U) S ERRMSG="-1^NPI mismatch for user ID'd by OID+UID" Q
  1. . ;I SSN'="" D Q:ERRMSG'=""
  1. . ;. I SSN'=$P($G(^VA(200,Y,1)),U,9) S ERRMSG="-1^SSN mismatch for user ID'd by OID+UID" Q
  1. . S NEWDUZ=Y
  1. . S ERRMSG=$$UPDU(.XATR,NEWDUZ) ; Update fields if changes are needed
  1. . Q
  1. I NEWDUZ>0 Q NEWDUZ ;Quit here if we found a match on OID+UID
  1. Q "-1^User not found"
  1. ;
  1. ADDUSER(XATR) ;Function. Add user using minimum attributes for user identification
  1. ; Input: XATR = Array containing user attributes (see above).
  1. ; Return: Fail = "-1^Error Message"
  1. ; Success = IEN of NEW PERSON file (#200) entry (Note: this routine will NOT set DUZ to the identified IEN)
  1. ;
  1. N SID,NEWDUZ,ERRMSG
  1. I '$$AUTH() Q "-1^Not an authorized calling routine"
  1. I $G(DUZ("LOA"))<2 Q "-1^Not authorized"
  1. S ERRMSG=""
  1. ;Minimum 4 Attributes are required to add a new user
  1. I ($G(XATR(1))="")!($L($G(XATR(1)))<4) Q "-1^Subject Organization is required to add a new user"
  1. I ($G(XATR(2))="")!($L($G(XATR(2)))<4) Q "-1^Subject Organization ID is required to add a new user"
  1. I $G(XATR(3))="" Q "-1^Unique User ID is required to add a new user"
  1. I $G(XATR(4))="" Q "-1^Subject ID is required to add a new user"
  1. ; Format user attributes to match FileMan fields
  1. S XATR(1)=$$TITLE^XLFSTR($E($G(XATR(1)),1,50)) ;Subject Organization
  1. S XATR(2)=$$LOW^XLFSTR($E($G(XATR(2)),1,50)) ;Subject Organization ID
  1. S XATR(3)=$TR($$LOW^XLFSTR($E($G(XATR(3)),1,40)),"^","%") ;Unique User ID
  1. I $G(XATR(4))'="" D Q:ERRMSG'="" ERRMSG ;
  1. . S SID=XATR(4) S XATR(4)=$$FORMAT^XLFNAME7(.SID,3,35,,0,,,2) ; Subject ID converted to standard format
  1. . I $G(XATR(4))'?1U.E1","1U.E S ERRMSG="-1^Subject ID could not be converted to VistA standard format"
  1. S XATR(6)=$$UP^XLFSTR($E($G(XATR(6)),1,15)) ;AD Network Username
  1. S XATR(7)=$TR($E($G(XATR(7)),1,40),"^","%") ;SecID
  1. S NEWDUZ=$$ADDU(XATR(4)) ;Put the name in the .01 field first
  1. I +NEWDUZ<1 Q "-1^Create of new user record failed"
  1. S ERRMSG=$$UPDU(.XATR,NEWDUZ) ;Then update the remaining fields
  1. I +ERRMSG<0 D CLEAN(NEWDUZ) Q ERRMSG ;Delete the added user if update fails (incomplete record)
  1. I +NEWDUZ<1 Q "-1^Create or update of user record failed"
  1. I ($G(DUZ("REMAPP"))'="") D SETREMAP(NEWDUZ,$P(DUZ("REMAPP"),"^"))
  1. Q NEWDUZ ;Every thing OK
  1. ;
  1. SECMATCH(SECID) ;Function. Find match for SECID.
  1. N Y,Z
  1. I $G(SECID)="" Q ""
  1. S Y=0,Z=0
  1. F D Q:Y=""
  1. . S Y=$O(^VA(200,"ASECID",$E(SECID,1,40),Y)) ; p771
  1. . I Y>0 D Q
  1. . . I SECID=$P($G(^VA(200,Y,205)),U,1) S Z=Y,Y=""
  1. Q Z
  1. ;
  1. UPNMATCH(ADUPN) ;Function. Find match for ADUPN.
  1. N W,Y,Z
  1. I $G(ADUPN)="" Q ""
  1. S W=$E(ADUPN,1,30),Y=0,Z=0
  1. F D Q:Y=""
  1. . S Y=$O(^VA(200,"ADUPN",$G(ADUPN),Y))
  1. . I Y>0 D Q
  1. . . I ADUPN=$P($G(^VA(200,Y,205)),U,5) S Z=Y,Y=""
  1. Q Z
  1. ;
  1. AOIUID(OID,UID) ;Function. Find match for OID+UID cross-reference.
  1. N W,X,Y,Z
  1. I ($G(OID)="")!($G(UID)="") Q ""
  1. S W=$E(OID,1,30),X=$E(UID,1,30),Y=0,Z=0
  1. F D Q:Y=""
  1. . S Y=$O(^VA(200,"AOIUID",W,X,Y))
  1. . I Y>0 D Q
  1. . . I (OID=$P($G(^VA(200,Y,205)),U,3))&(UID=$P($G(^VA(200,Y,205)),U,4)) S Z=Y,Y=""
  1. Q Z
  1. ;
  1. NETMAIL(NETNAME,MAIL) ;Function. Find match for NETWORK USERNAME and EMAIL ADDRESS
  1. N L1,L2,N,Y,Z
  1. S NETNAME=$G(NETNAME),MAIL=$G(MAIL)
  1. S L1=$L(NETNAME),L2=$L(MAIL)
  1. Q:(L1=0)&(L2=0) 0
  1. S Y=0,Z=0,N=0
  1. F D Q:Y=""
  1. . S Y=$O(^VA(200,Y))
  1. . S N=N+1
  1. . I (N#10000)=0 H 1
  1. . I Y>0 D
  1. . . I L1,NETNAME=$P($G(^VA(200,Y,501)),U,1) S Z=Y,Y="" Q
  1. . . I L2,MAIL=$P($G(^VA(200,Y,.15)),U,1) S Z=Y,Y="" Q
  1. Q Z
  1. ;
  1. ADDU(XUNAME) ;Function. Add a new name to the NPF
  1. N DD,DO,DIC,DA,X,Y,DUZZERO
  1. K ^TMP("DIERR",$J)
  1. S DIC="^VA(200,",DIC(0)="F",X=XUNAME
  1. ; Get a LOCK. Block if can't get.
  1. L +^VA(200,"HL7"):10 Q:'$T "-1^Addition of new users is blocked"
  1. S DUZZERO=DUZ(0),DUZ(0)="@" ;Make sure we can add the entry
  1. D FILE^DICN
  1. S DUZ(0)=DUZZERO ;Restore original FM access
  1. L -^VA(200,"HL7")
  1. Q +Y
  1. ;
  1. UPDU(XATR,NEWDUZ) ;Function. Update user in the NPF
  1. N DUZZERO,DIC,ERRMSG,FDR,IEN,XUCODE,XUENTRY
  1. K ^TMP("DIERR",$J)
  1. S DIC(0)="",ERRMSG=""
  1. S IEN=NEWDUZ_","
  1. 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
  1. 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
  1. 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
  1. 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
  1. 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
  1. I ($G(XATR(8))'=""),(XATR(8)'=$P($G(^VA(200,NEWDUZ,"NPI")),U,1)) S FDR(200,IEN,41.99)=$G(XATR(8)) ;NPI
  1. 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
  1. 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
  1. 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
  1. I $G(XATR(5))'="" S ERRMSG=$$SETCNTXT(NEWDUZ,$G(XATR(5))) I ERRMSG'="" Q ERRMSG ;Assign Context Option
  1. ; Apply all the changes
  1. S DUZZERO=DUZ(0),DUZ(0)="@" ;Make sure we can update the entry
  1. I $D(FDR) K IEN D UPDATE^DIE("E","FDR","IEN") ;File all the data
  1. S DUZ(0)=DUZZERO ;Restore original FM access
  1. I $D(^TMP("DIERR",$J)) Q "-1^FileMan error" ;FileMan Error
  1. I +ERRMSG<1 Q ERRMSG ;Couldn't update user
  1. I +NEWDUZ<1 Q "-1^Update of user record failed"
  1. Q ""
  1. ;
  1. ADDS(FDR,NEWDUZ,SSN) ;Function. Add a SSN to the NPF
  1. N IEN,ERRMSG
  1. S IEN=NEWDUZ_",",ERRMSG=""
  1. I '$$SSNCHECK^XUESSO1(SSN) Q "-1^SSN is not valid per SSA criteria"
  1. S FDR(200,IEN,9)=SSN
  1. Q ERRMSG
  1. ;
  1. CLEAN(Y) ;Subroutine. Clean up (delete) incomplete record in NPF
  1. ; ZEXCEPT: DA,DIK
  1. N DUZZERO
  1. S DUZZERO=DUZ(0),DUZ(0)="@" ;Make sure we can update the entry
  1. I +Y>0 D
  1. . K DA,DIK S DIK="^VA(200,",DA=+Y D ^DIK
  1. S DUZ(0)=DUZZERO ;Restore original FM access
  1. Q
  1. ;
  1. SETCNTXT(NEWDUZ,XAPHRASE) ;Function. Assign Context Option to user Secondary Menu Options
  1. N OPT,XUENTRY,XOPT,XUCONTXT,X
  1. S XUENTRY=$$GETCNTXT(XAPHRASE) I +XUENTRY<0 Q XUENTRY
  1. S DUZ("REMAPP")=XUENTRY_U_$$GET1^DIQ(8994.5,XUENTRY_",",.01)
  1. S XOPT=$P($G(^XWB(8994.5,XUENTRY,0)),U,2)
  1. I XOPT'>0 Q "-1^Context Option must be identified in the REMOTE APPLICATION file"
  1. S XUCONTXT="`"_XOPT
  1. I $$FIND1^DIC(19,"","X",XUCONTXT)'>0 Q "-1^Context Option not in OPTION file"
  1. ;Have to use $D because of screen in 200.03 keeps FIND1^DIC from working.
  1. I '$D(^VA(200,NEWDUZ,203,"B",XOPT)) D
  1. . ; Have to give the user a delegated option
  1. . N XARR S XARR(200.19,"+1,"_NEWDUZ_",",.01)=XUCONTXT
  1. . D UPDATE^DIE("E","XARR")
  1. . ; And now user can give self the context option
  1. . K XARR S XARR(200.03,"+1,"_NEWDUZ_",",.01)=XUCONTXT
  1. . D UPDATE^DIE("E","XARR") ; Give context option as a secondary menu item
  1. . ; But now we have to remove the delegated option
  1. . S OPT=$$FIND1^DIC(200.19,","_NEWDUZ_",","X",XUCONTXT)
  1. . I OPT>0 D
  1. . . K XARR S XARR(200.19,(OPT_","_NEWDUZ_","),.01)="@"
  1. . . D FILE^DIE("E","XARR")
  1. . . Q
  1. . Q
  1. Q ""
  1. ;
  1. GETCNTXT(XAPHRASE) ;Function. Identify the REMOTE APPLICATION
  1. N XUCODE,XUENTRY
  1. ;Identify Remote Application with SHA256 hash
  1. S XUCODE=$$SHAHASH^XUSHSH(256,$G(XAPHRASE),"B") ; ICR #6189
  1. S XUENTRY=$$FIND1^DIC(8994.5,"","X",XUCODE,"ACODE")
  1. ;If not found, check with old hash and replace with SHA256 hash if found
  1. I XUENTRY'>0 D
  1. . S XUCODE=$$EN^XUSHSH($G(XAPHRASE)) ; IA #10045
  1. . S XUENTRY=$$FIND1^DIC(8994.5,"","X",XUCODE,"ACODE")
  1. . I XUENTRY>0 D
  1. . . S XUCODE=$$SHAHASH^XUSHSH(256,$G(XAPHRASE),"B") ; ICR #6189
  1. . . N FDR
  1. . . S FDR(8994.5,XUENTRY_",",.03)=XUCODE
  1. . . D FILE^DIE("E","FDR")
  1. ;If not found, check with lowercase hash (called by ^XUSAML) p779
  1. I XUENTRY'>0 D
  1. . S XUCODE=$$SHAHASH^XUSHSH(256,$$LOW^XLFSTR($G(XAPHRASE)),"B") ; ICR #6189
  1. . S XUENTRY=$$FIND1^DIC(8994.5,"","X",XUCODE,"ACODE")
  1. ;If not found, check with old hash (using lowercase) and replace with SHA256 hash if found p779
  1. I XUENTRY'>0 D
  1. . S XUCODE=$$EN^XUSHSH($$LOW^XLFSTR($G(XAPHRASE))) ; IA #10045
  1. . S XUENTRY=$$FIND1^DIC(8994.5,"","X",XUCODE,"ACODE")
  1. . I XUENTRY>0 D
  1. . . S XUCODE=$$SHAHASH^XUSHSH(256,$$LOW^XLFSTR($G(XAPHRASE)),"B") ; ICR #6189
  1. . . N FDR
  1. . . S FDR(8994.5,XUENTRY_",",.03)=XUCODE
  1. . . D FILE^DIE("E","FDR")
  1. I XUENTRY'>0 Q "-1^Application ID must be registered in the REMOTE APPLICATION file"
  1. Q XUENTRY
  1. ;
  1. 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.
  1. N X,Z
  1. S $ECODE="" ;look at current stack, not error stack
  1. S X=$ST($ST-2,"PLACE"),Z=$P(X,"^",2),X="^"_$P(Z," ")
  1. I $E(X,1,3)="^XU" Q 1 ;Authorized Kernel access
  1. Q 0
  1. ;
  1. SETREMAP(USER,REMAPP) ; user created by remote application
  1. N IEN,FDR
  1. Q:$G(USER)<1
  1. S IEN=USER_","
  1. S FDR(200,IEN,202.06)=$G(REMAPP) K IEN D UPDATE^DIE("","FDR","IEN")
  1. Q
  1. ;