- 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 Feb 19, 2025@00:19:56 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
