DDBRU2 ;SFISC/DCL-BROWSE LOCAL OR GLOBAL ARRAY DDBROOT DESCENDANTS ;2AUG2004
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;Per VA Directive 6402, this routine should not be modified.
;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
;;Licensed under the terms of the Apache License, Version 2.0.
;
Q
EN N DDBNCC G CNTNU
ROOT(DDBNCC,DDBRTOP,DDBRBOT) ; Browse Array Root Descendants ; DDBNCC node count check (default=1000)
CNTNU K ^TMP("DDBARD",$J),^TMP("DDBARDL",$J)
;W !!,"Enter Root> " R DDBROOT W !!
;I DDBROOT="^"!(DDBROOT="") Q
D ARSEL
I $O(^TMP("DDBARDL",$J,""))']"" Q
N DDBARDX,N,X
S DDBARDX="",DDBNCC=$G(DDBNCC,1000)
F S DDBARDX=$O(^TMP("DDBARDL",$J,DDBARDX)) Q:DDBARDX="" S X=^(DDBARDX) D
.S N=$O(^TMP("DDBARD",$J,""),-1)+1
.S ^TMP("DDBARDL",$J,DDBARDX)=$NA(^TMP("DDBARD",$J,N))
.W !,"...loading ",DDBARDX
.D BLD(DDBNCC,X,N)
.Q
W !,"...building ""Current List"" tables"
D DOCLIST^DDBR("^TMP(""DDBARDL"",$J)","",$G(DDBRTOP),$G(DDBRBOT))
END K ^TMP("DDBARD",$J),^TMP("DDBARDL",$J)
Q
;
BLD(DDBNCC,DDBROOT,DDBN) ;build structures
N DDBMAXL,DDBR1X
S DDBMAXL=$G(DDBMAXL,255)
S DDBNCC=$G(DDBNCC,1000)
S DDBR1X=$$OREF^DIQGU(DDBROOT)
N DDBR1,DDBR1A,DDBR1B,DDBR1I,DDBR1Q,DDBI,DDBII,DDBX,DDBX1,DDBX1L,DDBX2,DDBX2L,DDBX3,DDBX3L,DDBXT
S DDBR1A=$$OREF^DIQGU($NA(@$$CREF^DIQGU(DDBR1X))),DDBR1Q=""""""
I $L(DDBR1A,",")>1,$P(DDBR1A,",",$L(DDBR1A,","))]"" S DDBR1Q=$P(DDBR1A,",",$L(DDBR1A,",")),$P(DDBR1A,",",$L(DDBR1A,","))=""
S DDBR1=DDBR1A_DDBR1Q_")",DDBR1B=$L(DDBR1A)+1,DDBX2=" = ",DDBX2L=$L(DDBX2),DDBII=0
F DDBI=1:1 S DDBR1=$Q(@DDBR1) Q:$P(DDBR1,DDBR1A)]""!(DDBR1="") D Q:DDBII
.I '(DDBI#DDBNCC) D
..W $C(7),!,DDBROOT,!,"Node count: ",DDBI,!!,"Do you wish to continue //Yes "
..R DDBX:$G(DTIME,300) W !!
..I DDBX=""!($TR($E(DDBX),"y","Y")="Y") Q
..S DDBII=1
..Q
.S DDBX1=DDBR1
.S DDBX3=@DDBR1
.S DDBX1L=$L(DDBX1),DDBX3L=$L(DDBX3)
.S DDBXT=DDBX1L+DDBX2L+DDBX3L
.I DDBXT'>DDBMAXL S ^TMP("DDBARD",$J,DDBN,DDBI)=DDBX1_DDBX2_DDBX3 Q
.I DDBX1L+DDBX2L'>DDBMAXL D Q
..S ^TMP("DDBARD",$J,DDBN,DDBI)=DDBX1_DDBX2_$E(DDBX3,1,DDBMAXL-(DDBX1L+DDBX2L))
..S DDBI=DDBI+1
..S ^TMP("DDBARD",$J,DDBN,DDBI)=$E(DDBX3,(DDBMAXL-(DDBX1L+DDBX2L)+1),DDBMAXL)
..Q
.Q
Q
;
ARSEL ; Array Root Select
N DDBERR,DDBRLVD,X,Y
W !!
SEL R !,"Select Root> ",X:$G(DTIME,300)
I X="" Q
I X="^" K ^TMP("DDBARDL",$J) Q
I $E(X)="?" D HLP G SEL
I X="^TMP"!(X="^TMP(")!($E(X,1,14)="^TMP(""DDBARDL""") D HLP G SEL
S Y=$$OREF^DIQGU(X),DDBERR=0,Y=$$R(Y) I DDBERR W $C(7)," ...INVALID",!!,"'",X,"' CAN NOT BE RESOLVED",! G SEL
S DDBRLVD=$$CREF^DIQGU(Y)
S Y=$$CREF^DIQGU(X)
I $D(@Y)'>9 S Y=$X W $C(7)," ...INVALID",!!,"'",X,"' HAS NO DESCENDANTS",! G SEL
I DDBRLVD'=Y S X=X_" ["_DDBRLVD_"]"
S ^TMP("DDBARDL",$J,X_" | DESCENDANTS |")=Y
G SEL
;
HLP ;
W !!,"Enter a valid local or global array root"
W !,"Can not be ^TMP, ^TMP( or ^TMP(""DDBARDL""",!
Q
;
R(%R) ;
N %C,%F,%G,%I,%R1,%R2
S %R1=$P(%R,"(")_"("
I $E(%R1)="^" S %R2=$E($P(%R1,"("),2,99) D Q:$G(DDBERR) %R
.I $L(%R2)'>0 S DDBERR=1 Q
.I %R2="%" Q
.I $E(%R2)="%" D Q
..I $E(%R2,2,99)?.E1P.E S DDBERR=1 Q
..Q
.I %R2?1N.E S DDBERR=1 Q
.I %R2?.E1P.E S DDBERR=1 Q
.Q
.;I %R2'="%"&(%R2'?.A) S DDBERR=1 Q %R
I $E(%R1)'="^" S %R2=$P(%R1,"(") D Q:$G(DDBERR) %R
.I $L(%R2)'>0 S DDBERR=1 Q
.I %R2="%" Q
.I $E(%R2)="%" D Q
..I $E(%R2,2,99)?.E1P.E S DDBERR=1 Q
..Q
.I %R2?1N.E S DDBERR=1 Q
.I %R2?.E1P.E S DDBERR=1 Q
.Q
.;,$E(%R1)'="%",$E(%R1)'?.A S DDBERR=1 Q %R
I $E(%R1)="^" S %R2=$P($Q(@(%R1_""""")")),"(")_"(" S:$P(%R2,"(")]"" %R1=%R2
S %R2=$P($E(%R,1,($L(%R)-($E(%R,$L(%R))=")"))),"(",2,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
.S %G=$$S(%G),$P(%R2,",",%F,%I)=%G,%F=%F+$L(%G,","),%I=%F-1,%C=%C+($L(%G,",")-1)
.Q
S:'DDBERR DDBERR=%F'=%C
Q %R1_%R2
S(%Z) ;
I $G(%Z)']"" Q ""
I $E(%Z)'="""",$L(%Z,"E")=2,+$P(%Z,"E")=$P(%Z,"E"),+$P(%Z,"E",2)=$P(%Z,"E",2) Q +%Z
I +%Z=%Z Q %Z
I $E(%Z)?1N,+%Z'=%Z S DDBERR=1 Q %Z
I %Z="""""" Q ""
I $E(%Z)="""" Q %Z
I $E(%Z)'?1A,"%$+@"'[$E(%Z) S DDBERR=1 Q %Z
I "+$"[$E(%Z) X "S %Z="_%Z Q $$Q(%Z)
I $D(@%Z) Q $$Q(@%Z)
S DDBERR=1 ;Unable to resolve a variable within a reference
Q %Z
Q(%Z) ;
S %Z(%Z)="",%Z=$Q(%Z("")) Q $E(%Z,4,$L(%Z)-1)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDBRU2 4511 printed Apr 09, 2024@21:45:42 Page 2
DDBRU2 ;SFISC/DCL-BROWSE LOCAL OR GLOBAL ARRAY DDBROOT DESCENDANTS ;2AUG2004
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
+4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
+5 ;;Licensed under the terms of the Apache License, Version 2.0.
+6 ;
+7 QUIT
EN NEW DDBNCC
GOTO CNTNU
ROOT(DDBNCC,DDBRTOP,DDBRBOT) ; Browse Array Root Descendants ; DDBNCC node count check (default=1000)
CNTNU KILL ^TMP("DDBARD",$JOB),^TMP("DDBARDL",$JOB)
+1 ;W !!,"Enter Root> " R DDBROOT W !!
+2 ;I DDBROOT="^"!(DDBROOT="") Q
+3 DO ARSEL
+4 IF $ORDER(^TMP("DDBARDL",$JOB,""))']""
QUIT
+5 NEW DDBARDX,N,X
+6 SET DDBARDX=""
SET DDBNCC=$GET(DDBNCC,1000)
+7 FOR
SET DDBARDX=$ORDER(^TMP("DDBARDL",$JOB,DDBARDX))
if DDBARDX=""
QUIT
SET X=^(DDBARDX)
Begin DoDot:1
+8 SET N=$ORDER(^TMP("DDBARD",$JOB,""),-1)+1
+9 SET ^TMP("DDBARDL",$JOB,DDBARDX)=$NAME(^TMP("DDBARD",$JOB,N))
+10 WRITE !,"...loading ",DDBARDX
+11 DO BLD(DDBNCC,X,N)
+12 QUIT
End DoDot:1
+13 WRITE !,"...building ""Current List"" tables"
+14 DO DOCLIST^DDBR("^TMP(""DDBARDL"",$J)","",$GET(DDBRTOP),$GET(DDBRBOT))
END KILL ^TMP("DDBARD",$JOB),^TMP("DDBARDL",$JOB)
+1 QUIT
+2 ;
BLD(DDBNCC,DDBROOT,DDBN) ;build structures
+1 NEW DDBMAXL,DDBR1X
+2 SET DDBMAXL=$GET(DDBMAXL,255)
+3 SET DDBNCC=$GET(DDBNCC,1000)
+4 SET DDBR1X=$$OREF^DIQGU(DDBROOT)
+5 NEW DDBR1,DDBR1A,DDBR1B,DDBR1I,DDBR1Q,DDBI,DDBII,DDBX,DDBX1,DDBX1L,DDBX2,DDBX2L,DDBX3,DDBX3L,DDBXT
+6 SET DDBR1A=$$OREF^DIQGU($NAME(@$$CREF^DIQGU(DDBR1X)))
SET DDBR1Q=""""""
+7 IF $LENGTH(DDBR1A,",")>1
IF $PIECE(DDBR1A,",",$LENGTH(DDBR1A,","))]""
SET DDBR1Q=$PIECE(DDBR1A,",",$LENGTH(DDBR1A,","))
SET $PIECE(DDBR1A,",",$LENGTH(DDBR1A,","))=""
+8 SET DDBR1=DDBR1A_DDBR1Q_")"
SET DDBR1B=$LENGTH(DDBR1A)+1
SET DDBX2=" = "
SET DDBX2L=$LENGTH(DDBX2)
SET DDBII=0
+9 FOR DDBI=1:1
SET DDBR1=$QUERY(@DDBR1)
if $PIECE(DDBR1,DDBR1A)]""!(DDBR1="")
QUIT
Begin DoDot:1
+10 IF '(DDBI#DDBNCC)
Begin DoDot:2
+11 WRITE $CHAR(7),!,DDBROOT,!,"Node count: ",DDBI,!!,"Do you wish to continue //Yes "
+12 READ DDBX:$GET(DTIME,300)
WRITE !!
+13 IF DDBX=""!($TRANSLATE($EXTRACT(DDBX),"y","Y")="Y")
QUIT
+14 SET DDBII=1
+15 QUIT
End DoDot:2
+16 SET DDBX1=DDBR1
+17 SET DDBX3=@DDBR1
+18 SET DDBX1L=$LENGTH(DDBX1)
SET DDBX3L=$LENGTH(DDBX3)
+19 SET DDBXT=DDBX1L+DDBX2L+DDBX3L
+20 IF DDBXT'>DDBMAXL
SET ^TMP("DDBARD",$JOB,DDBN,DDBI)=DDBX1_DDBX2_DDBX3
QUIT
+21 IF DDBX1L+DDBX2L'>DDBMAXL
Begin DoDot:2
+22 SET ^TMP("DDBARD",$JOB,DDBN,DDBI)=DDBX1_DDBX2_$EXTRACT(DDBX3,1,DDBMAXL-(DDBX1L+DDBX2L))
+23 SET DDBI=DDBI+1
+24 SET ^TMP("DDBARD",$JOB,DDBN,DDBI)=$EXTRACT(DDBX3,(DDBMAXL-(DDBX1L+DDBX2L)+1),DDBMAXL)
+25 QUIT
End DoDot:2
QUIT
+26 QUIT
End DoDot:1
if DDBII
QUIT
+27 QUIT
+28 ;
ARSEL ; Array Root Select
+1 NEW DDBERR,DDBRLVD,X,Y
+2 WRITE !!
SEL READ !,"Select Root> ",X:$GET(DTIME,300)
+1 IF X=""
QUIT
+2 IF X="^"
KILL ^TMP("DDBARDL",$JOB)
QUIT
+3 IF $EXTRACT(X)="?"
DO HLP
GOTO SEL
+4 IF X="^TMP"!(X="^TMP(")!($EXTRACT(X,1,14)="^TMP(""DDBARDL""")
DO HLP
GOTO SEL
+5 SET Y=$$OREF^DIQGU(X)
SET DDBERR=0
SET Y=$$R(Y)
IF DDBERR
WRITE $CHAR(7)," ...INVALID",!!,"'",X,"' CAN NOT BE RESOLVED",!
GOTO SEL
+6 SET DDBRLVD=$$CREF^DIQGU(Y)
+7 SET Y=$$CREF^DIQGU(X)
+8 IF $DATA(@Y)'>9
SET Y=$X
WRITE $CHAR(7)," ...INVALID",!!,"'",X,"' HAS NO DESCENDANTS",!
GOTO SEL
+9 IF DDBRLVD'=Y
SET X=X_" ["_DDBRLVD_"]"
+10 SET ^TMP("DDBARDL",$JOB,X_" | DESCENDANTS |")=Y
+11 GOTO SEL
+12 ;
HLP ;
+1 WRITE !!,"Enter a valid local or global array root"
+2 WRITE !,"Can not be ^TMP, ^TMP( or ^TMP(""DDBARDL""",!
+3 QUIT
+4 ;
R(%R) ;
+1 NEW %C,%F,%G,%I,%R1,%R2
+2 SET %R1=$PIECE(%R,"(")_"("
+3 IF $EXTRACT(%R1)="^"
SET %R2=$EXTRACT($PIECE(%R1,"("),2,99)
Begin DoDot:1
+4 IF $LENGTH(%R2)'>0
SET DDBERR=1
QUIT
+5 IF %R2="%"
QUIT
+6 IF $EXTRACT(%R2)="%"
Begin DoDot:2
+7 IF $EXTRACT(%R2,2,99)?.E1P.E
SET DDBERR=1
QUIT
+8 QUIT
End DoDot:2
QUIT
+9 IF %R2?1N.E
SET DDBERR=1
QUIT
+10 IF %R2?.E1P.E
SET DDBERR=1
QUIT
+11 QUIT
+12 ;I %R2'="%"&(%R2'?.A) S DDBERR=1 Q %R
End DoDot:1
if $GET(DDBERR)
QUIT %R
+13 IF $EXTRACT(%R1)'="^"
SET %R2=$PIECE(%R1,"(")
Begin DoDot:1
+14 IF $LENGTH(%R2)'>0
SET DDBERR=1
QUIT
+15 IF %R2="%"
QUIT
+16 IF $EXTRACT(%R2)="%"
Begin DoDot:2
+17 IF $EXTRACT(%R2,2,99)?.E1P.E
SET DDBERR=1
QUIT
+18 QUIT
End DoDot:2
QUIT
+19 IF %R2?1N.E
SET DDBERR=1
QUIT
+20 IF %R2?.E1P.E
SET DDBERR=1
QUIT
+21 QUIT
+22 ;,$E(%R1)'="%",$E(%R1)'?.A S DDBERR=1 Q %R
End DoDot:1
if $GET(DDBERR)
QUIT %R
+23 IF $EXTRACT(%R1)="^"
SET %R2=$PIECE($QUERY(@(%R1_""""")")),"(")_"("
if $PIECE(%R2,"(")]""
SET %R1=%R2
+24 SET %R2=$PIECE($EXTRACT(%R,1,($LENGTH(%R)-($EXTRACT(%R,$LENGTH(%R))=")"))),"(",2,99)
+25 SET %C=$LENGTH(%R2,",")
SET %F=1
FOR %I=1:1
if %I'<%C
QUIT
SET %G=$PIECE(%R2,",",%F,%I)
if %G=""
QUIT
IF ($LENGTH(%G,"(")=$LENGTH(%G,")")&($LENGTH(%G,"""")#2))!(($LENGTH(%G,"""")#2)&($EXTRACT(%G)="""")&($EXTRACT(%G,$LENGTH(%G))=""""))
Begin DoDot:1
+26 SET %G=$$S(%G)
SET $PIECE(%R2,",",%F,%I)=%G
SET %F=%F+$LENGTH(%G,",")
SET %I=%F-1
SET %C=%C+($LENGTH(%G,",")-1)
+27 QUIT
End DoDot:1
+28 if 'DDBERR
SET DDBERR=%F'=%C
+29 QUIT %R1_%R2
S(%Z) ;
+1 IF $GET(%Z)']""
QUIT ""
+2 IF $EXTRACT(%Z)'=""""
IF $LENGTH(%Z,"E")=2
IF +$PIECE(%Z,"E")=$PIECE(%Z,"E")
IF +$PIECE(%Z,"E",2)=$PIECE(%Z,"E",2)
QUIT +%Z
+3 IF +%Z=%Z
QUIT %Z
+4 IF $EXTRACT(%Z)?1N
IF +%Z'=%Z
SET DDBERR=1
QUIT %Z
+5 IF %Z=""""""
QUIT ""
+6 IF $EXTRACT(%Z)=""""
QUIT %Z
+7 IF $EXTRACT(%Z)'?1A
IF "%$+@"'[$EXTRACT(%Z)
SET DDBERR=1
QUIT %Z
+8 IF "+$"[$EXTRACT(%Z)
XECUTE "S %Z="_%Z
QUIT $$Q(%Z)
+9 IF $DATA(@%Z)
QUIT $$Q(@%Z)
+10 ;Unable to resolve a variable within a reference
SET DDBERR=1
+11 QUIT %Z
Q(%Z) ;
+1 SET %Z(%Z)=""
SET %Z=$QUERY(%Z(""))
QUIT $EXTRACT(%Z,4,$LENGTH(%Z)-1)
