DDSFO.m

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 ---DDSFO   1007     printed  Apr 09, 2024@21:54:04                                                                                                                                                                                                       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