Return to DDBRU2.m CVS log

Up to [Coherent Logic Development] / freem_fileman / USER

Annotation of freem_fileman/USER/DDBRU2.m, revision 1.1

1.1     ! snw         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)