XUIAMPR ;BHM/DLR,DRI - IAM PROVISIONING - ADD/UPDATE OF A NEW PERSON ;1/26/23 09:01
;;8.0;KERNEL;**799**;Jul 10, 1995;Build 3
;;Per VHA Directive 2004-038, this routine should not be modified
;
ENTERPRISE(XUREQTYP,XUTERMDT) ;iam enterprise new person search and add to VistA ;**663 - STORY 783347 (dri)
;**799 VAMPI-22625
; Input:
; XUREQTYP = 'ADD' or 'MODIFY' of a new person
; XUTERMDT = the optional termination date when doing batch entry of
; new persons through 'Grant Access by Profile' option
;
; Output:
; IEN (DUZ) from file #200 if successfully added
; -1^error message = there's a problem, can't continue
; 0 = can't perform enterprise search, possibly due to network
; issue or non-production account, optionally continue with
; legacy functionality
;
; Reference to WEB SERVER (#18.12) file allowed with supported IA #6408
; Reference to OP^XQCHK supported by IA #10078
;
;
N PROD,XUIAM,XUOPT,XURET,XUSRCH
;
I $$GET1^DIQ(18.12,+$$FIND1^DIC(18.12,,"BX","MPI_PSIM_NEW EXECUTE")_",",.04,"E")="" Q 0 ;don't use enterprise search functionality if web service server doesn't exist
;
S XUOPT=$$OPTION() ;what option is the user in
;
S Y=$$CHKUSER(.DUZ) I Y'=1 D Q +Y ;does user performing 'add' have a secid at enterprise
.W !!,"Sorry ... I can't verify your credentials."
.W !,$P(Y,"^",2) ;returned error message
.I +Y=0 S Y=$$LEGACY() S Y=$S(Y=1:0,1:-1) Q ;communication issue, allow legacy add
.I +Y<0 W !!,"You can attempt to use Link My Account to resolve the issue and retry.",!,"If you need assistance or the problem persists, please log a service ticket." ;problem with user
;
;S Y=$$ASKSRCH() I Y'=1 Q Y ;perform an enterprise search? ;not implementing
;
S XUSRCH=$$ASKCRIT() I XUSRCH<0 Q XUSRCH ;lookup by email address, network username or traits
;
S Y=$$RETCRIT(XUSRCH,.XUIAM) I Y<0 Q Y ;return email address or network username
;
I (XUSRCH'="T"),($$SRCH(.XURET,.XUIAM)'=1) Q -1 ;perform an initial query of psim to find person, unless by Traits
;
I '$O(XURET(0)) I $$XSRCH(.XURET,.XUIAM,XUSRCH)'=1 Q -1 ;if initial search didn't find anyone, add more traits and perform an enhanced query of psim to find person
;
S PROD=$$PROD^XUPROD() ;0-test, 1-production
I 'PROD,$S($G(XURET)<0:1,$G(XURET("errorMessage"))'="":1,1:0) D Q Y ;if a test account and issues
.I $G(XURET)<0 W !!,"... ",$P(XURET,"^",2) S Y=$$LEGACY() S Y=$S(Y=1:0,1:-1) Q ;and a communication issue with enterprise, fall into legacy functionality
.I $G(XURET("errorMessage"))'="" W !!,"... ",XURET("errorMessage") S Y=$$LEGACY() S Y=$S(Y=1:0,1:-1) Q ;and person not found at enterprise, fall into legacy functionality
I PROD,$S($G(XURET)<0:1,$G(XURET("errorMessage"))'="":1,1:0) D Q Y ;if a production account and issues
.I $G(XURET)<0 W !!,"... ",$P(XURET,"^",2) D S Y=$$LEGACY() S Y=$S(Y=1:0,1:-1) Q ;and a communication issue with enterprise, fall into legacy functionality
..W !!,"... ","Enterprise Search is currently unavailable. You can exit and try",!?4,"again later or proceed using the legacy '",$G(XUOPT),"'."
.I $G(XURET("errorMessage"))'="" W !!,"... ",XURET("errorMessage") D S Y=-1 Q ;and person is not found at enterprise, try again
..W !!,"... User was not found but should already be known at Enterprise.",!?4,"Please review the criteria and try again. If you are still unable",!?4,"to look them up please log a service ticket for assistance."
;
Q $$FINDUSER^XUIAMPR1(.XURET,XUREQTYP,XUTERMDT) ;return duz of user to ^xusernew
;
;
OPTION() ;return option being executed
N XQORNOD,XQOPT,XUOPT
S XUOPT="Add a New User to the System" ;default if in programmer mode
D OP^XQCHK I +XQOPT'=-1 S XUOPT=$P(XQOPT,"^",2)
Q XUOPT
;
CHKUSER(DUZ) ;user must have secid at enterprise to perform enterprise search
; Input:
; DUZ = User's IEN in File #200
;
; Output:
; 1 = secid was found at enterprise
; 0 = could not communicate with enterprise
; -1 = error condition
;
N XUARR,XUIAM,XURET
I $G(DUZ("LOA"))<2 Q "-1^Insufficient Level of Assurance"
D GETS^DIQ(200,+DUZ_",","205.5;501.1","E","XUARR")
S XUIAM("VAemail")=XUARR(200,+DUZ_",",205.5,"E") ;adupn/email address" ;adupn/email address
S XUIAM("samacctnm")=XUARR(200,+DUZ_",",501.1,"E") ;SaMaccountName/network username
I XUIAM("VAemail")=""&(XUIAM("samacctnm")="") Q "-1^Network Username or ADUPN must be defined in the NEW PERSON (#200) file."
D USER^XUIAMXML(.XURET,.XUIAM) ;is person adding new persons known at enterprise
I $G(XURET)<0 Q "0^"_$P(XURET,"^",2) ;communication issue with enterprise, continue with legacy functionality
I $G(XURET("errorMessage"))'="" Q "-1^"_XURET("errorMessage")
I $G(XURET("secId"))="" Q "-1^secID not defined at Enterprise."
Q $G(XURET("secId"))'=""
;
ASKSRCH() ;enterprise search by email address or network username
N DIR,DIRUT,DTOUT,DUOUT,X,Y
W ! S DIR(0)="Y",DIR("B")="Yes",DIR("A")="Do you want to do an Enterprise Search" D ^DIR I $D(DIRUT) S Y=-1_"^Enterprise Search Rejected"
Q Y
;
ASKCRIT() ;enterprise search by email address, network username or traits
W !!,"Utilizing Enterprise User Search ..."
N DIR,DIRUT,DTOUT,DUOUT,X,Y
W ! S DIR(0)="SA^E:Email Address;N:Network Username;T:Traits",DIR("A")="Enter an 'E'mail Address, 'N'etwork Username or 'T'raits: ",DIR("B")="E" D ^DIR I $D(DIRUT) S Y=-1_"^Search Criteria not Entered"
Q Y
;
RETCRIT(XUSRCH,XUIAM) ;return search criteria
I XUSRCH="E" D I Y<0 Q Y ;email address
.;K DIR S DIR(0)="200,.151^r" D ^DIR I Y'["@" S Y="-1^Invalid EMAIL ADDRESS" Q ;email address input transform is stronger that adupn's
.K DIR S DIR(0)="FAO^7:50^K:$L(X)>50!($L(X)<7)!'(X?1.E1""@""1.E) X I $D(X) K:X["",""!(X["" "") X"
.S DIR("A")="Enter EMAIL ADDRESS: ",DIR("?")="Enter valid internet address in xxx@domain format, 7-50 characters in length, no commas or spaces."
.D ^DIR I Y'["@" S Y="-1^Invalid EMAIL ADDRESS" Q ;email address/adupn
.S XUIAM("VAemail")=$TR(Y,"&","") ;strip off any '&', throws off the spml
;
I XUSRCH="N" D I Y<0 Q Y ;network username
.;K DIR S DIR(0)="200,501.1^r" D ^DIR I Y'["@" S Y="-1^Invalid NETWORK USERNAME" Q ;network username input transform too strong
.K DIR S DIR(0)="FAO^9:15"
.S DIR("A")="Enter NETWORK USERNAME: ",DIR("?")="Enter the Active Directory Username (9-15 characters)."
.D ^DIR I $D(DIRUT)!(Y="") S Y="-1^Invalid NETWORK USERNAME" Q ;network username
.S XUIAM("samacctnm")=$$UP^XLFSTR($TR(Y,"&","")) ;strip off any '&', throws off the spml
Q 1
;
LEGACY() ;ask to perform legacy add of new person
N DIR,DIRUT,DTOUT,DUOUT,X,Y
W ! S DIR(0)="Y",DIR("A")="Continue with the Legacy '"_$G(XUOPT)_"' option",DIR("B")="No",DIR("?")="Enter 'YES' to use the legacy functionality to add the new user." D ^DIR I Y Q Y
Q +Y
;
SRCH(XURET,XUIAM) ;perform initial enterprise search
N XURET2
K XURET ;we'll come out of here with either returned traits or nothing if an error condition
;
W !!,"Searching Enterprise ..."
D USER^XUIAMXML(.XURET,.XUIAM) ;is person known at enterprise
I $S($G(XURET)<0:1,$G(XURET("errorMessage"))'="":1,$G(XURET("lastName"))="":1,1:0) K XURET Q 1 ;if error or traits not returned continue to enhanced search
S CNT=1 M XURET2=XURET K XURET M XURET(CNT)=XURET2 ;person found, merge traits into subscripted array
D XDISP(.XURET,CNT) ;display extended traits
Q $$ASKCONT()
;
XSRCH(XURET,XUIAM,XUSRCH) ;perform an enhanced enterprise search by including more traits
N CONT,XURET2
K XURET ;we'll come out of here with returned traits or error condition
S CONT=0 ;initialize continue prompt
S:(XUSRCH="T") XUIAM("VAemail")="NOT_PROVIDED@DOMAIN.EXT" ;PSIM keyword to perform TRAITS ONLY search
W !!,$S((XUSRCH="T"):"Enter traits to search on ...",1:"User not found, let's gather a few additional traits and try again ...")
I $$ASKTRTS(.XUIAM)<0 Q -1 ;pass through previously entered VAemail or samacctnm for search
W !!,"Searching Enterprise with the ",$S((XUSRCH="T"):"",1:"additional "),"traits ..."
D QRYUSER^XUIAMXML(.XURET2,.XUIAM) ;is person(s) known at enterprise
I $S($G(XURET2)<0:1,$G(XURET2("errorMessage"))'="":1,1:0) M XURET=XURET2 Q 1 ;return error and fall into test/prod prompting
I '$O(XURET2(0)) K XURET2 S XURET("errorMessage")="User NOT FOUND" Q 1 ;should have returned traits but possibly an unforseen xml error returned, fall into test/prod prompting
S CNT=$O(XURET2(0)) ;find first person in list
;if more than one person returned
I $O(XURET2(CNT)) D Q CONT
.F D I CONT Q
..D DISP(.XURET2) ;display list of returned persons
..S CNT=$$ASKPRSN(.XURET2) I CNT<0 S CONT=-1 Q ;choose which person to display
..D XDISP(.XURET2,CNT) ;display extended traits
..S CONT=$$ASKCONT() I CONT'=1 Q ;person was not selected
..I $G(XURET2(CNT,"note"))["Mismatch" W !!,"User isn't selectable due to:",!?5,XURET2(CNT,"note"),!?5,"If assistance is required, please log a service ticket." S CONT=0 Q
..I $G(XURET2(CNT,"note"))["Orchestration" D ORCH(.XURET,.XURET2,CNT) ;selected person needs orchestrated
..M XURET(CNT)=XURET2(CNT)
;only one person returned
D XDISP(.XURET2,CNT) ;display extended traits
S CONT=$$ASKCONT() I CONT'=1 Q CONT ;person was not selected
I $G(XURET2(CNT,"note"))["Mismatch" W !!,"User isn't selectable due to:",!?5,XURET2(CNT,"note"),!?5,"If assistance is required, please log a service ticket." S CONT=0 Q CONT
I $G(XURET2(CNT,"note"))["Orchestration" D ORCH(.XURET,.XURET2,CNT) ;selected person needs orchestrated
M XURET=XURET2
Q CONT
;
ASKTRTS(XUIAM) ;prompt for additional traits and perform additional psim lookup
N DIR,DIRUT,DTOUT,DUOUT,X,Y
W ! S DIR(0)="200,.01",DIR("A")="NAME (last,first middle)" D ^DIR I $D(DIRUT)!(Y="") Q -1 ;name required
D NAMECOMP^XLFNAME(.Y)
S XUIAM("firstName")=Y("GIVEN")
S XUIAM("middleName")=Y("MIDDLE")
S XUIAM("lastName")=Y("FAMILY")
K DIR,DIRUT,DTOUT,DUOUT,X,Y S DIR(0)="FA^0:999999999^K:'(X?9N) X",DIR("A")="SSN (No Dashes): ",DIR("?")="SSN should be 9 numbers" D ^DIR I $D(DIRUT)!(Y="") Q -1 ;ssn required
S XUIAM("pnid")=Y
K DIR,DIRUT,DTOUT,DUOUT,X,Y S DIR(0)="200,5" D ^DIR I $D(DTOUT)!$D(DUOUT) Q -1 ;dob optional
I Y'="" S XUIAM("dob")=$$FMTHL7^XLFDT(Y)
K DIR,DIRUT,DTOUT,DUOUT,X,Y S DIR(0)="200,4" D ^DIR I $D(DTOUT)!$D(DUOUT) Q -1 ;gender optional
I Y'="" S XUIAM("gender")=Y
S XUIAM("WHO")=DUZ_"^PN^"_$P($$SITE^VASITE(),"^",3)_"^USDVA" ;requestor
Q 0
;
DISP(XURET) ;display returned persons
W !!!,"Users found at Enterprise ...",!!?2,"#",?4,"ICN",?23,"NAME",?54,"SSN",?65,"DOB",?75,"SEX"
S CNT=0 F S CNT=$O(XURET(CNT)) Q:'CNT D
.W !,$J(CNT,3),?4,$G(XURET(CNT,"icn")),?23,$G(XURET(CNT,"lastName")),",",$G(XURET(CNT,"firstName"))," ",$G(XURET(CNT,"middleName")),?54,$G(XURET(CNT,"pnid"))
.W ?65,$E($G(XURET(CNT,"dob")),5,6)_"/"_$E($G(XURET(CNT,"dob")),7,8)_"/"_$E($G(XURET(CNT,"dob")),3,4),?76,$G(XURET(CNT,"gender"))
Q
;
ASKPRSN(XURET) ;ask for person
N BC,EC,DIR,DIRUT,DTOUT,DUOUT,X,Y
S BC=+$O(XURET(0)),EC=+$O(XURET("@"),-1) ;beginning and ending count
W ! S DIR(0)="NA^"_BC_":"_EC,DIR("A")="Display additional traits for user # ",DIR("?")="Enter a number between "_BC_" and "_EC D ^DIR K DIR I $D(DIRUT) Q -1
Q Y
;
XDISP(XURET,CNT) ;display extended traits
W !!,"Traits for user from Enterprise ...",!
I $G(XURET(CNT,"icn"))'="" W !?4,"ICN:",?17,$G(XURET(CNT,"icn"))
W !?4,"Name:",?17,$G(XURET(CNT,"lastName")),",",$G(XURET(CNT,"firstName"))," ",$G(XURET(CNT,"middleName"))
W !?4,"Email: ",?17,$G(XURET(CNT,"email"))
W !?4,"NT Username:",?17,$S($G(XURET(CNT,"samAccountName"))'="":XURET(CNT,"samAccountName"),$G(XURET(CNT,"samacctnm"))'="":XURET(CNT,"samacctnm"),1:"")
W !?4,"SSN:",?17,$G(XURET(CNT,"pnid"))
W !?4,"DOB:",?17,$E($G(XURET(CNT,"dob")),5,6)_"/"_$E($G(XURET(CNT,"dob")),7,8)_"/"_$E($G(XURET(CNT,"dob")),3,4) ;$$FMTE^XLFDT($$HL7TFM^XLFDT($G(XURET("dob"))))
W !?4,"Sex:",?17,$G(XURET(CNT,"gender"))
W !!?4,"Address:"
I $G(XURET(CNT,"street_1"))'="" W ?17,XURET(CNT,"street_1"),!
I $G(XURET(CNT,"street_2"))'="" W ?17,XURET(CNT,"street_2"),!
I $G(XURET(CNT,"street_3"))'="" W ?17,XURET(CNT,"street_3"),!
W ?17,$G(XURET(CNT,"city"))_", "_$G(XURET(CNT,"state"))_" "_$G(XURET(CNT,"postalCode")),!
W !?4,"Phone:",?17,$G(XURET(CNT,"phone"))
W !?4,"SECID:",?17,$G(XURET(CNT,"secId"))
W !?4,"NPI:",?17,$G(XURET(CNT,"npi"))
Q
;
ASKCONT() ;ask whether to continue with selected person
N DIR,DIRUT,DTOUT,DUOUT,X,Y
W ! S DIR(0)="Y",DIR("B")="NO",DIR("A")="Proceed with this user" D ^DIR I $D(DIRUT) Q -1
Q Y
;
ORCH(XURET,XURET2,CNT) ;orchestrate person
K XUIAM M XUIAM=XURET2(CNT) K XURET2
S XUIAM("WHO")=DUZ_"^PN^"_$P($$SITE^VASITE(),"^",3)_"^USDVA" ;requestor
D ORCHUSER^XUIAMXML(.XURET2,.XUIAM) ;orchestrate person
I $G(XURET2(CNT,"secId"))="" S XURET2("errorMessage")="Problem with Orchestration" ;shouldn't occur, means something went wrong with orchestration
M XURET=XURET2 ;merge selected person's traits back into xuret
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUIAMPR 13076 printed Sep 23, 2025@19:45:48 Page 2
XUIAMPR ;BHM/DLR,DRI - IAM PROVISIONING - ADD/UPDATE OF A NEW PERSON ;1/26/23 09:01
+1 ;;8.0;KERNEL;**799**;Jul 10, 1995;Build 3
+2 ;;Per VHA Directive 2004-038, this routine should not be modified
+3 ;
ENTERPRISE(XUREQTYP,XUTERMDT) ;iam enterprise new person search and add to VistA ;**663 - STORY 783347 (dri)
+1 ;**799 VAMPI-22625
+2 ; Input:
+3 ; XUREQTYP = 'ADD' or 'MODIFY' of a new person
+4 ; XUTERMDT = the optional termination date when doing batch entry of
+5 ; new persons through 'Grant Access by Profile' option
+6 ;
+7 ; Output:
+8 ; IEN (DUZ) from file #200 if successfully added
+9 ; -1^error message = there's a problem, can't continue
+10 ; 0 = can't perform enterprise search, possibly due to network
+11 ; issue or non-production account, optionally continue with
+12 ; legacy functionality
+13 ;
+14 ; Reference to WEB SERVER (#18.12) file allowed with supported IA #6408
+15 ; Reference to OP^XQCHK supported by IA #10078
+16 ;
+17 ;
+18 NEW PROD,XUIAM,XUOPT,XURET,XUSRCH
+19 ;
+20 ;don't use enterprise search functionality if web service server doesn't exist
IF $$GET1^DIQ(18.12,+$$FIND1^DIC(18.12,,"BX","MPI_PSIM_NEW EXECUTE")_",",.04,"E")=""
QUIT 0
+21 ;
+22 ;what option is the user in
SET XUOPT=$$OPTION()
+23 ;
+24 ;does user performing 'add' have a secid at enterprise
SET Y=$$CHKUSER(.DUZ)
IF Y'=1
Begin DoDot:1
+25 WRITE !!,"Sorry ... I can't verify your credentials."
+26 ;returned error message
WRITE !,$PIECE(Y,"^",2)
+27 ;communication issue, allow legacy add
IF +Y=0
SET Y=$$LEGACY()
SET Y=$SELECT(Y=1:0,1:-1)
QUIT
+28 ;problem with user
IF +Y<0
WRITE !!,"You can attempt to use Link My Account to resolve the issue and retry.",!,"If you need assistance or the problem persists, please log a service ticket."
End DoDot:1
QUIT +Y
+29 ;
+30 ;S Y=$$ASKSRCH() I Y'=1 Q Y ;perform an enterprise search? ;not implementing
+31 ;
+32 ;lookup by email address, network username or traits
SET XUSRCH=$$ASKCRIT()
IF XUSRCH<0
QUIT XUSRCH
+33 ;
+34 ;return email address or network username
SET Y=$$RETCRIT(XUSRCH,.XUIAM)
IF Y<0
QUIT Y
+35 ;
+36 ;perform an initial query of psim to find person, unless by Traits
IF (XUSRCH'="T")
IF ($$SRCH(.XURET,.XUIAM)'=1)
QUIT -1
+37 ;
+38 ;if initial search didn't find anyone, add more traits and perform an enhanced query of psim to find person
IF '$ORDER(XURET(0))
IF $$XSRCH(.XURET,.XUIAM,XUSRCH)'=1
QUIT -1
+39 ;
+40 ;0-test, 1-production
SET PROD=$$PROD^XUPROD()
+41 ;if a test account and issues
IF 'PROD
IF $SELECT($GET(XURET)<0:1,$GET(XURET("errorMessage"))'="":1,1:0)
Begin DoDot:1
+42 ;and a communication issue with enterprise, fall into legacy functionality
IF $GET(XURET)<0
WRITE !!,"... ",$PIECE(XURET,"^",2)
SET Y=$$LEGACY()
SET Y=$SELECT(Y=1:0,1:-1)
QUIT
+43 ;and person not found at enterprise, fall into legacy functionality
IF $GET(XURET("errorMessage"))'=""
WRITE !!,"... ",XURET("errorMessage")
SET Y=$$LEGACY()
SET Y=$SELECT(Y=1:0,1:-1)
QUIT
End DoDot:1
QUIT Y
+44 ;if a production account and issues
IF PROD
IF $SELECT($GET(XURET)<0:1,$GET(XURET("errorMessage"))'="":1,1:0)
Begin DoDot:1
+45 ;and a communication issue with enterprise, fall into legacy functionality
IF $GET(XURET)<0
WRITE !!,"... ",$PIECE(XURET,"^",2)
Begin DoDot:2
+46 WRITE !!,"... ","Enterprise Search is currently unavailable. You can exit and try",!?4,"again later or proceed using the legacy '",$GET(XUOPT),"'."
End DoDot:2
SET Y=$$LEGACY()
SET Y=$SELECT(Y=1:0,1:-1)
QUIT
+47 ;and person is not found at enterprise, try again
IF $GET(XURET("errorMessage"))'=""
WRITE !!,"... ",XURET("errorMessage")
Begin DoDot:2
+48 WRITE !!,"... User was not found but should already be known at Enterprise.",!?4,"Please review the criteria and try again. If you are still unable",!?4,"to look them up please log a service ticket for assistance."
End DoDot:2
SET Y=-1
QUIT
End DoDot:1
QUIT Y
+49 ;
+50 ;return duz of user to ^xusernew
QUIT $$FINDUSER^XUIAMPR1(.XURET,XUREQTYP,XUTERMDT)
+51 ;
+52 ;
OPTION() ;return option being executed
+1 NEW XQORNOD,XQOPT,XUOPT
+2 ;default if in programmer mode
SET XUOPT="Add a New User to the System"
+3 DO OP^XQCHK
IF +XQOPT'=-1
SET XUOPT=$PIECE(XQOPT,"^",2)
+4 QUIT XUOPT
+5 ;
CHKUSER(DUZ) ;user must have secid at enterprise to perform enterprise search
+1 ; Input:
+2 ; DUZ = User's IEN in File #200
+3 ;
+4 ; Output:
+5 ; 1 = secid was found at enterprise
+6 ; 0 = could not communicate with enterprise
+7 ; -1 = error condition
+8 ;
+9 NEW XUARR,XUIAM,XURET
+10 IF $GET(DUZ("LOA"))<2
QUIT "-1^Insufficient Level of Assurance"
+11 DO GETS^DIQ(200,+DUZ_",","205.5;501.1","E","XUARR")
+12 ;adupn/email address" ;adupn/email address
SET XUIAM("VAemail")=XUARR(200,+DUZ_",",205.5,"E")
+13 ;SaMaccountName/network username
SET XUIAM("samacctnm")=XUARR(200,+DUZ_",",501.1,"E")
+14 IF XUIAM("VAemail")=""&(XUIAM("samacctnm")="")
QUIT "-1^Network Username or ADUPN must be defined in the NEW PERSON (#200) file."
+15 ;is person adding new persons known at enterprise
DO USER^XUIAMXML(.XURET,.XUIAM)
+16 ;communication issue with enterprise, continue with legacy functionality
IF $GET(XURET)<0
QUIT "0^"_$PIECE(XURET,"^",2)
+17 IF $GET(XURET("errorMessage"))'=""
QUIT "-1^"_XURET("errorMessage")
+18 IF $GET(XURET("secId"))=""
QUIT "-1^secID not defined at Enterprise."
+19 QUIT $GET(XURET("secId"))'=""
+20 ;
ASKSRCH() ;enterprise search by email address or network username
+1 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
+2 WRITE !
SET DIR(0)="Y"
SET DIR("B")="Yes"
SET DIR("A")="Do you want to do an Enterprise Search"
DO ^DIR
IF $DATA(DIRUT)
SET Y=-1_"^Enterprise Search Rejected"
+3 QUIT Y
+4 ;
ASKCRIT() ;enterprise search by email address, network username or traits
+1 WRITE !!,"Utilizing Enterprise User Search ..."
+2 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
+3 WRITE !
SET DIR(0)="SA^E:Email Address;N:Network Username;T:Traits"
SET DIR("A")="Enter an 'E'mail Address, 'N'etwork Username or 'T'raits: "
SET DIR("B")="E"
DO ^DIR
IF $DATA(DIRUT)
SET Y=-1_"^Search Criteria not Entered"
+4 QUIT Y
+5 ;
RETCRIT(XUSRCH,XUIAM) ;return search criteria
+1 ;email address
IF XUSRCH="E"
Begin DoDot:1
+2 ;K DIR S DIR(0)="200,.151^r" D ^DIR I Y'["@" S Y="-1^Invalid EMAIL ADDRESS" Q ;email address input transform is stronger that adupn's
+3 KILL DIR
SET DIR(0)="FAO^7:50^K:$L(X)>50!($L(X)<7)!'(X?1.E1""@""1.E) X I $D(X) K:X["",""!(X["" "") X"
+4 SET DIR("A")="Enter EMAIL ADDRESS: "
SET DIR("?")="Enter valid internet address in xxx@domain format, 7-50 characters in length, no commas or spaces."
+5 ;email address/adupn
DO ^DIR
IF Y'["@"
SET Y="-1^Invalid EMAIL ADDRESS"
QUIT
+6 ;strip off any '&', throws off the spml
SET XUIAM("VAemail")=$TRANSLATE(Y,"&","")
End DoDot:1
IF Y<0
QUIT Y
+7 ;
+8 ;network username
IF XUSRCH="N"
Begin DoDot:1
+9 ;K DIR S DIR(0)="200,501.1^r" D ^DIR I Y'["@" S Y="-1^Invalid NETWORK USERNAME" Q ;network username input transform too strong
+10 KILL DIR
SET DIR(0)="FAO^9:15"
+11 SET DIR("A")="Enter NETWORK USERNAME: "
SET DIR("?")="Enter the Active Directory Username (9-15 characters)."
+12 ;network username
DO ^DIR
IF $DATA(DIRUT)!(Y="")
SET Y="-1^Invalid NETWORK USERNAME"
QUIT
+13 ;strip off any '&', throws off the spml
SET XUIAM("samacctnm")=$$UP^XLFSTR($TRANSLATE(Y,"&",""))
End DoDot:1
IF Y<0
QUIT Y
+14 QUIT 1
+15 ;
LEGACY() ;ask to perform legacy add of new person
+1 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
+2 WRITE !
SET DIR(0)="Y"
SET DIR("A")="Continue with the Legacy '"_$GET(XUOPT)_"' option"
SET DIR("B")="No"
SET DIR("?")="Enter 'YES' to use the legacy functionality to add the new user."
DO ^DIR
IF Y
QUIT Y
+3 QUIT +Y
+4 ;
SRCH(XURET,XUIAM) ;perform initial enterprise search
+1 NEW XURET2
+2 ;we'll come out of here with either returned traits or nothing if an error condition
KILL XURET
+3 ;
+4 WRITE !!,"Searching Enterprise ..."
+5 ;is person known at enterprise
DO USER^XUIAMXML(.XURET,.XUIAM)
+6 ;if error or traits not returned continue to enhanced search
IF $SELECT($GET(XURET)<0:1,$GET(XURET("errorMessage"))'="":1,$GET(XURET("lastName"))="":1,1:0)
KILL XURET
QUIT 1
+7 ;person found, merge traits into subscripted array
SET CNT=1
MERGE XURET2=XURET
KILL XURET
MERGE XURET(CNT)=XURET2
+8 ;display extended traits
DO XDISP(.XURET,CNT)
+9 QUIT $$ASKCONT()
+10 ;
XSRCH(XURET,XUIAM,XUSRCH) ;perform an enhanced enterprise search by including more traits
+1 NEW CONT,XURET2
+2 ;we'll come out of here with returned traits or error condition
KILL XURET
+3 ;initialize continue prompt
SET CONT=0
+4 ;PSIM keyword to perform TRAITS ONLY search
if (XUSRCH="T")
SET XUIAM("VAemail")="NOT_PROVIDED@DOMAIN.EXT"
+5 WRITE !!,$SELECT((XUSRCH="T"):"Enter traits to search on ...",1:"User not found, let's gather a few additional traits and try again ...")
+6 ;pass through previously entered VAemail or samacctnm for search
IF $$ASKTRTS(.XUIAM)<0
QUIT -1
+7 WRITE !!,"Searching Enterprise with the ",$SELECT((XUSRCH="T"):"",1:"additional "),"traits ..."
+8 ;is person(s) known at enterprise
DO QRYUSER^XUIAMXML(.XURET2,.XUIAM)
+9 ;return error and fall into test/prod prompting
IF $SELECT($GET(XURET2)<0:1,$GET(XURET2("errorMessage"))'="":1,1:0)
MERGE XURET=XURET2
QUIT 1
+10 ;should have returned traits but possibly an unforseen xml error returned, fall into test/prod prompting
IF '$ORDER(XURET2(0))
KILL XURET2
SET XURET("errorMessage")="User NOT FOUND"
QUIT 1
+11 ;find first person in list
SET CNT=$ORDER(XURET2(0))
+12 ;if more than one person returned
+13 IF $ORDER(XURET2(CNT))
Begin DoDot:1
+14 FOR
Begin DoDot:2
+15 ;display list of returned persons
DO DISP(.XURET2)
+16 ;choose which person to display
SET CNT=$$ASKPRSN(.XURET2)
IF CNT<0
SET CONT=-1
QUIT
+17 ;display extended traits
DO XDISP(.XURET2,CNT)
+18 ;person was not selected
SET CONT=$$ASKCONT()
IF CONT'=1
QUIT
+19 IF $GET(XURET2(CNT,"note"))["Mismatch"
WRITE !!,"User isn't selectable due to:",!?5,XURET2(CNT,"note"),!?5,"If assistance is required, please log a service ticket."
SET CONT=0
QUIT
+20 ;selected person needs orchestrated
IF $GET(XURET2(CNT,"note"))["Orchestration"
DO ORCH(.XURET,.XURET2,CNT)
+21 MERGE XURET(CNT)=XURET2(CNT)
End DoDot:2
IF CONT
QUIT
End DoDot:1
QUIT CONT
+22 ;only one person returned
+23 ;display extended traits
DO XDISP(.XURET2,CNT)
+24 ;person was not selected
SET CONT=$$ASKCONT()
IF CONT'=1
QUIT CONT
+25 IF $GET(XURET2(CNT,"note"))["Mismatch"
WRITE !!,"User isn't selectable due to:",!?5,XURET2(CNT,"note"),!?5,"If assistance is required, please log a service ticket."
SET CONT=0
QUIT CONT
+26 ;selected person needs orchestrated
IF $GET(XURET2(CNT,"note"))["Orchestration"
DO ORCH(.XURET,.XURET2,CNT)
+27 MERGE XURET=XURET2
+28 QUIT CONT
+29 ;
ASKTRTS(XUIAM) ;prompt for additional traits and perform additional psim lookup
+1 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
+2 ;name required
WRITE !
SET DIR(0)="200,.01"
SET DIR("A")="NAME (last,first middle)"
DO ^DIR
IF $DATA(DIRUT)!(Y="")
QUIT -1
+3 DO NAMECOMP^XLFNAME(.Y)
+4 SET XUIAM("firstName")=Y("GIVEN")
+5 SET XUIAM("middleName")=Y("MIDDLE")
+6 SET XUIAM("lastName")=Y("FAMILY")
+7 ;ssn required
KILL DIR,DIRUT,DTOUT,DUOUT,X,Y
SET DIR(0)="FA^0:999999999^K:'(X?9N) X"
SET DIR("A")="SSN (No Dashes): "
SET DIR("?")="SSN should be 9 numbers"
DO ^DIR
IF $DATA(DIRUT)!(Y="")
QUIT -1
+8 SET XUIAM("pnid")=Y
+9 ;dob optional
KILL DIR,DIRUT,DTOUT,DUOUT,X,Y
SET DIR(0)="200,5"
DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT -1
+10 IF Y'=""
SET XUIAM("dob")=$$FMTHL7^XLFDT(Y)
+11 ;gender optional
KILL DIR,DIRUT,DTOUT,DUOUT,X,Y
SET DIR(0)="200,4"
DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT -1
+12 IF Y'=""
SET XUIAM("gender")=Y
+13 ;requestor
SET XUIAM("WHO")=DUZ_"^PN^"_$PIECE($$SITE^VASITE(),"^",3)_"^USDVA"
+14 QUIT 0
+15 ;
DISP(XURET) ;display returned persons
+1 WRITE !!!,"Users found at Enterprise ...",!!?2,"#",?4,"ICN",?23,"NAME",?54,"SSN",?65,"DOB",?75,"SEX"
+2 SET CNT=0
FOR
SET CNT=$ORDER(XURET(CNT))
if 'CNT
QUIT
Begin DoDot:1
+3 WRITE !,$JUSTIFY(CNT,3),?4,$GET(XURET(CNT,"icn")),?23,$GET(XURET(CNT,"lastName")),",",$GET(XURET(CNT,"firstName"))," ",$GET(XURET(CNT,"middleName")),?54,$GET(XURET(CNT,"pnid"))
+4 WRITE ?65,$EXTRACT($GET(XURET(CNT,"dob")),5,6)_"/"_$EXTRACT($GET(XURET(CNT,"dob")),7,8)_"/"_$EXTRACT($GET(XURET(CNT,"dob")),3,4),?76,$GET(XURET(CNT,"gender"))
End DoDot:1
+5 QUIT
+6 ;
ASKPRSN(XURET) ;ask for person
+1 NEW BC,EC,DIR,DIRUT,DTOUT,DUOUT,X,Y
+2 ;beginning and ending count
SET BC=+$ORDER(XURET(0))
SET EC=+$ORDER(XURET("@"),-1)
+3 WRITE !
SET DIR(0)="NA^"_BC_":"_EC
SET DIR("A")="Display additional traits for user # "
SET DIR("?")="Enter a number between "_BC_" and "_EC
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
QUIT -1
+4 QUIT Y
+5 ;
XDISP(XURET,CNT) ;display extended traits
+1 WRITE !!,"Traits for user from Enterprise ...",!
+2 IF $GET(XURET(CNT,"icn"))'=""
WRITE !?4,"ICN:",?17,$GET(XURET(CNT,"icn"))
+3 WRITE !?4,"Name:",?17,$GET(XURET(CNT,"lastName")),",",$GET(XURET(CNT,"firstName"))," ",$GET(XURET(CNT,"middleName"))
+4 WRITE !?4,"Email: ",?17,$GET(XURET(CNT,"email"))
+5 WRITE !?4,"NT Username:",?17,$SELECT($GET(XURET(CNT,"samAccountName"))'="":XURET(CNT,"samAccountName"),$GET(XURET(CNT,"samacctnm"))'="":XURET(CNT,"samacctnm"),1:"")
+6 WRITE !?4,"SSN:",?17,$GET(XURET(CNT,"pnid"))
+7 ;$$FMTE^XLFDT($$HL7TFM^XLFDT($G(XURET("dob"))))
WRITE !?4,"DOB:",?17,$EXTRACT($GET(XURET(CNT,"dob")),5,6)_"/"_$EXTRACT($GET(XURET(CNT,"dob")),7,8)_"/"_$EXTRACT($GET(XURET(CNT,"dob")),3,4)
+8 WRITE !?4,"Sex:",?17,$GET(XURET(CNT,"gender"))
+9 WRITE !!?4,"Address:"
+10 IF $GET(XURET(CNT,"street_1"))'=""
WRITE ?17,XURET(CNT,"street_1"),!
+11 IF $GET(XURET(CNT,"street_2"))'=""
WRITE ?17,XURET(CNT,"street_2"),!
+12 IF $GET(XURET(CNT,"street_3"))'=""
WRITE ?17,XURET(CNT,"street_3"),!
+13 WRITE ?17,$GET(XURET(CNT,"city"))_", "_$GET(XURET(CNT,"state"))_" "_$GET(XURET(CNT,"postalCode")),!
+14 WRITE !?4,"Phone:",?17,$GET(XURET(CNT,"phone"))
+15 WRITE !?4,"SECID:",?17,$GET(XURET(CNT,"secId"))
+16 WRITE !?4,"NPI:",?17,$GET(XURET(CNT,"npi"))
+17 QUIT
+18 ;
ASKCONT() ;ask whether to continue with selected person
+1 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
+2 WRITE !
SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("A")="Proceed with this user"
DO ^DIR
IF $DATA(DIRUT)
QUIT -1
+3 QUIT Y
+4 ;
ORCH(XURET,XURET2,CNT) ;orchestrate person
+1 KILL XUIAM
MERGE XUIAM=XURET2(CNT)
KILL XURET2
+2 ;requestor
SET XUIAM("WHO")=DUZ_"^PN^"_$PIECE($$SITE^VASITE(),"^",3)_"^USDVA"
+3 ;orchestrate person
DO ORCHUSER^XUIAMXML(.XURET2,.XUIAM)
+4 ;shouldn't occur, means something went wrong with orchestration
IF $GET(XURET2(CNT,"secId"))=""
SET XURET2("errorMessage")="Problem with Orchestration"
+5 ;merge selected person's traits back into xuret
MERGE XURET=XURET2
+6 QUIT
+7 ;
