USRUMMBR ; SLC/JER,MA - User Class Membership by User actions ;2/2/10
;;1.0;AUTHORIZATION/SUBSCRIPTION;**2,3,5,6,7,8,14,16,33**;Jun 20, 1997;Build 7
; 14 Feb 00 MA - Added check for 0 USRDA in DELETE
; 19 Jun 00 MA - Added check for inactive class when adding user.
EDIT ; Edit user's class membership
;N USRDA,USRDATA,USREXPND,USRI,USRSTAT,DIROUT,USRCHNG,USRLST
N USRDA,USRDATA,USRI,DIROUT,USRCHNG,USRLST
I '$D(VALMY) D EN^VALM2(XQORNOD(0))
S (USRCHNG,USRI)=0
F S USRI=$O(VALMY(USRI)) Q:+USRI'>0 D Q:$D(DIROUT)
. S USRDATA=$G(^TMP("USRUSERIDX",$J,USRI))
. W !!,"Editing #",+USRDATA,!
. S USRDA=+$P(USRDATA,U,2) D EDIT1
. I +$G(USRCHNG) S USRLST=$S($L($G(USRLST)):$G(USRLST)_", ",1:"")_USRI
. I $D(USRDATA) D UPDATE^USRUM(USRDATA)
W !,"Refreshing the list."
S VALMSG="** "_$S($L($G(USRLST)):"Item"_$S($L($G(USRLST),",")>1:"s ",1:" ")_$G(USRLST),1:"Nothing")_" Edited **"
K VALMY S VALMBCK="R"
Q
EDIT1 ; Single record edit
; Receives USRDA
N DA,DIE,DR
I '+$G(USRDA) W !,"No Member selected." H 2 S USRCHNG=0 Q
S DIE="^USR(8930.3,",DA=USRDA,DR="[USR MEMBERSHIP EDIT]"
D FULL^VALM1,^DIE S USRCHNG=1
Q
ADD ; Add a membership to selected classes for current user
N CLASSADD,DIC,DLAYGO,FDA,MSG,X,Y
N I2N,FDA,FDAIEN,MSG
;N USRCLASS,USRCREAT,USRUSER,USRCNT,USRQUIT
N USRCLASS,USRUSER,USRCNT,USRQUIT
D FULL^VALM1
I $$ISTERM^USRLM(USRDUZ) D Q ;USRDUZ is newed and set in USRULST
. W !,"You cannot add class memberships, this user is terminated!"
. H 2
S USRCNT=0
F D Q:+$G(USRQUIT)
. W !
. S DIC=8930,DIC(0)="AEMQ"
. S DIC("A")="Select "_$S(USRCNT'>0:"",1:"Another ")_"USER CLASS: "
. D ^DIC I +Y'>0 S USRQUIT=1 Q
. ;
. I $P(^USR(8930,+Y,0),"^",3)=0 D Q
.. W !,"You may not add a user to a inactive USER CLASS !!!"
.. I $$READ^USRU("FAO","Press return to continue")
.. S USRQUIT=1
. S USRCLASS=+Y
. S DIC=200,DIC(0)="NMX",X="`"_USRDUZ
.;Make sure the user is not already a member of this class.
. I $$ISAWM^USRLM(USRDUZ,USRCLASS) S USRQUIT=1 Q
. K FDA,FDAIEN,MSG
. S CLASSADD=0
. S I2N="+1,"
. S FDA(8930.3,I2N,.01)=USRDUZ
. S FDA(8930.3,I2N,.02)=USRCLASS
. D UPDATE^DIE("","FDA","FDAIEN","MSG")
. I +$G(FDAIEN(1))>0 D
.. S CLASSADD=1
.. S DA=+FDAIEN(1),DIE=8930.3,DIE("NO^")="BACK"
.. S DR=".03;.04" D ^DIE
.. I $D(Y) D
... S DIK=DIC D ^DIK K DIK
... S CLASSADD=0
. I 'CLASSADD D Q
.. W !,"Error adding ",$$CLNAME^USRLM(+$P($G(^USR(8930.3,+DA,0)),U,2),1)
. E S USRCNT=USRCNT+1
W !,"Rebuilding membership list."
D BUILD^USRULST(USRDUZ)
I USRCNT>0 D
. S USRUSER=$$SIGNAME^USRLS(+$G(USRDUZ))
. S VALMSG="** "_USRUSER_" added to "_USRCNT_" classes **"
S VALMCNT=+$G(@VALMAR@(0))
S VALMBCK="R"
Q
DELETE ; Delete a member of the class
N DIE,X,Y,USRCLASS D FULL^VALM1
N USRCLASS,USRDA,USRCHNG,USRDATA,USRI,USRLST,DIROUT
I '$D(VALMY) D EN^VALM2(XQORNOD(0))
S USRI=0
F S USRI=$O(VALMY(USRI)) Q:+USRI'>0 D Q:$D(DIROUT)
. S USRDATA=$G(^TMP("USRUSERIDX",$J,USRI))
. ;02/14/00 Been having trouble with USRDA=0
. ;possible bad x-ref. Will check for USRDA=0
. ;Changed USRLM to check for valid 0 node for x-ref AUC
. S USRDA=+$P(USRDATA,U,2) Q:USRDA=0 D DELETE1(USRDA)
. S:+$G(USRCHNG) USRLST=$S(+$G(USRLST):USRLST_", ",1:"")_+USRDATA
. I $D(USRDATA) D UPDATE^USRUM(USRDATA)
W !,"Rebuilding the list."
S USRCLASS=+$G(^TMP("USRU",$J,0))
D BUILD^USRULST(USRDUZ)
S VALMCNT=+$G(@VALMAR@(0))
K VALMY S VALMBCK="R"
S VALMSG="** "_$S($L($G(USRLST)):"Item"_$S($L($G(USRLST),",")>1:"s ",1:" ")_$G(USRLST),1:"Nothing")_" removed **"
Q
DELETE1(DA) ; Delete one member from a class
N DIE,DR,USER,CLASS,USRMEM0 S USRMEM0=$G(^USR(8930.3,+DA,0))
I USRMEM0']"" W !,"Record #",DA," NOT FOUND!" H 2 D MAILMSG Q
;S USER=$P($G(^VA(200,+USRMEM0,0)),U)
;S USER=$$GET1^DIQ(200,+USRMEM0,.01) ; ICR 10060
S USER=$$PERSNAME^USRLM1(+USRMEM0)
S CLASS=$P($G(^USR(8930,+$P(USRMEM0,U,2),0)),U)
W !,"Removing ",USER," from ",CLASS
I '$$READ^USRU("Y","Are you SURE","NO") S USRCHNG=0 W !,USER," NOT Removed from ",CLASS,"." H 2 Q
S USRCHNG=1
S DIK="^USR(8930.3," D ^DIK W "."
Q
MAILMSG ; This section will mail an error message to DUZ
;W " A mail message is being sent to ",$P($G(^VA(200,DUZ,0)),"^",1) H 1
W " A mail message is being sent to ",$$GET1^DIQ(200,USER,.01) H 1
N XMY,XMSUB,USRTEXT,XMTEXT,XMDUZ
S XMDUZ=0.5
S XMY(DUZ)=""
S XMSUB="ERROR MESSAGE FROM AUTHORIZED/SUBSCRIPTION (USRUMMBR)"
S USRTEXT(1)="This message is being generated due to a bad x-ref (AUC)"
S USRTEXT(2)="in ^USR(8930.3) pointing to a IEN on the 0 node that"
S USRTEXT(3)="does not exist."
S USRTEXT(4)=""
S USRTEXT(5)="Please forward this message to your IRM representative"
S USRTEXT(6)="asking them to verify the Global ^USR(8930.3) x-ref"
S USRTEXT(7)="on AUC & ACU."
S USRTEXT(8)=""
S USRTEXT(9)="IRM will need to verify that the x-ref AUC & ACU for"
S USRTEXT(10)=$$GET1^DIQ(200,USRDUZ,.01)_" is pointing to a valid 0 node."
S USRTEXT(11)=""
S USRTEXT(12)="DO NOT CONTINUE WITH THIS USER UNTIL IRM VERIFIES!!"
S USRTEXT(13)=""
S USRTEXT(14)="IRM please check ^USR(8930.3,""AUC"","_USRDUZ_") to"
S USRTEXT(15)="verify it is pointing to a valid 0 node IEN."
S USRTEXT(16)="Also do the same for x-ref ACU"
S XMTEXT="USRTEXT("
D ^XMD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HUSRUMMBR 5333 printed Sep 23, 2025@19:15:08 Page 2
USRUMMBR ; SLC/JER,MA - User Class Membership by User actions ;2/2/10
+1 ;;1.0;AUTHORIZATION/SUBSCRIPTION;**2,3,5,6,7,8,14,16,33**;Jun 20, 1997;Build 7
+2 ; 14 Feb 00 MA - Added check for 0 USRDA in DELETE
+3 ; 19 Jun 00 MA - Added check for inactive class when adding user.
EDIT ; Edit user's class membership
+1 ;N USRDA,USRDATA,USREXPND,USRI,USRSTAT,DIROUT,USRCHNG,USRLST
+2 NEW USRDA,USRDATA,USRI,DIROUT,USRCHNG,USRLST
+3 IF '$DATA(VALMY)
DO EN^VALM2(XQORNOD(0))
+4 SET (USRCHNG,USRI)=0
+5 FOR
SET USRI=$ORDER(VALMY(USRI))
if +USRI'>0
QUIT
Begin DoDot:1
+6 SET USRDATA=$GET(^TMP("USRUSERIDX",$JOB,USRI))
+7 WRITE !!,"Editing #",+USRDATA,!
+8 SET USRDA=+$PIECE(USRDATA,U,2)
DO EDIT1
+9 IF +$GET(USRCHNG)
SET USRLST=$SELECT($LENGTH($GET(USRLST)):$GET(USRLST)_", ",1:"")_USRI
+10 IF $DATA(USRDATA)
DO UPDATE^USRUM(USRDATA)
End DoDot:1
if $DATA(DIROUT)
QUIT
+11 WRITE !,"Refreshing the list."
+12 SET VALMSG="** "_$SELECT($LENGTH($GET(USRLST)):"Item"_$SELECT($LENGTH($GET(USRLST),",")>1:"s ",1:" ")_$GET(USRLST),1:"Nothing")_" Edited **"
+13 KILL VALMY
SET VALMBCK="R"
+14 QUIT
EDIT1 ; Single record edit
+1 ; Receives USRDA
+2 NEW DA,DIE,DR
+3 IF '+$GET(USRDA)
WRITE !,"No Member selected."
HANG 2
SET USRCHNG=0
QUIT
+4 SET DIE="^USR(8930.3,"
SET DA=USRDA
SET DR="[USR MEMBERSHIP EDIT]"
+5 DO FULL^VALM1
DO ^DIE
SET USRCHNG=1
+6 QUIT
ADD ; Add a membership to selected classes for current user
+1 NEW CLASSADD,DIC,DLAYGO,FDA,MSG,X,Y
+2 NEW I2N,FDA,FDAIEN,MSG
+3 ;N USRCLASS,USRCREAT,USRUSER,USRCNT,USRQUIT
+4 NEW USRCLASS,USRUSER,USRCNT,USRQUIT
+5 DO FULL^VALM1
+6 ;USRDUZ is newed and set in USRULST
IF $$ISTERM^USRLM(USRDUZ)
Begin DoDot:1
+7 WRITE !,"You cannot add class memberships, this user is terminated!"
+8 HANG 2
End DoDot:1
QUIT
+9 SET USRCNT=0
+10 FOR
Begin DoDot:1
+11 WRITE !
+12 SET DIC=8930
SET DIC(0)="AEMQ"
+13 SET DIC("A")="Select "_$SELECT(USRCNT'>0:"",1:"Another ")_"USER CLASS: "
+14 DO ^DIC
IF +Y'>0
SET USRQUIT=1
QUIT
+15 ;
+16 IF $PIECE(^USR(8930,+Y,0),"^",3)=0
Begin DoDot:2
+17 WRITE !,"You may not add a user to a inactive USER CLASS !!!"
+18 IF $$READ^USRU("FAO","Press return to continue")
+19 SET USRQUIT=1
End DoDot:2
QUIT
+20 SET USRCLASS=+Y
+21 SET DIC=200
SET DIC(0)="NMX"
SET X="`"_USRDUZ
+22 ;Make sure the user is not already a member of this class.
+23 IF $$ISAWM^USRLM(USRDUZ,USRCLASS)
SET USRQUIT=1
QUIT
+24 KILL FDA,FDAIEN,MSG
+25 SET CLASSADD=0
+26 SET I2N="+1,"
+27 SET FDA(8930.3,I2N,.01)=USRDUZ
+28 SET FDA(8930.3,I2N,.02)=USRCLASS
+29 DO UPDATE^DIE("","FDA","FDAIEN","MSG")
+30 IF +$GET(FDAIEN(1))>0
Begin DoDot:2
+31 SET CLASSADD=1
+32 SET DA=+FDAIEN(1)
SET DIE=8930.3
SET DIE("NO^")="BACK"
+33 SET DR=".03;.04"
DO ^DIE
+34 IF $DATA(Y)
Begin DoDot:3
+35 SET DIK=DIC
DO ^DIK
KILL DIK
+36 SET CLASSADD=0
End DoDot:3
End DoDot:2
+37 IF 'CLASSADD
Begin DoDot:2
+38 WRITE !,"Error adding ",$$CLNAME^USRLM(+$PIECE($GET(^USR(8930.3,+DA,0)),U,2),1)
End DoDot:2
QUIT
+39 IF '$TEST
SET USRCNT=USRCNT+1
End DoDot:1
if +$GET(USRQUIT)
QUIT
+40 WRITE !,"Rebuilding membership list."
+41 DO BUILD^USRULST(USRDUZ)
+42 IF USRCNT>0
Begin DoDot:1
+43 SET USRUSER=$$SIGNAME^USRLS(+$GET(USRDUZ))
+44 SET VALMSG="** "_USRUSER_" added to "_USRCNT_" classes **"
End DoDot:1
+45 SET VALMCNT=+$GET(@VALMAR@(0))
+46 SET VALMBCK="R"
+47 QUIT
DELETE ; Delete a member of the class
+1 NEW DIE,X,Y,USRCLASS
DO FULL^VALM1
+2 NEW USRCLASS,USRDA,USRCHNG,USRDATA,USRI,USRLST,DIROUT
+3 IF '$DATA(VALMY)
DO EN^VALM2(XQORNOD(0))
+4 SET USRI=0
+5 FOR
SET USRI=$ORDER(VALMY(USRI))
if +USRI'>0
QUIT
Begin DoDot:1
+6 SET USRDATA=$GET(^TMP("USRUSERIDX",$JOB,USRI))
+7 ;02/14/00 Been having trouble with USRDA=0
+8 ;possible bad x-ref. Will check for USRDA=0
+9 ;Changed USRLM to check for valid 0 node for x-ref AUC
+10 SET USRDA=+$PIECE(USRDATA,U,2)
if USRDA=0
QUIT
DO DELETE1(USRDA)
+11 if +$GET(USRCHNG)
SET USRLST=$SELECT(+$GET(USRLST):USRLST_", ",1:"")_+USRDATA
+12 IF $DATA(USRDATA)
DO UPDATE^USRUM(USRDATA)
End DoDot:1
if $DATA(DIROUT)
QUIT
+13 WRITE !,"Rebuilding the list."
+14 SET USRCLASS=+$GET(^TMP("USRU",$JOB,0))
+15 DO BUILD^USRULST(USRDUZ)
+16 SET VALMCNT=+$GET(@VALMAR@(0))
+17 KILL VALMY
SET VALMBCK="R"
+18 SET VALMSG="** "_$SELECT($LENGTH($GET(USRLST)):"Item"_$SELECT($LENGTH($GET(USRLST),",")>1:"s ",1:" ")_$GET(USRLST),1:"Nothing")_" removed **"
+19 QUIT
DELETE1(DA) ; Delete one member from a class
+1 NEW DIE,DR,USER,CLASS,USRMEM0
SET USRMEM0=$GET(^USR(8930.3,+DA,0))
+2 IF USRMEM0']""
WRITE !,"Record #",DA," NOT FOUND!"
HANG 2
DO MAILMSG
QUIT
+3 ;S USER=$P($G(^VA(200,+USRMEM0,0)),U)
+4 ;S USER=$$GET1^DIQ(200,+USRMEM0,.01) ; ICR 10060
+5 SET USER=$$PERSNAME^USRLM1(+USRMEM0)
+6 SET CLASS=$PIECE($GET(^USR(8930,+$PIECE(USRMEM0,U,2),0)),U)
+7 WRITE !,"Removing ",USER," from ",CLASS
+8 IF '$$READ^USRU("Y","Are you SURE","NO")
SET USRCHNG=0
WRITE !,USER," NOT Removed from ",CLASS,"."
HANG 2
QUIT
+9 SET USRCHNG=1
+10 SET DIK="^USR(8930.3,"
DO ^DIK
WRITE "."
+11 QUIT
MAILMSG ; This section will mail an error message to DUZ
+1 ;W " A mail message is being sent to ",$P($G(^VA(200,DUZ,0)),"^",1) H 1
+2 WRITE " A mail message is being sent to ",$$GET1^DIQ(200,USER,.01)
HANG 1
+3 NEW XMY,XMSUB,USRTEXT,XMTEXT,XMDUZ
+4 SET XMDUZ=0.5
+5 SET XMY(DUZ)=""
+6 SET XMSUB="ERROR MESSAGE FROM AUTHORIZED/SUBSCRIPTION (USRUMMBR)"
+7 SET USRTEXT(1)="This message is being generated due to a bad x-ref (AUC)"
+8 SET USRTEXT(2)="in ^USR(8930.3) pointing to a IEN on the 0 node that"
+9 SET USRTEXT(3)="does not exist."
+10 SET USRTEXT(4)=""
+11 SET USRTEXT(5)="Please forward this message to your IRM representative"
+12 SET USRTEXT(6)="asking them to verify the Global ^USR(8930.3) x-ref"
+13 SET USRTEXT(7)="on AUC & ACU."
+14 SET USRTEXT(8)=""
+15 SET USRTEXT(9)="IRM will need to verify that the x-ref AUC & ACU for"
+16 SET USRTEXT(10)=$$GET1^DIQ(200,USRDUZ,.01)_" is pointing to a valid 0 node."
+17 SET USRTEXT(11)=""
+18 SET USRTEXT(12)="DO NOT CONTINUE WITH THIS USER UNTIL IRM VERIFIES!!"
+19 SET USRTEXT(13)=""
+20 SET USRTEXT(14)="IRM please check ^USR(8930.3,""AUC"","_USRDUZ_") to"
+21 SET USRTEXT(15)="verify it is pointing to a valid 0 node IEN."
+22 SET USRTEXT(16)="Also do the same for x-ref ACU"
+23 SET XMTEXT="USRTEXT("
+24 DO ^XMD
+25 QUIT
