source: WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DDBRU2.m@ 1450

Last change on this file since 1450 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 4.1 KB
Line 
1DDBRU2 ;SFISC/DCL-BROWSE LOCAL OR GLOBAL ARRAY DDBROOT DESCENDANTS ;12:54 PM 20 Nov 1994
2 ;;22.0;VA FileMan;;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5EN N DDBNCC G CNTNU
6ROOT(DDBNCC,DDBRTOP,DDBRBOT) ; Browse Array Root Descendants ; DDBNCC node count check (default=1000)
7CNTNU 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))
22END K ^TMP("DDBARD",$J),^TMP("DDBARDL",$J)
23 Q
24 ;
25BLD(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 ;
54ARSEL ; Array Root Select
55 N DDBERR,DDBRLVD,X,Y
56 W !!
57SEL 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 ;
70HLP ;
71 W !!,"Enter a valid local or global array root"
72 W !,"Can not be ^TMP, ^TMP( or ^TMP(""DDBARDL""",!
73 Q
74R(%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
104S(%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
116Q(%Z) ;
117 S %Z(%Z)="",%Z=$Q(%Z("")) Q $E(%Z,4,$L(%Z)-1)
Note: See TracBrowser for help on using the repository browser.