Return to DDBRU2.m CVS log

Up to [Coherent Logic Development] / freem_fileman / USER

Restructure repository

    1: DDBRU2	;SFISC/DCL-BROWSE LOCAL OR GLOBAL ARRAY DDBROOT DESCENDANTS;12:54 PM  20 Nov 1994;
    2: 	;;21.0;VA FileMan;;Dec 28, 1994
    3: 	;Per VHA Directive 10-93-142, this routine should not be modified.
    4: 	Q
    5: EN	N DDBNCC G CNTNU
    6: ROOT(DDBNCC,DDBRTOP,DDBRBOT)	; Browse Array Root Descendants ; DDBNCC node count check (default=1000)
    7: CNTNU	K ^TMP("DDBARD",$J),^TMP("DDBARDL",$J)
    8: 	;W !!,"Enter Root> " R DDBROOT W !!
    9: 	;I DDBROOT="^"!(DDBROOT="") Q
   10: 	D ARSEL
   11: 	I $O(^TMP("DDBARDL",$J,""))']"" Q
   12: 	N DDBARDX,N,X
   13: 	S DDBARDX="",DDBNCC=$G(DDBNCC,1000)
   14: 	F  S DDBARDX=$O(^TMP("DDBARDL",$J,DDBARDX)) Q:DDBARDX=""  S X=^(DDBARDX) D
   15: 	.S N=$O(^TMP("DDBARD",$J,""),-1)+1
   16: 	.S ^TMP("DDBARDL",$J,DDBARDX)=$NA(^TMP("DDBARD",$J,N))
   17: 	.W !,"...loading ",DDBARDX
   18: 	.D BLD(DDBNCC,X,N)
   19: 	.Q
   20: 	W !,"...building ""Current List"" tables"
   21: 	D DOCLIST^DDBR("^TMP(""DDBARDL"",$J)","",$G(DDBRTOP),$G(DDBRBOT))
   22: END	K ^TMP("DDBARD",$J),^TMP("DDBARDL",$J)
   23: 	Q
   24: 	;
   25: BLD(DDBNCC,DDBROOT,DDBN)	;build structures
   26: 	N DDBMAXL,DDBR1X
   27: 	S DDBMAXL=$G(DDBMAXL,255)
   28: 	S DDBNCC=$G(DDBNCC,1000)
   29: 	S DDBR1X=$$OREF^DIQGU(DDBROOT)
   30: 	N DDBR1,DDBR1A,DDBR1B,DDBR1I,DDBR1Q,DDBI,DDBII,DDBX,DDBX1,DDBX1L,DDBX2,DDBX2L,DDBX3,DDBX3L,DDBXT
   31: 	S DDBR1A=$$R^%RCR(DDBR1X),DDBR1Q=""""""
   32: 	I $L(DDBR1A,",")>1,$P(DDBR1A,",",$L(DDBR1A,","))]"" S DDBR1Q=$P(DDBR1A,",",$L(DDBR1A,",")),$P(DDBR1A,",",$L(DDBR1A,","))=""
   33: 	S DDBR1=DDBR1A_DDBR1Q_")",DDBR1B=$L(DDBR1A)+1,DDBX2=" = ",DDBX2L=$L(DDBX2),DDBII=0
   34: 	F DDBI=1:1 S DDBR1=$Q(@DDBR1) Q:$P(DDBR1,DDBR1A)]""!(DDBR1="")  D  Q:DDBII
   35: 	.I '(DDBI#DDBNCC) D
   36: 	..W $C(7),!,DDBROOT,!,"Node count: ",DDBI,!!,"Do you wish to continue //Yes  "
   37: 	..R DDBX:$G(DTIME,300) W !!
   38: 	..I DDBX=""!($TR($E(DDBX),"y","Y")="Y") Q
   39: 	..S DDBII=1
   40: 	..Q
   41: 	.S DDBX1=DDBR1
   42: 	.S DDBX3=@DDBR1
   43: 	.S DDBX1L=$L(DDBX1),DDBX3L=$L(DDBX3)
   44: 	.S DDBXT=DDBX1L+DDBX2L+DDBX3L
   45: 	.I DDBXT'>DDBMAXL S ^TMP("DDBARD",$J,DDBN,DDBI)=DDBX1_DDBX2_DDBX3 Q
   46: 	.I DDBX1L+DDBX2L'>DDBMAXL D  Q
   47: 	..S ^TMP("DDBARD",$J,DDBN,DDBI)=DDBX1_DDBX2_$E(DDBX3,1,DDBMAXL-(DDBX1L+DDBX2L))
   48: 	..S DDBI=DDBI+1
   49: 	..S ^TMP("DDBARD",$J,DDBN,DDBI)=$E(DDBX3,(DDBMAXL-(DDBX1L+DDBX2L)+1),DDBMAXL)
   50: 	..Q
   51: 	.Q
   52: 	Q
   53: 	;
   54: ARSEL	; Array Root Select
   55: 	N DDBERR,DDBRLVD,X,Y
   56: 	W !!
   57: SEL	R !,"Select Root> ",X:$G(DTIME,300)
   58: 	I X="" Q
   59: 	I X="^" K ^TMP("DDBARDL",$J) Q
   60: 	I $E(X)="?" D HLP G SEL
   61: 	I X="^TMP"!(X="^TMP(")!($E(X,1,14)="^TMP(""DDBARDL""") D HLP G SEL
   62: 	S Y=$$OREF^DIQGU(X),DDBERR=0,Y=$$R(Y) I DDBERR W $C(7),"  ...INVALID",!!,"'",X,"' CAN NOT BE RESOLVED",! G SEL
   63: 	S DDBRLVD=$$CREF^DIQGU(Y)
   64: 	S Y=$$CREF^DIQGU(X)
   65: 	I $D(@Y)'>9 S Y=$X W $C(7),"  ...INVALID",!!,"'",X,"' HAS NO DESCENDANTS",! G SEL
   66: 	I DDBRLVD'=Y S X=X_" ["_DDBRLVD_"]"
   67: 	S ^TMP("DDBARDL",$J,X_" | DESCENDANTS |")=Y
   68: 	G SEL
   69: 	;
   70: HLP	;
   71: 	W !!,"Enter a valid local or global array root"
   72: 	W !,"Can not be ^TMP, ^TMP( or ^TMP(""DDBARDL""",!
   73: 	Q
   74: R(%R)	;
   75: 	N %C,%F,%G,%I,%R1,%R2
   76: 	S %R1=$P(%R,"(")_"("
   77: 	I $E(%R1)="^" S %R2=$E($P(%R1,"("),2,99) D  Q:$G(DDBERR) %R
   78: 	.I $L(%R2)'>0 S DDBERR=1 Q
   79: 	.I %R2="%" Q
   80: 	.I $E(%R2)="%" D  Q
   81: 	..I $E(%R2,2,99)?.E1P.E S DDBERR=1 Q
   82: 	..Q
   83: 	.I %R2?1N.E S DDBERR=1 Q
   84: 	.I %R2?.E1P.E S DDBERR=1 Q
   85: 	.Q
   86: 	.;I %R2'="%"&(%R2'?.A) S DDBERR=1 Q %R
   87: 	I $E(%R1)'="^" S %R2=$P(%R1,"(") D  Q:$G(DDBERR) %R
   88: 	.I $L(%R2)'>0 S DDBERR=1 Q
   89: 	.I %R2="%" Q
   90: 	.I $E(%R2)="%" D  Q
   91: 	..I $E(%R2,2,99)?.E1P.E S DDBERR=1 Q
   92: 	..Q
   93: 	.I %R2?1N.E S DDBERR=1 Q
   94: 	.I %R2?.E1P.E S DDBERR=1 Q
   95: 	.Q
   96: 	.;,$E(%R1)'="%",$E(%R1)'?.A S DDBERR=1 Q %R
   97: 	I $E(%R1)="^" S %R2=$P($Q(@(%R1_""""")")),"(")_"(" S:$P(%R2,"(")]"" %R1=%R2
   98: 	S %R2=$P($E(%R,1,($L(%R)-($E(%R,$L(%R))=")"))),"(",2,99)
   99: 	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
  100: 	.S %G=$$S(%G),$P(%R2,",",%F,%I)=%G,%F=%F+$L(%G,","),%I=%F-1,%C=%C+($L(%G,",")-1)
  101: 	.Q
  102: 	S DDBERR=%F'=%C
  103: 	Q %R1_%R2
  104: S(%Z)	;
  105: 	I $G(%Z)']"" Q ""
  106: 	I $E(%Z)'="""",$L(%Z,"E")=2,+$P(%Z,"E")=$P(%Z,"E"),+$P(%Z,"E",2)=$P(%Z,"E",2) Q +%Z
  107: 	I +%Z=%Z Q %Z
  108: 	I $E(%Z)?1N,+%Z'=%Z S DDBERR=1 Q %Z
  109: 	I %Z="""""" Q ""
  110: 	I $E(%Z)="""" Q %Z
  111: 	I $E(%Z)'?1A,"%$+@"'[$E(%Z) S DDBERR=1 Q %Z
  112: 	I "+$"[$E(%Z) X "S %Z="_%Z Q $$Q(%Z)
  113: 	I $D(@%Z) Q $$Q(@%Z)
  114: 	S DDBERR=1  ;Unable to resolve a variable within a reference
  115: 	Q %Z
  116: Q(%Z)	;
  117: 	S %Z(%Z)="",%Z=$Q(%Z("")) Q $E(%Z,4,$L(%Z)-1)