BDGDDU.m

BDGDDU ; IHS/ANMC/LJF - PIMS DD UTILITIES ;

 ;;5.3;PIMS;;APR 26, 2002

 ;

GROUP ;EP; list all fields in selected file with IHS under GROUP

 NEW FILE,FLD,DIR,Y,X,DIRUT

 S DIR(0)="NO^1:9999999.99",DIR("A")="Select FILE NUMBER"

 D ^DIR Q:Y<1  S FILE=+Y

 ;

 S FLD=0

 F  S FLD=$O(^DD(FILE,FLD)) Q:'FLD  D

 . S X=0 F  S X=$O(^DD(FILE,FLD,20,X)) Q:'X  D

 .. I $G(^DD(FILE,FLD,20,X,0))="IHS" D

 ... W !,FLD,?15,$P(^DD(FILE,FLD,0),U)

 .. I +$P(^DD(FILE,FLD,0),U,2) D SUBFILE(FILE,FLD)  ;multiple

 Q

 ;

SUBFILE(FILE,FLD) ; find subfile fields with IHS under GROUP

 NEW SUBFILE,SUBFLD,X

 S SUBFILE=+$P(^DD(FILE,FLD,0),U,2),SUBFLD=0

 F  S SUBFLD=$O(^DD(SUBFILE,SUBFLD)) Q:'SUBFLD  D

 . S X=0 F  S X=$O(^DD(SUBFILE,SUBFLD,20,X)) Q:'X  D

 .. I $G(^DD(SUBFILE,SUBFLD,20,X,0))="IHS" D

 ... W !?5,SUBFLD,?20,$P(^DD(SUBFILE,SUBFLD,0),U)

 .. I +$P(^DD(SUBFILE,SUBFLD,0),U,2) D SUBFILE(SUBFILE,SUBFLD)

 Q

BDGDDU    ; IHS/ANMC/LJF - PIMS DD UTILITIES ;

 +1       ;;5.3;PIMS;;APR 26, 2002

 +2       ;

GROUP     ;EP; list all fields in selected file with IHS under GROUP

 +1        NEW FILE,FLD,DIR,Y,X,DIRUT

 +2        SET DIR(0)="NO^1:9999999.99"

           SET DIR("A")="Select FILE NUMBER"

 +3        DO ^DIR

           IF Y<1

               QUIT 

           SET FILE=+Y

 +4       ;

 +5        SET FLD=0

 +6        FOR 

               SET FLD=$ORDER(^DD(FILE,FLD))

               IF 'FLD

                   QUIT 

               Begin DoDot:1

 +7                SET X=0

                   FOR 

                       SET X=$ORDER(^DD(FILE,FLD,20,X))

                       IF 'X

                           QUIT 

                       Begin DoDot:2

 +8                        IF $GET(^DD(FILE,FLD,20,X,0))="IHS"

                               Begin DoDot:3

 +9                                WRITE !,FLD,?15,$PIECE(^DD(FILE,FLD,0),U)

                               End DoDot:3

 +10      ;multiple

                           IF +$PIECE(^DD(FILE,FLD,0),U,2)

                               DO SUBFILE(FILE,FLD)

                       End DoDot:2

               End DoDot:1

 +11       QUIT 

 +12      ;

SUBFILE(FILE,FLD) ; find subfile fields with IHS under GROUP

 +1        NEW SUBFILE,SUBFLD,X

 +2        SET SUBFILE=+$PIECE(^DD(FILE,FLD,0),U,2)

           SET SUBFLD=0

 +3        FOR 

               SET SUBFLD=$ORDER(^DD(SUBFILE,SUBFLD))

               IF 'SUBFLD

                   QUIT 

               Begin DoDot:1

 +4                SET X=0

                   FOR 

                       SET X=$ORDER(^DD(SUBFILE,SUBFLD,20,X))

                       IF 'X

                           QUIT 

                       Begin DoDot:2

 +5                        IF $GET(^DD(SUBFILE,SUBFLD,20,X,0))="IHS"

                               Begin DoDot:3

 +6                                WRITE !?5,SUBFLD,?20,$PIECE(^DD(SUBFILE,SUBFLD,0),U)

                               End DoDot:3

 +7                        IF +$PIECE(^DD(SUBFILE,SUBFLD,0),U,2)

                               DO SUBFILE(SUBFILE,SUBFLD)

                       End DoDot:2

               End DoDot:1

 +8        QUIT