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

USRECCL.m

Go to the documentation of this file. 
  1. 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 5
  1.  ; Patch USR*1*18 additional quit to contract logic in tag EC.
  1.  ; This routine invokes IA #872
  1.  ;======================================================================
  1. COPYCL(LIST,LSTART,START,END) ;Copy elements of ^TMP("USRCLASS",$J) starting
  1.  ;at START going to END.
  1.  N IND,TEXT
  1.  F IND=START:1:END D
  1.  . S LSTART=LSTART+1
  1.  . S TEXT=^TMP("USRCLASS",$J,IND,0)
  1.  . S TEXT=$$SETFLD^VALM1(LSTART,TEXT,"NUMBER")
  1.  . S LIST(LSTART)=TEXT_U_$P($G(^TMP("USRCLASSIDX",$J,IND)),U,2)
  1.  Q LSTART
  1.  ;
  1.  ;======================================================================
  1. EC(USRVALMY) ;Expand or contract the list of classes in VALMY.
  1.  ;Make sure the request is valid.
  1.  I '$$VEXREQ(.USRVALMY) Q
  1.  N ACTION,DIROUT,LISTNUM,REBUILD,START,TSTART,TEXT,USRTMP
  1.  N USRDATA,USRI,USRIEN,USRPICK,TMP0
  1.  S REBUILD=0
  1.  S START=1
  1.  S TSTART=0
  1.  S USRI=""
  1.  F  S USRI=$O(VALMY(USRI)) Q:+USRI'>0  D  Q:$D(DIROUT)
  1.  . S USRDATA=^TMP("USRCLASSIDX",$J,USRI)
  1.  . S LISTNUM=$P(USRDATA,U,1)
  1.  . S USRIEN=$P(USRDATA,U,2)
  1.  . S TEXT=$G(^TMP("USRCLASS",$J,LISTNUM,0))
  1.  . S ACTION=$S(TEXT["+":"+",TEXT["-":"-",1:"")
  1.  . I ACTION="" Q
  1.  .;If ACTION="+" then expand the class, if ACTION="-" shrink the class.
  1.  . I ACTION="+" D
  1.  .. S REBUILD=1
  1.  .. S TSTART=$$COPYCL(.USRTMP,TSTART,START,LISTNUM-1)
  1.  .. S START=LISTNUM+1
  1.  .. S TSTART=TSTART+1
  1.  .. S USRTMP(TSTART)=$$SETFLD^VALM1(TSTART,TEXT,"NUMBER")
  1.  .. S USRTMP(TSTART)=$TR(USRTMP(TSTART),"+","-")
  1.  .. S USRTMP(TSTART)=USRTMP(TSTART)_U_USRIEN
  1.  .. S TSTART=$$INSSUB(.USRTMP,TSTART,USRIEN)
  1.  . ; -- ACTION="-" --
  1.  . I ACTION="-" D
  1.  .. N TEMP,CONTRACT
  1.  .. S REBUILD=1
  1.  .. S TSTART=$$COPYCL(.USRTMP,TSTART,START,LISTNUM-1)
  1.  .. S TSTART=TSTART+1
  1.  .. S USRTMP(TSTART)=$$SETFLD^VALM1(TSTART,TEXT,"NUMBER")
  1.  .. S USRLEVEL=$L(TEXT,"|")
  1.  .. S USRTMP(TSTART)=$TR(USRTMP(TSTART),"-","+")_U_USRIEN
  1.  .. S START=USRI+1
  1.  .. S CONTRACT=1
  1.  .. ; Patch 18 added the second quit.
  1.  .. F  Q:'CONTRACT  Q:'$D(^TMP("USRCLASS",$J,START,0))  D
  1.  ... S TEMP=^TMP("USRCLASS",$J,START,0)
  1.  ...;Contract if at a or higher level than the main line
  1.  ... I TEMP["|",$L(TEMP,"|")>USRLEVEL S START=START+1
  1.  ... E  S CONTRACT=0
  1.  .;
  1.  .;Restore the original video attributes.
  1.  . D RESTORE^VALM10(USRI)
  1.  ;No more classes to expand or contract, add the rest of the list.
  1.  I 'REBUILD Q
  1.  S TMP0=^TMP("USRCLASS",$J,0)
  1.  S LISTNUM=$P(TMP0,U)
  1.  S TSTART=$$COPYCL(.USRTMP,TSTART,START,LISTNUM)
  1.  ;Rebuild the ^TMP arrays.
  1.  K ^TMP("USRCLASS",$J),^TMP("USRCLASSIDX",$J),^TMP("USRCLASS",$J,"PICK")
  1.  S VALMCNT=0
  1.  S START=0
  1.  F  S START=$O(USRTMP(START)) Q:START=""  D
  1.  . S VALMCNT=VALMCNT+1
  1.  . S TEXT=$P(USRTMP(START),U,1)
  1.  . S USRIEN=$P(USRTMP(START),U,2)
  1.  . S ^TMP("USRCLASS",$J,START,0)=TEXT
  1.  . S ^TMP("USRCLASS",$J,"IDX",START,START)=""
  1.  . S ^TMP("USRCLASSIDX",$J,START)=START_U_USRIEN
  1.  S ^TMP("USRCLASS",$J,0)=VALMCNT_U_$P(TMP0,U,2)_$P(TMP0,U,3)_$P(TMP0,U,4)
  1.  S USRPICK=+$O(^ORD(101,"B","USR ACTION SELECT LIST ELEMENT",0))
  1.  S ^TMP("USRCLASS",$J,"#")=USRPICK_U_"1:"_+$G(VALMCNT)
  1.  Q
  1.  ;
  1.  ;======================================================================
  1. INSSUB(LIST,TSTART,USRIEN) ;Insert the subclasses into the list.
  1.  N ACTIVE,CLN,CLNS,DATA,IND,IEN,USRLEVEL,MSG,TEXT
  1.  ;Determine the level of the subclass and create the appropriate
  1.  ;diagram.
  1.  S USRLEVEL=$L(LIST(TSTART),"|")
  1.  I USRLEVEL=1 S CLNS=" "
  1.  E  S CLNS=""
  1.  F IND=2:1:USRLEVEL S CLNS=CLNS_" | "
  1.  I USRLEVEL>1 S CLNS=CLNS_" |_"
  1.  E  S CLNS=CLNS_"|_"
  1.  S IND=0
  1.  F  S IND=$O(^USR(8930,USRIEN,1,IND)) Q:+IND=0  D
  1.  . S IEN=^USR(8930,USRIEN,1,IND,0)
  1.  . S DATA=$G(^USR(8930,IEN,0))
  1.  . S TSTART=TSTART+1
  1.  . S TEXT=$$SETFLD^VALM1(TSTART,"","NUMBER")
  1.  . S CLN=CLNS
  1.  . I $D(^USR(8930,IEN,1,0))&$D(^USR(8930,IEN,1,"B")) S CLN=CLN_"+"
  1.  . E  S CLN=CLN_" "
  1.  . S CLN=CLN_$P(DATA,U) ; Use .01 name, not dipsplay name
  1.  . S TEXT=$$SETFLD^VALM1(CLN,TEXT,"CLASS NAME")
  1.  . S TEXT=$$SETFLD^VALM1($P(DATA,U,2),TEXT,"ABBREVIATION")
  1.  . S ACTIVE=$$EXTERNAL^DILFD(8930,.03,"",$P(DATA,U,3),"MSG")
  1.  . S TEXT=$$SETFLD^VALM1(ACTIVE,TEXT,"ACTIVE")
  1.  .;NEED USRCLASSIDX INFO
  1.  . S LIST(TSTART)=TEXT_U_IEN
  1.  Q TSTART
  1.  ;
  1.  ;======================================================================
  1. ISSUB(CLASS1,CLASS2,USRLEVEL) ;Return true if CLASS2 is sub to CLASS1.
  1.  N IND,ISSUB
  1.  I USRLEVEL(CLASS1)'<USRLEVEL(CLASS2) Q 0
  1.  ;Check sublevel links between class1 and class2
  1.  S ISSUB=1
  1.  F IND=(CLASS1+1):1:(CLASS2-1) D
  1.  . I USRLEVEL(IND)=1 D  Q
  1.  .. S ISSUB=0
  1.  Q ISSUB
  1.  ;
  1.  ;======================================================================
  1. VEXREQ(VALMY) ;Check for valid expand/contract requests.
  1.  N END,START
  1.  S START=$O(VALMY(""))
  1.  S END=$O(VALMY(""),-1)
  1.  I START=END Q 1
  1.  ;
  1.  N ACTION,ACTIND,ACTJND,CIND,CN,IND,JND,USRLEVEL,MSG,TEXT,VALID
  1.  ;Build the level list.
  1.  F IND=START:1:END D
  1.  . S USRLEVEL(IND)=$L(^TMP("USRCLASS",$J,IND,0),"|")
  1.  S VALID=1
  1.  S IND=""
  1.  F  S IND=$O(VALMY(IND)) Q:IND=""  D
  1.  . S TEXT(IND)=$G(^TMP("USRCLASS",$J,IND,0))
  1.  . S ACTIND=$S(TEXT(IND)["+":"+ ",TEXT(IND)["-":"-",1:"")
  1.  . I ACTIND="" Q
  1.  . S ACTION(IND)=$S(TEXT(IND)["+":"expand ",TEXT(IND)["-":"collapse ",1:"")
  1.  . S JND=IND
  1.  . F  S JND=$O(VALMY(JND)) Q:JND=""  D
  1.  .. S TEXT(JND)=$G(^TMP("USRCLASS",$J,JND,0))
  1.  .. S ACTJND=$S(TEXT(JND)["+":"+",TEXT(JND)["-":"-",1:"")
  1.  .. I ACTJND="" Q
  1.  .. S ACTION(JND)=$S(TEXT(JND)["+":"expand ",TEXT(JND)["-":"collapse ",1:"")
  1.  .. I $$ISSUB(IND,JND,.USRLEVEL) D
  1.  ... I ACTION(IND)'=ACTION(JND) D  Q
  1.  .... S CIND(IND)=$P(^TMP("USRCLASSIDX",$J,IND),U,2)
  1.  .... S CN(IND)=$P(^USR(8930,CIND(IND),0),U,1)
  1.  .... S CIND(JND)=$P(^TMP("USRCLASSIDX",$J,JND),U,2)
  1.  .... S CN(JND)=$P(^USR(8930,CIND(JND),0),U,1)
  1.  .... S MSG="You cannot "_ACTION(IND)_CN(IND)_" and "_ACTION(JND)_CN(JND)
  1.  .... D MSG^VALM10(MSG)
  1.  .... H 4
  1.  .... S VALID=0
  1.  Q VALID
  1.  ;