- 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 Feb 18, 2025@23:35:51 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 ;