- 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 Jan 18, 2025@03:10:37 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