DIQGU0 ;SFISC/DCL-DATA RETRIVIAL UTILITY PROGRAM ;02:42 PM 24 Aug 1993
;;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.
;
R(%R) ;
N %C,%F,%G,%I,%R1,%R2
S %R1=$P(%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:%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))="""")) S %G=$$S(%G),$P(%R2,",",%F,%I)=%G,%F=%F+$L(%G,","),%I=%F-1
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 %Z="""""" Q ""
I $E(%Z)'?1A,"%$+@"'[$E(%Z) Q %Z
I "+$"[$E(%Z) X "S %Z="_%Z Q $$Q(%Z)
I $D(@%Z) Q $$Q(@%Z)
Q %Z
Q(%Z) ;
S %Z(%Z)="",%Z=$Q(%Z("")) Q $E(%Z,4,$L(%Z)-1)
DDLST(DDN,ATRN,FL) ;
N X,Y S:$D(^DD(DDN)) ATRN(DDN)="" S FL=+$G(FL)
D S X=0 F S X=$O(^DD(DDN,"SB",X)) Q:X'>0 S ATRN(X)="" D D DDLST(X,.ATRN,FL)
.I 'FL S Y="" F S Y=$O(^DD(DDN,"B",Y)) Q:Y="" S ATRN(Y,DDN)=$O(^(Y,""))
.Q
Q
DDN(ATN,F) ;
N DNA,DDN,X,Y S X="$$$ NO SUCH ATTRIBUTE $$$"
Q:$G(ATN)']"" X
D DDLST(+$G(F),.DNA,1)
S DDN="" F S DDN=$O(DNA(DDN)) Q:DDN="" D Q:X
.S Y="" F S Y=$O(^DD(DDN,"B",Y)) Q:Y="" I Y=ATN S X=DDN_"^"_$O(^DD(DDN,"B",Y,"")) Q
.Q
I '$G(F),$E(X,1,6)="$$$ NO" Q $$DDN(ATN,1)
Q X
DDLST2(DDN,ATRN,FL) ;
N X,Y S:$D(^DD(DDN)) ATRN(DDN)="" S FL='$D(FL)
S X=0 F S X=$O(^DD(DDN,"SB",X)) Q:X'>0 D
.I FL S ATRN(X)="",Y=0 F S Y=$O(^DD(DDN,Y)) Q:Y'>0 S ATRN(Y,DDN)=$P($G(^(Y,0)),"^")
.D DDLST2(X,.ATRN)
.Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIQGU0 1891 printed Apr 09, 2024@21:50:15 Page 2
DIQGU0 ;SFISC/DCL-DATA RETRIVIAL UTILITY PROGRAM ;02:42 PM 24 Aug 1993
+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 ;
R(%R) ;
+1 NEW %C,%F,%G,%I,%R1,%R2
+2 SET %R1=$PIECE(%R,"(")_"("
IF $EXTRACT(%R1)="^"
SET %R2=$PIECE($QUERY(@(%R1_""""")")),"(")_"("
if $PIECE(%R2,"(")]""
SET %R1=%R2
+3 SET %R2=$PIECE($EXTRACT(%R,1,($LENGTH(%R)-($EXTRACT(%R,$LENGTH(%R))=")"))),"(",2,99)
+4 SET %C=$LENGTH(%R2,",")
SET %F=1
FOR %I=1:1:%C
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))=""""))
SET %G=$$S(%G)
SET $PIECE(%R2,",",%F,%I)=%G
SET %F=%F+$LENGTH(%G,",")
SET %I=%F-1
+5 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 %Z=""""""
QUIT ""
+5 IF $EXTRACT(%Z)'?1A
IF "%$+@"'[$EXTRACT(%Z)
QUIT %Z
+6 IF "+$"[$EXTRACT(%Z)
XECUTE "S %Z="_%Z
QUIT $$Q(%Z)
+7 IF $DATA(@%Z)
QUIT $$Q(@%Z)
+8 QUIT %Z
Q(%Z) ;
+1 SET %Z(%Z)=""
SET %Z=$QUERY(%Z(""))
QUIT $EXTRACT(%Z,4,$LENGTH(%Z)-1)
DDLST(DDN,ATRN,FL) ;
+1 NEW X,Y
if $DATA(^DD(DDN))
SET ATRN(DDN)=""
SET FL=+$GET(FL)
+2 Begin DoDot:1
+3 IF 'FL
SET Y=""
FOR
SET Y=$ORDER(^DD(DDN,"B",Y))
if Y=""
QUIT
SET ATRN(Y,DDN)=$ORDER(^(Y,""))
+4 QUIT
End DoDot:1
SET X=0
FOR
SET X=$ORDER(^DD(DDN,"SB",X))
if X'>0
QUIT
SET ATRN(X)=""
Begin DoDot:1
End DoDot:1
DO DDLST(X,.ATRN,FL)
+5 QUIT
DDN(ATN,F) ;
+1 NEW DNA,DDN,X,Y
SET X="$$$ NO SUCH ATTRIBUTE $$$"
+2 if $GET(ATN)']""
QUIT X
+3 DO DDLST(+$GET(F),.DNA,1)
+4 SET DDN=""
FOR
SET DDN=$ORDER(DNA(DDN))
if DDN=""
QUIT
Begin DoDot:1
+5 SET Y=""
FOR
SET Y=$ORDER(^DD(DDN,"B",Y))
if Y=""
QUIT
IF Y=ATN
SET X=DDN_"^"_$ORDER(^DD(DDN,"B",Y,""))
QUIT
+6 QUIT
End DoDot:1
if X
QUIT
+7 IF '$GET(F)
IF $EXTRACT(X,1,6)="$$$ NO"
QUIT $$DDN(ATN,1)
+8 QUIT X
DDLST2(DDN,ATRN,FL) ;
+1 NEW X,Y
if $DATA(^DD(DDN))
SET ATRN(DDN)=""
SET FL='$DATA(FL)
+2 SET X=0
FOR
SET X=$ORDER(^DD(DDN,"SB",X))
if X'>0
QUIT
Begin DoDot:1
+3 IF FL
SET ATRN(X)=""
SET Y=0
FOR
SET Y=$ORDER(^DD(DDN,Y))
if Y'>0
QUIT
SET ATRN(Y,DDN)=$PIECE($GET(^(Y,0)),"^")
+4 DO DDLST2(X,.ATRN)
+5 QUIT
End DoDot:1
+6 QUIT
