USRECCL ; SLC/PKR,MA - Routines for expanding/collapsing class views ;11/25/09
;;1.0;AUTHORIZATION/SUBSCRIPTION;**7,18,33**;Jun 20, 1997;Build 7
; Patch USR*1*18 additional quit to contract logic in tag EC.
; This routine invokes IA #872
;======================================================================
COPYCL(LIST,LSTART,START,END) ;Copy elements of ^TMP("USRCLASS",$J) starting
;at START going to END.
N IND,TEXT
F IND=START:1:END D
. S LSTART=LSTART+1
. S TEXT=^TMP("USRCLASS",$J,IND,0)
. S TEXT=$$SETFLD^VALM1(LSTART,TEXT,"NUMBER")
. S LIST(LSTART)=TEXT_U_$P($G(^TMP("USRCLASSIDX",$J,IND)),U,2)
Q LSTART
;
;======================================================================
EC(USRVALMY) ;Expand or contract the list of classes in VALMY.
;Make sure the request is valid.
I '$$VEXREQ(.USRVALMY) Q
N ACTION,DIROUT,LISTNUM,REBUILD,START,TSTART,TEXT,USRTMP
N USRDATA,USRI,USRIEN,USRPICK,TMP0
S REBUILD=0
S START=1
S TSTART=0
S USRI=""
F S USRI=$O(VALMY(USRI)) Q:+USRI'>0 D Q:$D(DIROUT)
. S USRDATA=^TMP("USRCLASSIDX",$J,USRI)
. S LISTNUM=$P(USRDATA,U,1)
. S USRIEN=$P(USRDATA,U,2)
. S TEXT=$G(^TMP("USRCLASS",$J,LISTNUM,0))
. S ACTION=$S(TEXT["+":"+",TEXT["-":"-",1:"")
. I ACTION="" Q
.;If ACTION="+" then expand the class, if ACTION="-" shrink the class.
. I ACTION="+" D
.. S REBUILD=1
.. S TSTART=$$COPYCL(.USRTMP,TSTART,START,LISTNUM-1)
.. S START=LISTNUM+1
.. S TSTART=TSTART+1
.. S USRTMP(TSTART)=$$SETFLD^VALM1(TSTART,TEXT,"NUMBER")
.. S USRTMP(TSTART)=$TR(USRTMP(TSTART),"+","-")
.. S USRTMP(TSTART)=USRTMP(TSTART)_U_USRIEN
.. S TSTART=$$INSSUB(.USRTMP,TSTART,USRIEN)
. ; -- ACTION="-" --
. I ACTION="-" D
.. N TEMP,CONTRACT
.. S REBUILD=1
.. S TSTART=$$COPYCL(.USRTMP,TSTART,START,LISTNUM-1)
.. S TSTART=TSTART+1
.. S USRTMP(TSTART)=$$SETFLD^VALM1(TSTART,TEXT,"NUMBER")
.. S USRLEVEL=$L(TEXT,"|")
.. S USRTMP(TSTART)=$TR(USRTMP(TSTART),"-","+")_U_USRIEN
.. S START=USRI+1
.. S CONTRACT=1
.. ; Patch 18 added the second quit.
.. F Q:'CONTRACT Q:'$D(^TMP("USRCLASS",$J,START,0)) D
... S TEMP=^TMP("USRCLASS",$J,START,0)
...;Contract if at a or higher level than the main line
... I TEMP["|",$L(TEMP,"|")>USRLEVEL S START=START+1
... E S CONTRACT=0
.;
.;Restore the original video attributes.
. D RESTORE^VALM10(USRI)
;No more classes to expand or contract, add the rest of the list.
I 'REBUILD Q
S TMP0=^TMP("USRCLASS",$J,0)
S LISTNUM=$P(TMP0,U)
S TSTART=$$COPYCL(.USRTMP,TSTART,START,LISTNUM)
;Rebuild the ^TMP arrays.
K ^TMP("USRCLASS",$J),^TMP("USRCLASSIDX",$J),^TMP("USRCLASS",$J,"PICK")
S VALMCNT=0
S START=0
F S START=$O(USRTMP(START)) Q:START="" D
. S VALMCNT=VALMCNT+1
. S TEXT=$P(USRTMP(START),U,1)
. S USRIEN=$P(USRTMP(START),U,2)
. S ^TMP("USRCLASS",$J,START,0)=TEXT
. S ^TMP("USRCLASS",$J,"IDX",START,START)=""
. S ^TMP("USRCLASSIDX",$J,START)=START_U_USRIEN
S ^TMP("USRCLASS",$J,0)=VALMCNT_U_$P(TMP0,U,2)_$P(TMP0,U,3)_$P(TMP0,U,4)
S USRPICK=+$O(^ORD(101,"B","USR ACTION SELECT LIST ELEMENT",0))
S ^TMP("USRCLASS",$J,"#")=USRPICK_U_"1:"_+$G(VALMCNT)
Q
;
;======================================================================
INSSUB(LIST,TSTART,USRIEN) ;Insert the subclasses into the list.
N ACTIVE,CLN,CLNS,DATA,IND,IEN,USRLEVEL,MSG,TEXT
;Determine the level of the subclass and create the appropriate
;diagram.
S USRLEVEL=$L(LIST(TSTART),"|")
I USRLEVEL=1 S CLNS=" "
E S CLNS=""
F IND=2:1:USRLEVEL S CLNS=CLNS_" | "
I USRLEVEL>1 S CLNS=CLNS_" |_"
E S CLNS=CLNS_"|_"
S IND=0
F S IND=$O(^USR(8930,USRIEN,1,IND)) Q:+IND=0 D
. S IEN=^USR(8930,USRIEN,1,IND,0)
. S DATA=$G(^USR(8930,IEN,0))
. S TSTART=TSTART+1
. S TEXT=$$SETFLD^VALM1(TSTART,"","NUMBER")
. S CLN=CLNS
. I $D(^USR(8930,IEN,1,0))&$D(^USR(8930,IEN,1,"B")) S CLN=CLN_"+"
. E S CLN=CLN_" "
. S CLN=CLN_$P(DATA,U) ; Use .01 name, not dipsplay name
. S TEXT=$$SETFLD^VALM1(CLN,TEXT,"CLASS NAME")
. S TEXT=$$SETFLD^VALM1($P(DATA,U,2),TEXT,"ABBREVIATION")
. S ACTIVE=$$EXTERNAL^DILFD(8930,.03,"",$P(DATA,U,3),"MSG")
. S TEXT=$$SETFLD^VALM1(ACTIVE,TEXT,"ACTIVE")
.;NEED USRCLASSIDX INFO
. S LIST(TSTART)=TEXT_U_IEN
Q TSTART
;
;======================================================================
ISSUB(CLASS1,CLASS2,USRLEVEL) ;Return true if CLASS2 is sub to CLASS1.
N IND,ISSUB
I USRLEVEL(CLASS1)'<USRLEVEL(CLASS2) Q 0
;Check sublevel links between class1 and class2
S ISSUB=1
F IND=(CLASS1+1):1:(CLASS2-1) D
. I USRLEVEL(IND)=1 D Q
.. S ISSUB=0
Q ISSUB
;
;======================================================================
VEXREQ(VALMY) ;Check for valid expand/contract requests.
N END,START
S START=$O(VALMY(""))
S END=$O(VALMY(""),-1)
I START=END Q 1
;
N ACTION,ACTIND,ACTJND,CIND,CN,IND,JND,USRLEVEL,MSG,TEXT,VALID
;Build the level list.
F IND=START:1:END D
. S USRLEVEL(IND)=$L(^TMP("USRCLASS",$J,IND,0),"|")
S VALID=1
S IND=""
F S IND=$O(VALMY(IND)) Q:IND="" D
. S TEXT(IND)=$G(^TMP("USRCLASS",$J,IND,0))
. S ACTIND=$S(TEXT(IND)["+":"+ ",TEXT(IND)["-":"-",1:"")
. I ACTIND="" Q
. S ACTION(IND)=$S(TEXT(IND)["+":"expand ",TEXT(IND)["-":"collapse ",1:"")
. S JND=IND
. F S JND=$O(VALMY(JND)) Q:JND="" D
.. S TEXT(JND)=$G(^TMP("USRCLASS",$J,JND,0))
.. S ACTJND=$S(TEXT(JND)["+":"+",TEXT(JND)["-":"-",1:"")
.. I ACTJND="" Q
.. S ACTION(JND)=$S(TEXT(JND)["+":"expand ",TEXT(JND)["-":"collapse ",1:"")
.. I $$ISSUB(IND,JND,.USRLEVEL) D
... I ACTION(IND)'=ACTION(JND) D Q
.... S CIND(IND)=$P(^TMP("USRCLASSIDX",$J,IND),U,2)
.... S CN(IND)=$P(^USR(8930,CIND(IND),0),U,1)
.... S CIND(JND)=$P(^TMP("USRCLASSIDX",$J,JND),U,2)
.... S CN(JND)=$P(^USR(8930,CIND(JND),0),U,1)
.... S MSG="You cannot "_ACTION(IND)_CN(IND)_" and "_ACTION(JND)_CN(JND)
.... D MSG^VALM10(MSG)
.... H 4
.... S VALID=0
Q VALID
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HUSRECCL 5920 printed Sep 23, 2025@19:14:41 Page 2
USRECCL ; SLC/PKR,MA - Routines for expanding/collapsing class views ;11/25/09
+1 ;;1.0;AUTHORIZATION/SUBSCRIPTION;**7,18,33**;Jun 20, 1997;Build 7
+2 ; Patch USR*1*18 additional quit to contract logic in tag EC.
+3 ; This routine invokes IA #872
+4 ;======================================================================
COPYCL(LIST,LSTART,START,END) ;Copy elements of ^TMP("USRCLASS",$J) starting
+1 ;at START going to END.
+2 NEW IND,TEXT
+3 FOR IND=START:1:END
Begin DoDot:1
+4 SET LSTART=LSTART+1
+5 SET TEXT=^TMP("USRCLASS",$JOB,IND,0)
+6 SET TEXT=$$SETFLD^VALM1(LSTART,TEXT,"NUMBER")
+7 SET LIST(LSTART)=TEXT_U_$PIECE($GET(^TMP("USRCLASSIDX",$JOB,IND)),U,2)
End DoDot:1
+8 QUIT LSTART
+9 ;
+10 ;======================================================================
EC(USRVALMY) ;Expand or contract the list of classes in VALMY.
+1 ;Make sure the request is valid.
+2 IF '$$VEXREQ(.USRVALMY)
QUIT
+3 NEW ACTION,DIROUT,LISTNUM,REBUILD,START,TSTART,TEXT,USRTMP
+4 NEW USRDATA,USRI,USRIEN,USRPICK,TMP0
+5 SET REBUILD=0
+6 SET START=1
+7 SET TSTART=0
+8 SET USRI=""
+9 FOR
SET USRI=$ORDER(VALMY(USRI))
if +USRI'>0
QUIT
Begin DoDot:1
+10 SET USRDATA=^TMP("USRCLASSIDX",$JOB,USRI)
+11 SET LISTNUM=$PIECE(USRDATA,U,1)
+12 SET USRIEN=$PIECE(USRDATA,U,2)
+13 SET TEXT=$GET(^TMP("USRCLASS",$JOB,LISTNUM,0))
+14 SET ACTION=$SELECT(TEXT["+":"+",TEXT["-":"-",1:"")
+15 IF ACTION=""
QUIT
+16 ;If ACTION="+" then expand the class, if ACTION="-" shrink the class.
+17 IF ACTION="+"
Begin DoDot:2
+18 SET REBUILD=1
+19 SET TSTART=$$COPYCL(.USRTMP,TSTART,START,LISTNUM-1)
+20 SET START=LISTNUM+1
+21 SET TSTART=TSTART+1
+22 SET USRTMP(TSTART)=$$SETFLD^VALM1(TSTART,TEXT,"NUMBER")
+23 SET USRTMP(TSTART)=$TRANSLATE(USRTMP(TSTART),"+","-")
+24 SET USRTMP(TSTART)=USRTMP(TSTART)_U_USRIEN
+25 SET TSTART=$$INSSUB(.USRTMP,TSTART,USRIEN)
End DoDot:2
+26 ; -- ACTION="-" --
+27 IF ACTION="-"
Begin DoDot:2
+28 NEW TEMP,CONTRACT
+29 SET REBUILD=1
+30 SET TSTART=$$COPYCL(.USRTMP,TSTART,START,LISTNUM-1)
+31 SET TSTART=TSTART+1
+32 SET USRTMP(TSTART)=$$SETFLD^VALM1(TSTART,TEXT,"NUMBER")
+33 SET USRLEVEL=$LENGTH(TEXT,"|")
+34 SET USRTMP(TSTART)=$TRANSLATE(USRTMP(TSTART),"-","+")_U_USRIEN
+35 SET START=USRI+1
+36 SET CONTRACT=1
+37 ; Patch 18 added the second quit.
+38 FOR
if 'CONTRACT
QUIT
if '$DATA(^TMP("USRCLASS",$JOB,START,0))
QUIT
Begin DoDot:3
+39 SET TEMP=^TMP("USRCLASS",$JOB,START,0)
+40 ;Contract if at a or higher level than the main line
+41 IF TEMP["|"
IF $LENGTH(TEMP,"|")>USRLEVEL
SET START=START+1
+42 IF '$TEST
SET CONTRACT=0
End DoDot:3
End DoDot:2
+43 ;
+44 ;Restore the original video attributes.
+45 DO RESTORE^VALM10(USRI)
End DoDot:1
if $DATA(DIROUT)
QUIT
+46 ;No more classes to expand or contract, add the rest of the list.
+47 IF 'REBUILD
QUIT
+48 SET TMP0=^TMP("USRCLASS",$JOB,0)
+49 SET LISTNUM=$PIECE(TMP0,U)
+50 SET TSTART=$$COPYCL(.USRTMP,TSTART,START,LISTNUM)
+51 ;Rebuild the ^TMP arrays.
+52 KILL ^TMP("USRCLASS",$JOB),^TMP("USRCLASSIDX",$JOB),^TMP("USRCLASS",$JOB,"PICK")
+53 SET VALMCNT=0
+54 SET START=0
+55 FOR
SET START=$ORDER(USRTMP(START))
if START=""
QUIT
Begin DoDot:1
+56 SET VALMCNT=VALMCNT+1
+57 SET TEXT=$PIECE(USRTMP(START),U,1)
+58 SET USRIEN=$PIECE(USRTMP(START),U,2)
+59 SET ^TMP("USRCLASS",$JOB,START,0)=TEXT
+60 SET ^TMP("USRCLASS",$JOB,"IDX",START,START)=""
+61 SET ^TMP("USRCLASSIDX",$JOB,START)=START_U_USRIEN
End DoDot:1
+62 SET ^TMP("USRCLASS",$JOB,0)=VALMCNT_U_$PIECE(TMP0,U,2)_$PIECE(TMP0,U,3)_$PIECE(TMP0,U,4)
+63 SET USRPICK=+$ORDER(^ORD(101,"B","USR ACTION SELECT LIST ELEMENT",0))
+64 SET ^TMP("USRCLASS",$JOB,"#")=USRPICK_U_"1:"_+$GET(VALMCNT)
+65 QUIT
+66 ;
+67 ;======================================================================
INSSUB(LIST,TSTART,USRIEN) ;Insert the subclasses into the list.
+1 NEW ACTIVE,CLN,CLNS,DATA,IND,IEN,USRLEVEL,MSG,TEXT
+2 ;Determine the level of the subclass and create the appropriate
+3 ;diagram.
+4 SET USRLEVEL=$LENGTH(LIST(TSTART),"|")
+5 IF USRLEVEL=1
SET CLNS=" "
+6 IF '$TEST
SET CLNS=""
+7 FOR IND=2:1:USRLEVEL
SET CLNS=CLNS_" | "
+8 IF USRLEVEL>1
SET CLNS=CLNS_" |_"
+9 IF '$TEST
SET CLNS=CLNS_"|_"
+10 SET IND=0
+11 FOR
SET IND=$ORDER(^USR(8930,USRIEN,1,IND))
if +IND=0
QUIT
Begin DoDot:1
+12 SET IEN=^USR(8930,USRIEN,1,IND,0)
+13 SET DATA=$GET(^USR(8930,IEN,0))
+14 SET TSTART=TSTART+1
+15 SET TEXT=$$SETFLD^VALM1(TSTART,"","NUMBER")
+16 SET CLN=CLNS
+17 IF $DATA(^USR(8930,IEN,1,0))&$DATA(^USR(8930,IEN,1,"B"))
SET CLN=CLN_"+"
+18 IF '$TEST
SET CLN=CLN_" "
+19 ; Use .01 name, not dipsplay name
SET CLN=CLN_$PIECE(DATA,U)
+20 SET TEXT=$$SETFLD^VALM1(CLN,TEXT,"CLASS NAME")
+21 SET TEXT=$$SETFLD^VALM1($PIECE(DATA,U,2),TEXT,"ABBREVIATION")
+22 SET ACTIVE=$$EXTERNAL^DILFD(8930,.03,"",$PIECE(DATA,U,3),"MSG")
+23 SET TEXT=$$SETFLD^VALM1(ACTIVE,TEXT,"ACTIVE")
+24 ;NEED USRCLASSIDX INFO
+25 SET LIST(TSTART)=TEXT_U_IEN
End DoDot:1
+26 QUIT TSTART
+27 ;
+28 ;======================================================================
ISSUB(CLASS1,CLASS2,USRLEVEL) ;Return true if CLASS2 is sub to CLASS1.
+1 NEW IND,ISSUB
+2 IF USRLEVEL(CLASS1)'<USRLEVEL(CLASS2)
QUIT 0
+3 ;Check sublevel links between class1 and class2
+4 SET ISSUB=1
+5 FOR IND=(CLASS1+1):1:(CLASS2-1)
Begin DoDot:1
+6 IF USRLEVEL(IND)=1
Begin DoDot:2
+7 SET ISSUB=0
End DoDot:2
QUIT
End DoDot:1
+8 QUIT ISSUB
+9 ;
+10 ;======================================================================
VEXREQ(VALMY) ;Check for valid expand/contract requests.
+1 NEW END,START
+2 SET START=$ORDER(VALMY(""))
+3 SET END=$ORDER(VALMY(""),-1)
+4 IF START=END
QUIT 1
+5 ;
+6 NEW ACTION,ACTIND,ACTJND,CIND,CN,IND,JND,USRLEVEL,MSG,TEXT,VALID
+7 ;Build the level list.
+8 FOR IND=START:1:END
Begin DoDot:1
+9 SET USRLEVEL(IND)=$LENGTH(^TMP("USRCLASS",$JOB,IND,0),"|")
End DoDot:1
+10 SET VALID=1
+11 SET IND=""
+12 FOR
SET IND=$ORDER(VALMY(IND))
if IND=""
QUIT
Begin DoDot:1
+13 SET TEXT(IND)=$GET(^TMP("USRCLASS",$JOB,IND,0))
+14 SET ACTIND=$SELECT(TEXT(IND)["+":"+ ",TEXT(IND)["-":"-",1:"")
+15 IF ACTIND=""
QUIT
+16 SET ACTION(IND)=$SELECT(TEXT(IND)["+":"expand ",TEXT(IND)["-":"collapse ",1:"")
+17 SET JND=IND
+18 FOR
SET JND=$ORDER(VALMY(JND))
if JND=""
QUIT
Begin DoDot:2
+19 SET TEXT(JND)=$GET(^TMP("USRCLASS",$JOB,JND,0))
+20 SET ACTJND=$SELECT(TEXT(JND)["+":"+",TEXT(JND)["-":"-",1:"")
+21 IF ACTJND=""
QUIT
+22 SET ACTION(JND)=$SELECT(TEXT(JND)["+":"expand ",TEXT(JND)["-":"collapse ",1:"")
+23 IF $$ISSUB(IND,JND,.USRLEVEL)
Begin DoDot:3
+24 IF ACTION(IND)'=ACTION(JND)
Begin DoDot:4
+25 SET CIND(IND)=$PIECE(^TMP("USRCLASSIDX",$JOB,IND),U,2)
+26 SET CN(IND)=$PIECE(^USR(8930,CIND(IND),0),U,1)
+27 SET CIND(JND)=$PIECE(^TMP("USRCLASSIDX",$JOB,JND),U,2)
+28 SET CN(JND)=$PIECE(^USR(8930,CIND(JND),0),U,1)
+29 SET MSG="You cannot "_ACTION(IND)_CN(IND)_" and "_ACTION(JND)_CN(JND)
+30 DO MSG^VALM10(MSG)
+31 HANG 4
+32 SET VALID=0
End DoDot:4
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+33 QUIT VALID
+34 ;
