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

USRCLST.m

Go to the documentation of this file. 
  1. USRCLST ; SLC/JER - Review User Classes ;11/25/09
  1.  ;;1.0;AUTHORIZATION/SUBSCRIPTION;**1,3,7,33**;Jun 20, 1997;Build 7
  1. MAKELIST ; Build review screen list
  1.  N STATUS,FNAME,LNAME
  1.  S STATUS=$$SELSTAT("ACTIVE")
  1.  I +STATUS<0 S VALMQUIT=1 Q
  1.  S FNAME=$$RANGE("        Start With Class","FIRST")
  1.  I +FNAME=-1 S VALMQUIT=1 Q
  1.  S LNAME=$$RANGE("             Go To Class","LAST")
  1.  I +LNAME=-1 S VALMQUIT=1 Q 
  1.  W !,"Searching for the User Classes."
  1.  D BUILD(STATUS,FNAME,LNAME)
  1.  Q
  1. SELSTAT(DEFLT) ; Select User Class status
  1.  N DIC,XQORM,X,Y
  1.  S DIC=101,DIC(0)="X",X="USR CLASS STATUS SELECT" D ^DIC
  1.  I +Y>0 D
  1.  . S XQORM=+Y_";ORD(101,",XQORM(0)="1A",XQORM("A")="Select User Class Status: " ;ICR 872
  1.  . S XQORM("B")=DEFLT D ^XQORM
  1.  . I +Y,($D(Y)>9) S Y=$S($P(Y(1),U,3)="Inactive":0,$P(Y(1),U,3)="Active":1,1:2)
  1.  Q Y
  1. RANGE(PROMPT,DEFAULT) ; Get range of classes to browse
  1.  N Y
  1.  S Y=$$READ^USRU("F^1:20",PROMPT,DEFAULT) ; Y^Y(0)
  1.  I Y="^" S Y=-1 Q Y
  1.  S Y=$S(Y["FIRST":"",Y["LAST":"ZZZZ",1:$P(Y,U))
  1.  Q Y
  1. BUILD(SELSTAT,USRFNM,USRLNM) ; Build List
  1.  N USRPICK,USRJ,NODE0,STATUS,USRUPNM,CLNM,CLIEN,CLABB,USRCNT,USRREC
  1.  N USRABBR,STATUSNM,NODE0,NAME,CLSTATNM,USRFNMX,USRLNMX,PREFIX
  1.  S VALMCNT=0
  1.  S USRPICK=+$O(^ORD(101,"B","USR ACTION SELECT LIST ELEMENT",0)) ;ICR 872
  1.  ; P33 DRAFT
  1.  K ^TMP("USRCLASS",$J),^TMP("USRCLASSIDX",$J),^TMP("USRUPCL",$J)
  1.  S USRFNMX=$S(USRFNM]"":$$UP^XLFSTR($E(USRFNM)),1:USRFNM)
  1.  S USRLNMX=$$LOW^XLFSTR(USRLNM)_"z"
  1.  ; -- S ^TMP("USRUPCL",$J,UPPERCASE NAME,IEN,STATNM) by Uppercase .01 name --
  1.  F  D  Q:$O(^USR(8930,USRJ))'>0
  1.  . N NAME
  1.  . S USRJ=$G(USRJ)+1,STATUS=""
  1.  . ; -- Reject unselected statuses --
  1.  . I $D(^USR(8930,"D",1,USRJ)) S STATUS=1
  1.  . I $D(^USR(8930,"D",0,USRJ)) S STATUS=0
  1.  . I STATUS']"" Q
  1.  . I SELSTAT'=2,STATUS'=SELSTAT Q
  1.  . S NODE0=$G(^USR(8930,USRJ,0)),NAME=$P(NODE0,U)
  1.  . Q:NODE0']""
  1.  . ; -- Reject entries clearly outside alpha boundaries --
  1.  . I USRFNMX]NAME Q
  1.  . I NAME]USRLNMX Q
  1.  . S STATUSNM=$S(STATUS=0:"INACTIVE",STATUS=1:"ACTIVE",1:"??")
  1.  . S USRABBR=$P(NODE0,U,2)
  1.  . S USRUPNM=$$UP^XLFSTR(NAME)
  1.  . S ^TMP("USRUPCL",$J,USRUPNM,USRJ,STATUSNM)=USRABBR_U_NAME
  1.  ; -- Loop thru TMP("USRUPCL" and set info into USRREC array --
  1.  ;  ; -- Now we're dealing with uppercase only so get exact boundaries --
  1.  S USRFNMX=$$UP^XLFSTR(USRFNM),USRLNMX=$$UP^XLFSTR(USRLNM)_"Z"
  1.  S CLNM=$S($G(USRFNMX)]"":$O(^TMP("USRUPCL",$J,USRFNMX),-1),1:"")
  1.  F  S CLNM=$O(^TMP("USRUPCL",$J,CLNM)) Q:CLNM=""  Q:CLNM]USRLNMX  D
  1.  . N NAME,TMP0
  1.  . ; -- CLASS NAMES may not be unique --
  1.  . S CLIEN="" F  S CLIEN=$O(^TMP("USRUPCL",$J,CLNM,CLIEN)) Q:+CLIEN'>0  D
  1.  . . S PREFIX=+$O(^USR(8930,+CLIEN,1,0))
  1.  . . S PREFIX=$S(PREFIX>0:"+",1:"")
  1.  . . S CLSTATNM=$O(^TMP("USRUPCL",$J,CLNM,CLIEN,""))
  1.  . . S TMP0=^TMP("USRUPCL",$J,CLNM,CLIEN,CLSTATNM)
  1.  . . S CLABB=$P(TMP0,U),NAME=$P(TMP0,U,2)
  1.  . . S USRCNT=+$G(USRCNT)+1
  1.  . . S USRREC=$$SETFLD^VALM1(USRCNT,"","NUMBER")
  1.  . . S USRREC=$$SETFLD^VALM1(PREFIX_NAME,USRREC,"CLASS NAME")
  1.  . . S USRREC=$$SETFLD^VALM1(CLABB,USRREC,"ABBREVIATION")
  1.  . . I SELSTAT=2 S USRREC=$$SETFLD^VALM1(CLSTATNM,USRREC,"ACTIVE")
  1.  . . S VALMCNT=+$G(VALMCNT)+1
  1.  . . S ^TMP("USRCLASS",$J,VALMCNT,0)=USRREC
  1.  . . S ^TMP("USRCLASS",$J,"IDX",VALMCNT,USRCNT)=""
  1.  . . S ^TMP("USRCLASSIDX",$J,USRCNT)=VALMCNT_U_CLIEN_U W:VALMCNT#10'>0 "."
  1.  ;Clear the video attributes so we start fresh.
  1.  D KILL^VALM10(VALMCNT) K ^TMP("USRUPCL",$J)
  1.  S ^TMP("USRCLASS",$J,0)=+$G(USRCNT)_U_SELSTAT_U_USRFNM_U_USRLNM
  1.  S ^TMP("USRCLASS",$J,"#")=USRPICK_U_"1:"_+$G(USRCNT)
  1.  I $D(VALMHDR)>9 D HDR
  1.  I +$G(USRCNT)'>0 D
  1.  . S ^TMP("USRCLASS",$J,1,0)=""
  1.  . S ^TMP("USRCLASS",$J,2,0)="No "_$S(SELSTAT=0:"Inactive ",SELSTAT=1:"Active ",1:"")_"User Classes found"
  1.  . S VALMCNT=2
  1.  Q
  1.   ;
  1. HDR ; Initialize header for review screen
  1.  N BY,USRX,USRCNT,SCREEN,STATUS,TITLE
  1.  S USRX=$G(^TMP("USRCLASS",$J,0)),STATUS=$P("INACTIVE^ACTIVE^ALL",U,+$P(USRX,U,2)+1)
  1.  S TITLE=STATUS_" USER CLASSES"
  1.  S USRCNT=$J(+$G(^TMP("USRCLASS",$J,0)),4)
  1.  S USRCNT=USRCNT_" Class"_$S(+USRCNT=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("USRCLASS",$J),^TMP("USRCLASSIDX",$J)
  1.  Q