- 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 Feb 18, 2025@23:38:50 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