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

XUESSO3.m

Go to the documentation of this file.
  1. XUESSO3 ;ISD/HGW Enhanced Single Sign-On Utilities ;02/25/16 15:33
  1. ;;8.0;KERNEL;**655,659**;Jul 10, 1995;Build 22
  1. ;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. Q
  1. 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).
  1. ; Input: One or more of Name, SSN, DoB, AD UPN, and/or SecID must be provided.
  1. ; AUTHCODE = Security Phrase for IAM Provisioning Application
  1. ; Return: Fail R(0)="-1^Error Message"
  1. ; Success R(0)=total number of entries found, from "0" to "n".
  1. ; R(1) through R(n)="DUZ^Name^NameComponents^SSN^Dob^AD UPN^SecID"
  1. ;
  1. ; ZEXCEPT: %DT
  1. N X,XARRY,XCOUNT,XI,XJ,XNAME,XRESULT,XSHOWSSN,XTEMP,XUENTRY,XUIAM,Y
  1. K R
  1. I DUZ'>1 S R(0)="-1^Unauthorized access" Q
  1. S XUENTRY=$$GETCNTXT^XUESSO2($G(AUTHCODE)) I +XUENTRY<0 S R(0)=XUENTRY Q
  1. I $P($G(^XWB(8994.5,XUENTRY,0)),U)'="IAM PROVISIONING" S R(0)="-1^Unauthorized access" Q
  1. S XUIAM=1 ;Do not trigger IAM updates
  1. S XSHOWSSN=$$KCHK^XUSRB("XUSHOWSSN")
  1. S XCOUNT=0
  1. ; 1. Search by NAME
  1. I $G(NAME)'="" D
  1. . D FIND^DIC(200,"","@","PC",NAME,"*","B")
  1. . S XI=0 F S XI=$O(^TMP("DILIST",$J,XI)) Q:'XI D
  1. . . S XRESULT=$G(^TMP("DILIST",$J,XI,0))
  1. . . D:XRESULT>0 ADDTOLST(.R,.XCOUNT,XSHOWSSN,XRESULT)
  1. . D CLEAN^DILF
  1. . K ^TMP("DILIST",$J)
  1. ; 2. Search by SSN
  1. I ($G(SSN)'="")&($G(XSHOWSSN)=1) D
  1. . S XARRY(9)=SSN
  1. . S XRESULT=$$FINDUSER^XUESSO2(.XARRY)
  1. . I +XRESULT>0 D ADDTOLST(.R,.XCOUNT,XSHOWSSN,XRESULT)
  1. . K XARRY(9)
  1. ; 3. Search by DOB
  1. I ($G(DOB)'="")&($G(XSHOWSSN)=1) D
  1. . S X=DOB,%DT="X" D ^%DT S X=Y,XRESULT=0
  1. . F D Q:XRESULT=""
  1. . . S XRESULT=$O(^VA(200,XRESULT)) Q:XRESULT=""
  1. . . I $P($G(^VA(200,XRESULT,1)),U,3)=X D ADDTOLST(.R,.XCOUNT,XSHOWSSN,XRESULT)
  1. ; 4. Search by ADUPN
  1. I $G(ADUPN)'="" D
  1. . S X=$$LOW^XLFSTR(ADUPN),XRESULT=0
  1. . S XRESULT=$$UPNMATCH^XUESSO2(ADUPN)
  1. . I XRESULT>0 D ADDTOLST(.R,.XCOUNT,XSHOWSSN,XRESULT)
  1. ; 5. Search by SECID
  1. I $G(SECID)'="" D
  1. . S XARRY(7)=SECID
  1. . S XRESULT=$$FINDUSER^XUESSO2(.XARRY)
  1. . I +XRESULT>0 D ADDTOLST(.R,.XCOUNT,XSHOWSSN,XRESULT)
  1. . K XARRY(7)
  1. ; 6. Return results
  1. S R(0)=XCOUNT
  1. Q
  1. ;
  1. IAMDU(R,DISPDUZ,AUTHCODE) ;RPC. XUS IAM DISPLAY USER - IA #6289
  1. ; Input: DISPDUZ = DUZ (IEN) of user to be displayed
  1. ; AUTHCODE = Security Phrase for IAM Provisioning Application
  1. ; Return: Fail R(0) ="-1^Error Message"
  1. ; Success R(0) = 1
  1. ; R("NAME") = NAME
  1. ; R("LASTNAME") = Family Name
  1. ; R("FIRSTNAME") = Given Name
  1. ; R("MIDDLENAME") = Middle Name
  1. ; R("SUFFIX") = Suffix(es)
  1. ; R("INITIAL") = INITIAL
  1. ; R("TITLE") = TITLE
  1. ; R("NICK_NAME") = NICK NAME
  1. ; R("SSN") = SSN (<Hidden> if caller does not have XUSHOWSSN key)
  1. ; R("DOB") = DOB (<Hidden> if caller does not have XUSHOWSSN key)
  1. ; R("DEGREE") = DEGREE
  1. ; R("MAIL_CODE") = MAIL CODE
  1. ; R("STATUS") = $$ACTIVE^XUSER(DISPDUZ)
  1. ; R("DISUSER") = DISUSER
  1. ; R("TERMINATION_DATE") = TERMINATION DATE
  1. ; R("TERMINATION_REASON") = TERMINATION REASON
  1. ; R("PRIMARY_MENU_OPTION") = PRIMARY MENU OPTION
  1. ; R("SECONDARY_MENU_OPTION",0) = SECONDARY MENU OPTION (number of entries)
  1. ; R("SECONDARY_MENU_OPTION",1) to R("SECONDARY_MENU_OPTION",n) = SECONDARY MENU OPTION entries
  1. ; R("FILE_MANAGER_ACCESS_CODE") = FILE MANAGER ACCESS CODE
  1. ; R("DIVISION",0) = DIVISION (number of entries)
  1. ; R("DIVISION",1) to R("DIVISION",n) = DIVISION entries
  1. ; R("SERVICE_SECTION") = SERVICE/SECTION
  1. ; R("SUBJECT_ALTERNATIVE_NAME") = SUBJECT ALTERNATIVE NAME (PIV CARD)
  1. ; R("SECID") = SECID
  1. ; R("ORGANIZATION_NAME") = SUBJECT ORGANIZATION
  1. ; R("ORGANIZATION_ID") = SUBJECT ORGANIZATION ID
  1. ; R("UNIQUE_USER_ID") = UNIQUE USER ID
  1. ; R("NETWORK_USER_NAME") = NETWORK USERNAME
  1. ; R("AD_UPN") = ADUPN
  1. ; R("EMAIL") = EMAIL ADDRESS
  1. ; R("GENDER") = SEX (M/F)
  1. ;
  1. N X,XI,XIEN,XJ,XN,XSHOWSSN,XT,XT1,XT205,XT5,XT501,XUENTRY,XUIAM,Y
  1. K R
  1. I DUZ'>1 S R(0)="-1^Unauthorized access" Q
  1. S XUENTRY=$$GETCNTXT^XUESSO2($G(AUTHCODE)) I +XUENTRY<0 S R(0)=XUENTRY Q
  1. I $P($G(^XWB(8994.5,XUENTRY,0)),U)'="IAM PROVISIONING" S R(0)="-1^Unauthorized access" Q
  1. I $G(DUZ("LOA"))<2 S R(0)="-1^Unauthorized access" Q
  1. I $G(DISPDUZ)'>0 S R(0)="-1^User not selected" Q
  1. I $G(^VA(200,DISPDUZ,0))="" S R(0)="-1^User not found" Q
  1. S XUIAM=1 ;Do not trigger IAM updates
  1. S XSHOWSSN=$$KCHK^XUSRB("XUSHOWSSN")
  1. S XT=$G(^VA(200,DISPDUZ,0))
  1. S XT1=$G(^VA(200,DISPDUZ,1))
  1. S XT5=$G(^VA(200,DISPDUZ,5))
  1. S XT205=$G(^VA(200,DISPDUZ,205))
  1. S XT501=$G(^VA(200,DISPDUZ,501))
  1. S R(0)=1
  1. S (XN,R("NAME"))=$P($G(XT),U)
  1. S XIEN=DISPDUZ_","
  1. S X=0 S X=$O(^VA(20,"BB",200,.01,XIEN,X)) ;Get NAME COMPONENTS
  1. S Y="" I +X>0 S Y=$G(^VA(20,X,1))
  1. S R("LASTNAME")=$P(Y,U)
  1. S R("FIRSTNAME")=$P(Y,U,2)
  1. S R("MIDDLENAME")=$P(Y,U,3)
  1. S R("SUFFIX")=$P(Y,U,4)
  1. S R("INITIAL")=$P($G(XT),U,2)
  1. S R("TITLE")="" S X=$P($G(XT),U,9)
  1. I $G(X)>0 S R("TITLE")=$P($G(^DIC(3.1,X,0)),U)
  1. S R("NICK_NAME")=$P($G(^VA(200,DISPDUZ,.1)),U,4)
  1. S R("SSN")="<Hidden>" I $G(XSHOWSSN)=1 S R("SSN")=$P($G(XT1),U,9)
  1. S R("DOB")="<Hidden>" I $G(XSHOWSSN)=1 S R("DOB")=$TR($$FMTE^XLFDT($P($G(XT1),U,3),"5DZ"),"/","")
  1. S R("DEGREE")=$P($G(^VA(200,DISPDUZ,3.1)),U,6)
  1. S R("MAIL_CODE")=$P($G(XT5),U,2)
  1. S R("STATUS")=$$ACTIVE^XUSER(DISPDUZ) ;Supported IA #2343
  1. S X=$P($G(R("STATUS")),U,3) I X'="" D
  1. . S X=$TR($$FMTE^XLFDT(X,"5DZ"),"/","")
  1. . S $P(R("STATUS"),U,3)=X
  1. S R("DISUSER")=$P($G(XT),U,7)
  1. S R("TERMINATION_DATE")=$TR($$FMTE^XLFDT($P($G(XT),U,11),"5DZ"),"/","")
  1. S R("TERMINATION_REASON")=$P($G(XT),U,13)
  1. S R("PRIMARY_MENU_OPTION")=$P($G(^VA(200,DISPDUZ,201)),U)
  1. I $G(R("PRIMARY_MENU_OPTION"))>0 S R("PRIMARY_MENU_OPTION")=$P($G(^DIC(19,R("PRIMARY_MENU_OPTION"),0)),U)
  1. S (XI,XJ)=0
  1. I $G(^VA(200,DISPDUZ,203,0))'="" F D Q:+XI'>0
  1. . S XI=$O(^VA(200,DISPDUZ,203,XI)) Q:+XI'>0
  1. . S XJ=XJ+1,R("SECONDARY_MENU_OPTION",XJ)=$P($G(^VA(200,DISPDUZ,203,XI,0)),U)
  1. . 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)
  1. S R("SECONDARY_MENU_OPTION",0)=XJ ;number of entries
  1. S R("FILE_MANAGER_ACCESS_CODE")=$P($G(XT),U,4)
  1. S (XI,XJ)=0
  1. I $G(^VA(200,DISPDUZ,2,0))'="" F D Q:+XI'>0
  1. . S XI=$O(^VA(200,DISPDUZ,2,XI)) Q:+XI'>0
  1. . S XJ=XJ+1,R("DIVISION",XJ)=$P($G(^VA(200,DISPDUZ,2,XI,0)),U)
  1. . I $G(R("DIVISION",XJ))>0 S R("DIVISION",XJ)=$P($G(^DIC(4,R("DIVISION",XJ),99)),U)
  1. S R("DIVISION",0)=XJ ;number of entries
  1. S R("SERVICE_SECTION")=$P($G(XT5),U,1)
  1. I $G(R("SERVICE_SECTION"))>0 S R("SERVICE_SECTION")=$P($G(^DIC(49,R("SERVICE_SECTION"),0)),U)
  1. S R("SUBJECT_ALTERNATIVE_NAME")=$P($G(XT501),U,2)
  1. S R("SECID")=$TR($P($G(XT205),U),"%","^")
  1. S R("ORGANIZATION_NAME")=$P($G(XT205),U,2)
  1. S R("ORGANIZATION_ID")=$P($G(XT205),U,3)
  1. S R("UNIQUE_USER_ID")=$P($G(XT205),U,4)
  1. S R("NETWORK_USER_NAME")=$P($G(XT501),U)
  1. S R("AD_UPN")=$P($G(XT205),U,5)
  1. S R("EMAIL")=$P($G(^VA(200,DISPDUZ,.15)),U)
  1. S R("GENDER")=$P($G(XT1),U,2)
  1. Q
  1. ;
  1. 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).
  1. ; Input: NAME = SubjectID to be used in SAML Token
  1. ; SECID = UniqueUserID to be used in SSOi or SSOe SAML Token
  1. ; EMAIL = User's e-mail address
  1. ; ADUPN = Active Directory User Principle Name
  1. ; SSN = User's Social Security Number or Taxpayer Identification Number
  1. ; DOB = User's Date of Birth
  1. ; STATION = NEW PERSON file (#200) DIVISION
  1. ; AUTHCODE = (Required) Security Phrase for IAM Provisioning Application
  1. ; Return: Fail R(0) = "-1^Number of Errors"
  1. ; R(1) through R(n) = "Error Message"
  1. ; Success R(0) = "DUZ^STATION"
  1. ;
  1. ; ZEXCEPT: %DT,DA,DIERR,DIK ;FileMan special variables
  1. N DIC,DUZZERO,ERRMSG,FDR,IEN,NEWDUZ,X,XARRAY,XDIV,XUENTRY,XUIAM,Y
  1. K R
  1. S R(0)=0
  1. I DUZ'>1 D EDITERR(.R,"Unauthorized access") Q
  1. I +$$ACTIVE^XUSER(DUZ)=0 D EDITERR(.R,"Unauthorized access") Q
  1. I $G(DUZ("LOA"))<2 D EDITERR(.R,"Unauthorized access") Q
  1. S XUIAM=1 ;Do not trigger IAM updates
  1. I ($G(SSN)'>1)&('$$KCHK^XUSRB("XUSPF200")) D EDITERR(.R,"Need XUSPF200 key if no SSN") Q
  1. S XUENTRY=$$GETCNTXT^XUESSO2($G(AUTHCODE)) I +XUENTRY<0 D EDITERR(.R,XUENTRY) Q
  1. I $P($G(^XWB(8994.5,XUENTRY,0)),U)'="IAM PROVISIONING" D EDITERR(.R,"Unauthorized access") Q
  1. I $G(NAME)="" D EDITERR(.R,"Missing SubjectID") Q
  1. I $G(SECID)="" D EDITERR(.R,"Missing SecID") Q
  1. S Y=$$SECMATCH^XUESSO2(SECID) I Y>0 D EDITERR(.R,"User with given SecID already exists") Q
  1. I $G(SSN)>1 S Y=+$O(^VA(200,"SSN",SSN,0))
  1. I Y>0 D EDITERR(.R,"User with given SSN already exists") Q
  1. I ($G(SSN)>1)&('$$SSNCHECK^XUESSO1($G(SSN))) D EDITERR(.R,"Invalid SSN") Q
  1. I $G(DOB)'="" D Q:Y=-1
  1. . S X=DOB S %DT="X" D ^%DT I Y=-1 D EDITERR(.R,"Invalid DOB") Q
  1. . S DOB=$G(Y)
  1. I $G(STATION)'="" D Q:Y=""
  1. . S Y="" S Y=$O(^DIC(4,"D",$G(STATION),Y))
  1. . I Y="" D EDITERR(.R,"-1^Invalid STATION") Q
  1. . S XDIV=$P($G(^DIC(4,Y,0)),U,1)
  1. S XARRAY(1)=$P($G(^XTV(8989.3,1,200)),U,2)
  1. S XARRAY(2)=$P($G(^XTV(8989.3,1,200)),U,3)
  1. S XARRAY(3)=SECID
  1. S XARRAY(4)=NAME
  1. S XARRAY(7)=SECID
  1. S XARRAY(9)=$G(SSN)
  1. S Y=$$ADDUSER^XUESSO2(.XARRAY) ;Add the user
  1. I +Y<0 D EDITERR(.R,Y) Q
  1. S NEWDUZ=Y
  1. ;Use FM calls to edit the user with the remaining information
  1. K ^TMP("DIERR",$J)
  1. S DIC(0)="",ERRMSG=""
  1. S IEN=NEWDUZ_","
  1. I $G(EMAIL)'="" S FDR(200,IEN,.151)=$$LOW^XLFSTR(EMAIL)
  1. I $G(ADUPN)'="" S FDR(200,IEN,205.5)=$$LOW^XLFSTR(ADUPN)
  1. I $G(DOB)'="" S FDR(200,IEN,5)=DOB
  1. I $G(XDIV)'="" S FDR(200.02,"+3,"_IEN,.01)=XDIV
  1. ; Apply all the changes: File valid values and reject invalid values.
  1. S DUZZERO=DUZ(0),DUZ(0)="@"
  1. I $D(FDR) K IEN D UPDATE^DIE("E","FDR","IEN") ;File all the data
  1. S DUZ(0)=DUZZERO ;Restore original FM access
  1. I $D(DIERR) D
  1. . S Y=0
  1. . F D Q:+Y'>0
  1. . . S Y=$O(^TMP("DIERR",$J,Y)) I +Y>0 W !,$G(^TMP("DIERR",$J,Y,"TEXT",1))
  1. . . I +Y>0 D EDITERR(.R,$G(^TMP("DIERR",$J,Y,"TEXT",1))) ;FileMan Error
  1. . K DA,DIK S DIK="^VA(200,",DA=NEWDUZ D ^DIK ;Rollback add if all fields could not be filed
  1. I +$G(R(0))'=-1 S R(0)=NEWDUZ_U_STATION
  1. Q
  1. ;
  1. 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).
  1. ; Input: INARRY("SECID") = SecID - Used to identify entry to be edited
  1. ; INARRAY("LASTNAME") = User NAME is "LASTNAME,FIRSTNAME MIDDLENAME SUFFIX"
  1. ; INARRAY("FIRSTNAME")
  1. ; INARRAY("MIDDLENAME")
  1. ; INARRAY("SUFFIX")
  1. ; INARRY("ORGANIZATION_NAME")= SUBJECT ORGANIZATION
  1. ; INARRY("ORGANIZATION_ID") = SUBJECT ORGANIZATION ID
  1. ; INARRY("EMAIL") = EMAIL ADDRESS
  1. ; INARRY("AD_UPN") = ADUPN
  1. ; INARRY("SSN") = SSN
  1. ; INARRY("DOB") = DOB (Date of Birth)
  1. ; AUTHCODE = Security Phrase for IAM Provisioning Application
  1. ; Return: Fail R(0) = "-1^Number of Errors"
  1. ; R(1) through R(n) = "Error Message"
  1. ; Success R(0) = DUZ of NEW PERSON file entry that was edited
  1. ;
  1. ; ZEXCEPT: %DT,DIERR ;FileMan special variables
  1. N DUZZERO,FDR,IEN,X,XARRAY,XDUZ,XSHOWSSN,XUENTRY,XUIAM,XUN,XUNAME,XUNEWN,XUOLDN,Y
  1. K R
  1. S R(0)=0
  1. S XUIAM=1 ;Do not trigger IAM updates
  1. I DUZ'>1 D EDITERR(.R,"Unauthorized access") Q
  1. I +$$ACTIVE^XUSER(DUZ)=0 D EDITERR(.R,"Unauthorized access") Q
  1. S XUENTRY=$$GETCNTXT^XUESSO2($G(AUTHCODE)) I +XUENTRY<0 D EDITERR(.R,$P(XUENTRY,U,2)) Q
  1. I $P($G(^XWB(8994.5,XUENTRY,0)),U)'="IAM PROVISIONING" D EDITERR(.R,"Unauthorized access") Q
  1. I $G(DUZ("LOA"))<2 D EDITERR(.R,"Unauthorized access") Q
  1. I $G(INARRY("SECID"))="" D EDITERR(.R,"User not identified by SecID") Q
  1. S XARRAY(7)=INARRY("SECID")
  1. S XDUZ=$$SECMATCH^XUESSO2(XARRAY(7)) I XDUZ'>0 D EDITERR(.R,"User not found") Q
  1. 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
  1. S XSHOWSSN=$$KCHK^XUSRB("XUSHOWSSN")
  1. I ($G(INARRY("SSN")))&('XSHOWSSN) D EDITERR(.R,"XUSHOWSSN Security Key is required to edit SSN")
  1. I ($G(INARRY("DOB")))&('XSHOWSSN) D EDITERR(.R,"XUSHOWSSN Security Key is required to edit DOB")
  1. ;Use FM calls to edit the user with the remaining information
  1. K ^TMP("DIERR",$J)
  1. S IEN=XDUZ_","
  1. S XUN("FILE")=200,XUN("IENS")=IEN,XUN("FIELD")=.01
  1. S XUOLDN=$$NAMEFMT^XLFNAME(.XUN,"F","CS")
  1. K XUN S XUN=XUOLDN
  1. D NAMECOMP^XLFNAME(.XUN)
  1. I $D(INARRY("LASTNAME")) S XUN("FAMILY")=$G(INARRY("LASTNAME"))
  1. I $D(INARRY("FIRSTNAME")) S XUN("GIVEN")=$G(INARRY("FIRSTNAME"))
  1. I $D(INARRY("MIDDLENAME")) S XUN("MIDDLE")=$G(INARRY("MIDDLENAME"))
  1. I $D(INARRY("SUFFIX")) S XUN("SUFFIX")=$G(INARRY("SUFFIX"))
  1. S XUNEWN=$$NAMEFMT^XLFNAME(.XUN,"F","CS")
  1. I XUNEWN'=XUOLDN S FDR(200,IEN,.01)=XUNEWN ;set NAME if changed
  1. I $G(INARRY("ORGANIZATION_NAME"))'="" D
  1. . S X=$$TITLE^XLFSTR($E(INARRY("ORGANIZATION_NAME"),1,50))
  1. . I X'=$P($G(^VA(200,XDUZ,205)),U,2) S FDR(200,IEN,205.2)=X ;set SUBJECT ORGANIZATION if changed
  1. I $G(INARRY("ORGANIZATION_ID"))'="" D
  1. . S X=$$LOW^XLFSTR($E(INARRY("ORGANIZATION_ID"),1,50))
  1. . I X'=$P($G(^VA(200,XDUZ,205)),U,3) S FDR(200,IEN,205.3)=X ;set SUBJECT ORGANIZATION ID if changed
  1. I $G(INARRY("EMAIL"))'="" D
  1. . S X=$$LOW^XLFSTR(INARRY("EMAIL"))
  1. . I X'=$P($G(^VA(200,XDUZ,.15)),U) S FDR(200,IEN,.151)=X ;set EMAIL ADDRESS if changed
  1. I $G(INARRY("AD_UPN"))'="" D
  1. . S X=$$LOW^XLFSTR($E(INARRY("AD_UPN"),1,50))
  1. . I X'=$P($G(^VA(200,XDUZ,205)),U,5) S FDR(200,IEN,205.5)=X ;edit ADUPN if changed
  1. I ($G(INARRY("SSN"))'="")&(XSHOWSSN) D
  1. . S X=+$O(^VA(200,"SSN",INARRY("SSN"),0)) ;Search for existing user with this SSN
  1. . I +X>0 D ;SSN found
  1. . . I +X'=XDUZ D ;SSN assigned to another user
  1. . . . D EDITERR(.R,"This SSN is assigned to another user")
  1. . . ; else SSN is assigned to this user, so no need to change SSN
  1. . E D ;SSN not found
  1. . . I $$SSNCHECK^XUESSO1(INARRY("SSN")) D ;validate SSN
  1. . . . S FDR(200,IEN,9)=INARRY("SSN") ;edit SSN if valid
  1. . . E D ;error if SSN not valid
  1. . . . D EDITERR(.R,"Not a valid SSN")
  1. I ($G(INARRY("DOB"))'="")&(XSHOWSSN) D
  1. . S X=INARRY("DOB") S %DT="X" D ^%DT
  1. . I Y>1 D
  1. . . I Y'=$P($G(^VA(200,XDUZ,1)),U,3) S FDR(200,IEN,5)=Y ;edit DOB if changed
  1. . E D ;error if DOB not valid
  1. . . D EDITERR(.R,"Not a valid DOB")
  1. ; Apply all the changes: File valid values and reject invalid values.
  1. S DUZZERO=DUZ(0),DUZ(0)="@"
  1. I $D(FDR) D FILE^DIE("E","FDR") ;File all the data
  1. S DUZ(0)=DUZZERO ;Restore original FM access
  1. I $D(DIERR) D
  1. . S Y=0
  1. . F D Q:+Y'>0
  1. . . S Y=$O(^TMP("DIERR",$J,Y))
  1. . . I +Y>0 D EDITERR(.R,$G(^TMP("DIERR",$J,Y,"TEXT",1))) ;FileMan Error
  1. E I +$G(R(0))'=-1 D
  1. . S R(0)=XDUZ
  1. Q
  1. ;
  1. IAMTU(R,SECID,TERMDATE,TERMRESN,AUTHCODE) ;RPC. XUS IAM TERMINATE USER - IA #6292
  1. ; Input: SECID = SECID - Used to identify entry to be edited
  1. ; TERMDATE = TERMINATION DATE
  1. ; TERMRESN = Termination Reason
  1. ; AUTHCODE = Security Phrase for IAM Provisioning Application
  1. ; Return: Fail R(0) = "-1^Number of Errors"
  1. ; R(1) through R(n) = "Error Message"
  1. ; Success R(0) = DUZ
  1. ;
  1. ; ZEXCEPT: %DT,DIERR ;FileMan special variables
  1. N DUZZERO,FDR,IEN,INARRY,X,XARRAY,XDUZ,XUENTRY,XUIAM,Y
  1. K R
  1. S R(0)=0
  1. S XUIAM=1 ;Do not trigger IAM updates
  1. I DUZ'>1 D EDITERR(.R,"Unauthorized access") Q
  1. I +$$ACTIVE^XUSER(DUZ)=0 D EDITERR(.R,"Unauthorized access") Q
  1. S XUENTRY=$$GETCNTXT^XUESSO2($G(AUTHCODE)) I +XUENTRY<0 D EDITERR(.R,$P(XUENTRY,U,2)) Q
  1. I $P($G(^XWB(8994.5,XUENTRY,0)),U)'="IAM PROVISIONING" D EDITERR(.R,"Unauthorized access") Q
  1. I $G(SECID)="" D EDITERR(.R,"User not identified by SecID") Q
  1. I $G(TERMDATE)="" D EDITERR(.R,"Missing Termination Date") Q
  1. I $G(TERMRESN)="" D EDITERR(.R,"Missing Termination Reason") Q
  1. S XARRAY(7)=SECID ;SecID
  1. S XDUZ=$$FINDUSER^XUESSO2(.XARRAY) ;Find user to be terminated
  1. I +XDUZ'>1 D EDITERR(.R,"User not found") Q
  1. ;Use FM calls to edit the user
  1. K ^TMP("DIERR",$J)
  1. S IEN=XDUZ_","
  1. S FDR(200,IEN,9.2)=TERMDATE ;set Termination Date
  1. S FDR(200,IEN,9.4)=$E(TERMRESN,1,45) ;set Termination Reason
  1. ; Apply the changes.
  1. S DUZZERO=DUZ(0),DUZ(0)="@"
  1. I $D(FDR) D FILE^DIE("E","FDR") ;File all the data
  1. S DUZ(0)=DUZZERO ;Restore original FM access
  1. I $D(DIERR) D
  1. . S Y=0
  1. . F D Q:+Y'>0
  1. . . S Y=$O(^TMP("DIERR",$J,Y))
  1. . . I +Y>0 D EDITERR(.R,$G(^TMP("DIERR",$J,Y,"TEXT",1))) ;FileMan Error
  1. E I +$G(R(0))'=-1 D
  1. . S R(0)=XDUZ
  1. Q
  1. ;
  1. IAMRU(R,SECID,AUTHCODE) ;RPC. XUS IAM REACTIVATE USER - IA #6293
  1. ; Input: SECID = SECID - Used to identify entry to be edited
  1. ; AUTHCODE = Security Phrase for IAM Provisioning Application
  1. ; Return: Fail R(0) = "-1^Number of Errors"
  1. ; R(1) through R(n) = "Error Message"
  1. ; Success R(0) = 1
  1. ;
  1. ; ZEXCEPT: DIERR ;FileMan special variables
  1. N DUZZERO,FDR,IEN,INARRY,X,XARRAY,XDUZ,XUENTRY,XUIAM,Y
  1. K R
  1. S R(0)=0
  1. S XUIAM=1 ;Do not trigger IAM updates
  1. I DUZ'>1 D EDITERR(.R,"Unauthorized access") Q
  1. I +$$ACTIVE^XUSER(DUZ)=0 D EDITERR(.R,"Unauthorized access") Q
  1. S XUENTRY=$$GETCNTXT^XUESSO2($G(AUTHCODE)) I +XUENTRY<0 D EDITERR(.R,$P(XUENTRY,U,2)) Q
  1. I $P($G(^XWB(8994.5,XUENTRY,0)),U)'="IAM PROVISIONING" D EDITERR(.R,"Unauthorized access") Q
  1. I $G(SECID)="" D EDITERR(.R,"User not identified by SecID") Q
  1. S XARRAY(7)=SECID ;SecID
  1. S XDUZ=$$FINDUSER^XUESSO2(.XARRAY) ;Find user to be reactivated
  1. I +XDUZ'>1 D EDITERR(.R,"User not found") Q
  1. K ^TMP("DIERR",$J)
  1. S IEN=XDUZ_","
  1. S FDR(200,IEN,9.2)="" ;set Termination Date
  1. ; Apply the changes.
  1. S DUZZERO=DUZ(0),DUZ(0)="@"
  1. I $D(FDR) D FILE^DIE("E","FDR") ;File all the data
  1. S DUZ(0)=DUZZERO ;Restore original FM access
  1. I $D(DIERR) D
  1. . S Y=0
  1. . F D Q:+Y'>0
  1. . . S Y=$O(^TMP("DIERR",$J,Y))
  1. . . I +Y>0 D EDITERR(.R,$G(^TMP("DIERR",$J,Y,"TEXT",1))) ;FileMan Error
  1. E I +$G(R(0))'=-1 D
  1. . S R(0)=XDUZ
  1. Q
  1. ;
  1. ADDTOLST(XR,XCOUNT,XSHOWSSN,XRESULT) ;Intrinsic Subroutine. Add user to list.
  1. N XFLAG,XI,XODOB,XONME,XONMEC,XOSEC,XOSSN,XOUPN
  1. S XFLAG=0
  1. F XI=1:1:XCOUNT D
  1. . I XRESULT=$P($G(XR(XI)),U) S XFLAG=1
  1. I XFLAG=0 D
  1. . S XCOUNT=XCOUNT+1
  1. . S XONME=$P($G(^VA(200,XRESULT,0)),U)
  1. . S XONMEC=$$NAMECOMP(XRESULT)
  1. . S XOSSN="<Hidden>" I $G(XSHOWSSN)=1 S XOSSN=$P($G(^VA(200,XRESULT,1)),U,9)
  1. . S XODOB="<Hidden>" I $G(XSHOWSSN)=1 S XODOB=$TR($$FMTE^XLFDT($P($G(^VA(200,XRESULT,1)),U,3),"5DZ"),"/","")
  1. . S XOUPN=$P($G(^VA(200,XRESULT,205)),U,5)
  1. . S XOSEC=$TR($P($G(^VA(200,XRESULT,205)),U),"%","^")
  1. . S XR(XCOUNT)=XRESULT_"^"_XONME_"^"_XONMEC_"^"_XOSSN_"^"_XODOB_"^"_XOUPN_"^"_XOSEC
  1. Q
  1. ;
  1. NAMECOMP(IEN) ;Intrinsic Function. Get NAME COMPONENTS.
  1. N NAME,NC1,NCIEN
  1. S NCIEN=$O(^VA(20,"BB",200,.01,IEN_",",0))
  1. Q:'NCIEN ""
  1. S NC1=$G(^VA(20,NCIEN,1))
  1. Q $TR($P(NC1,U,1,3)_U_$P(NC1,U,5),U,"`")
  1. ;
  1. EDITERR(Y,XMSG) ;Intrinsic Subroutine. Add error to list.
  1. N I
  1. S:$P(XMSG,"-1^")="" $E(XMSG,1,3)=""
  1. S I=$O(Y(""),-1)+1,Y(I)=XMSG,Y(0)=-1_U_I
  1. Q