USRCLST ; SLC/JER - Review User Classes ;11/25/09
;;1.0;AUTHORIZATION/SUBSCRIPTION;**1,3,7,33**;Jun 20, 1997;Build 7
MAKELIST ; Build review screen list
N STATUS,FNAME,LNAME
S STATUS=$$SELSTAT("ACTIVE")
I +STATUS<0 S VALMQUIT=1 Q
S FNAME=$$RANGE(" Start With Class","FIRST")
I +FNAME=-1 S VALMQUIT=1 Q
S LNAME=$$RANGE(" Go To Class","LAST")
I +LNAME=-1 S VALMQUIT=1 Q
W !,"Searching for the User Classes."
D BUILD(STATUS,FNAME,LNAME)
Q
SELSTAT(DEFLT) ; Select User Class status
N DIC,XQORM,X,Y
S DIC=101,DIC(0)="X",X="USR CLASS STATUS SELECT" D ^DIC
I +Y>0 D
. S XQORM=+Y_";ORD(101,",XQORM(0)="1A",XQORM("A")="Select User Class Status: " ;ICR 872
. S XQORM("B")=DEFLT D ^XQORM
. I +Y,($D(Y)>9) S Y=$S($P(Y(1),U,3)="Inactive":0,$P(Y(1),U,3)="Active":1,1:2)
Q Y
RANGE(PROMPT,DEFAULT) ; Get range of classes to browse
N Y
S Y=$$READ^USRU("F^1:20",PROMPT,DEFAULT) ; Y^Y(0)
I Y="^" S Y=-1 Q Y
S Y=$S(Y["FIRST":"",Y["LAST":"ZZZZ",1:$P(Y,U))
Q Y
BUILD(SELSTAT,USRFNM,USRLNM) ; Build List
N USRPICK,USRJ,NODE0,STATUS,USRUPNM,CLNM,CLIEN,CLABB,USRCNT,USRREC
N USRABBR,STATUSNM,NODE0,NAME,CLSTATNM,USRFNMX,USRLNMX,PREFIX
S VALMCNT=0
S USRPICK=+$O(^ORD(101,"B","USR ACTION SELECT LIST ELEMENT",0)) ;ICR 872
; P33 DRAFT
K ^TMP("USRCLASS",$J),^TMP("USRCLASSIDX",$J),^TMP("USRUPCL",$J)
S USRFNMX=$S(USRFNM]"":$$UP^XLFSTR($E(USRFNM)),1:USRFNM)
S USRLNMX=$$LOW^XLFSTR(USRLNM)_"z"
; -- S ^TMP("USRUPCL",$J,UPPERCASE NAME,IEN,STATNM) by Uppercase .01 name --
F D Q:$O(^USR(8930,USRJ))'>0
. N NAME
. S USRJ=$G(USRJ)+1,STATUS=""
. ; -- Reject unselected statuses --
. I $D(^USR(8930,"D",1,USRJ)) S STATUS=1
. I $D(^USR(8930,"D",0,USRJ)) S STATUS=0
. I STATUS']"" Q
. I SELSTAT'=2,STATUS'=SELSTAT Q
. S NODE0=$G(^USR(8930,USRJ,0)),NAME=$P(NODE0,U)
. Q:NODE0']""
. ; -- Reject entries clearly outside alpha boundaries --
. I USRFNMX]NAME Q
. I NAME]USRLNMX Q
. S STATUSNM=$S(STATUS=0:"INACTIVE",STATUS=1:"ACTIVE",1:"??")
. S USRABBR=$P(NODE0,U,2)
. S USRUPNM=$$UP^XLFSTR(NAME)
. S ^TMP("USRUPCL",$J,USRUPNM,USRJ,STATUSNM)=USRABBR_U_NAME
; -- Loop thru TMP("USRUPCL" and set info into USRREC array --
; ; -- Now we're dealing with uppercase only so get exact boundaries --
S USRFNMX=$$UP^XLFSTR(USRFNM),USRLNMX=$$UP^XLFSTR(USRLNM)_"Z"
S CLNM=$S($G(USRFNMX)]"":$O(^TMP("USRUPCL",$J,USRFNMX),-1),1:"")
F S CLNM=$O(^TMP("USRUPCL",$J,CLNM)) Q:CLNM="" Q:CLNM]USRLNMX D
. N NAME,TMP0
. ; -- CLASS NAMES may not be unique --
. S CLIEN="" F S CLIEN=$O(^TMP("USRUPCL",$J,CLNM,CLIEN)) Q:+CLIEN'>0 D
. . S PREFIX=+$O(^USR(8930,+CLIEN,1,0))
. . S PREFIX=$S(PREFIX>0:"+",1:"")
. . S CLSTATNM=$O(^TMP("USRUPCL",$J,CLNM,CLIEN,""))
. . S TMP0=^TMP("USRUPCL",$J,CLNM,CLIEN,CLSTATNM)
. . S CLABB=$P(TMP0,U),NAME=$P(TMP0,U,2)
. . S USRCNT=+$G(USRCNT)+1
. . S USRREC=$$SETFLD^VALM1(USRCNT,"","NUMBER")
. . S USRREC=$$SETFLD^VALM1(PREFIX_NAME,USRREC,"CLASS NAME")
. . S USRREC=$$SETFLD^VALM1(CLABB,USRREC,"ABBREVIATION")
. . I SELSTAT=2 S USRREC=$$SETFLD^VALM1(CLSTATNM,USRREC,"ACTIVE")
. . S VALMCNT=+$G(VALMCNT)+1
. . S ^TMP("USRCLASS",$J,VALMCNT,0)=USRREC
. . S ^TMP("USRCLASS",$J,"IDX",VALMCNT,USRCNT)=""
. . S ^TMP("USRCLASSIDX",$J,USRCNT)=VALMCNT_U_CLIEN_U W:VALMCNT#10'>0 "."
;Clear the video attributes so we start fresh.
D KILL^VALM10(VALMCNT) K ^TMP("USRUPCL",$J)
S ^TMP("USRCLASS",$J,0)=+$G(USRCNT)_U_SELSTAT_U_USRFNM_U_USRLNM
S ^TMP("USRCLASS",$J,"#")=USRPICK_U_"1:"_+$G(USRCNT)
I $D(VALMHDR)>9 D HDR
I +$G(USRCNT)'>0 D
. S ^TMP("USRCLASS",$J,1,0)=""
. S ^TMP("USRCLASS",$J,2,0)="No "_$S(SELSTAT=0:"Inactive ",SELSTAT=1:"Active ",1:"")_"User Classes found"
. S VALMCNT=2
Q
;
HDR ; Initialize header for review screen
N BY,USRX,USRCNT,SCREEN,STATUS,TITLE
S USRX=$G(^TMP("USRCLASS",$J,0)),STATUS=$P("INACTIVE^ACTIVE^ALL",U,+$P(USRX,U,2)+1)
S TITLE=STATUS_" USER CLASSES"
S USRCNT=$J(+$G(^TMP("USRCLASS",$J,0)),4)
S USRCNT=USRCNT_" Class"_$S(+USRCNT=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("USRCLASS",$J),^TMP("USRCLASSIDX",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HUSRCLST 4243 printed Dec 13, 2024@01:38:40 Page 2
USRCLST ; SLC/JER - Review User Classes ;11/25/09
+1 ;;1.0;AUTHORIZATION/SUBSCRIPTION;**1,3,7,33**;Jun 20, 1997;Build 7
MAKELIST ; Build review screen list
+1 NEW STATUS,FNAME,LNAME
+2 SET STATUS=$$SELSTAT("ACTIVE")
+3 IF +STATUS<0
SET VALMQUIT=1
QUIT
+4 SET FNAME=$$RANGE(" Start With Class","FIRST")
+5 IF +FNAME=-1
SET VALMQUIT=1
QUIT
+6 SET LNAME=$$RANGE(" Go To Class","LAST")
+7 IF +LNAME=-1
SET VALMQUIT=1
QUIT
+8 WRITE !,"Searching for the User Classes."
+9 DO BUILD(STATUS,FNAME,LNAME)
+10 QUIT
SELSTAT(DEFLT) ; Select User Class status
+1 NEW DIC,XQORM,X,Y
+2 SET DIC=101
SET DIC(0)="X"
SET X="USR CLASS STATUS SELECT"
DO ^DIC
+3 IF +Y>0
Begin DoDot:1
+4 ;ICR 872
SET XQORM=+Y_";ORD(101,"
SET XQORM(0)="1A"
SET XQORM("A")="Select User Class Status: "
+5 SET XQORM("B")=DEFLT
DO ^XQORM
+6 IF +Y
IF ($DATA(Y)>9)
SET Y=$SELECT($PIECE(Y(1),U,3)="Inactive":0,$PIECE(Y(1),U,3)="Active":1,1:2)
End DoDot:1
+7 QUIT Y
RANGE(PROMPT,DEFAULT) ; Get range of classes to browse
+1 NEW Y
+2 ; Y^Y(0)
SET Y=$$READ^USRU("F^1:20",PROMPT,DEFAULT)
+3 IF Y="^"
SET Y=-1
QUIT Y
+4 SET Y=$SELECT(Y["FIRST":"",Y["LAST":"ZZZZ",1:$PIECE(Y,U))
+5 QUIT Y
BUILD(SELSTAT,USRFNM,USRLNM) ; Build List
+1 NEW USRPICK,USRJ,NODE0,STATUS,USRUPNM,CLNM,CLIEN,CLABB,USRCNT,USRREC
+2 NEW USRABBR,STATUSNM,NODE0,NAME,CLSTATNM,USRFNMX,USRLNMX,PREFIX
+3 SET VALMCNT=0
+4 ;ICR 872
SET USRPICK=+$ORDER(^ORD(101,"B","USR ACTION SELECT LIST ELEMENT",0))
+5 ; P33 DRAFT
+6 KILL ^TMP("USRCLASS",$JOB),^TMP("USRCLASSIDX",$JOB),^TMP("USRUPCL",$JOB)
+7 SET USRFNMX=$SELECT(USRFNM]"":$$UP^XLFSTR($EXTRACT(USRFNM)),1:USRFNM)
+8 SET USRLNMX=$$LOW^XLFSTR(USRLNM)_"z"
+9 ; -- S ^TMP("USRUPCL",$J,UPPERCASE NAME,IEN,STATNM) by Uppercase .01 name --
+10 FOR
Begin DoDot:1
+11 NEW NAME
+12 SET USRJ=$GET(USRJ)+1
SET STATUS=""
+13 ; -- Reject unselected statuses --
+14 IF $DATA(^USR(8930,"D",1,USRJ))
SET STATUS=1
+15 IF $DATA(^USR(8930,"D",0,USRJ))
SET STATUS=0
+16 IF STATUS']""
QUIT
+17 IF SELSTAT'=2
IF STATUS'=SELSTAT
QUIT
+18 SET NODE0=$GET(^USR(8930,USRJ,0))
SET NAME=$PIECE(NODE0,U)
+19 if NODE0']""
QUIT
+20 ; -- Reject entries clearly outside alpha boundaries --
+21 IF USRFNMX]NAME
QUIT
+22 IF NAME]USRLNMX
QUIT
+23 SET STATUSNM=$SELECT(STATUS=0:"INACTIVE",STATUS=1:"ACTIVE",1:"??")
+24 SET USRABBR=$PIECE(NODE0,U,2)
+25 SET USRUPNM=$$UP^XLFSTR(NAME)
+26 SET ^TMP("USRUPCL",$JOB,USRUPNM,USRJ,STATUSNM)=USRABBR_U_NAME
End DoDot:1
if $ORDER(^USR(8930,USRJ))'>0
QUIT
+27 ; -- Loop thru TMP("USRUPCL" and set info into USRREC array --
+28 ; ; -- Now we're dealing with uppercase only so get exact boundaries --
+29 SET USRFNMX=$$UP^XLFSTR(USRFNM)
SET USRLNMX=$$UP^XLFSTR(USRLNM)_"Z"
+30 SET CLNM=$SELECT($GET(USRFNMX)]"":$ORDER(^TMP("USRUPCL",$JOB,USRFNMX),-1),1:"")
+31 FOR
SET CLNM=$ORDER(^TMP("USRUPCL",$JOB,CLNM))
if CLNM=""
QUIT
if CLNM]USRLNMX
QUIT
Begin DoDot:1
+32 NEW NAME,TMP0
+33 ; -- CLASS NAMES may not be unique --
+34 SET CLIEN=""
FOR
SET CLIEN=$ORDER(^TMP("USRUPCL",$JOB,CLNM,CLIEN))
if +CLIEN'>0
QUIT
Begin DoDot:2
+35 SET PREFIX=+$ORDER(^USR(8930,+CLIEN,1,0))
+36 SET PREFIX=$SELECT(PREFIX>0:"+",1:"")
+37 SET CLSTATNM=$ORDER(^TMP("USRUPCL",$JOB,CLNM,CLIEN,""))
+38 SET TMP0=^TMP("USRUPCL",$JOB,CLNM,CLIEN,CLSTATNM)
+39 SET CLABB=$PIECE(TMP0,U)
SET NAME=$PIECE(TMP0,U,2)
+40 SET USRCNT=+$GET(USRCNT)+1
+41 SET USRREC=$$SETFLD^VALM1(USRCNT,"","NUMBER")
+42 SET USRREC=$$SETFLD^VALM1(PREFIX_NAME,USRREC,"CLASS NAME")
+43 SET USRREC=$$SETFLD^VALM1(CLABB,USRREC,"ABBREVIATION")
+44 IF SELSTAT=2
SET USRREC=$$SETFLD^VALM1(CLSTATNM,USRREC,"ACTIVE")
+45 SET VALMCNT=+$GET(VALMCNT)+1
+46 SET ^TMP("USRCLASS",$JOB,VALMCNT,0)=USRREC
+47 SET ^TMP("USRCLASS",$JOB,"IDX",VALMCNT,USRCNT)=""
+48 SET ^TMP("USRCLASSIDX",$JOB,USRCNT)=VALMCNT_U_CLIEN_U
if VALMCNT#10'>0
WRITE "."
End DoDot:2
End DoDot:1
+49 ;Clear the video attributes so we start fresh.
+50 DO KILL^VALM10(VALMCNT)
KILL ^TMP("USRUPCL",$JOB)
+51 SET ^TMP("USRCLASS",$JOB,0)=+$GET(USRCNT)_U_SELSTAT_U_USRFNM_U_USRLNM
+52 SET ^TMP("USRCLASS",$JOB,"#")=USRPICK_U_"1:"_+$GET(USRCNT)
+53 IF $DATA(VALMHDR)>9
DO HDR
+54 IF +$GET(USRCNT)'>0
Begin DoDot:1
+55 SET ^TMP("USRCLASS",$JOB,1,0)=""
+56 SET ^TMP("USRCLASS",$JOB,2,0)="No "_$SELECT(SELSTAT=0:"Inactive ",SELSTAT=1:"Active ",1:"")_"User Classes found"
+57 SET VALMCNT=2
End DoDot:1
+58 QUIT
+59 ;
HDR ; Initialize header for review screen
+1 NEW BY,USRX,USRCNT,SCREEN,STATUS,TITLE
+2 SET USRX=$GET(^TMP("USRCLASS",$JOB,0))
SET STATUS=$PIECE("INACTIVE^ACTIVE^ALL",U,+$PIECE(USRX,U,2)+1)
+3 SET TITLE=STATUS_" USER CLASSES"
+4 SET USRCNT=$JUSTIFY(+$GET(^TMP("USRCLASS",$JOB,0)),4)
+5 SET USRCNT=USRCNT_" Class"_$SELECT(+USRCNT=1:"",1:"es")
+6 SET VALMHDR(1)=$$CENTER^USRLS(TITLE)
+7 SET VALMHDR(1)=$$SETSTR^VALM1(USRCNT,VALMHDR(1),(IOM-$LENGTH(USRCNT)),$LENGTH(USRCNT))
+8 QUIT
CLEAN ; "Joel...Clean up your mess!"
+1 KILL ^TMP("USRCLASS",$JOB),^TMP("USRCLASSIDX",$JOB)
+2 QUIT
