Changeset 623 for WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSERNEW.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSERNEW.m
r613 r623 1 XUSERNEW ;SF/RWF - ADD NEW USER ;5/13/08 17:19 2 ;;8.0;KERNEL;**16,49,134,208,157,313,351,419,467,480**;Jul 10, 1995;Build 38 3 ;;Per VHA Directive 2004-038, this routine should not be modified 4 ;In the call to NEW^XM for new users the variable XMZ must be undef. 5 ;on a reactivation XMZ should be set to the current max message number. 6 EN ;Add 7 N Y,XUN,DR,DIE,DA,DTOUT,DIWF,XMDT,XMM,XMZ 8 S Y=$$ADD("","",1) G EXIT:Y'>0,RE:$P(Y,U,3)'=1 9 S XUN=+Y ;XU USER ADD called in $$ADD 10 S DR="["_$$GET^XUPARAM("XUNEW USER","N")_"]" 11 S DIE=200,DA=XUN D XUDIE^XUS5 G:$D(DTOUT) EXIT 12 I $$GET1^DIQ(200,XUN_",",11,"I")="" W !,"Without a VERIFY code the user will not be able to sign-on!",$C(7),! 13 S Y=XUN K XMZ D NEW^XM K XMDT,XMM,XMZ 14 ;ACCESS LETTER, Also see XUSERBLK 15 W ! D LETTER(XUN,1) 16 K DIR,DIWF,XUTEXT 17 ; 18 ;Fall in from above, called from REACT 19 KEYS N DIR,XQHOLD,XQKEY,XQDA,XQAL,XQ6,XQFL 20 S DIR(0)="Y",DIR("B")="NO",DIR("A")="Do you wish to allocate security keys" D ^DIR G:$D(DIRUT) EXIT 21 I Y=1 S XQHOLD(XUN)="",XQKEY(0)=0,XQDA=0,XQAL=1,XQ6="",XQFL="" D KEY^XQ6 22 ; 23 ;Check on adding this user to user groups 24 I $P(^VA(200,XUN,0),U,3)'="" D ;Must have access code & mailbox 25 .N DIR,Y 26 .S DIR(0)="Y",DIR("B")="NO",DIR("A")="Do you wish to add this user to mail groups" D ^DIR Q:$D(DIRUT) 27 .I Y=1 D ENLOCAL1^XMVGRP(XUN) 28 .K XMDUN,XMDUZ,XMV 29 .Q 30 ; 31 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 32 Q 33 ; 34 RE ;Jump from new user to reactivate 35 S XUN=+Y,DIR("A")="This isn't a new user, Want to reactivate?",DIR(0)="Y",DIR("B")="NO" 36 D ^DIR 37 G EXIT:$D(DIRUT)!(Y'=1),RE2 38 ;Reactivate a user 39 REACT ;SEA/WDE-REACTIVATE A USER 40 N XUN,XUSOLD,DIE,DIC,DA,DR,FDA 41 S XUN=+$$LOOKUP^XUSER G EXIT:XUN<0 42 RE2 S XUSOLD=^VA(200,XUN,0) 43 S FDA(200,XUN_",",9.2)="@" ;Clear the Termination date 44 D UPDATE^DIE("E","FDA") 45 ;Show the screanman form 46 S DIE=200,DR="["_$$GET^XUPARAM("XUREACT USER","N")_"]",DA=XUN 47 D XUDIE^XUS5 G:$D(DTOUT) EXIT 48 I $P(^VA(200,XUN,0),U,3)="" W !!,"No ACCESS CODE has been entered.",$C(7),! 49 I $P(^VA(200,XUN,0),U,11)>0,$P(^(0),U,11)'>DT W !!,"User is still TERMINATED.",$C(7),! 50 I $$GET1^DIQ(200,XUN_",",11,"I")="" W !,"Without a VERIFY code the user will not be able to sign-on!",$C(7),! 51 N DIR 52 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." 53 D ^DIR G:$D(DIRUT) EXIT 54 K XMZ S:Y=1 XMZ=+$P(^XMB(3.9,0),"^",3) S Y=XUN D NEW^XM K XMDT,XMM,XMZ 55 D REACT^XQ84(XUN) ;See if this user's menu trees need to be rebuilt 56 G KEYS 57 Q 58 ; 59 ADD(NP1,KEYS,NONC) ;Common point to do DIC call for adding a new person. 60 ;NP1 will be added to the default or what comes from the NPI field or the KSP. 61 ;KEYS is a list of Keys to give the new person 62 N DA,DR,DLAYGO,XUITNAME,XUS1,XUS2,DIC,DIE,DIK,NP2,Y 63 I $G(^XTV(8989.3,1,"NPI"))]"" X ^("NPI") S NP2=DR 64 S:'$D(NP2) NP2="1;"_$S($D(^XUSEC("XUSPF200",DUZ)):9,1:"9R~")_";4;41.99" 65 ;";41.99" is for adding National Provider Identifier 66 S DIC="^VA(200,",DIC(0)="AELMQ",DLAYGO=200,DIC("A")="Enter NEW PERSON's name (Family,Given Middle Suffix): ",DIC("DR")="",XUITNAME=1 67 D ^DIC S XUS1=Y G AX:(Y'>0)!($P(Y,U,3)'>0) 68 S DA=+$G(^VA(200,+XUS1,3.1)) I DA,'$G(NONC) D 69 . W !,"Name components." 70 . S DIE="^VA(20,",DR="1;2;3;5" 71 . L +^VA(20,DA,0):60 D ^DIE L -^VA(20,DA,0) 72 . I $D(Y)!$D(DTOUT) S DA=+XUS1,XUS1=-1 73 . E S $P(XUS1,U,2)=$P(^VA(200,+XUS1,0),U) 74 D:XUS1>0 75 . W !,"Now for the Identifiers." 76 . S DA=+XUS1,DIE="^VA(200,",DR=NP2_$S($D(NP1):";"_NP1,1:""),DIE("NO^")="OUTOK" 77 . L +^VA(200,DA,0):60 D ^DIE L -^VA(200,DA,0) 78 . S:$D(Y)!$D(DTOUT) XUS1=-1 79 I XUS1<0 D S XUS1=-1 80 . W !?5,"<'",$P(^VA(200,DA,0),U),"' DELETED>" 81 . S DIK="^VA(200," D ^DIK 82 . Q:$P($G(^DIC(3,0)),U)'="USER"!'$D(^DD(3,0)) 83 . S DIK="^DIC(3,",XUS1=$P($G(^DIC(3,DA,0)),U,16) D ^DIK 84 . Q:'XUS1!($P($G(^DIC(16,0)),U)'="PERSON")!'$D(^DD(16,0)) 85 . S DIK="^DIC(16,",DA=XUS1 D ^DIK 86 N XUSNPI S XUSNPI=$P($G(^VA(200,DA,"NPI")),"^") 87 I XUS1>0,+XUSNPI>0 D 88 . S XUSNPI=$$ADDNPI^XUSNPI("Individual_ID",DA,XUSNPI,$$NOW^XLFDT(),1) ;add NPI to multiple 89 . ; Initialize field 41.97 to 1 (YES) 90 . Q:+XUSNPI'>0 91 . N DIE,DR,DA S DIE="^VA(200,",DA=+XUS1,DR="41.97////1" D ^DIE 92 . Q 93 I XUS1>0,$D(KEYS) F XUS2=1:1 S Y=$P(KEYS,",",XUS2) Q:'$L(Y) D 94 . S %=$$ADD^XQKEY(XUS1,Y) I '% W !,"Key '",Y,"' not allocated" 95 I XUS1>0 D CALL^XUSERP(+XUS1,1) ;XQOR add 96 AX Q XUS1 97 ; 98 REPRINT ;Reprint letter 99 S DA=+$$LOOKUP^XUSER G EXIT:DA'>0 100 D LETTER(DA) 101 G EXIT 102 ; 103 LETTER(XUN,ASK) ;Print access letter 104 Q:'$G(XUN) 105 N DIWF,FR,TO,BY,DIR,XUTEXT 106 S XUTEXT=$$GET^XUPARAM("XUSER COMPUTER ACCOUNT","N"),XUTEXT=$O(^DIC(9.2,"B",XUTEXT,0)) 107 S DIR(0)="Y",DIR("A")="Print User Account Access Letter" 108 I XUTEXT>0 S Y=1 D:$G(ASK) ^DIR I Y=1 D 109 . S (XUU,XUU2)="________",DIWF="^DIC(9.2,XUTEXT,1,",DIWF(1)=200,FR=XUN,TO=XUN,BY="NUMBER" D EN2^DIWF 110 . Q 111 Q 1 XUSERNEW ;SF/RWF - ADD NEW USER ;6/27/07 2 ;;8.0;KERNEL;**16,49,134,208,157,313,351,419,467**;Jul 10, 1995;Build 12 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. 5 EN ;Add 6 N Y,XUN,DR,DIE,DA,DTOUT,DIWF,XMDT,XMM,XMZ 7 S Y=$$ADD("","",1) G EXIT:Y'>0,RE:$P(Y,U,3)'=1 8 S XUN=+Y ;XU USER ADD called in $$ADD 9 S DR="["_$$GET^XUPARAM("XUNEW USER","N")_"]" 10 S DIE=200,DA=XUN D XUDIE^XUS5 G:$D(DTOUT) EXIT 11 I $$GET1^DIQ(200,XUN_",",11,"I")="" W !,"Without a VERIFY code the user will not be able to sign-on!",$C(7),! 12 S Y=XUN K XMZ D NEW^XM K XMDT,XMM,XMZ 13 ;ACCESS LETTER, Also see XUSERBLK 14 W ! D LETTER(XUN,1) 15 K DIR,DIWF,XUTEXT 16 ; 17 ;Fall in from above, called from REACT 18 KEYS N DIR,XQHOLD,XQKEY,XQDA,XQAL,XQ6,XQFL 19 S DIR(0)="Y",DIR("B")="NO",DIR("A")="Do you wish to allocate security keys" D ^DIR G:$D(DIRUT) EXIT 20 I Y=1 S XQHOLD(XUN)="",XQKEY(0)=0,XQDA=0,XQAL=1,XQ6="",XQFL="" D KEY^XQ6 21 ; 22 ;Check on adding this user to user groups 23 I $P(^VA(200,XUN,0),U,3)'="" D ;Must have access code & mailbox 24 .N DIR,Y 25 .S DIR(0)="Y",DIR("B")="NO",DIR("A")="Do you wish to add this user to mail groups" D ^DIR Q:$D(DIRUT) 26 .I Y=1 D ENLOCAL1^XMVGRP(XUN) 27 .K XMDUN,XMDUZ,XMV 28 .Q 29 ; 30 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 31 Q 32 ; 33 RE ;Jump from new user to reactivate 34 S XUN=+Y,DIR("A")="This isn't a new user, Want to reactivate?",DIR(0)="Y",DIR("B")="NO" 35 D ^DIR 36 G EXIT:$D(DIRUT)!(Y'=1),RE2 37 ;Reactivate a user 38 REACT ;SEA/WDE-REACTIVATE A USER 39 N XUN,XUSOLD,DIE,DIC,DA,DR,FDA 40 S XUN=+$$LOOKUP^XUSER G EXIT:XUN<0 41 RE2 S XUSOLD=^VA(200,XUN,0) 42 S FDA(200,XUN_",",9.2)="@" ;Clear the Termination date 43 D UPDATE^DIE("E","FDA") 44 ;Show the screanman form 45 S DIE=200,DR="["_$$GET^XUPARAM("XUREACT USER","N")_"]",DA=XUN 46 D XUDIE^XUS5 G:$D(DTOUT) EXIT 47 I $P(^VA(200,XUN,0),U,3)="" W !!,"No ACCESS CODE has been entered.",$C(7),! 48 I $P(^VA(200,XUN,0),U,11)>0,$P(^(0),U,11)'>DT W !!,"User is still TERMINATED.",$C(7),! 49 I $$GET1^DIQ(200,XUN_",",11,"I")="" W !,"Without a VERIFY code the user will not be able to sign-on!",$C(7),! 50 N DIR 51 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." 52 D ^DIR G:$D(DIRUT) EXIT 53 K XMZ S:Y=1 XMZ=+$P(^XMB(3.9,0),"^",3) S Y=XUN D NEW^XM K XMDT,XMM,XMZ 54 D REACT^XQ84(XUN) ;See if this user's menu trees need to be rebuilt 55 G KEYS 56 Q 57 ; 58 ADD(NP1,KEYS,NONC) ;Common point to do DIC call for adding a new person. 59 ;NP1 will be added to the default or what comes from the NPI field of the KSP. 60 ;KEYS is a list of Keys to give the new person 61 N DA,DR,DLAYGO,XUITNAME,XUS1,XUS2,DIC,DIE,DIK,NP2,Y 62 I $G(^XTV(8989.3,1,"NPI"))]"" X ^("NPI") S NP2=DR 63 S:'$D(NP2) NP2="1;"_$S($D(^XUSEC("XUSPF200",DUZ)):9,1:"9R~")_";4;41.99" 64 ;";41.99" is for adding National Provider Identifier 65 S DIC="^VA(200,",DIC(0)="AELMQ",DLAYGO=200,DIC("A")="Enter NEW PERSON's name (Family,Given Middle Suffix): ",DIC("DR")="",XUITNAME=1 66 D ^DIC S XUS1=Y G AX:(Y'>0)!($P(Y,U,3)'>0) 67 S DA=+$G(^VA(200,+XUS1,3.1)) I DA,'$G(NONC) D 68 . W !,"Name components." 69 . S DIE="^VA(20,",DR="1;2;3;5" 70 . L +^VA(20,DA,0):60 D ^DIE L -^VA(20,DA,0) 71 . I $D(Y)!$D(DTOUT) S DA=+XUS1,XUS1=-1 72 . E S $P(XUS1,U,2)=$P(^VA(200,+XUS1,0),U) 73 D:XUS1>0 74 . W !,"Now for the Identifiers." 75 . S DA=+XUS1,DIE="^VA(200,",DR=NP2_$S($D(NP1):";"_NP1,1:""),DIE("NO^")="OUTOK" 76 . L +^VA(200,DA,0):60 D ^DIE L -^VA(200,DA,0) 77 . S:$D(Y)!$D(DTOUT) XUS1=-1 78 I XUS1<0 D S XUS1=-1 79 . W !?5,"<'",$P(^VA(200,DA,0),U),"' DELETED>" 80 . S DIK="^VA(200," D ^DIK 81 . Q:$P($G(^DIC(3,0)),U)'="USER"!'$D(^DD(3,0)) 82 . S DIK="^DIC(3,",XUS1=$P($G(^DIC(3,DA,0)),U,16) D ^DIK 83 . Q:'XUS1!($P($G(^DIC(16,0)),U)'="PERSON")!'$D(^DD(16,0)) 84 . S DIK="^DIC(16,",DA=XUS1 D ^DIK 85 N XUSNPI S XUSNPI=$P($G(^VA(200,DA,"NPI")),"^") 86 I XUS1>0,+XUSNPI>0 S XUSNPI=$$ADDNPI^XUSNPI("Individual_ID",DA,XUSNPI,$$NOW^XLFDT(),1) ;add NPI 87 I XUS1>0,$D(KEYS) F XUS2=1:1 S Y=$P(KEYS,",",XUS2) Q:'$L(Y) D 88 . S %=$$ADD^XQKEY(XUS1,Y) I '% W !,"Key '",Y,"' not allocated" 89 I XUS1>0 D CALL^XUSERP(+XUS1,1) ;XQOR add 90 AX Q XUS1 91 ; 92 REPRINT ;Reprint letter 93 S DA=+$$LOOKUP^XUSER G EXIT:DA'>0 94 D LETTER(DA) 95 G EXIT 96 ; 97 LETTER(XUN,ASK) ;Print access letter 98 Q:'$G(XUN) 99 N DIWF,FR,TO,BY,DIR,XUTEXT 100 S XUTEXT=$$GET^XUPARAM("XUSER COMPUTER ACCOUNT","N"),XUTEXT=$O(^DIC(9.2,"B",XUTEXT,0)) 101 S DIR(0)="Y",DIR("A")="Print User Account Access Letter" 102 I XUTEXT>0 S Y=1 D:$G(ASK) ^DIR I Y=1 D 103 . S (XUU,XUU2)="________",DIWF="^DIC(9.2,XUTEXT,1,",DIWF(1)=200,FR=XUN,TO=XUN,BY="NUMBER" D EN2^DIWF 104 . Q 105 Q
Note:
See TracChangeset
for help on using the changeset viewer.
