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

DDBRU2.m

Go to the documentation of this file. 
  1. DDBRU2 ;SFISC/DCL-BROWSE LOCAL OR GLOBAL ARRAY DDBROOT DESCENDANTS ;12:54 PM  20 Nov 1994
  1.  ;;22.0;VA FileMan;;Mar 30, 1999
  1.  ;Per VHA Directive 10-93-142, this routine should not be modified.
  1.  Q
  1. EN N DDBNCC G CNTNU
  1. ROOT(DDBNCC,DDBRTOP,DDBRBOT) ; Browse Array Root Descendants ; DDBNCC node count check (default=1000)
  1. CNTNU K ^TMP("DDBARD",$J),^TMP("DDBARDL",$J)
  1.  ;W !!,"Enter Root> " R DDBROOT W !!
  1.  ;I DDBROOT="^"!(DDBROOT="") Q
  1.  D ARSEL
  1.  I $O(^TMP("DDBARDL",$J,""))']"" Q
  1.  N DDBARDX,N,X
  1.  S DDBARDX="",DDBNCC=$G(DDBNCC,1000)
  1.  F  S DDBARDX=$O(^TMP("DDBARDL",$J,DDBARDX)) Q:DDBARDX=""  S X=^(DDBARDX) D
  1.  .S N=$O(^TMP("DDBARD",$J,""),-1)+1
  1.  .S ^TMP("DDBARDL",$J,DDBARDX)=$NA(^TMP("DDBARD",$J,N))
  1.  .W !,"...loading ",DDBARDX
  1.  .D BLD(DDBNCC,X,N)
  1.  .Q
  1.  W !,"...building ""Current List"" tables"
  1.  D DOCLIST^DDBR("^TMP(""DDBARDL"",$J)","",$G(DDBRTOP),$G(DDBRBOT))
  1. END K ^TMP("DDBARD",$J),^TMP("DDBARDL",$J)
  1.  Q
  1.  ;
  1. BLD(DDBNCC,DDBROOT,DDBN) ;build structures
  1.  N DDBMAXL,DDBR1X
  1.  S DDBMAXL=$G(DDBMAXL,255)
  1.  S DDBNCC=$G(DDBNCC,1000)
  1.  S DDBR1X=$$OREF^DIQGU(DDBROOT)
  1.  N DDBR1,DDBR1A,DDBR1B,DDBR1I,DDBR1Q,DDBI,DDBII,DDBX,DDBX1,DDBX1L,DDBX2,DDBX2L,DDBX3,DDBX3L,DDBXT
  1.  S DDBR1A=$$R^%RCR(DDBR1X),DDBR1Q=""""""
  1.  I $L(DDBR1A,",")>1,$P(DDBR1A,",",$L(DDBR1A,","))]"" S DDBR1Q=$P(DDBR1A,",",$L(DDBR1A,",")),$P(DDBR1A,",",$L(DDBR1A,","))=""
  1.  S DDBR1=DDBR1A_DDBR1Q_")",DDBR1B=$L(DDBR1A)+1,DDBX2=" = ",DDBX2L=$L(DDBX2),DDBII=0
  1.  F DDBI=1:1 S DDBR1=$Q(@DDBR1) Q:$P(DDBR1,DDBR1A)]""!(DDBR1="")  D  Q:DDBII
  1.  .I '(DDBI#DDBNCC) D
  1.  ..W $C(7),!,DDBROOT,!,"Node count: ",DDBI,!!,"Do you wish to continue //Yes  "
  1.  ..R DDBX:$G(DTIME,300) W !!
  1.  ..I DDBX=""!($TR($E(DDBX),"y","Y")="Y") Q
  1.  ..S DDBII=1
  1.  ..Q
  1.  .S DDBX1=DDBR1
  1.  .S DDBX3=@DDBR1
  1.  .S DDBX1L=$L(DDBX1),DDBX3L=$L(DDBX3)
  1.  .S DDBXT=DDBX1L+DDBX2L+DDBX3L
  1.  .I DDBXT'>DDBMAXL S ^TMP("DDBARD",$J,DDBN,DDBI)=DDBX1_DDBX2_DDBX3 Q
  1.  .I DDBX1L+DDBX2L'>DDBMAXL D  Q
  1.  ..S ^TMP("DDBARD",$J,DDBN,DDBI)=DDBX1_DDBX2_$E(DDBX3,1,DDBMAXL-(DDBX1L+DDBX2L))
  1.  ..S DDBI=DDBI+1
  1.  ..S ^TMP("DDBARD",$J,DDBN,DDBI)=$E(DDBX3,(DDBMAXL-(DDBX1L+DDBX2L)+1),DDBMAXL)
  1.  ..Q
  1.  .Q
  1.  Q
  1.  ;
  1. ARSEL ; Array Root Select
  1.  N DDBERR,DDBRLVD,X,Y
  1.  W !!
  1. SEL R !,"Select Root> ",X:$G(DTIME,300)
  1.  I X="" Q
  1.  I X="^" K ^TMP("DDBARDL",$J) Q
  1.  I $E(X)="?" D HLP G SEL
  1.  I X="^TMP"!(X="^TMP(")!($E(X,1,14)="^TMP(""DDBARDL""") D HLP G SEL
  1.  S Y=$$OREF^DIQGU(X),DDBERR=0,Y=$$R(Y) I DDBERR W $C(7),"  ...INVALID",!!,"'",X,"' CAN NOT BE RESOLVED",! G SEL
  1.  S DDBRLVD=$$CREF^DIQGU(Y)
  1.  S Y=$$CREF^DIQGU(X)
  1.  I $D(@Y)'>9 S Y=$X W $C(7),"  ...INVALID",!!,"'",X,"' HAS NO DESCENDANTS",! G SEL
  1.  I DDBRLVD'=Y S X=X_" ["_DDBRLVD_"]"
  1.  S ^TMP("DDBARDL",$J,X_" | DESCENDANTS |")=Y
  1.  G SEL
  1.  ;
  1. HLP ;
  1.  W !!,"Enter a valid local or global array root"
  1.  W !,"Can not be ^TMP, ^TMP( or ^TMP(""DDBARDL""",!
  1.  Q
  1. R(%R) ;
  1.  N %C,%F,%G,%I,%R1,%R2
  1.  S %R1=$P(%R,"(")_"("
  1.  I $E(%R1)="^" S %R2=$E($P(%R1,"("),2,99) D  Q:$G(DDBERR) %R
  1.  .I $L(%R2)'>0 S DDBERR=1 Q
  1.  .I %R2="%" Q
  1.  .I $E(%R2)="%" D  Q
  1.  ..I $E(%R2,2,99)?.E1P.E S DDBERR=1 Q
  1.  ..Q
  1.  .I %R2?1N.E S DDBERR=1 Q
  1.  .I %R2?.E1P.E S DDBERR=1 Q
  1.  .Q
  1.  .;I %R2'="%"&(%R2'?.A) S DDBERR=1 Q %R
  1.  I $E(%R1)'="^" S %R2=$P(%R1,"(") D  Q:$G(DDBERR) %R
  1.  .I $L(%R2)'>0 S DDBERR=1 Q
  1.  .I %R2="%" Q
  1.  .I $E(%R2)="%" D  Q
  1.  ..I $E(%R2,2,99)?.E1P.E S DDBERR=1 Q
  1.  ..Q
  1.  .I %R2?1N.E S DDBERR=1 Q
  1.  .I %R2?.E1P.E S DDBERR=1 Q
  1.  .Q
  1.  .;,$E(%R1)'="%",$E(%R1)'?.A S DDBERR=1 Q %R
  1.  I $E(%R1)="^" S %R2=$P($Q(@(%R1_""""")")),"(")_"(" S:$P(%R2,"(")]"" %R1=%R2
  1.  S %R2=$P($E(%R,1,($L(%R)-($E(%R,$L(%R))=")"))),"(",2,99)
  1.  S %C=$L(%R2,","),%F=1 F %I=1:1 Q:%I'<%C  S %G=$P(%R2,",",%F,%I) Q:%G=""  I ($L(%G,"(")=$L(%G,")")&($L(%G,"""")#2))!(($L(%G,"""")#2)&($E(%G)="""")&($E(%G,$L(%G))="""")) D
  1.  .S %G=$$S(%G),$P(%R2,",",%F,%I)=%G,%F=%F+$L(%G,","),%I=%F-1,%C=%C+($L(%G,",")-1)
  1.  .Q
  1.  S DDBERR=%F'=%C
  1.  Q %R1_%R2
  1. S(%Z) ;
  1.  I $G(%Z)']"" Q ""
  1.  I $E(%Z)'="""",$L(%Z,"E")=2,+$P(%Z,"E")=$P(%Z,"E"),+$P(%Z,"E",2)=$P(%Z,"E",2) Q +%Z
  1.  I +%Z=%Z Q %Z
  1.  I $E(%Z)?1N,+%Z'=%Z S DDBERR=1 Q %Z
  1.  I %Z="""""" Q ""
  1.  I $E(%Z)="""" Q %Z
  1.  I $E(%Z)'?1A,"%$+@"'[$E(%Z) S DDBERR=1 Q %Z
  1.  I "+$"[$E(%Z) X "S %Z="_%Z Q $$Q(%Z)
  1.  I $D(@%Z) Q $$Q(@%Z)
  1.  S DDBERR=1  ;Unable to resolve a variable within a reference
  1.  Q %Z
  1. Q(%Z) ;
  1.  S %Z(%Z)="",%Z=$Q(%Z("")) Q $E(%Z,4,$L(%Z)-1)