USRULST ; SLC/JER - List Class Membership by user ;3/23/10
;;1.0;AUTHORIZATION/SUBSCRIPTION;**2,3,4,9,10,16,17,21,22,28,33**;Jun 20, 1997;Build 7
; 30 Jun 00 MA - Added MAIN2 to prevent stack overflow
; 20 Sep 00 MA - Removed MAIN2 and added GETUSER and chg protocol to
; avoid looping through MAIN when doing a "CHANGE VIEW".
; 7 Aug 01 MA - Removed line "S USRDUZ=+Y" from line tag GETUSER()
; 6 Sep 01 MA - Added line "I +Y>0 S USRDUZ=Y" in GETUSER
; to avoid adding USER Classes to the wrong person.
MAIN ; Control Branching
N DIC,X,Y,USRDUZ
S DIC=200,DIC(0)="AEMQ",DIC("A")="Select USER: "
D ^DIC Q:+Y'>0
S USRDUZ=+Y
D EN^VALM(USRLTMPL)
K USRLTMPL
Q
GETUSER() ; Get a new user
N DIC,X,Y
S DIC=200,DIC(0)="AEMQ",DIC("A")="Select USER: "
D ^DIC ; If Y is not set then will use current USRDUZ
I +Y>0 S USRDUZ=+Y
Q USRDUZ
MAKELIST ; Build review screen list
W !,"Searching for the User Classes."
D BUILD(USRDUZ)
Q
BUILD(USRDUZ) ; Build List
; DBIA 872 ^ORD(101)
N USRCNT,USRNAME,USRPICK
S (USRCNT,VALMCNT)=0
S USRPICK=+$O(^ORD(101,"B","USR ACTION SELECT LIST ELEMENT",0)) ;ICR 87
K ^TMP("USRUSER",$J),^TMP("USRUSERIDX",$J),^TMP("USRU",$J)
;D WHATIS^USRLM(USRDUZ,"^TMP(""USRU"",$J)")
D WHATIS^USRLM(USRDUZ,"^TMP(""USRU"",$J)",1) ; Use .01 class name
S USRNAME=""
F S USRNAME=$O(^TMP("USRU",$J,USRNAME),-1) Q:USRNAME="" Q:USRNAME=0 D
. N USRDA,USREFF,USREXP,USRMEM,USRREC,USRCLNM
. S USRMEM=$G(^TMP("USRU",$J,USRNAME))
. S USRDA=+$P(USRMEM,U,2)
. S USRCLNM=$P(USRMEM,U,3)
. S USREFF=$$DATE^USRLS(+$P(USRMEM,U,4),"MM/DD/YY")
. S USREXP=$$DATE^USRLS(+$P(USRMEM,U,5),"MM/DD/YY")
. S USRCNT=+$G(USRCNT)+1
. S USRREC=$$SETFLD^VALM1(USRCNT,"","NUMBER")
. S USRREC=$$SETFLD^VALM1(USRCLNM,USRREC,"CLASS")
. S USRREC=$$SETFLD^VALM1(USREFF,USRREC,"EFFECTIVE")
. S USRREC=$$SETFLD^VALM1(USREXP,USRREC,"EXPIRES")
. S VALMCNT=+$G(VALMCNT)+1
. S ^TMP("USRUSER",$J,VALMCNT,0)=USRREC
. S ^TMP("USRUSER",$J,"IDX",VALMCNT,USRCNT)=""
. S ^TMP("USRUSERIDX",$J,USRCNT)=VALMCNT_U_USRDA W:VALMCNT#10'>0 "."
S ^TMP("USRUSER",$J,0)=+$G(USRCNT)_U_$P(^TMP("USRU",$J,0),U,2)
S ^TMP("USRUSER",$J,"#")=USRPICK_"^0:"_+$G(USRCNT)
I $D(VALMHDR)>9 D HDR
I +$G(USRCNT)'>0 D
. S ^TMP("USRUSER",$J,1,0)="",VALMCNT=2
. S ^TMP("USRUSER",$J,2,0)="No Class Memberships found for "_$P(^TMP("USRU",$J,0),U,2)
Q
HDR ; Initialize header for review screen
N BY,USRX,USRCNT,TITLE,USRNAME
S USRX=$G(^TMP("USRUSER",$J,0)),USRNAME=$P(USRX,U,2)
S TITLE=USRNAME
I USRNAME["?SBPN" D
. S VALMSG="(?SBPN) missing SIGNATURE BLOCK PRINTED NAME"
;If this user has been terminated change the title to reflect this.
I $$ISTERM^USRLM(USRDUZ) S TITLE=TITLE_" (terminated)"
S USRCNT=$J(+USRX,4)_" Class"_$S(+USRX=1:"",1:"es")
S VALMHDR(1)=$$CENTER^USRLS(TITLE)
S VALMHDR(1)=$$SETSTR^VALM1(USRCNT,VALMHDR(1),(IOM-$L(USRCNT)),$L(USRCNT))
Q
CLEAN ; "Joel...Clean up your mess!"
K ^TMP("USRUSER",$J),^TMP("USRUSERIDX",$J),^TMP("USRU",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HUSRULST 3028 printed Oct 16, 2024@17:39:58 Page 2
USRULST ; SLC/JER - List Class Membership by user ;3/23/10
+1 ;;1.0;AUTHORIZATION/SUBSCRIPTION;**2,3,4,9,10,16,17,21,22,28,33**;Jun 20, 1997;Build 7
+2 ; 30 Jun 00 MA - Added MAIN2 to prevent stack overflow
+3 ; 20 Sep 00 MA - Removed MAIN2 and added GETUSER and chg protocol to
+4 ; avoid looping through MAIN when doing a "CHANGE VIEW".
+5 ; 7 Aug 01 MA - Removed line "S USRDUZ=+Y" from line tag GETUSER()
+6 ; 6 Sep 01 MA - Added line "I +Y>0 S USRDUZ=Y" in GETUSER
+7 ; to avoid adding USER Classes to the wrong person.
MAIN ; Control Branching
+1 NEW DIC,X,Y,USRDUZ
+2 SET DIC=200
SET DIC(0)="AEMQ"
SET DIC("A")="Select USER: "
+3 DO ^DIC
if +Y'>0
QUIT
+4 SET USRDUZ=+Y
+5 DO EN^VALM(USRLTMPL)
+6 KILL USRLTMPL
+7 QUIT
GETUSER() ; Get a new user
+1 NEW DIC,X,Y
+2 SET DIC=200
SET DIC(0)="AEMQ"
SET DIC("A")="Select USER: "
+3 ; If Y is not set then will use current USRDUZ
DO ^DIC
+4 IF +Y>0
SET USRDUZ=+Y
+5 QUIT USRDUZ
MAKELIST ; Build review screen list
+1 WRITE !,"Searching for the User Classes."
+2 DO BUILD(USRDUZ)
+3 QUIT
BUILD(USRDUZ) ; Build List
+1 ; DBIA 872 ^ORD(101)
+2 NEW USRCNT,USRNAME,USRPICK
+3 SET (USRCNT,VALMCNT)=0
+4 ;ICR 87
SET USRPICK=+$ORDER(^ORD(101,"B","USR ACTION SELECT LIST ELEMENT",0))
+5 KILL ^TMP("USRUSER",$JOB),^TMP("USRUSERIDX",$JOB),^TMP("USRU",$JOB)
+6 ;D WHATIS^USRLM(USRDUZ,"^TMP(""USRU"",$J)")
+7 ; Use .01 class name
DO WHATIS^USRLM(USRDUZ,"^TMP(""USRU"",$J)",1)
+8 SET USRNAME=""
+9 FOR
SET USRNAME=$ORDER(^TMP("USRU",$JOB,USRNAME),-1)
if USRNAME=""
QUIT
if USRNAME=0
QUIT
Begin DoDot:1
+10 NEW USRDA,USREFF,USREXP,USRMEM,USRREC,USRCLNM
+11 SET USRMEM=$GET(^TMP("USRU",$JOB,USRNAME))
+12 SET USRDA=+$PIECE(USRMEM,U,2)
+13 SET USRCLNM=$PIECE(USRMEM,U,3)
+14 SET USREFF=$$DATE^USRLS(+$PIECE(USRMEM,U,4),"MM/DD/YY")
+15 SET USREXP=$$DATE^USRLS(+$PIECE(USRMEM,U,5),"MM/DD/YY")
+16 SET USRCNT=+$GET(USRCNT)+1
+17 SET USRREC=$$SETFLD^VALM1(USRCNT,"","NUMBER")
+18 SET USRREC=$$SETFLD^VALM1(USRCLNM,USRREC,"CLASS")
+19 SET USRREC=$$SETFLD^VALM1(USREFF,USRREC,"EFFECTIVE")
+20 SET USRREC=$$SETFLD^VALM1(USREXP,USRREC,"EXPIRES")
+21 SET VALMCNT=+$GET(VALMCNT)+1
+22 SET ^TMP("USRUSER",$JOB,VALMCNT,0)=USRREC
+23 SET ^TMP("USRUSER",$JOB,"IDX",VALMCNT,USRCNT)=""
+24 SET ^TMP("USRUSERIDX",$JOB,USRCNT)=VALMCNT_U_USRDA
if VALMCNT#10'>0
WRITE "."
End DoDot:1
+25 SET ^TMP("USRUSER",$JOB,0)=+$GET(USRCNT)_U_$PIECE(^TMP("USRU",$JOB,0),U,2)
+26 SET ^TMP("USRUSER",$JOB,"#")=USRPICK_"^0:"_+$GET(USRCNT)
+27 IF $DATA(VALMHDR)>9
DO HDR
+28 IF +$GET(USRCNT)'>0
Begin DoDot:1
+29 SET ^TMP("USRUSER",$JOB,1,0)=""
SET VALMCNT=2
+30 SET ^TMP("USRUSER",$JOB,2,0)="No Class Memberships found for "_$PIECE(^TMP("USRU",$JOB,0),U,2)
End DoDot:1
+31 QUIT
HDR ; Initialize header for review screen
+1 NEW BY,USRX,USRCNT,TITLE,USRNAME
+2 SET USRX=$GET(^TMP("USRUSER",$JOB,0))
SET USRNAME=$PIECE(USRX,U,2)
+3 SET TITLE=USRNAME
+4 IF USRNAME["?SBPN"
Begin DoDot:1
+5 SET VALMSG="(?SBPN) missing SIGNATURE BLOCK PRINTED NAME"
End DoDot:1
+6 ;If this user has been terminated change the title to reflect this.
+7 IF $$ISTERM^USRLM(USRDUZ)
SET TITLE=TITLE_" (terminated)"
+8 SET USRCNT=$JUSTIFY(+USRX,4)_" Class"_$SELECT(+USRX=1:"",1:"es")
+9 SET VALMHDR(1)=$$CENTER^USRLS(TITLE)
+10 SET VALMHDR(1)=$$SETSTR^VALM1(USRCNT,VALMHDR(1),(IOM-$LENGTH(USRCNT)),$LENGTH(USRCNT))
+11 QUIT
CLEAN ; "Joel...Clean up your mess!"
+1 KILL ^TMP("USRUSER",$JOB),^TMP("USRUSERIDX",$JOB),^TMP("USRU",$JOB)
+2 QUIT
