- USRMLST ; SLC/JER - List User Class Members ;3/23/10
- ;;1.0;AUTHORIZATION/SUBSCRIPTION;**2,3,4,9,33**;Jun 20, 1997;Build 7
- MAIN ; Control Branching
- N DIC,MSBPN,X,Y,USRDUZ
- ;MSBPN is set true if a user is missing the SIGNATURE BLOCK PRINT
- ;NAME.
- S MSBPN=0
- S DIC=8930,DIC(0)="AEMQ",DIC("A")="Select CLASS: "
- D ^DIC Q:+Y'>0
- S USRDA=+Y
- D EN^VALM(USRLTMPL)
- K USRLTMPL
- Q
- MAKELIST ; Build review screen list
- K VALMY
- W !,"Searching for the User Classes."
- D BUILD(USRDA)
- Q
- BUILD(USRDA) ; Build List
- N USRCNT,USRNAME,USRPICK
- S (USRCNT,VALMCNT)=0
- S USRPICK=+$O(^ORD(101,"B","USR ACTION SELECT LIST ELEMENT",0)) ;ICR 872
- K ^TMP("USRMMBR",$J),^TMP("USRMMBRIDX",$J),^TMP("USRM",$J)
- ;D WHOIS^USRLM("^TMP(""USRM"",$J)",USRDA)
- D WHOIS^USRLM("^TMP(""USRM"",$J)",USRDA,1) ; Display .01 Class name
- S USRNAME=0
- F S USRNAME=$O(^TMP("USRM",$J,USRNAME)) Q:USRNAME="" D
- . N USRDA,USRDUZ,USRSIGNM,USREFF,USREXP,USRMEM,USRREC,USRCLNM
- . S USRMEM=$G(^TMP("USRM",$J,USRNAME))
- . S USRDUZ=+USRMEM,USRSIGNM=$$SIGNAME^USRLS(+USRDUZ)
- . I USRSIGNM["?SBPN" S MSBPN=1
- .;If this user has been terminated change the name to reflect this.
- . I $$ISTERM^USRLM(+USRDUZ) S USRSIGNM="(T) "_USRSIGNM
- . S USRDA=+$P(USRMEM,U,2),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(USRSIGNM,USRREC,"MEMBER")
- . S USRREC=$$SETFLD^VALM1(USREFF,USRREC,"EFFECTIVE")
- . S USRREC=$$SETFLD^VALM1(USREXP,USRREC,"EXPIRES")
- . S USRREC=$$SETFLD^VALM1(USRCLNM,USRREC,"CLASS")
- . S VALMCNT=+$G(VALMCNT)+1
- . S ^TMP("USRMMBR",$J,VALMCNT,0)=USRREC
- . S ^TMP("USRMMBR",$J,"IDX",VALMCNT,USRCNT)=""
- . S ^TMP("USRMMBRIDX",$J,USRCNT)=VALMCNT_U_USRDA W:VALMCNT#10'>0 "."
- S ^TMP("USRMMBR",$J,0)=+$G(USRCNT)_U_$P(^TMP("USRM",$J,0),U,2)
- S ^TMP("USRMMBR",$J,"#")=USRPICK_U_"1:"_USRCNT
- I $D(VALMHDR)>9 D HDR
- I +$G(USRCNT)'>0 D
- . S ^TMP("USRMMBR",$J,1,0)="",VALMCNT=2
- . S ^TMP("USRMMBR",$J,2,0)="No "_$P(^TMP("USRM",$J,0),U,2)_"s found"
- Q
- HDR ; Initialize header for review screen
- N BY,USRX,USRCNT,TITLE,USRCLASS
- S USRX=$G(^TMP("USRMMBR",$J,0)),USRCLASS=$P(USRX,U,2)
- S TITLE=USRCLASS_"s"
- S USRCNT=$J(+USRX,4)_" Member"_$S(+USRX=1:"",1:"s")
- S VALMHDR(1)=$$CENTER^USRLS(TITLE)
- S VALMHDR(1)=$$SETSTR^VALM1(USRCNT,VALMHDR(1),(IOM-$L(USRCNT)),$L(USRCNT))
- I $G(MSBPN) D
- . S VALMSG="(?SBPN) missing SIGNATURE BLOCK PRINTED NAME"
- Q
- CLEAN ; "Joel...Clean up your mess!"
- K ^TMP("USRMMBR",$J),^TMP("USRMMBRIDX",$J),^TMP("USRM",$J)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HUSRMLST 2637 printed Jan 18, 2025@02:40:08 Page 2
- USRMLST ; SLC/JER - List User Class Members ;3/23/10
- +1 ;;1.0;AUTHORIZATION/SUBSCRIPTION;**2,3,4,9,33**;Jun 20, 1997;Build 7
- MAIN ; Control Branching
- +1 NEW DIC,MSBPN,X,Y,USRDUZ
- +2 ;MSBPN is set true if a user is missing the SIGNATURE BLOCK PRINT
- +3 ;NAME.
- +4 SET MSBPN=0
- +5 SET DIC=8930
- SET DIC(0)="AEMQ"
- SET DIC("A")="Select CLASS: "
- +6 DO ^DIC
- if +Y'>0
- QUIT
- +7 SET USRDA=+Y
- +8 DO EN^VALM(USRLTMPL)
- +9 KILL USRLTMPL
- +10 QUIT
- MAKELIST ; Build review screen list
- +1 KILL VALMY
- +2 WRITE !,"Searching for the User Classes."
- +3 DO BUILD(USRDA)
- +4 QUIT
- BUILD(USRDA) ; Build List
- +1 NEW USRCNT,USRNAME,USRPICK
- +2 SET (USRCNT,VALMCNT)=0
- +3 ;ICR 872
- SET USRPICK=+$ORDER(^ORD(101,"B","USR ACTION SELECT LIST ELEMENT",0))
- +4 KILL ^TMP("USRMMBR",$JOB),^TMP("USRMMBRIDX",$JOB),^TMP("USRM",$JOB)
- +5 ;D WHOIS^USRLM("^TMP(""USRM"",$J)",USRDA)
- +6 ; Display .01 Class name
- DO WHOIS^USRLM("^TMP(""USRM"",$J)",USRDA,1)
- +7 SET USRNAME=0
- +8 FOR
- SET USRNAME=$ORDER(^TMP("USRM",$JOB,USRNAME))
- if USRNAME=""
- QUIT
- Begin DoDot:1
- +9 NEW USRDA,USRDUZ,USRSIGNM,USREFF,USREXP,USRMEM,USRREC,USRCLNM
- +10 SET USRMEM=$GET(^TMP("USRM",$JOB,USRNAME))
- +11 SET USRDUZ=+USRMEM
- SET USRSIGNM=$$SIGNAME^USRLS(+USRDUZ)
- +12 IF USRSIGNM["?SBPN"
- SET MSBPN=1
- +13 ;If this user has been terminated change the name to reflect this.
- +14 IF $$ISTERM^USRLM(+USRDUZ)
- SET USRSIGNM="(T) "_USRSIGNM
- +15 SET USRDA=+$PIECE(USRMEM,U,2)
- SET USRCLNM=$PIECE(USRMEM,U,3)
- +16 SET USREFF=$$DATE^USRLS(+$PIECE(USRMEM,U,4),"MM/DD/YY")
- +17 SET USREXP=$$DATE^USRLS(+$PIECE(USRMEM,U,5),"MM/DD/YY")
- +18 SET USRCNT=+$GET(USRCNT)+1
- +19 SET USRREC=$$SETFLD^VALM1(USRCNT,"","NUMBER")
- +20 SET USRREC=$$SETFLD^VALM1(USRSIGNM,USRREC,"MEMBER")
- +21 SET USRREC=$$SETFLD^VALM1(USREFF,USRREC,"EFFECTIVE")
- +22 SET USRREC=$$SETFLD^VALM1(USREXP,USRREC,"EXPIRES")
- +23 SET USRREC=$$SETFLD^VALM1(USRCLNM,USRREC,"CLASS")
- +24 SET VALMCNT=+$GET(VALMCNT)+1
- +25 SET ^TMP("USRMMBR",$JOB,VALMCNT,0)=USRREC
- +26 SET ^TMP("USRMMBR",$JOB,"IDX",VALMCNT,USRCNT)=""
- +27 SET ^TMP("USRMMBRIDX",$JOB,USRCNT)=VALMCNT_U_USRDA
- if VALMCNT#10'>0
- WRITE "."
- End DoDot:1
- +28 SET ^TMP("USRMMBR",$JOB,0)=+$GET(USRCNT)_U_$PIECE(^TMP("USRM",$JOB,0),U,2)
- +29 SET ^TMP("USRMMBR",$JOB,"#")=USRPICK_U_"1:"_USRCNT
- +30 IF $DATA(VALMHDR)>9
- DO HDR
- +31 IF +$GET(USRCNT)'>0
- Begin DoDot:1
- +32 SET ^TMP("USRMMBR",$JOB,1,0)=""
- SET VALMCNT=2
- +33 SET ^TMP("USRMMBR",$JOB,2,0)="No "_$PIECE(^TMP("USRM",$JOB,0),U,2)_"s found"
- End DoDot:1
- +34 QUIT
- HDR ; Initialize header for review screen
- +1 NEW BY,USRX,USRCNT,TITLE,USRCLASS
- +2 SET USRX=$GET(^TMP("USRMMBR",$JOB,0))
- SET USRCLASS=$PIECE(USRX,U,2)
- +3 SET TITLE=USRCLASS_"s"
- +4 SET USRCNT=$JUSTIFY(+USRX,4)_" Member"_$SELECT(+USRX=1:"",1:"s")
- +5 SET VALMHDR(1)=$$CENTER^USRLS(TITLE)
- +6 SET VALMHDR(1)=$$SETSTR^VALM1(USRCNT,VALMHDR(1),(IOM-$LENGTH(USRCNT)),$LENGTH(USRCNT))
- +7 IF $GET(MSBPN)
- Begin DoDot:1
- +8 SET VALMSG="(?SBPN) missing SIGNATURE BLOCK PRINTED NAME"
- End DoDot:1
- +9 QUIT
- CLEAN ; "Joel...Clean up your mess!"
- +1 KILL ^TMP("USRMMBR",$JOB),^TMP("USRMMBRIDX",$JOB),^TMP("USRM",$JOB)
- +2 QUIT