Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: USRULST

USRULST.m

Go to the documentation of this file. 
  1. 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
  1.  ; 30 Jun 00 MA - Added MAIN2 to prevent stack overflow
  1.  ; 20 Sep 00 MA - Removed MAIN2 and added GETUSER and chg protocol to
  1.  ; avoid looping through MAIN when doing a "CHANGE VIEW".
  1.  ;  7 Aug 01 MA - Removed line "S USRDUZ=+Y" from line tag GETUSER()
  1.  ;  6 Sep 01 MA - Added line "I +Y>0 S USRDUZ=Y" in GETUSER
  1.  ;  to avoid adding USER Classes to the wrong person.
  1. MAIN ; Control Branching
  1.  N DIC,X,Y,USRDUZ
  1.  S DIC=200,DIC(0)="AEMQ",DIC("A")="Select USER: "
  1.  D ^DIC Q:+Y'>0
  1.  S USRDUZ=+Y
  1.  D EN^VALM(USRLTMPL)
  1.  K USRLTMPL
  1.  Q
  1. GETUSER() ; Get a new user
  1.  N DIC,X,Y
  1.  S DIC=200,DIC(0)="AEMQ",DIC("A")="Select USER: "
  1.  D ^DIC     ; If Y is not set then will use current USRDUZ
  1.  I +Y>0 S USRDUZ=+Y
  1.  Q USRDUZ
  1. MAKELIST ; Build review screen list
  1.  W !,"Searching for the User Classes."
  1.  D BUILD(USRDUZ)
  1.  Q
  1. BUILD(USRDUZ) ; Build List
  1.  ; DBIA 872 ^ORD(101)
  1.  N USRCNT,USRNAME,USRPICK
  1.  S (USRCNT,VALMCNT)=0
  1.  S USRPICK=+$O(^ORD(101,"B","USR ACTION SELECT LIST ELEMENT",0)) ;ICR 87
  1.  K ^TMP("USRUSER",$J),^TMP("USRUSERIDX",$J),^TMP("USRU",$J)
  1.  ;D WHATIS^USRLM(USRDUZ,"^TMP(""USRU"",$J)")
  1.  D WHATIS^USRLM(USRDUZ,"^TMP(""USRU"",$J)",1) ; Use .01 class name 
  1.  S USRNAME=""
  1.  F  S USRNAME=$O(^TMP("USRU",$J,USRNAME),-1) Q:USRNAME=""  Q:USRNAME=0  D
  1.  . N USRDA,USREFF,USREXP,USRMEM,USRREC,USRCLNM
  1.  . S USRMEM=$G(^TMP("USRU",$J,USRNAME))
  1.  . S USRDA=+$P(USRMEM,U,2)
  1.  . S USRCLNM=$P(USRMEM,U,3)
  1.  . S USREFF=$$DATE^USRLS(+$P(USRMEM,U,4),"MM/DD/YY")
  1.  . S USREXP=$$DATE^USRLS(+$P(USRMEM,U,5),"MM/DD/YY")
  1.  . S USRCNT=+$G(USRCNT)+1
  1.  . S USRREC=$$SETFLD^VALM1(USRCNT,"","NUMBER")
  1.  . S USRREC=$$SETFLD^VALM1(USRCLNM,USRREC,"CLASS")
  1.  . S USRREC=$$SETFLD^VALM1(USREFF,USRREC,"EFFECTIVE")
  1.  . S USRREC=$$SETFLD^VALM1(USREXP,USRREC,"EXPIRES")
  1.  . S VALMCNT=+$G(VALMCNT)+1
  1.  . S ^TMP("USRUSER",$J,VALMCNT,0)=USRREC
  1.  . S ^TMP("USRUSER",$J,"IDX",VALMCNT,USRCNT)=""
  1.  . S ^TMP("USRUSERIDX",$J,USRCNT)=VALMCNT_U_USRDA W:VALMCNT#10'>0 "."
  1.  S ^TMP("USRUSER",$J,0)=+$G(USRCNT)_U_$P(^TMP("USRU",$J,0),U,2)
  1.  S ^TMP("USRUSER",$J,"#")=USRPICK_"^0:"_+$G(USRCNT)
  1.  I $D(VALMHDR)>9 D HDR
  1.  I +$G(USRCNT)'>0 D
  1.  . S ^TMP("USRUSER",$J,1,0)="",VALMCNT=2
  1.  . S ^TMP("USRUSER",$J,2,0)="No Class Memberships found for "_$P(^TMP("USRU",$J,0),U,2)
  1.  Q
  1. HDR ; Initialize header for review screen
  1.  N BY,USRX,USRCNT,TITLE,USRNAME
  1.  S USRX=$G(^TMP("USRUSER",$J,0)),USRNAME=$P(USRX,U,2)
  1.  S TITLE=USRNAME
  1.  I USRNAME["?SBPN" D
  1.  . S VALMSG="(?SBPN) missing SIGNATURE BLOCK PRINTED NAME"
  1.  ;If this user has been terminated change the title to reflect this.
  1.  I $$ISTERM^USRLM(USRDUZ) S TITLE=TITLE_" (terminated)"
  1.  S USRCNT=$J(+USRX,4)_" Class"_$S(+USRX=1:"",1:"es")
  1.  S VALMHDR(1)=$$CENTER^USRLS(TITLE)
  1.  S VALMHDR(1)=$$SETSTR^VALM1(USRCNT,VALMHDR(1),(IOM-$L(USRCNT)),$L(USRCNT))
  1.  Q
  1. CLEAN ; "Joel...Clean up your mess!"
  1.  K ^TMP("USRUSER",$J),^TMP("USRUSERIDX",$J),^TMP("USRU",$J)
  1.  Q