DDSFO ;SFISC/MKO-FORM ONLY FIELDS ;1:52 PM 19 Jun 1998
;;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.
;
DIR ;Setup input variables to DIR
N I,J
S DIR(0)=$P(DDSO(20),U)_$P(DDSO(20),U,2,3)
S:DIR(0)?1"DD".E DIR(0)=$P(DIR(0),U,2,999)
S:$P(DIR(0),U)'["O" $P(DIR(0),U)=$P(DIR(0),U)_"O"
I $P(DIR(0),U)["P",$P($P(DIR(0),U,2),":",2)'["Z" D
. S I=$P(DIR(0),U,2) Q:$P(I,":",2)["Z"
. S $P(I,":",2)=$P(I,":",2)_"Z"
. S $P(DIR(0),U,2)=I
S:$G(^DIST(.404,DDSBK,40,DDO,22))'?."^" $P(DIR(0),U,3)=^(22)
I $D(^DIST(.404,DDSBK,40,DDO,21)) D
. S (I,J)=0
. F S I=$O(^DIST(.404,DDSBK,40,DDO,21,I)) Q:I="" I $D(^(I,0))#2 S J=J+1,DIR("?",J)=^(0)
. I J>0 S DIR("?")=DIR("?",J) K DIR("?",J)
X:$G(^DIST(.404,DDSBK,40,DDO,24))'?."^" ^(24)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDSFO 1007 printed Dec 13, 2024@02:43:19 Page 2
DDSFO ;SFISC/MKO-FORM ONLY FIELDS ;1:52 PM 19 Jun 1998
+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 ;
DIR ;Setup input variables to DIR
+1 NEW I,J
+2 SET DIR(0)=$PIECE(DDSO(20),U)_$PIECE(DDSO(20),U,2,3)
+3 if DIR(0)?1"DD".E
SET DIR(0)=$PIECE(DIR(0),U,2,999)
+4 if $PIECE(DIR(0),U)'["O"
SET $PIECE(DIR(0),U)=$PIECE(DIR(0),U)_"O"
+5 IF $PIECE(DIR(0),U)["P"
IF $PIECE($PIECE(DIR(0),U,2),":",2)'["Z"
Begin DoDot:1
+6 SET I=$PIECE(DIR(0),U,2)
if $PIECE(I,"
QUIT
+7 SET $PIECE(I,":",2)=$PIECE(I,":",2)_"Z"
+8 SET $PIECE(DIR(0),U,2)=I
End DoDot:1
+9 if $GET(^DIST(.404,DDSBK,40,DDO,22))'?."^"
SET $PIECE(DIR(0),U,3)=^(22)
+10 IF $DATA(^DIST(.404,DDSBK,40,DDO,21))
Begin DoDot:1
+11 SET (I,J)=0
+12 FOR
SET I=$ORDER(^DIST(.404,DDSBK,40,DDO,21,I))
if I=""
QUIT
IF $DATA(^(I,0))#2
SET J=J+1
SET DIR("?",J)=^(0)
+13 IF J>0
SET DIR("?")=DIR("?",J)
KILL DIR("?",J)
End DoDot:1
+14 if $GET(^DIST(.404,DDSBK,40,DDO,24))'?."^"
XECUTE ^(24)
+15 QUIT
