XUESSO3 ;ISD/HGW Enhanced Single Sign-On Utilities ;02/25/16 15:33
;;8.0;KERNEL;**655,659**;Jul 10, 1995;Build 22
;Per VA Directive 6402, this routine should not be modified.
;
Q
IAMFU(R,NAME,SSN,DOB,ADUPN,SECID,AUTHCODE) ;RPC. XUS IAM FIND USER - IA #6288
; The XUSHOWSSN key is required to do lookups using PII (SSN or DoB).
; Input: One or more of Name, SSN, DoB, AD UPN, and/or SecID must be provided.
; AUTHCODE = Security Phrase for IAM Provisioning Application
; Return: Fail R(0)="-1^Error Message"
; Success R(0)=total number of entries found, from "0" to "n".
; R(1) through R(n)="DUZ^Name^NameComponents^SSN^Dob^AD UPN^SecID"
;
; ZEXCEPT: %DT
N X,XARRY,XCOUNT,XI,XJ,XNAME,XRESULT,XSHOWSSN,XTEMP,XUENTRY,XUIAM,Y
K R
I DUZ'>1 S R(0)="-1^Unauthorized access" Q
S XUENTRY=$$GETCNTXT^XUESSO2($G(AUTHCODE)) I +XUENTRY<0 S R(0)=XUENTRY Q
I $P($G(^XWB(8994.5,XUENTRY,0)),U)'="IAM PROVISIONING" S R(0)="-1^Unauthorized access" Q
S XUIAM=1 ;Do not trigger IAM updates
S XSHOWSSN=$$KCHK^XUSRB("XUSHOWSSN")
S XCOUNT=0
; 1. Search by NAME
I $G(NAME)'="" D
. D FIND^DIC(200,"","@","PC",NAME,"*","B")
. S XI=0 F S XI=$O(^TMP("DILIST",$J,XI)) Q:'XI D
. . S XRESULT=$G(^TMP("DILIST",$J,XI,0))
. . D:XRESULT>0 ADDTOLST(.R,.XCOUNT,XSHOWSSN,XRESULT)
. D CLEAN^DILF
. K ^TMP("DILIST",$J)
; 2. Search by SSN
I ($G(SSN)'="")&($G(XSHOWSSN)=1) D
. S XARRY(9)=SSN
. S XRESULT=$$FINDUSER^XUESSO2(.XARRY)
. I +XRESULT>0 D ADDTOLST(.R,.XCOUNT,XSHOWSSN,XRESULT)
. K XARRY(9)
; 3. Search by DOB
I ($G(DOB)'="")&($G(XSHOWSSN)=1) D
. S X=DOB,%DT="X" D ^%DT S X=Y,XRESULT=0
. F D Q:XRESULT=""
. . S XRESULT=$O(^VA(200,XRESULT)) Q:XRESULT=""
. . I $P($G(^VA(200,XRESULT,1)),U,3)=X D ADDTOLST(.R,.XCOUNT,XSHOWSSN,XRESULT)
; 4. Search by ADUPN
I $G(ADUPN)'="" D
. S X=$$LOW^XLFSTR(ADUPN),XRESULT=0
. S XRESULT=$$UPNMATCH^XUESSO2(ADUPN)
. I XRESULT>0 D ADDTOLST(.R,.XCOUNT,XSHOWSSN,XRESULT)
; 5. Search by SECID
I $G(SECID)'="" D
. S XARRY(7)=SECID
. S XRESULT=$$FINDUSER^XUESSO2(.XARRY)
. I +XRESULT>0 D ADDTOLST(.R,.XCOUNT,XSHOWSSN,XRESULT)
. K XARRY(7)
; 6. Return results
S R(0)=XCOUNT
Q
;
IAMDU(R,DISPDUZ,AUTHCODE) ;RPC. XUS IAM DISPLAY USER - IA #6289
; Input: DISPDUZ = DUZ (IEN) of user to be displayed
; AUTHCODE = Security Phrase for IAM Provisioning Application
; Return: Fail R(0) ="-1^Error Message"
; Success R(0) = 1
; R("NAME") = NAME
; R("LASTNAME") = Family Name
; R("FIRSTNAME") = Given Name
; R("MIDDLENAME") = Middle Name
; R("SUFFIX") = Suffix(es)
; R("INITIAL") = INITIAL
; R("TITLE") = TITLE
; R("NICK_NAME") = NICK NAME
; R("SSN") = SSN (<Hidden> if caller does not have XUSHOWSSN key)
; R("DOB") = DOB (<Hidden> if caller does not have XUSHOWSSN key)
; R("DEGREE") = DEGREE
; R("MAIL_CODE") = MAIL CODE
; R("STATUS") = $$ACTIVE^XUSER(DISPDUZ)
; R("DISUSER") = DISUSER
; R("TERMINATION_DATE") = TERMINATION DATE
; R("TERMINATION_REASON") = TERMINATION REASON
; R("PRIMARY_MENU_OPTION") = PRIMARY MENU OPTION
; R("SECONDARY_MENU_OPTION",0) = SECONDARY MENU OPTION (number of entries)
; R("SECONDARY_MENU_OPTION",1) to R("SECONDARY_MENU_OPTION",n) = SECONDARY MENU OPTION entries
; R("FILE_MANAGER_ACCESS_CODE") = FILE MANAGER ACCESS CODE
; R("DIVISION",0) = DIVISION (number of entries)
; R("DIVISION",1) to R("DIVISION",n) = DIVISION entries
; R("SERVICE_SECTION") = SERVICE/SECTION
; R("SUBJECT_ALTERNATIVE_NAME") = SUBJECT ALTERNATIVE NAME (PIV CARD)
; R("SECID") = SECID
; R("ORGANIZATION_NAME") = SUBJECT ORGANIZATION
; R("ORGANIZATION_ID") = SUBJECT ORGANIZATION ID
; R("UNIQUE_USER_ID") = UNIQUE USER ID
; R("NETWORK_USER_NAME") = NETWORK USERNAME
; R("AD_UPN") = ADUPN
; R("EMAIL") = EMAIL ADDRESS
; R("GENDER") = SEX (M/F)
;
N X,XI,XIEN,XJ,XN,XSHOWSSN,XT,XT1,XT205,XT5,XT501,XUENTRY,XUIAM,Y
K R
I DUZ'>1 S R(0)="-1^Unauthorized access" Q
S XUENTRY=$$GETCNTXT^XUESSO2($G(AUTHCODE)) I +XUENTRY<0 S R(0)=XUENTRY Q
I $P($G(^XWB(8994.5,XUENTRY,0)),U)'="IAM PROVISIONING" S R(0)="-1^Unauthorized access" Q
I $G(DUZ("LOA"))<2 S R(0)="-1^Unauthorized access" Q
I $G(DISPDUZ)'>0 S R(0)="-1^User not selected" Q
I $G(^VA(200,DISPDUZ,0))="" S R(0)="-1^User not found" Q
S XUIAM=1 ;Do not trigger IAM updates
S XSHOWSSN=$$KCHK^XUSRB("XUSHOWSSN")
S XT=$G(^VA(200,DISPDUZ,0))
S XT1=$G(^VA(200,DISPDUZ,1))
S XT5=$G(^VA(200,DISPDUZ,5))
S XT205=$G(^VA(200,DISPDUZ,205))
S XT501=$G(^VA(200,DISPDUZ,501))
S R(0)=1
S (XN,R("NAME"))=$P($G(XT),U)
S XIEN=DISPDUZ_","
S X=0 S X=$O(^VA(20,"BB",200,.01,XIEN,X)) ;Get NAME COMPONENTS
S Y="" I +X>0 S Y=$G(^VA(20,X,1))
S R("LASTNAME")=$P(Y,U)
S R("FIRSTNAME")=$P(Y,U,2)
S R("MIDDLENAME")=$P(Y,U,3)
S R("SUFFIX")=$P(Y,U,4)
S R("INITIAL")=$P($G(XT),U,2)
S R("TITLE")="" S X=$P($G(XT),U,9)
I $G(X)>0 S R("TITLE")=$P($G(^DIC(3.1,X,0)),U)
S R("NICK_NAME")=$P($G(^VA(200,DISPDUZ,.1)),U,4)
S R("SSN")="<Hidden>" I $G(XSHOWSSN)=1 S R("SSN")=$P($G(XT1),U,9)
S R("DOB")="<Hidden>" I $G(XSHOWSSN)=1 S R("DOB")=$TR($$FMTE^XLFDT($P($G(XT1),U,3),"5DZ"),"/","")
S R("DEGREE")=$P($G(^VA(200,DISPDUZ,3.1)),U,6)
S R("MAIL_CODE")=$P($G(XT5),U,2)
S R("STATUS")=$$ACTIVE^XUSER(DISPDUZ) ;Supported IA #2343
S X=$P($G(R("STATUS")),U,3) I X'="" D
. S X=$TR($$FMTE^XLFDT(X,"5DZ"),"/","")
. S $P(R("STATUS"),U,3)=X
S R("DISUSER")=$P($G(XT),U,7)
S R("TERMINATION_DATE")=$TR($$FMTE^XLFDT($P($G(XT),U,11),"5DZ"),"/","")
S R("TERMINATION_REASON")=$P($G(XT),U,13)
S R("PRIMARY_MENU_OPTION")=$P($G(^VA(200,DISPDUZ,201)),U)
I $G(R("PRIMARY_MENU_OPTION"))>0 S R("PRIMARY_MENU_OPTION")=$P($G(^DIC(19,R("PRIMARY_MENU_OPTION"),0)),U)
S (XI,XJ)=0
I $G(^VA(200,DISPDUZ,203,0))'="" F D Q:+XI'>0
. S XI=$O(^VA(200,DISPDUZ,203,XI)) Q:+XI'>0
. S XJ=XJ+1,R("SECONDARY_MENU_OPTION",XJ)=$P($G(^VA(200,DISPDUZ,203,XI,0)),U)
. I $G(R("SECONDARY_MENU_OPTION",XJ))>0 S R("SECONDARY_MENU_OPTION",XJ)=$P($G(^DIC(19,R("SECONDARY_MENU_OPTION",XJ),0)),U)
S R("SECONDARY_MENU_OPTION",0)=XJ ;number of entries
S R("FILE_MANAGER_ACCESS_CODE")=$P($G(XT),U,4)
S (XI,XJ)=0
I $G(^VA(200,DISPDUZ,2,0))'="" F D Q:+XI'>0
. S XI=$O(^VA(200,DISPDUZ,2,XI)) Q:+XI'>0
. S XJ=XJ+1,R("DIVISION",XJ)=$P($G(^VA(200,DISPDUZ,2,XI,0)),U)
. I $G(R("DIVISION",XJ))>0 S R("DIVISION",XJ)=$P($G(^DIC(4,R("DIVISION",XJ),99)),U)
S R("DIVISION",0)=XJ ;number of entries
S R("SERVICE_SECTION")=$P($G(XT5),U,1)
I $G(R("SERVICE_SECTION"))>0 S R("SERVICE_SECTION")=$P($G(^DIC(49,R("SERVICE_SECTION"),0)),U)
S R("SUBJECT_ALTERNATIVE_NAME")=$P($G(XT501),U,2)
S R("SECID")=$TR($P($G(XT205),U),"%","^")
S R("ORGANIZATION_NAME")=$P($G(XT205),U,2)
S R("ORGANIZATION_ID")=$P($G(XT205),U,3)
S R("UNIQUE_USER_ID")=$P($G(XT205),U,4)
S R("NETWORK_USER_NAME")=$P($G(XT501),U)
S R("AD_UPN")=$P($G(XT205),U,5)
S R("EMAIL")=$P($G(^VA(200,DISPDUZ,.15)),U)
S R("GENDER")=$P($G(XT1),U,2)
Q
;
IAMAU(R,NAME,SECID,EMAIL,ADUPN,SSN,DOB,STATION,AUTHCODE) ;RPC. XUS IAM ADD USER - IA #6290
; The XUSPF200 security key is required to add a user without an SSN (file #200 special privileges).
; Input: NAME = SubjectID to be used in SAML Token
; SECID = UniqueUserID to be used in SSOi or SSOe SAML Token
; EMAIL = User's e-mail address
; ADUPN = Active Directory User Principle Name
; SSN = User's Social Security Number or Taxpayer Identification Number
; DOB = User's Date of Birth
; STATION = NEW PERSON file (#200) DIVISION
; AUTHCODE = (Required) Security Phrase for IAM Provisioning Application
; Return: Fail R(0) = "-1^Number of Errors"
; R(1) through R(n) = "Error Message"
; Success R(0) = "DUZ^STATION"
;
; ZEXCEPT: %DT,DA,DIERR,DIK ;FileMan special variables
N DIC,DUZZERO,ERRMSG,FDR,IEN,NEWDUZ,X,XARRAY,XDIV,XUENTRY,XUIAM,Y
K R
S R(0)=0
I DUZ'>1 D EDITERR(.R,"Unauthorized access") Q
I +$$ACTIVE^XUSER(DUZ)=0 D EDITERR(.R,"Unauthorized access") Q
I $G(DUZ("LOA"))<2 D EDITERR(.R,"Unauthorized access") Q
S XUIAM=1 ;Do not trigger IAM updates
I ($G(SSN)'>1)&('$$KCHK^XUSRB("XUSPF200")) D EDITERR(.R,"Need XUSPF200 key if no SSN") Q
S XUENTRY=$$GETCNTXT^XUESSO2($G(AUTHCODE)) I +XUENTRY<0 D EDITERR(.R,XUENTRY) Q
I $P($G(^XWB(8994.5,XUENTRY,0)),U)'="IAM PROVISIONING" D EDITERR(.R,"Unauthorized access") Q
I $G(NAME)="" D EDITERR(.R,"Missing SubjectID") Q
I $G(SECID)="" D EDITERR(.R,"Missing SecID") Q
S Y=$$SECMATCH^XUESSO2(SECID) I Y>0 D EDITERR(.R,"User with given SecID already exists") Q
I $G(SSN)>1 S Y=+$O(^VA(200,"SSN",SSN,0))
I Y>0 D EDITERR(.R,"User with given SSN already exists") Q
I ($G(SSN)>1)&('$$SSNCHECK^XUESSO1($G(SSN))) D EDITERR(.R,"Invalid SSN") Q
I $G(DOB)'="" D Q:Y=-1
. S X=DOB S %DT="X" D ^%DT I Y=-1 D EDITERR(.R,"Invalid DOB") Q
. S DOB=$G(Y)
I $G(STATION)'="" D Q:Y=""
. S Y="" S Y=$O(^DIC(4,"D",$G(STATION),Y))
. I Y="" D EDITERR(.R,"-1^Invalid STATION") Q
. S XDIV=$P($G(^DIC(4,Y,0)),U,1)
S XARRAY(1)=$P($G(^XTV(8989.3,1,200)),U,2)
S XARRAY(2)=$P($G(^XTV(8989.3,1,200)),U,3)
S XARRAY(3)=SECID
S XARRAY(4)=NAME
S XARRAY(7)=SECID
S XARRAY(9)=$G(SSN)
S Y=$$ADDUSER^XUESSO2(.XARRAY) ;Add the user
I +Y<0 D EDITERR(.R,Y) Q
S NEWDUZ=Y
;Use FM calls to edit the user with the remaining information
K ^TMP("DIERR",$J)
S DIC(0)="",ERRMSG=""
S IEN=NEWDUZ_","
I $G(EMAIL)'="" S FDR(200,IEN,.151)=$$LOW^XLFSTR(EMAIL)
I $G(ADUPN)'="" S FDR(200,IEN,205.5)=$$LOW^XLFSTR(ADUPN)
I $G(DOB)'="" S FDR(200,IEN,5)=DOB
I $G(XDIV)'="" S FDR(200.02,"+3,"_IEN,.01)=XDIV
; Apply all the changes: File valid values and reject invalid values.
S DUZZERO=DUZ(0),DUZ(0)="@"
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(DIERR) D
. S Y=0
. F D Q:+Y'>0
. . S Y=$O(^TMP("DIERR",$J,Y)) I +Y>0 W !,$G(^TMP("DIERR",$J,Y,"TEXT",1))
. . I +Y>0 D EDITERR(.R,$G(^TMP("DIERR",$J,Y,"TEXT",1))) ;FileMan Error
. K DA,DIK S DIK="^VA(200,",DA=NEWDUZ D ^DIK ;Rollback add if all fields could not be filed
I +$G(R(0))'=-1 S R(0)=NEWDUZ_U_STATION
Q
;
IAMEU(R,INARRY,AUTHCODE) ;RPC. XUS IAM EDIT USER - IA #6291
; The XUSHOWSSN security key is required to allow edit of PII (SSN and DoB).
; Input: INARRY("SECID") = SecID - Used to identify entry to be edited
; INARRAY("LASTNAME") = User NAME is "LASTNAME,FIRSTNAME MIDDLENAME SUFFIX"
; INARRAY("FIRSTNAME")
; INARRAY("MIDDLENAME")
; INARRAY("SUFFIX")
; INARRY("ORGANIZATION_NAME")= SUBJECT ORGANIZATION
; INARRY("ORGANIZATION_ID") = SUBJECT ORGANIZATION ID
; INARRY("EMAIL") = EMAIL ADDRESS
; INARRY("AD_UPN") = ADUPN
; INARRY("SSN") = SSN
; INARRY("DOB") = DOB (Date of Birth)
; AUTHCODE = Security Phrase for IAM Provisioning Application
; Return: Fail R(0) = "-1^Number of Errors"
; R(1) through R(n) = "Error Message"
; Success R(0) = DUZ of NEW PERSON file entry that was edited
;
; ZEXCEPT: %DT,DIERR ;FileMan special variables
N DUZZERO,FDR,IEN,X,XARRAY,XDUZ,XSHOWSSN,XUENTRY,XUIAM,XUN,XUNAME,XUNEWN,XUOLDN,Y
K R
S R(0)=0
S XUIAM=1 ;Do not trigger IAM updates
I DUZ'>1 D EDITERR(.R,"Unauthorized access") Q
I +$$ACTIVE^XUSER(DUZ)=0 D EDITERR(.R,"Unauthorized access") Q
S XUENTRY=$$GETCNTXT^XUESSO2($G(AUTHCODE)) I +XUENTRY<0 D EDITERR(.R,$P(XUENTRY,U,2)) Q
I $P($G(^XWB(8994.5,XUENTRY,0)),U)'="IAM PROVISIONING" D EDITERR(.R,"Unauthorized access") Q
I $G(DUZ("LOA"))<2 D EDITERR(.R,"Unauthorized access") Q
I $G(INARRY("SECID"))="" D EDITERR(.R,"User not identified by SecID") Q
S XARRAY(7)=INARRY("SECID")
S XDUZ=$$SECMATCH^XUESSO2(XARRAY(7)) I XDUZ'>0 D EDITERR(.R,"User not found") Q
I $S($P(^VA(200,XDUZ,0),U,11):$P(^VA(200,XDUZ,0),U,11)<DT,1:0) D EDITERR(.R,"Not allowed to edit terminated user") Q
S XSHOWSSN=$$KCHK^XUSRB("XUSHOWSSN")
I ($G(INARRY("SSN")))&('XSHOWSSN) D EDITERR(.R,"XUSHOWSSN Security Key is required to edit SSN")
I ($G(INARRY("DOB")))&('XSHOWSSN) D EDITERR(.R,"XUSHOWSSN Security Key is required to edit DOB")
;Use FM calls to edit the user with the remaining information
K ^TMP("DIERR",$J)
S IEN=XDUZ_","
S XUN("FILE")=200,XUN("IENS")=IEN,XUN("FIELD")=.01
S XUOLDN=$$NAMEFMT^XLFNAME(.XUN,"F","CS")
K XUN S XUN=XUOLDN
D NAMECOMP^XLFNAME(.XUN)
I $D(INARRY("LASTNAME")) S XUN("FAMILY")=$G(INARRY("LASTNAME"))
I $D(INARRY("FIRSTNAME")) S XUN("GIVEN")=$G(INARRY("FIRSTNAME"))
I $D(INARRY("MIDDLENAME")) S XUN("MIDDLE")=$G(INARRY("MIDDLENAME"))
I $D(INARRY("SUFFIX")) S XUN("SUFFIX")=$G(INARRY("SUFFIX"))
S XUNEWN=$$NAMEFMT^XLFNAME(.XUN,"F","CS")
I XUNEWN'=XUOLDN S FDR(200,IEN,.01)=XUNEWN ;set NAME if changed
I $G(INARRY("ORGANIZATION_NAME"))'="" D
. S X=$$TITLE^XLFSTR($E(INARRY("ORGANIZATION_NAME"),1,50))
. I X'=$P($G(^VA(200,XDUZ,205)),U,2) S FDR(200,IEN,205.2)=X ;set SUBJECT ORGANIZATION if changed
I $G(INARRY("ORGANIZATION_ID"))'="" D
. S X=$$LOW^XLFSTR($E(INARRY("ORGANIZATION_ID"),1,50))
. I X'=$P($G(^VA(200,XDUZ,205)),U,3) S FDR(200,IEN,205.3)=X ;set SUBJECT ORGANIZATION ID if changed
I $G(INARRY("EMAIL"))'="" D
. S X=$$LOW^XLFSTR(INARRY("EMAIL"))
. I X'=$P($G(^VA(200,XDUZ,.15)),U) S FDR(200,IEN,.151)=X ;set EMAIL ADDRESS if changed
I $G(INARRY("AD_UPN"))'="" D
. S X=$$LOW^XLFSTR($E(INARRY("AD_UPN"),1,50))
. I X'=$P($G(^VA(200,XDUZ,205)),U,5) S FDR(200,IEN,205.5)=X ;edit ADUPN if changed
I ($G(INARRY("SSN"))'="")&(XSHOWSSN) D
. S X=+$O(^VA(200,"SSN",INARRY("SSN"),0)) ;Search for existing user with this SSN
. I +X>0 D ;SSN found
. . I +X'=XDUZ D ;SSN assigned to another user
. . . D EDITERR(.R,"This SSN is assigned to another user")
. . ; else SSN is assigned to this user, so no need to change SSN
. E D ;SSN not found
. . I $$SSNCHECK^XUESSO1(INARRY("SSN")) D ;validate SSN
. . . S FDR(200,IEN,9)=INARRY("SSN") ;edit SSN if valid
. . E D ;error if SSN not valid
. . . D EDITERR(.R,"Not a valid SSN")
I ($G(INARRY("DOB"))'="")&(XSHOWSSN) D
. S X=INARRY("DOB") S %DT="X" D ^%DT
. I Y>1 D
. . I Y'=$P($G(^VA(200,XDUZ,1)),U,3) S FDR(200,IEN,5)=Y ;edit DOB if changed
. E D ;error if DOB not valid
. . D EDITERR(.R,"Not a valid DOB")
; Apply all the changes: File valid values and reject invalid values.
S DUZZERO=DUZ(0),DUZ(0)="@"
I $D(FDR) D FILE^DIE("E","FDR") ;File all the data
S DUZ(0)=DUZZERO ;Restore original FM access
I $D(DIERR) D
. S Y=0
. F D Q:+Y'>0
. . S Y=$O(^TMP("DIERR",$J,Y))
. . I +Y>0 D EDITERR(.R,$G(^TMP("DIERR",$J,Y,"TEXT",1))) ;FileMan Error
E I +$G(R(0))'=-1 D
. S R(0)=XDUZ
Q
;
IAMTU(R,SECID,TERMDATE,TERMRESN,AUTHCODE) ;RPC. XUS IAM TERMINATE USER - IA #6292
; Input: SECID = SECID - Used to identify entry to be edited
; TERMDATE = TERMINATION DATE
; TERMRESN = Termination Reason
; AUTHCODE = Security Phrase for IAM Provisioning Application
; Return: Fail R(0) = "-1^Number of Errors"
; R(1) through R(n) = "Error Message"
; Success R(0) = DUZ
;
; ZEXCEPT: %DT,DIERR ;FileMan special variables
N DUZZERO,FDR,IEN,INARRY,X,XARRAY,XDUZ,XUENTRY,XUIAM,Y
K R
S R(0)=0
S XUIAM=1 ;Do not trigger IAM updates
I DUZ'>1 D EDITERR(.R,"Unauthorized access") Q
I +$$ACTIVE^XUSER(DUZ)=0 D EDITERR(.R,"Unauthorized access") Q
S XUENTRY=$$GETCNTXT^XUESSO2($G(AUTHCODE)) I +XUENTRY<0 D EDITERR(.R,$P(XUENTRY,U,2)) Q
I $P($G(^XWB(8994.5,XUENTRY,0)),U)'="IAM PROVISIONING" D EDITERR(.R,"Unauthorized access") Q
I $G(SECID)="" D EDITERR(.R,"User not identified by SecID") Q
I $G(TERMDATE)="" D EDITERR(.R,"Missing Termination Date") Q
I $G(TERMRESN)="" D EDITERR(.R,"Missing Termination Reason") Q
S XARRAY(7)=SECID ;SecID
S XDUZ=$$FINDUSER^XUESSO2(.XARRAY) ;Find user to be terminated
I +XDUZ'>1 D EDITERR(.R,"User not found") Q
;Use FM calls to edit the user
K ^TMP("DIERR",$J)
S IEN=XDUZ_","
S FDR(200,IEN,9.2)=TERMDATE ;set Termination Date
S FDR(200,IEN,9.4)=$E(TERMRESN,1,45) ;set Termination Reason
; Apply the changes.
S DUZZERO=DUZ(0),DUZ(0)="@"
I $D(FDR) D FILE^DIE("E","FDR") ;File all the data
S DUZ(0)=DUZZERO ;Restore original FM access
I $D(DIERR) D
. S Y=0
. F D Q:+Y'>0
. . S Y=$O(^TMP("DIERR",$J,Y))
. . I +Y>0 D EDITERR(.R,$G(^TMP("DIERR",$J,Y,"TEXT",1))) ;FileMan Error
E I +$G(R(0))'=-1 D
. S R(0)=XDUZ
Q
;
IAMRU(R,SECID,AUTHCODE) ;RPC. XUS IAM REACTIVATE USER - IA #6293
; Input: SECID = SECID - Used to identify entry to be edited
; AUTHCODE = Security Phrase for IAM Provisioning Application
; Return: Fail R(0) = "-1^Number of Errors"
; R(1) through R(n) = "Error Message"
; Success R(0) = 1
;
; ZEXCEPT: DIERR ;FileMan special variables
N DUZZERO,FDR,IEN,INARRY,X,XARRAY,XDUZ,XUENTRY,XUIAM,Y
K R
S R(0)=0
S XUIAM=1 ;Do not trigger IAM updates
I DUZ'>1 D EDITERR(.R,"Unauthorized access") Q
I +$$ACTIVE^XUSER(DUZ)=0 D EDITERR(.R,"Unauthorized access") Q
S XUENTRY=$$GETCNTXT^XUESSO2($G(AUTHCODE)) I +XUENTRY<0 D EDITERR(.R,$P(XUENTRY,U,2)) Q
I $P($G(^XWB(8994.5,XUENTRY,0)),U)'="IAM PROVISIONING" D EDITERR(.R,"Unauthorized access") Q
I $G(SECID)="" D EDITERR(.R,"User not identified by SecID") Q
S XARRAY(7)=SECID ;SecID
S XDUZ=$$FINDUSER^XUESSO2(.XARRAY) ;Find user to be reactivated
I +XDUZ'>1 D EDITERR(.R,"User not found") Q
K ^TMP("DIERR",$J)
S IEN=XDUZ_","
S FDR(200,IEN,9.2)="" ;set Termination Date
; Apply the changes.
S DUZZERO=DUZ(0),DUZ(0)="@"
I $D(FDR) D FILE^DIE("E","FDR") ;File all the data
S DUZ(0)=DUZZERO ;Restore original FM access
I $D(DIERR) D
. S Y=0
. F D Q:+Y'>0
. . S Y=$O(^TMP("DIERR",$J,Y))
. . I +Y>0 D EDITERR(.R,$G(^TMP("DIERR",$J,Y,"TEXT",1))) ;FileMan Error
E I +$G(R(0))'=-1 D
. S R(0)=XDUZ
Q
;
ADDTOLST(XR,XCOUNT,XSHOWSSN,XRESULT) ;Intrinsic Subroutine. Add user to list.
N XFLAG,XI,XODOB,XONME,XONMEC,XOSEC,XOSSN,XOUPN
S XFLAG=0
F XI=1:1:XCOUNT D
. I XRESULT=$P($G(XR(XI)),U) S XFLAG=1
I XFLAG=0 D
. S XCOUNT=XCOUNT+1
. S XONME=$P($G(^VA(200,XRESULT,0)),U)
. S XONMEC=$$NAMECOMP(XRESULT)
. S XOSSN="<Hidden>" I $G(XSHOWSSN)=1 S XOSSN=$P($G(^VA(200,XRESULT,1)),U,9)
. S XODOB="<Hidden>" I $G(XSHOWSSN)=1 S XODOB=$TR($$FMTE^XLFDT($P($G(^VA(200,XRESULT,1)),U,3),"5DZ"),"/","")
. S XOUPN=$P($G(^VA(200,XRESULT,205)),U,5)
. S XOSEC=$TR($P($G(^VA(200,XRESULT,205)),U),"%","^")
. S XR(XCOUNT)=XRESULT_"^"_XONME_"^"_XONMEC_"^"_XOSSN_"^"_XODOB_"^"_XOUPN_"^"_XOSEC
Q
;
NAMECOMP(IEN) ;Intrinsic Function. Get NAME COMPONENTS.
N NAME,NC1,NCIEN
S NCIEN=$O(^VA(20,"BB",200,.01,IEN_",",0))
Q:'NCIEN ""
S NC1=$G(^VA(20,NCIEN,1))
Q $TR($P(NC1,U,1,3)_U_$P(NC1,U,5),U,"`")
;
EDITERR(Y,XMSG) ;Intrinsic Subroutine. Add error to list.
N I
S:$P(XMSG,"-1^")="" $E(XMSG,1,3)=""
S I=$O(Y(""),-1)+1,Y(I)=XMSG,Y(0)=-1_U_I
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUESSO3 20000 printed Jun 11, 2024@21:58:56 Page 2
XUESSO3 ;ISD/HGW Enhanced Single Sign-On Utilities ;02/25/16 15:33
+1 ;;8.0;KERNEL;**655,659**;Jul 10, 1995;Build 22
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 QUIT
IAMFU(R,NAME,SSN,DOB,ADUPN,SECID,AUTHCODE) ;RPC. XUS IAM FIND USER - IA #6288
+1 ; The XUSHOWSSN key is required to do lookups using PII (SSN or DoB).
+2 ; Input: One or more of Name, SSN, DoB, AD UPN, and/or SecID must be provided.
+3 ; AUTHCODE = Security Phrase for IAM Provisioning Application
+4 ; Return: Fail R(0)="-1^Error Message"
+5 ; Success R(0)=total number of entries found, from "0" to "n".
+6 ; R(1) through R(n)="DUZ^Name^NameComponents^SSN^Dob^AD UPN^SecID"
+7 ;
+8 ; ZEXCEPT: %DT
+9 NEW X,XARRY,XCOUNT,XI,XJ,XNAME,XRESULT,XSHOWSSN,XTEMP,XUENTRY,XUIAM,Y
+10 KILL R
+11 IF DUZ'>1
SET R(0)="-1^Unauthorized access"
QUIT
+12 SET XUENTRY=$$GETCNTXT^XUESSO2($GET(AUTHCODE))
IF +XUENTRY<0
SET R(0)=XUENTRY
QUIT
+13 IF $PIECE($GET(^XWB(8994.5,XUENTRY,0)),U)'="IAM PROVISIONING"
SET R(0)="-1^Unauthorized access"
QUIT
+14 ;Do not trigger IAM updates
SET XUIAM=1
+15 SET XSHOWSSN=$$KCHK^XUSRB("XUSHOWSSN")
+16 SET XCOUNT=0
+17 ; 1. Search by NAME
+18 IF $GET(NAME)'=""
Begin DoDot:1
+19 DO FIND^DIC(200,"","@","PC",NAME,"*","B")
+20 SET XI=0
FOR
SET XI=$ORDER(^TMP("DILIST",$JOB,XI))
if 'XI
QUIT
Begin DoDot:2
+21 SET XRESULT=$GET(^TMP("DILIST",$JOB,XI,0))
+22 if XRESULT>0
DO ADDTOLST(.R,.XCOUNT,XSHOWSSN,XRESULT)
End DoDot:2
+23 DO CLEAN^DILF
+24 KILL ^TMP("DILIST",$JOB)
End DoDot:1
+25 ; 2. Search by SSN
+26 IF ($GET(SSN)'="")&($GET(XSHOWSSN)=1)
Begin DoDot:1
+27 SET XARRY(9)=SSN
+28 SET XRESULT=$$FINDUSER^XUESSO2(.XARRY)
+29 IF +XRESULT>0
DO ADDTOLST(.R,.XCOUNT,XSHOWSSN,XRESULT)
+30 KILL XARRY(9)
End DoDot:1
+31 ; 3. Search by DOB
+32 IF ($GET(DOB)'="")&($GET(XSHOWSSN)=1)
Begin DoDot:1
+33 SET X=DOB
SET %DT="X"
DO ^%DT
SET X=Y
SET XRESULT=0
+34 FOR
Begin DoDot:2
+35 SET XRESULT=$ORDER(^VA(200,XRESULT))
if XRESULT=""
QUIT
+36 IF $PIECE($GET(^VA(200,XRESULT,1)),U,3)=X
DO ADDTOLST(.R,.XCOUNT,XSHOWSSN,XRESULT)
End DoDot:2
if XRESULT=""
QUIT
End DoDot:1
+37 ; 4. Search by ADUPN
+38 IF $GET(ADUPN)'=""
Begin DoDot:1
+39 SET X=$$LOW^XLFSTR(ADUPN)
SET XRESULT=0
+40 SET XRESULT=$$UPNMATCH^XUESSO2(ADUPN)
+41 IF XRESULT>0
DO ADDTOLST(.R,.XCOUNT,XSHOWSSN,XRESULT)
End DoDot:1
+42 ; 5. Search by SECID
+43 IF $GET(SECID)'=""
Begin DoDot:1
+44 SET XARRY(7)=SECID
+45 SET XRESULT=$$FINDUSER^XUESSO2(.XARRY)
+46 IF +XRESULT>0
DO ADDTOLST(.R,.XCOUNT,XSHOWSSN,XRESULT)
+47 KILL XARRY(7)
End DoDot:1
+48 ; 6. Return results
+49 SET R(0)=XCOUNT
+50 QUIT
+51 ;
IAMDU(R,DISPDUZ,AUTHCODE) ;RPC. XUS IAM DISPLAY USER - IA #6289
+1 ; Input: DISPDUZ = DUZ (IEN) of user to be displayed
+2 ; AUTHCODE = Security Phrase for IAM Provisioning Application
+3 ; Return: Fail R(0) ="-1^Error Message"
+4 ; Success R(0) = 1
+5 ; R("NAME") = NAME
+6 ; R("LASTNAME") = Family Name
+7 ; R("FIRSTNAME") = Given Name
+8 ; R("MIDDLENAME") = Middle Name
+9 ; R("SUFFIX") = Suffix(es)
+10 ; R("INITIAL") = INITIAL
+11 ; R("TITLE") = TITLE
+12 ; R("NICK_NAME") = NICK NAME
+13 ; R("SSN") = SSN (<Hidden> if caller does not have XUSHOWSSN key)
+14 ; R("DOB") = DOB (<Hidden> if caller does not have XUSHOWSSN key)
+15 ; R("DEGREE") = DEGREE
+16 ; R("MAIL_CODE") = MAIL CODE
+17 ; R("STATUS") = $$ACTIVE^XUSER(DISPDUZ)
+18 ; R("DISUSER") = DISUSER
+19 ; R("TERMINATION_DATE") = TERMINATION DATE
+20 ; R("TERMINATION_REASON") = TERMINATION REASON
+21 ; R("PRIMARY_MENU_OPTION") = PRIMARY MENU OPTION
+22 ; R("SECONDARY_MENU_OPTION",0) = SECONDARY MENU OPTION (number of entries)
+23 ; R("SECONDARY_MENU_OPTION",1) to R("SECONDARY_MENU_OPTION",n) = SECONDARY MENU OPTION entries
+24 ; R("FILE_MANAGER_ACCESS_CODE") = FILE MANAGER ACCESS CODE
+25 ; R("DIVISION",0) = DIVISION (number of entries)
+26 ; R("DIVISION",1) to R("DIVISION",n) = DIVISION entries
+27 ; R("SERVICE_SECTION") = SERVICE/SECTION
+28 ; R("SUBJECT_ALTERNATIVE_NAME") = SUBJECT ALTERNATIVE NAME (PIV CARD)
+29 ; R("SECID") = SECID
+30 ; R("ORGANIZATION_NAME") = SUBJECT ORGANIZATION
+31 ; R("ORGANIZATION_ID") = SUBJECT ORGANIZATION ID
+32 ; R("UNIQUE_USER_ID") = UNIQUE USER ID
+33 ; R("NETWORK_USER_NAME") = NETWORK USERNAME
+34 ; R("AD_UPN") = ADUPN
+35 ; R("EMAIL") = EMAIL ADDRESS
+36 ; R("GENDER") = SEX (M/F)
+37 ;
+38 NEW X,XI,XIEN,XJ,XN,XSHOWSSN,XT,XT1,XT205,XT5,XT501,XUENTRY,XUIAM,Y
+39 KILL R
+40 IF DUZ'>1
SET R(0)="-1^Unauthorized access"
QUIT
+41 SET XUENTRY=$$GETCNTXT^XUESSO2($GET(AUTHCODE))
IF +XUENTRY<0
SET R(0)=XUENTRY
QUIT
+42 IF $PIECE($GET(^XWB(8994.5,XUENTRY,0)),U)'="IAM PROVISIONING"
SET R(0)="-1^Unauthorized access"
QUIT
+43 IF $GET(DUZ("LOA"))<2
SET R(0)="-1^Unauthorized access"
QUIT
+44 IF $GET(DISPDUZ)'>0
SET R(0)="-1^User not selected"
QUIT
+45 IF $GET(^VA(200,DISPDUZ,0))=""
SET R(0)="-1^User not found"
QUIT
+46 ;Do not trigger IAM updates
SET XUIAM=1
+47 SET XSHOWSSN=$$KCHK^XUSRB("XUSHOWSSN")
+48 SET XT=$GET(^VA(200,DISPDUZ,0))
+49 SET XT1=$GET(^VA(200,DISPDUZ,1))
+50 SET XT5=$GET(^VA(200,DISPDUZ,5))
+51 SET XT205=$GET(^VA(200,DISPDUZ,205))
+52 SET XT501=$GET(^VA(200,DISPDUZ,501))
+53 SET R(0)=1
+54 SET (XN,R("NAME"))=$PIECE($GET(XT),U)
+55 SET XIEN=DISPDUZ_","
+56 ;Get NAME COMPONENTS
SET X=0
SET X=$ORDER(^VA(20,"BB",200,.01,XIEN,X))
+57 SET Y=""
IF +X>0
SET Y=$GET(^VA(20,X,1))
+58 SET R("LASTNAME")=$PIECE(Y,U)
+59 SET R("FIRSTNAME")=$PIECE(Y,U,2)
+60 SET R("MIDDLENAME")=$PIECE(Y,U,3)
+61 SET R("SUFFIX")=$PIECE(Y,U,4)
+62 SET R("INITIAL")=$PIECE($GET(XT),U,2)
+63 SET R("TITLE")=""
SET X=$PIECE($GET(XT),U,9)
+64 IF $GET(X)>0
SET R("TITLE")=$PIECE($GET(^DIC(3.1,X,0)),U)
+65 SET R("NICK_NAME")=$PIECE($GET(^VA(200,DISPDUZ,.1)),U,4)
+66 SET R("SSN")="<Hidden>"
IF $GET(XSHOWSSN)=1
SET R("SSN")=$PIECE($GET(XT1),U,9)
+67 SET R("DOB")="<Hidden>"
IF $GET(XSHOWSSN)=1
SET R("DOB")=$TRANSLATE($$FMTE^XLFDT($PIECE($GET(XT1),U,3),"5DZ"),"/","")
+68 SET R("DEGREE")=$PIECE($GET(^VA(200,DISPDUZ,3.1)),U,6)
+69 SET R("MAIL_CODE")=$PIECE($GET(XT5),U,2)
+70 ;Supported IA #2343
SET R("STATUS")=$$ACTIVE^XUSER(DISPDUZ)
+71 SET X=$PIECE($GET(R("STATUS")),U,3)
IF X'=""
Begin DoDot:1
+72 SET X=$TRANSLATE($$FMTE^XLFDT(X,"5DZ"),"/","")
+73 SET $PIECE(R("STATUS"),U,3)=X
End DoDot:1
+74 SET R("DISUSER")=$PIECE($GET(XT),U,7)
+75 SET R("TERMINATION_DATE")=$TRANSLATE($$FMTE^XLFDT($PIECE($GET(XT),U,11),"5DZ"),"/","")
+76 SET R("TERMINATION_REASON")=$PIECE($GET(XT),U,13)
+77 SET R("PRIMARY_MENU_OPTION")=$PIECE($GET(^VA(200,DISPDUZ,201)),U)
+78 IF $GET(R("PRIMARY_MENU_OPTION"))>0
SET R("PRIMARY_MENU_OPTION")=$PIECE($GET(^DIC(19,R("PRIMARY_MENU_OPTION"),0)),U)
+79 SET (XI,XJ)=0
+80 IF $GET(^VA(200,DISPDUZ,203,0))'=""
FOR
Begin DoDot:1
+81 SET XI=$ORDER(^VA(200,DISPDUZ,203,XI))
if +XI'>0
QUIT
+82 SET XJ=XJ+1
SET R("SECONDARY_MENU_OPTION",XJ)=$PIECE($GET(^VA(200,DISPDUZ,203,XI,0)),U)
+83 IF $GET(R("SECONDARY_MENU_OPTION",XJ))>0
SET R("SECONDARY_MENU_OPTION",XJ)=$PIECE($GET(^DIC(19,R("SECONDARY_MENU_OPTION",XJ),0)),U)
End DoDot:1
if +XI'>0
QUIT
+84 ;number of entries
SET R("SECONDARY_MENU_OPTION",0)=XJ
+85 SET R("FILE_MANAGER_ACCESS_CODE")=$PIECE($GET(XT),U,4)
+86 SET (XI,XJ)=0
+87 IF $GET(^VA(200,DISPDUZ,2,0))'=""
FOR
Begin DoDot:1
+88 SET XI=$ORDER(^VA(200,DISPDUZ,2,XI))
if +XI'>0
QUIT
+89 SET XJ=XJ+1
SET R("DIVISION",XJ)=$PIECE($GET(^VA(200,DISPDUZ,2,XI,0)),U)
+90 IF $GET(R("DIVISION",XJ))>0
SET R("DIVISION",XJ)=$PIECE($GET(^DIC(4,R("DIVISION",XJ),99)),U)
End DoDot:1
if +XI'>0
QUIT
+91 ;number of entries
SET R("DIVISION",0)=XJ
+92 SET R("SERVICE_SECTION")=$PIECE($GET(XT5),U,1)
+93 IF $GET(R("SERVICE_SECTION"))>0
SET R("SERVICE_SECTION")=$PIECE($GET(^DIC(49,R("SERVICE_SECTION"),0)),U)
+94 SET R("SUBJECT_ALTERNATIVE_NAME")=$PIECE($GET(XT501),U,2)
+95 SET R("SECID")=$TRANSLATE($PIECE($GET(XT205),U),"%","^")
+96 SET R("ORGANIZATION_NAME")=$PIECE($GET(XT205),U,2)
+97 SET R("ORGANIZATION_ID")=$PIECE($GET(XT205),U,3)
+98 SET R("UNIQUE_USER_ID")=$PIECE($GET(XT205),U,4)
+99 SET R("NETWORK_USER_NAME")=$PIECE($GET(XT501),U)
+100 SET R("AD_UPN")=$PIECE($GET(XT205),U,5)
+101 SET R("EMAIL")=$PIECE($GET(^VA(200,DISPDUZ,.15)),U)
+102 SET R("GENDER")=$PIECE($GET(XT1),U,2)
+103 QUIT
+104 ;
IAMAU(R,NAME,SECID,EMAIL,ADUPN,SSN,DOB,STATION,AUTHCODE) ;RPC. XUS IAM ADD USER - IA #6290
+1 ; The XUSPF200 security key is required to add a user without an SSN (file #200 special privileges).
+2 ; Input: NAME = SubjectID to be used in SAML Token
+3 ; SECID = UniqueUserID to be used in SSOi or SSOe SAML Token
+4 ; EMAIL = User's e-mail address
+5 ; ADUPN = Active Directory User Principle Name
+6 ; SSN = User's Social Security Number or Taxpayer Identification Number
+7 ; DOB = User's Date of Birth
+8 ; STATION = NEW PERSON file (#200) DIVISION
+9 ; AUTHCODE = (Required) Security Phrase for IAM Provisioning Application
+10 ; Return: Fail R(0) = "-1^Number of Errors"
+11 ; R(1) through R(n) = "Error Message"
+12 ; Success R(0) = "DUZ^STATION"
+13 ;
+14 ; ZEXCEPT: %DT,DA,DIERR,DIK ;FileMan special variables
+15 NEW DIC,DUZZERO,ERRMSG,FDR,IEN,NEWDUZ,X,XARRAY,XDIV,XUENTRY,XUIAM,Y
+16 KILL R
+17 SET R(0)=0
+18 IF DUZ'>1
DO EDITERR(.R,"Unauthorized access")
QUIT
+19 IF +$$ACTIVE^XUSER(DUZ)=0
DO EDITERR(.R,"Unauthorized access")
QUIT
+20 IF $GET(DUZ("LOA"))<2
DO EDITERR(.R,"Unauthorized access")
QUIT
+21 ;Do not trigger IAM updates
SET XUIAM=1
+22 IF ($GET(SSN)'>1)&('$$KCHK^XUSRB("XUSPF200"))
DO EDITERR(.R,"Need XUSPF200 key if no SSN")
QUIT
+23 SET XUENTRY=$$GETCNTXT^XUESSO2($GET(AUTHCODE))
IF +XUENTRY<0
DO EDITERR(.R,XUENTRY)
QUIT
+24 IF $PIECE($GET(^XWB(8994.5,XUENTRY,0)),U)'="IAM PROVISIONING"
DO EDITERR(.R,"Unauthorized access")
QUIT
+25 IF $GET(NAME)=""
DO EDITERR(.R,"Missing SubjectID")
QUIT
+26 IF $GET(SECID)=""
DO EDITERR(.R,"Missing SecID")
QUIT
+27 SET Y=$$SECMATCH^XUESSO2(SECID)
IF Y>0
DO EDITERR(.R,"User with given SecID already exists")
QUIT
+28 IF $GET(SSN)>1
SET Y=+$ORDER(^VA(200,"SSN",SSN,0))
+29 IF Y>0
DO EDITERR(.R,"User with given SSN already exists")
QUIT
+30 IF ($GET(SSN)>1)&('$$SSNCHECK^XUESSO1($GET(SSN)))
DO EDITERR(.R,"Invalid SSN")
QUIT
+31 IF $GET(DOB)'=""
Begin DoDot:1
+32 SET X=DOB
SET %DT="X"
DO ^%DT
IF Y=-1
DO EDITERR(.R,"Invalid DOB")
QUIT
+33 SET DOB=$GET(Y)
End DoDot:1
if Y=-1
QUIT
+34 IF $GET(STATION)'=""
Begin DoDot:1
+35 SET Y=""
SET Y=$ORDER(^DIC(4,"D",$GET(STATION),Y))
+36 IF Y=""
DO EDITERR(.R,"-1^Invalid STATION")
QUIT
+37 SET XDIV=$PIECE($GET(^DIC(4,Y,0)),U,1)
End DoDot:1
if Y=""
QUIT
+38 SET XARRAY(1)=$PIECE($GET(^XTV(8989.3,1,200)),U,2)
+39 SET XARRAY(2)=$PIECE($GET(^XTV(8989.3,1,200)),U,3)
+40 SET XARRAY(3)=SECID
+41 SET XARRAY(4)=NAME
+42 SET XARRAY(7)=SECID
+43 SET XARRAY(9)=$GET(SSN)
+44 ;Add the user
SET Y=$$ADDUSER^XUESSO2(.XARRAY)
+45 IF +Y<0
DO EDITERR(.R,Y)
QUIT
+46 SET NEWDUZ=Y
+47 ;Use FM calls to edit the user with the remaining information
+48 KILL ^TMP("DIERR",$JOB)
+49 SET DIC(0)=""
SET ERRMSG=""
+50 SET IEN=NEWDUZ_","
+51 IF $GET(EMAIL)'=""
SET FDR(200,IEN,.151)=$$LOW^XLFSTR(EMAIL)
+52 IF $GET(ADUPN)'=""
SET FDR(200,IEN,205.5)=$$LOW^XLFSTR(ADUPN)
+53 IF $GET(DOB)'=""
SET FDR(200,IEN,5)=DOB
+54 IF $GET(XDIV)'=""
SET FDR(200.02,"+3,"_IEN,.01)=XDIV
+55 ; Apply all the changes: File valid values and reject invalid values.
+56 SET DUZZERO=DUZ(0)
SET DUZ(0)="@"
+57 ;File all the data
IF $DATA(FDR)
KILL IEN
DO UPDATE^DIE("E","FDR","IEN")
+58 ;Restore original FM access
SET DUZ(0)=DUZZERO
+59 IF $DATA(DIERR)
Begin DoDot:1
+60 SET Y=0
+61 FOR
Begin DoDot:2
+62 SET Y=$ORDER(^TMP("DIERR",$JOB,Y))
IF +Y>0
WRITE !,$GET(^TMP("DIERR",$JOB,Y,"TEXT",1))
+63 ;FileMan Error
IF +Y>0
DO EDITERR(.R,$GET(^TMP("DIERR",$JOB,Y,"TEXT",1)))
End DoDot:2
if +Y'>0
QUIT
+64 ;Rollback add if all fields could not be filed
KILL DA,DIK
SET DIK="^VA(200,"
SET DA=NEWDUZ
DO ^DIK
End DoDot:1
+65 IF +$GET(R(0))'=-1
SET R(0)=NEWDUZ_U_STATION
+66 QUIT
+67 ;
IAMEU(R,INARRY,AUTHCODE) ;RPC. XUS IAM EDIT USER - IA #6291
+1 ; The XUSHOWSSN security key is required to allow edit of PII (SSN and DoB).
+2 ; Input: INARRY("SECID") = SecID - Used to identify entry to be edited
+3 ; INARRAY("LASTNAME") = User NAME is "LASTNAME,FIRSTNAME MIDDLENAME SUFFIX"
+4 ; INARRAY("FIRSTNAME")
+5 ; INARRAY("MIDDLENAME")
+6 ; INARRAY("SUFFIX")
+7 ; INARRY("ORGANIZATION_NAME")= SUBJECT ORGANIZATION
+8 ; INARRY("ORGANIZATION_ID") = SUBJECT ORGANIZATION ID
+9 ; INARRY("EMAIL") = EMAIL ADDRESS
+10 ; INARRY("AD_UPN") = ADUPN
+11 ; INARRY("SSN") = SSN
+12 ; INARRY("DOB") = DOB (Date of Birth)
+13 ; AUTHCODE = Security Phrase for IAM Provisioning Application
+14 ; Return: Fail R(0) = "-1^Number of Errors"
+15 ; R(1) through R(n) = "Error Message"
+16 ; Success R(0) = DUZ of NEW PERSON file entry that was edited
+17 ;
+18 ; ZEXCEPT: %DT,DIERR ;FileMan special variables
+19 NEW DUZZERO,FDR,IEN,X,XARRAY,XDUZ,XSHOWSSN,XUENTRY,XUIAM,XUN,XUNAME,XUNEWN,XUOLDN,Y
+20 KILL R
+21 SET R(0)=0
+22 ;Do not trigger IAM updates
SET XUIAM=1
+23 IF DUZ'>1
DO EDITERR(.R,"Unauthorized access")
QUIT
+24 IF +$$ACTIVE^XUSER(DUZ)=0
DO EDITERR(.R,"Unauthorized access")
QUIT
+25 SET XUENTRY=$$GETCNTXT^XUESSO2($GET(AUTHCODE))
IF +XUENTRY<0
DO EDITERR(.R,$PIECE(XUENTRY,U,2))
QUIT
+26 IF $PIECE($GET(^XWB(8994.5,XUENTRY,0)),U)'="IAM PROVISIONING"
DO EDITERR(.R,"Unauthorized access")
QUIT
+27 IF $GET(DUZ("LOA"))<2
DO EDITERR(.R,"Unauthorized access")
QUIT
+28 IF $GET(INARRY("SECID"))=""
DO EDITERR(.R,"User not identified by SecID")
QUIT
+29 SET XARRAY(7)=INARRY("SECID")
+30 SET XDUZ=$$SECMATCH^XUESSO2(XARRAY(7))
IF XDUZ'>0
DO EDITERR(.R,"User not found")
QUIT
+31 IF $SELECT($PIECE(^VA(200,XDUZ,0),U,11):$PIECE(^VA(200,XDUZ,0),U,11)<DT,1:0)
DO EDITERR(.R,"Not allowed to edit terminated user")
QUIT
+32 SET XSHOWSSN=$$KCHK^XUSRB("XUSHOWSSN")
+33 IF ($GET(INARRY("SSN")))&('XSHOWSSN)
DO EDITERR(.R,"XUSHOWSSN Security Key is required to edit SSN")
+34 IF ($GET(INARRY("DOB")))&('XSHOWSSN)
DO EDITERR(.R,"XUSHOWSSN Security Key is required to edit DOB")
+35 ;Use FM calls to edit the user with the remaining information
+36 KILL ^TMP("DIERR",$JOB)
+37 SET IEN=XDUZ_","
+38 SET XUN("FILE")=200
SET XUN("IENS")=IEN
SET XUN("FIELD")=.01
+39 SET XUOLDN=$$NAMEFMT^XLFNAME(.XUN,"F","CS")
+40 KILL XUN
SET XUN=XUOLDN
+41 DO NAMECOMP^XLFNAME(.XUN)
+42 IF $DATA(INARRY("LASTNAME"))
SET XUN("FAMILY")=$GET(INARRY("LASTNAME"))
+43 IF $DATA(INARRY("FIRSTNAME"))
SET XUN("GIVEN")=$GET(INARRY("FIRSTNAME"))
+44 IF $DATA(INARRY("MIDDLENAME"))
SET XUN("MIDDLE")=$GET(INARRY("MIDDLENAME"))
+45 IF $DATA(INARRY("SUFFIX"))
SET XUN("SUFFIX")=$GET(INARRY("SUFFIX"))
+46 SET XUNEWN=$$NAMEFMT^XLFNAME(.XUN,"F","CS")
+47 ;set NAME if changed
IF XUNEWN'=XUOLDN
SET FDR(200,IEN,.01)=XUNEWN
+48 IF $GET(INARRY("ORGANIZATION_NAME"))'=""
Begin DoDot:1
+49 SET X=$$TITLE^XLFSTR($EXTRACT(INARRY("ORGANIZATION_NAME"),1,50))
+50 ;set SUBJECT ORGANIZATION if changed
IF X'=$PIECE($GET(^VA(200,XDUZ,205)),U,2)
SET FDR(200,IEN,205.2)=X
End DoDot:1
+51 IF $GET(INARRY("ORGANIZATION_ID"))'=""
Begin DoDot:1
+52 SET X=$$LOW^XLFSTR($EXTRACT(INARRY("ORGANIZATION_ID"),1,50))
+53 ;set SUBJECT ORGANIZATION ID if changed
IF X'=$PIECE($GET(^VA(200,XDUZ,205)),U,3)
SET FDR(200,IEN,205.3)=X
End DoDot:1
+54 IF $GET(INARRY("EMAIL"))'=""
Begin DoDot:1
+55 SET X=$$LOW^XLFSTR(INARRY("EMAIL"))
+56 ;set EMAIL ADDRESS if changed
IF X'=$PIECE($GET(^VA(200,XDUZ,.15)),U)
SET FDR(200,IEN,.151)=X
End DoDot:1
+57 IF $GET(INARRY("AD_UPN"))'=""
Begin DoDot:1
+58 SET X=$$LOW^XLFSTR($EXTRACT(INARRY("AD_UPN"),1,50))
+59 ;edit ADUPN if changed
IF X'=$PIECE($GET(^VA(200,XDUZ,205)),U,5)
SET FDR(200,IEN,205.5)=X
End DoDot:1
+60 IF ($GET(INARRY("SSN"))'="")&(XSHOWSSN)
Begin DoDot:1
+61 ;Search for existing user with this SSN
SET X=+$ORDER(^VA(200,"SSN",INARRY("SSN"),0))
+62 ;SSN found
IF +X>0
Begin DoDot:2
+63 ;SSN assigned to another user
IF +X'=XDUZ
Begin DoDot:3
+64 DO EDITERR(.R,"This SSN is assigned to another user")
End DoDot:3
+65 ; else SSN is assigned to this user, so no need to change SSN
End DoDot:2
+66 ;SSN not found
IF '$TEST
Begin DoDot:2
+67 ;validate SSN
IF $$SSNCHECK^XUESSO1(INARRY("SSN"))
Begin DoDot:3
+68 ;edit SSN if valid
SET FDR(200,IEN,9)=INARRY("SSN")
End DoDot:3
+69 ;error if SSN not valid
IF '$TEST
Begin DoDot:3
+70 DO EDITERR(.R,"Not a valid SSN")
End DoDot:3
End DoDot:2
End DoDot:1
+71 IF ($GET(INARRY("DOB"))'="")&(XSHOWSSN)
Begin DoDot:1
+72 SET X=INARRY("DOB")
SET %DT="X"
DO ^%DT
+73 IF Y>1
Begin DoDot:2
+74 ;edit DOB if changed
IF Y'=$PIECE($GET(^VA(200,XDUZ,1)),U,3)
SET FDR(200,IEN,5)=Y
End DoDot:2
+75 ;error if DOB not valid
IF '$TEST
Begin DoDot:2
+76 DO EDITERR(.R,"Not a valid DOB")
End DoDot:2
End DoDot:1
+77 ; Apply all the changes: File valid values and reject invalid values.
+78 SET DUZZERO=DUZ(0)
SET DUZ(0)="@"
+79 ;File all the data
IF $DATA(FDR)
DO FILE^DIE("E","FDR")
+80 ;Restore original FM access
SET DUZ(0)=DUZZERO
+81 IF $DATA(DIERR)
Begin DoDot:1
+82 SET Y=0
+83 FOR
Begin DoDot:2
+84 SET Y=$ORDER(^TMP("DIERR",$JOB,Y))
+85 ;FileMan Error
IF +Y>0
DO EDITERR(.R,$GET(^TMP("DIERR",$JOB,Y,"TEXT",1)))
End DoDot:2
if +Y'>0
QUIT
End DoDot:1
+86 IF '$TEST
IF +$GET(R(0))'=-1
Begin DoDot:1
+87 SET R(0)=XDUZ
End DoDot:1
+88 QUIT
+89 ;
IAMTU(R,SECID,TERMDATE,TERMRESN,AUTHCODE) ;RPC. XUS IAM TERMINATE USER - IA #6292
+1 ; Input: SECID = SECID - Used to identify entry to be edited
+2 ; TERMDATE = TERMINATION DATE
+3 ; TERMRESN = Termination Reason
+4 ; AUTHCODE = Security Phrase for IAM Provisioning Application
+5 ; Return: Fail R(0) = "-1^Number of Errors"
+6 ; R(1) through R(n) = "Error Message"
+7 ; Success R(0) = DUZ
+8 ;
+9 ; ZEXCEPT: %DT,DIERR ;FileMan special variables
+10 NEW DUZZERO,FDR,IEN,INARRY,X,XARRAY,XDUZ,XUENTRY,XUIAM,Y
+11 KILL R
+12 SET R(0)=0
+13 ;Do not trigger IAM updates
SET XUIAM=1
+14 IF DUZ'>1
DO EDITERR(.R,"Unauthorized access")
QUIT
+15 IF +$$ACTIVE^XUSER(DUZ)=0
DO EDITERR(.R,"Unauthorized access")
QUIT
+16 SET XUENTRY=$$GETCNTXT^XUESSO2($GET(AUTHCODE))
IF +XUENTRY<0
DO EDITERR(.R,$PIECE(XUENTRY,U,2))
QUIT
+17 IF $PIECE($GET(^XWB(8994.5,XUENTRY,0)),U)'="IAM PROVISIONING"
DO EDITERR(.R,"Unauthorized access")
QUIT
+18 IF $GET(SECID)=""
DO EDITERR(.R,"User not identified by SecID")
QUIT
+19 IF $GET(TERMDATE)=""
DO EDITERR(.R,"Missing Termination Date")
QUIT
+20 IF $GET(TERMRESN)=""
DO EDITERR(.R,"Missing Termination Reason")
QUIT
+21 ;SecID
SET XARRAY(7)=SECID
+22 ;Find user to be terminated
SET XDUZ=$$FINDUSER^XUESSO2(.XARRAY)
+23 IF +XDUZ'>1
DO EDITERR(.R,"User not found")
QUIT
+24 ;Use FM calls to edit the user
+25 KILL ^TMP("DIERR",$JOB)
+26 SET IEN=XDUZ_","
+27 ;set Termination Date
SET FDR(200,IEN,9.2)=TERMDATE
+28 ;set Termination Reason
SET FDR(200,IEN,9.4)=$EXTRACT(TERMRESN,1,45)
+29 ; Apply the changes.
+30 SET DUZZERO=DUZ(0)
SET DUZ(0)="@"
+31 ;File all the data
IF $DATA(FDR)
DO FILE^DIE("E","FDR")
+32 ;Restore original FM access
SET DUZ(0)=DUZZERO
+33 IF $DATA(DIERR)
Begin DoDot:1
+34 SET Y=0
+35 FOR
Begin DoDot:2
+36 SET Y=$ORDER(^TMP("DIERR",$JOB,Y))
+37 ;FileMan Error
IF +Y>0
DO EDITERR(.R,$GET(^TMP("DIERR",$JOB,Y,"TEXT",1)))
End DoDot:2
if +Y'>0
QUIT
End DoDot:1
+38 IF '$TEST
IF +$GET(R(0))'=-1
Begin DoDot:1
+39 SET R(0)=XDUZ
End DoDot:1
+40 QUIT
+41 ;
IAMRU(R,SECID,AUTHCODE) ;RPC. XUS IAM REACTIVATE USER - IA #6293
+1 ; Input: SECID = SECID - Used to identify entry to be edited
+2 ; AUTHCODE = Security Phrase for IAM Provisioning Application
+3 ; Return: Fail R(0) = "-1^Number of Errors"
+4 ; R(1) through R(n) = "Error Message"
+5 ; Success R(0) = 1
+6 ;
+7 ; ZEXCEPT: DIERR ;FileMan special variables
+8 NEW DUZZERO,FDR,IEN,INARRY,X,XARRAY,XDUZ,XUENTRY,XUIAM,Y
+9 KILL R
+10 SET R(0)=0
+11 ;Do not trigger IAM updates
SET XUIAM=1
+12 IF DUZ'>1
DO EDITERR(.R,"Unauthorized access")
QUIT
+13 IF +$$ACTIVE^XUSER(DUZ)=0
DO EDITERR(.R,"Unauthorized access")
QUIT
+14 SET XUENTRY=$$GETCNTXT^XUESSO2($GET(AUTHCODE))
IF +XUENTRY<0
DO EDITERR(.R,$PIECE(XUENTRY,U,2))
QUIT
+15 IF $PIECE($GET(^XWB(8994.5,XUENTRY,0)),U)'="IAM PROVISIONING"
DO EDITERR(.R,"Unauthorized access")
QUIT
+16 IF $GET(SECID)=""
DO EDITERR(.R,"User not identified by SecID")
QUIT
+17 ;SecID
SET XARRAY(7)=SECID
+18 ;Find user to be reactivated
SET XDUZ=$$FINDUSER^XUESSO2(.XARRAY)
+19 IF +XDUZ'>1
DO EDITERR(.R,"User not found")
QUIT
+20 KILL ^TMP("DIERR",$JOB)
+21 SET IEN=XDUZ_","
+22 ;set Termination Date
SET FDR(200,IEN,9.2)=""
+23 ; Apply the changes.
+24 SET DUZZERO=DUZ(0)
SET DUZ(0)="@"
+25 ;File all the data
IF $DATA(FDR)
DO FILE^DIE("E","FDR")
+26 ;Restore original FM access
SET DUZ(0)=DUZZERO
+27 IF $DATA(DIERR)
Begin DoDot:1
+28 SET Y=0
+29 FOR
Begin DoDot:2
+30 SET Y=$ORDER(^TMP("DIERR",$JOB,Y))
+31 ;FileMan Error
IF +Y>0
DO EDITERR(.R,$GET(^TMP("DIERR",$JOB,Y,"TEXT",1)))
End DoDot:2
if +Y'>0
QUIT
End DoDot:1
+32 IF '$TEST
IF +$GET(R(0))'=-1
Begin DoDot:1
+33 SET R(0)=XDUZ
End DoDot:1
+34 QUIT
+35 ;
ADDTOLST(XR,XCOUNT,XSHOWSSN,XRESULT) ;Intrinsic Subroutine. Add user to list.
+1 NEW XFLAG,XI,XODOB,XONME,XONMEC,XOSEC,XOSSN,XOUPN
+2 SET XFLAG=0
+3 FOR XI=1:1:XCOUNT
Begin DoDot:1
+4 IF XRESULT=$PIECE($GET(XR(XI)),U)
SET XFLAG=1
End DoDot:1
+5 IF XFLAG=0
Begin DoDot:1
+6 SET XCOUNT=XCOUNT+1
+7 SET XONME=$PIECE($GET(^VA(200,XRESULT,0)),U)
+8 SET XONMEC=$$NAMECOMP(XRESULT)
+9 SET XOSSN="<Hidden>"
IF $GET(XSHOWSSN)=1
SET XOSSN=$PIECE($GET(^VA(200,XRESULT,1)),U,9)
+10 SET XODOB="<Hidden>"
IF $GET(XSHOWSSN)=1
SET XODOB=$TRANSLATE($$FMTE^XLFDT($PIECE($GET(^VA(200,XRESULT,1)),U,3),"5DZ"),"/","")
+11 SET XOUPN=$PIECE($GET(^VA(200,XRESULT,205)),U,5)
+12 SET XOSEC=$TRANSLATE($PIECE($GET(^VA(200,XRESULT,205)),U),"%","^")
+13 SET XR(XCOUNT)=XRESULT_"^"_XONME_"^"_XONMEC_"^"_XOSSN_"^"_XODOB_"^"_XOUPN_"^"_XOSEC
End DoDot:1
+14 QUIT
+15 ;
NAMECOMP(IEN) ;Intrinsic Function. Get NAME COMPONENTS.
+1 NEW NAME,NC1,NCIEN
+2 SET NCIEN=$ORDER(^VA(20,"BB",200,.01,IEN_",",0))
+3 if 'NCIEN
QUIT ""
+4 SET NC1=$GET(^VA(20,NCIEN,1))
+5 QUIT $TRANSLATE($PIECE(NC1,U,1,3)_U_$PIECE(NC1,U,5),U,"`")
+6 ;
EDITERR(Y,XMSG) ;Intrinsic Subroutine. Add error to list.
+1 NEW I
+2 if $PIECE(XMSG,"-1^")=""
SET $EXTRACT(XMSG,1,3)=""
+3 SET I=$ORDER(Y(""),-1)+1
SET Y(I)=XMSG
SET Y(0)=-1_U_I
+4 QUIT
