XUSERNEW ;SF/RWF - ADD NEW USER ;5/13/08 17:19
;;8.0;KERNEL;**16,49,134,208,157,313,351,419,467,480**;Jul 10, 1995;Build 0
;;Per VHA Directive 2004-038, this routine should not be modified
;In the call to NEW^XM for new users the variable XMZ must be undef.
;on a reactivation XMZ should be set to the current max message number.
EN ;Add
N Y,XUN,DR,DIE,DA,DTOUT,DIWF,XMDT,XMM,XMZ
S Y=$$ADD("","",1) G EXIT:Y'>0,RE:$P(Y,U,3)'=1
S XUN=+Y ;XU USER ADD called in $$ADD
S DR="["_$$GET^XUPARAM("XUNEW USER","N")_"]"
S DIE=200,DA=XUN D XUDIE^XUS5 G:$D(DTOUT) EXIT
I $$GET1^DIQ(200,XUN_",",11,"I")="" W !,"Without a VERIFY code the user will not be able to sign-on!",$C(7),!
S Y=XUN K XMZ D NEW^XM K XMDT,XMM,XMZ
;ACCESS LETTER, Also see XUSERBLK
W ! D LETTER(XUN,1)
K DIR,DIWF,XUTEXT
;
;Fall in from above, called from REACT
KEYS N DIR,XQHOLD,XQKEY,XQDA,XQAL,XQ6,XQFL
S DIR(0)="Y",DIR("B")="NO",DIR("A")="Do you wish to allocate security keys" D ^DIR G:$D(DIRUT) EXIT
I Y=1 S XQHOLD(XUN)="",XQKEY(0)=0,XQDA=0,XQAL=1,XQ6="",XQFL="" D KEY^XQ6
;
;Check on adding this user to user groups
I $P(^VA(200,XUN,0),U,3)'="" D ;Must have access code & mailbox
.N DIR,Y
.S DIR(0)="Y",DIR("B")="NO",DIR("A")="Do you wish to add this user to mail groups" D ^DIR Q:$D(DIRUT)
.I Y=1 D ENLOCAL1^XMVGRP(XUN)
.K XMDUN,XMDUZ,XMV
.Q
;
EXIT K D0,DA,DDER,DDSFILE,DIE,DIC,DIR,DI,DICR,DIG,DIH,DISYS,DIU,DIV,DIWT,DLAYGO,DR,DQ,K,I,X,X1,XQHOLD,XQKEY,XUN,XUSOLD,XMB,XMZ,Y,Z,XQ6,XQFL,DTOUT
Q
;
RE ;Jump from new user to reactivate
S XUN=+Y,DIR("A")="This isn't a new user, Want to reactivate?",DIR(0)="Y",DIR("B")="NO"
D ^DIR
G EXIT:$D(DIRUT)!(Y'=1),RE2
;Reactivate a user
REACT ;SEA/WDE-REACTIVATE A USER
N XUN,XUSOLD,DIE,DIC,DA,DR,FDA
S XUN=+$$LOOKUP^XUSER G EXIT:XUN<0
RE2 S XUSOLD=^VA(200,XUN,0)
S FDA(200,XUN_",",9.2)="@" ;Clear the Termination date
D UPDATE^DIE("E","FDA")
;Show the screanman form
S DIE=200,DR="["_$$GET^XUPARAM("XUREACT USER","N")_"]",DA=XUN
D XUDIE^XUS5 G:$D(DTOUT) EXIT
I $P(^VA(200,XUN,0),U,3)="" W !!,"No ACCESS CODE has been entered.",$C(7),!
I $P(^VA(200,XUN,0),U,11)>0,$P(^(0),U,11)'>DT W !!,"User is still TERMINATED.",$C(7),!
I $$GET1^DIQ(200,XUN_",",11,"I")="" W !,"Without a VERIFY code the user will not be able to sign-on!",$C(7),!
N DIR
S DIR(0)="Y",DIR("A")="Deny access to old mail messages",DIR("B")="NO",DIR("?")="Enter a 'YES' to restrict access to old mail messages."
D ^DIR G:$D(DIRUT) EXIT
K XMZ S:Y=1 XMZ=+$P(^XMB(3.9,0),"^",3) S Y=XUN D NEW^XM K XMDT,XMM,XMZ
D REACT^XQ84(XUN) ;See if this user's menu trees need to be rebuilt
G KEYS
Q
;
ADD(NP1,KEYS,NONC) ;Common point to do DIC call for adding a new person.
;NP1 will be added to the default or what comes from the NPI field or the KSP.
;KEYS is a list of Keys to give the new person
N DA,DR,DLAYGO,XUITNAME,XUS1,XUS2,DIC,DIE,DIK,NP2,Y
I $G(^XTV(8989.3,1,"NPI"))]"" X ^("NPI") S NP2=DR
S:'$D(NP2) NP2="1;"_$S($D(^XUSEC("XUSPF200",DUZ)):9,1:"9R~")_";4;41.99"
;";41.99" is for adding National Provider Identifier
S DIC="^VA(200,",DIC(0)="AELMQ",DLAYGO=200,DIC("A")="Enter NEW PERSON's name (Family,Given Middle Suffix): ",DIC("DR")="",XUITNAME=1
D ^DIC S XUS1=Y G AX:(Y'>0)!($P(Y,U,3)'>0)
S DA=+$G(^VA(200,+XUS1,3.1)) I DA,'$G(NONC) D
. W !,"Name components."
. S DIE="^VA(20,",DR="1;2;3;5"
. L +^VA(20,DA,0):60 D ^DIE L -^VA(20,DA,0)
. I $D(Y)!$D(DTOUT) S DA=+XUS1,XUS1=-1
. E S $P(XUS1,U,2)=$P(^VA(200,+XUS1,0),U)
D:XUS1>0
. W !,"Now for the Identifiers."
. S DA=+XUS1,DIE="^VA(200,",DR=NP2_$S($D(NP1):";"_NP1,1:""),DIE("NO^")="OUTOK"
. L +^VA(200,DA,0):60 D ^DIE L -^VA(200,DA,0)
. S:$D(Y)!$D(DTOUT) XUS1=-1
I XUS1<0 D S XUS1=-1
. W !?5,"<'",$P(^VA(200,DA,0),U),"' DELETED>"
. S DIK="^VA(200," D ^DIK
. Q:$P($G(^DIC(3,0)),U)'="USER"!'$D(^DD(3,0))
. S DIK="^DIC(3,",XUS1=$P($G(^DIC(3,DA,0)),U,16) D ^DIK
. Q:'XUS1!($P($G(^DIC(16,0)),U)'="PERSON")!'$D(^DD(16,0))
. S DIK="^DIC(16,",DA=XUS1 D ^DIK
N XUSNPI S XUSNPI=$P($G(^VA(200,DA,"NPI")),"^")
I XUS1>0,+XUSNPI>0 D
. S XUSNPI=$$ADDNPI^XUSNPI("Individual_ID",DA,XUSNPI,$$NOW^XLFDT(),1) ;add NPI to multiple
. ; Initialize field 41.97 to 1 (YES)
. Q:+XUSNPI'>0
. N DIE,DR,DA S DIE="^VA(200,",DA=+XUS1,DR="41.97////1" D ^DIE
. Q
I XUS1>0,$D(KEYS) F XUS2=1:1 S Y=$P(KEYS,",",XUS2) Q:'$L(Y) D
. S %=$$ADD^XQKEY(XUS1,Y) I '% W !,"Key '",Y,"' not allocated"
I XUS1>0 D CALL^XUSERP(+XUS1,1) ;XQOR add
AX Q XUS1
;
REPRINT ;Reprint letter
S DA=+$$LOOKUP^XUSER G EXIT:DA'>0
D LETTER(DA)
G EXIT
;
LETTER(XUN,ASK) ;Print access letter
Q:'$G(XUN)
N DIWF,FR,TO,BY,DIR,XUTEXT
S XUTEXT=$$GET^XUPARAM("XUSER COMPUTER ACCOUNT","N"),XUTEXT=$O(^DIC(9.2,"B",XUTEXT,0))
S DIR(0)="Y",DIR("A")="Print User Account Access Letter"
I XUTEXT>0 S Y=1 D:$G(ASK) ^DIR I Y=1 D
. S (XUU,XUU2)="________",DIWF="^DIC(9.2,XUTEXT,1,",DIWF(1)=200,FR=XUN,TO=XUN,BY="NUMBER" D EN2^DIWF
. Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUSERNEW 4981 printed Dec 13, 2024@02:12:24 Page 2
XUSERNEW ;SF/RWF - ADD NEW USER ;5/13/08 17:19
+1 ;;8.0;KERNEL;**16,49,134,208,157,313,351,419,467,480**;Jul 10, 1995;Build 0
+2 ;;Per VHA Directive 2004-038, this routine should not be modified
+3 ;In the call to NEW^XM for new users the variable XMZ must be undef.
+4 ;on a reactivation XMZ should be set to the current max message number.
EN ;Add
+1 NEW Y,XUN,DR,DIE,DA,DTOUT,DIWF,XMDT,XMM,XMZ
+2 SET Y=$$ADD("","",1)
if Y'>0
GOTO EXIT
if $PIECE(Y,U,3)'=1
GOTO RE
+3 ;XU USER ADD called in $$ADD
SET XUN=+Y
+4 SET DR="["_$$GET^XUPARAM("XUNEW USER","N")_"]"
+5 SET DIE=200
SET DA=XUN
DO XUDIE^XUS5
if $DATA(DTOUT)
GOTO EXIT
+6 IF $$GET1^DIQ(200,XUN_",",11,"I")=""
WRITE !,"Without a VERIFY code the user will not be able to sign-on!",$CHAR(7),!
+7 SET Y=XUN
KILL XMZ
DO NEW^XM
KILL XMDT,XMM,XMZ
+8 ;ACCESS LETTER, Also see XUSERBLK
+9 WRITE !
DO LETTER(XUN,1)
+10 KILL DIR,DIWF,XUTEXT
+11 ;
+12 ;Fall in from above, called from REACT
KEYS NEW DIR,XQHOLD,XQKEY,XQDA,XQAL,XQ6,XQFL
+1 SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("A")="Do you wish to allocate security keys"
DO ^DIR
if $DATA(DIRUT)
GOTO EXIT
+2 IF Y=1
SET XQHOLD(XUN)=""
SET XQKEY(0)=0
SET XQDA=0
SET XQAL=1
SET XQ6=""
SET XQFL=""
DO KEY^XQ6
+3 ;
+4 ;Check on adding this user to user groups
+5 ;Must have access code & mailbox
IF $PIECE(^VA(200,XUN,0),U,3)'=""
Begin DoDot:1
+6 NEW DIR,Y
+7 SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("A")="Do you wish to add this user to mail groups"
DO ^DIR
if $DATA(DIRUT)
QUIT
+8 IF Y=1
DO ENLOCAL1^XMVGRP(XUN)
+9 KILL XMDUN,XMDUZ,XMV
+10 QUIT
End DoDot:1
+11 ;
EXIT KILL D0,DA,DDER,DDSFILE,DIE,DIC,DIR,DI,DICR,DIG,DIH,DISYS,DIU,DIV,DIWT,DLAYGO,DR,DQ,K,I,X,X1,XQHOLD,XQKEY,XUN,XUSOLD,XMB,XMZ,Y,Z,XQ6,XQFL,DTOUT
+1 QUIT
+2 ;
RE ;Jump from new user to reactivate
+1 SET XUN=+Y
SET DIR("A")="This isn't a new user, Want to reactivate?"
SET DIR(0)="Y"
SET DIR("B")="NO"
+2 DO ^DIR
+3 if $DATA(DIRUT)!(Y'=1)
GOTO EXIT
GOTO RE2
+4 ;Reactivate a user
REACT ;SEA/WDE-REACTIVATE A USER
+1 NEW XUN,XUSOLD,DIE,DIC,DA,DR,FDA
+2 SET XUN=+$$LOOKUP^XUSER
if XUN<0
GOTO EXIT
RE2 SET XUSOLD=^VA(200,XUN,0)
+1 ;Clear the Termination date
SET FDA(200,XUN_",",9.2)="@"
+2 DO UPDATE^DIE("E","FDA")
+3 ;Show the screanman form
+4 SET DIE=200
SET DR="["_$$GET^XUPARAM("XUREACT USER","N")_"]"
SET DA=XUN
+5 DO XUDIE^XUS5
if $DATA(DTOUT)
GOTO EXIT
+6 IF $PIECE(^VA(200,XUN,0),U,3)=""
WRITE !!,"No ACCESS CODE has been entered.",$CHAR(7),!
+7 IF $PIECE(^VA(200,XUN,0),U,11)>0
IF $PIECE(^(0),U,11)'>DT
WRITE !!,"User is still TERMINATED.",$CHAR(7),!
+8 IF $$GET1^DIQ(200,XUN_",",11,"I")=""
WRITE !,"Without a VERIFY code the user will not be able to sign-on!",$CHAR(7),!
+9 NEW DIR
+10 SET DIR(0)="Y"
SET DIR("A")="Deny access to old mail messages"
SET DIR("B")="NO"
SET DIR("?")="Enter a 'YES' to restrict access to old mail messages."
+11 DO ^DIR
if $DATA(DIRUT)
GOTO EXIT
+12 KILL XMZ
if Y=1
SET XMZ=+$PIECE(^XMB(3.9,0),"^",3)
SET Y=XUN
DO NEW^XM
KILL XMDT,XMM,XMZ
+13 ;See if this user's menu trees need to be rebuilt
DO REACT^XQ84(XUN)
+14 GOTO KEYS
+15 QUIT
+16 ;
ADD(NP1,KEYS,NONC) ;Common point to do DIC call for adding a new person.
+1 ;NP1 will be added to the default or what comes from the NPI field or the KSP.
+2 ;KEYS is a list of Keys to give the new person
+3 NEW DA,DR,DLAYGO,XUITNAME,XUS1,XUS2,DIC,DIE,DIK,NP2,Y
+4 IF $GET(^XTV(8989.3,1,"NPI"))]""
XECUTE ^("NPI")
SET NP2=DR
+5 if '$DATA(NP2)
SET NP2="1;"_$SELECT($DATA(^XUSEC("XUSPF200",DUZ)):9,1:"9R~")_";4;41.99"
+6 ;";41.99" is for adding National Provider Identifier
+7 SET DIC="^VA(200,"
SET DIC(0)="AELMQ"
SET DLAYGO=200
SET DIC("A")="Enter NEW PERSON's name (Family,Given Middle Suffix): "
SET DIC("DR")=""
SET XUITNAME=1
+8 DO ^DIC
SET XUS1=Y
if (Y'>0)!($PIECE(Y,U,3)'>0)
GOTO AX
+9 SET DA=+$GET(^VA(200,+XUS1,3.1))
IF DA
IF '$GET(NONC)
Begin DoDot:1
+10 WRITE !,"Name components."
+11 SET DIE="^VA(20,"
SET DR="1;2;3;5"
+12 LOCK +^VA(20,DA,0):60
DO ^DIE
LOCK -^VA(20,DA,0)
+13 IF $DATA(Y)!$DATA(DTOUT)
SET DA=+XUS1
SET XUS1=-1
+14 IF '$TEST
SET $PIECE(XUS1,U,2)=$PIECE(^VA(200,+XUS1,0),U)
End DoDot:1
+15 if XUS1>0
Begin DoDot:1
+16 WRITE !,"Now for the Identifiers."
+17 SET DA=+XUS1
SET DIE="^VA(200,"
SET DR=NP2_$SELECT($DATA(NP1):";"_NP1,1:"")
SET DIE("NO^")="OUTOK"
+18 LOCK +^VA(200,DA,0):60
DO ^DIE
LOCK -^VA(200,DA,0)
+19 if $DATA(Y)!$DATA(DTOUT)
SET XUS1=-1
End DoDot:1
+20 IF XUS1<0
Begin DoDot:1
+21 WRITE !?5,"<'",$PIECE(^VA(200,DA,0),U),"' DELETED>"
+22 SET DIK="^VA(200,"
DO ^DIK
+23 if $PIECE($GET(^DIC(3,0)),U)'="USER"!'$DATA(^DD(3,0))
QUIT
+24 SET DIK="^DIC(3,"
SET XUS1=$PIECE($GET(^DIC(3,DA,0)),U,16)
DO ^DIK
+25 if 'XUS1!($PIECE($GET(^DIC(16,0)),U)'="PERSON")!'$DATA(^DD(16,0))
QUIT
+26 SET DIK="^DIC(16,"
SET DA=XUS1
DO ^DIK
End DoDot:1
SET XUS1=-1
+27 NEW XUSNPI
SET XUSNPI=$PIECE($GET(^VA(200,DA,"NPI")),"^")
+28 IF XUS1>0
IF +XUSNPI>0
Begin DoDot:1
+29 ;add NPI to multiple
SET XUSNPI=$$ADDNPI^XUSNPI("Individual_ID",DA,XUSNPI,$$NOW^XLFDT(),1)
+30 ; Initialize field 41.97 to 1 (YES)
+31 if +XUSNPI'>0
QUIT
+32 NEW DIE,DR,DA
SET DIE="^VA(200,"
SET DA=+XUS1
SET DR="41.97////1"
DO ^DIE
+33 QUIT
End DoDot:1
+34 IF XUS1>0
IF $DATA(KEYS)
FOR XUS2=1:1
SET Y=$PIECE(KEYS,",",XUS2)
if '$LENGTH(Y)
QUIT
Begin DoDot:1
+35 SET %=$$ADD^XQKEY(XUS1,Y)
IF '%
WRITE !,"Key '",Y,"' not allocated"
End DoDot:1
+36 ;XQOR add
IF XUS1>0
DO CALL^XUSERP(+XUS1,1)
AX QUIT XUS1
+1 ;
REPRINT ;Reprint letter
+1 SET DA=+$$LOOKUP^XUSER
if DA'>0
GOTO EXIT
+2 DO LETTER(DA)
+3 GOTO EXIT
+4 ;
LETTER(XUN,ASK) ;Print access letter
+1 if '$GET(XUN)
QUIT
+2 NEW DIWF,FR,TO,BY,DIR,XUTEXT
+3 SET XUTEXT=$$GET^XUPARAM("XUSER COMPUTER ACCOUNT","N")
SET XUTEXT=$ORDER(^DIC(9.2,"B",XUTEXT,0))
+4 SET DIR(0)="Y"
SET DIR("A")="Print User Account Access Letter"
+5 IF XUTEXT>0
SET Y=1
if $GET(ASK)
DO ^DIR
IF Y=1
Begin DoDot:1
+6 SET (XUU,XUU2)="________"
SET DIWF="^DIC(9.2,XUTEXT,1,"
SET DIWF(1)=200
SET FR=XUN
SET TO=XUN
SET BY="NUMBER"
DO EN2^DIWF
+7 QUIT
End DoDot:1
+8 QUIT
