- DIRQ ;SFISC/XAK-READER-MAID END ;7/11/94 14:34
- ;;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.
- ;
- K:$D(%G) DIR("B")
- K DIR0("L")
- Q
- DA I DA'=+$P(DA,"E") K DA Q
- S (X,Y)=%B1,DA(0)=DA
- F %=0:1 Q:'$D(^DD(X,0,"UP")) S X=^("UP"),%P=$O(^DD(X,"SB",Y,0)),%(%)=""""_$P($P(^DD(X,%P,0),U,4),";")_""",",Y=X
- S %(%)=$S($D(^DIC(X,0,"GL")):^("GL"),1:"") G Q:%(%)=""
- S %G="" F %=%:-1:0 G GQ:'$D(DA(%)) S %G=%G_%(%)_DA(%)_","
- S %P=$P(%B3,U,4),%=$P(%P,";"),%G=%G_""""_%_""")" G GQ:'$D(@%G)
- S %G=$P(%P,";",2),Y=$S(%G:$P(^(%),U,%G),1:$E(^(%),+$P(%G,"E",2),$P(%G,",",2))) G GQ:Y=""
- S %G=Y,C=$P(^DD(%B1,%B2,0),U,2) D Y^DIQ S DIR("B")=Y G Q
- GQ K %G
- Q K %,%P,X,Y,DA(0) Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIRQ 927 printed Mar 13, 2025@21:58:48 Page 2
- DIRQ ;SFISC/XAK-READER-MAID END ;7/11/94 14:34
- +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 if $DATA(%G)
- KILL DIR("B")
- +8 KILL DIR0("L")
- +9 QUIT
- DA IF DA'=+$PIECE(DA,"E")
- KILL DA
- QUIT
- +1 SET (X,Y)=%B1
- SET DA(0)=DA
- +2 FOR %=0:1
- if '$DATA(^DD(X,0,"UP"))
- QUIT
- SET X=^("UP")
- SET %P=$ORDER(^DD(X,"SB",Y,0))
- SET %(%)=""""_$PIECE($PIECE(^DD(X,%P,0),U,4),";")_""","
- SET Y=X
- +3 SET %(%)=$SELECT($DATA(^DIC(X,0,"GL")):^("GL"),1:"")
- if %(%)=""
- GOTO Q
- +4 SET %G=""
- FOR %=%:-1:0
- if '$DATA(DA(%))
- GOTO GQ
- SET %G=%G_%(%)_DA(%)_","
- +5 SET %P=$PIECE(%B3,U,4)
- SET %=$PIECE(%P,";")
- SET %G=%G_""""_%_""")"
- if '$DATA(@%G)
- GOTO GQ
- +6 SET %G=$PIECE(%P,";",2)
- SET Y=$SELECT(%G:$PIECE(^(%),U,%G),1:$EXTRACT(^(%),+$PIECE(%G,"E",2),$PIECE(%G,",",2)))
- if Y=""
- GOTO GQ
- +7 SET %G=Y
- SET C=$PIECE(^DD(%B1,%B2,0),U,2)
- DO Y^DIQ
- SET DIR("B")=Y
- GOTO Q
- GQ KILL %G
- Q KILL %,%P,X,Y,DA(0)
- QUIT
