Return to DDBRU2.m CVS log

Up to [Coherent Logic Development] / freem_fileman

Annotation of freem_fileman/DDBRU2.m, revision 1.1.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)