Routine: BGP4DPEF

BGP4DPEF ; IHS/CMI/LAB - IHS gpra print ;

 ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114

7 ;EP

 S X=""

 D S^BGP4DPED(" ",1,1) D S^BGP4DPED(" ",1,1) ;S X=$P(^BGPPEIJ(BGPIC,0),U,2) D S^BGP4DPED(X,1,1)

 D H1^BGP4PDL1

 D S^BGP4DPED(" ",1,1)

 S BGPCYD=$$V^BGP4DPED(1,BGPRPT,11,29)

 S BGPPRD=$$V^BGP4DPED(2,BGPRPT,11,29)

 S BGPBLD=$$V^BGP4DPED(3,BGPRPT,11,29)

 I $G(BGPSEAT) S X=$P(^DIBT(BGPSEAT,0),U,1)_" Population w/ Pat Ed" D S^BGP4DPED(X,1,1)

 I '$G(BGPSEAT) S X="# User Pop" D S^BGP4DPED(X,1,1)

 S Y=BGPCYD_"^^"_BGPPRD_"^^^"_BGPBLD D S^BGP4DPED(Y,,2)

 D S^BGP4DPED(" ",1,1)

 S X="Goal Setting" D S^BGP4DPED(X,1,1)

 S N=11,P=24 D SETN^BGP4DPED

 S X="# w/goal set" D S^BGP4DPED(X,1,1)

 D H2^BGP4PDL1

 D S^BGP4DPED(" ",1,1)

 K BGPPROVS

 S N=16 D SETNM^BGP4DPEQ

 K BGPX

 S BGPCNT=0

 S X="",C=0 F  S X=$O(BGPPROVS(X)) Q:X=""  S Y="" F  S Y=$O(BGPPROVS(X,Y)) Q:Y=""  S C=C+1 S BGPX((9999999-$P(BGPPROVS(X,Y),U,1)),C)=X_U_Y_U_BGPPROVS(X,Y)

 S BGP1=0 F  S BGP1=$O(BGPX(BGP1)) Q:BGP1'=+BGP1!(BGPCNT>15)  D

 .S BGPCNT=BGPCNT+1 S BGP2=0 F  S BGP2=$O(BGPX(BGP1,BGP2)) Q:BGP2'=+BGP2  D

 ..S X=BGPCNT_".  "_$P(BGPX(BGP1,BGP2),U,2) D S^BGP4DPED(X,1,1)

 ..S BGPCYN=$P(BGPX(BGP1,BGP2),U,3)

 ..S BGPPRN=$P(BGPX(BGP1,BGP2),U,4)

 ..S BGPBLN=$P(BGPX(BGP1,BGP2),U,5)

 ..S BGPCYP=$P(BGPX(BGP1,BGP2),U,6)

 ..S BGPPRP=$P(BGPX(BGP1,BGP2),U,7)

 ..S BGPBLP=$P(BGPX(BGP1,BGP2),U,8)

 ..D H2^BGP4PDL1

NOTSET ;

 D S^BGP4DPED(" ",1,1)

 S BGPCYD=$$V^BGP4DPED(1,BGPRPT,11,29)

 S BGPPRD=$$V^BGP4DPED(2,BGPRPT,11,29)

 S BGPBLD=$$V^BGP4DPED(3,BGPRPT,11,29)

 D S^BGP4DPED(" ",1,1)

 S N=11,P=25 D SETN^BGP4DPED

 S X="# w/goal not set" D S^BGP4DPED(X,1,1)

 D H2^BGP4PDL1

 D S^BGP4DPED(" ",1,1)

 K BGPPROVS

 S N=17 D SETNM^BGP4DPEQ

 K BGPX

 S BGPCNT=0

 S X="",C=0 F  S X=$O(BGPPROVS(X)) Q:X=""  S Y="" F  S Y=$O(BGPPROVS(X,Y)) Q:Y=""  S C=C+1 S BGPX((9999999-$P(BGPPROVS(X,Y),U,1)),C)=X_U_Y_U_BGPPROVS(X,Y)

 S BGP1=0 F  S BGP1=$O(BGPX(BGP1)) Q:BGP1'=+BGP1!(BGPCNT>15)  D

 .S BGPCNT=BGPCNT+1 S BGP2=0 F  S BGP2=$O(BGPX(BGP1,BGP2)) Q:BGP2'=+BGP2  D

 ..S X=BGPCNT_".  "_$P(BGPX(BGP1,BGP2),U,2) D S^BGP4DPED(X,1,1)

 ..S BGPCYN=$P(BGPX(BGP1,BGP2),U,3)

 ..S BGPPRN=$P(BGPX(BGP1,BGP2),U,4)

 ..S BGPBLN=$P(BGPX(BGP1,BGP2),U,5)

 ..S BGPCYP=$P(BGPX(BGP1,BGP2),U,6)

 ..S BGPPRP=$P(BGPX(BGP1,BGP2),U,7)

 ..S BGPBLP=$P(BGPX(BGP1,BGP2),U,8)

 ..D H2^BGP4PDL1

MET ;

 D S^BGP4DPED(" ",1,1)

 S BGPCYD=$$V^BGP4DPED(1,BGPRPT,11,29)

 S BGPPRD=$$V^BGP4DPED(2,BGPRPT,11,29)

 S BGPBLD=$$V^BGP4DPED(3,BGPRPT,11,29)

 D S^BGP4DPED(" ",1,1)

 S N=11,P=26 D SETN^BGP4DPED

 S X="# w/goal met" D S^BGP4DPED(X,1,1)

 D H2^BGP4PDL1

 D S^BGP4DPED(" ",1,1)

 K BGPPROVS

 S N=18 D SETNM^BGP4DPEQ

 K BGPX

 S BGPCNT=0

 S X="",C=0 F  S X=$O(BGPPROVS(X)) Q:X=""  S Y="" F  S Y=$O(BGPPROVS(X,Y)) Q:Y=""  S C=C+1 S BGPX((9999999-$P(BGPPROVS(X,Y),U,1)),C)=X_U_Y_U_BGPPROVS(X,Y)

 S BGP1=0 F  S BGP1=$O(BGPX(BGP1)) Q:BGP1'=+BGP1!(BGPCNT>15)  D

 .S BGPCNT=BGPCNT+1 S BGP2=0 F  S BGP2=$O(BGPX(BGP1,BGP2)) Q:BGP2'=+BGP2  D

 ..S X=BGPCNT_".  "_$P(BGPX(BGP1,BGP2),U,2) D S^BGP4DPED(X,1,1)

 ..S BGPCYN=$P(BGPX(BGP1,BGP2),U,3)

 ..S BGPPRN=$P(BGPX(BGP1,BGP2),U,4)

 ..S BGPBLN=$P(BGPX(BGP1,BGP2),U,5)

 ..S BGPCYP=$P(BGPX(BGP1,BGP2),U,6)

 ..S BGPPRP=$P(BGPX(BGP1,BGP2),U,7)

 ..S BGPBLP=$P(BGPX(BGP1,BGP2),U,8)

 ..D H2^BGP4PDL1

MAIN ;

 D S^BGP4DPED(" ",1,1)

 S BGPCYD=$$V^BGP4DPED(1,BGPRPT,11,29)

 S BGPPRD=$$V^BGP4DPED(2,BGPRPT,11,29)

 S BGPBLD=$$V^BGP4DPED(3,BGPRPT,11,29)

 D S^BGP4DPED(" ",1,1)

 S N=11,P=27 D SETN^BGP4DPED

 S X="# w/goal maintained" D S^BGP4DPED(X,1,1)

 D H2^BGP4PDL1

 D S^BGP4DPED(" ",1,1)

 K BGPPROVS

 S N=19 D SETNM^BGP4DPEQ

 K BGPX

 S BGPCNT=0

 S X="",C=0 F  S X=$O(BGPPROVS(X)) Q:X=""  S Y="" F  S Y=$O(BGPPROVS(X,Y)) Q:Y=""  S C=C+1 S BGPX((9999999-$P(BGPPROVS(X,Y),U,1)),C)=X_U_Y_U_BGPPROVS(X,Y)

 S BGP1=0 F  S BGP1=$O(BGPX(BGP1)) Q:BGP1'=+BGP1!(BGPCNT>15)  D

 .S BGPCNT=BGPCNT+1 S BGP2=0 F  S BGP2=$O(BGPX(BGP1,BGP2)) Q:BGP2'=+BGP2  D

 ..S X=BGPCNT_".  "_$P(BGPX(BGP1,BGP2),U,2) D S^BGP4DPED(X,1,1)

 ..S BGPCYN=$P(BGPX(BGP1,BGP2),U,3)

 ..S BGPPRN=$P(BGPX(BGP1,BGP2),U,4)

 ..S BGPBLN=$P(BGPX(BGP1,BGP2),U,5)

 ..S BGPCYP=$P(BGPX(BGP1,BGP2),U,6)

 ..S BGPPRP=$P(BGPX(BGP1,BGP2),U,7)

 ..S BGPBLP=$P(BGPX(BGP1,BGP2),U,8)

 ..D H2^BGP4PDL1

NOTMET ;

 D S^BGP4DPED(" ",1,1)

 S BGPCYD=$$V^BGP4DPED(1,BGPRPT,11,29)

 S BGPPRD=$$V^BGP4DPED(2,BGPRPT,11,29)

 S BGPBLD=$$V^BGP4DPED(3,BGPRPT,11,29)

 D S^BGP4DPED(" ",1,1)

 S N=11,P=28 D SETN^BGP4DPED

 S X="# w/goal not met" D S^BGP4DPED(X,1,1)

 D H2^BGP4PDL1

 D S^BGP4DPED(" ",1,1)

 K BGPPROVS

 S N=21 D SETNM^BGP4DPEQ

 K BGPX

 S BGPCNT=0

 S X="",C=0 F  S X=$O(BGPPROVS(X)) Q:X=""  S Y="" F  S Y=$O(BGPPROVS(X,Y)) Q:Y=""  S C=C+1 S BGPX((9999999-$P(BGPPROVS(X,Y),U,1)),C)=X_U_Y_U_BGPPROVS(X,Y)

 S BGP1=0 F  S BGP1=$O(BGPX(BGP1)) Q:BGP1'=+BGP1!(BGPCNT>15)  D

 .S BGPCNT=BGPCNT+1 S BGP2=0 F  S BGP2=$O(BGPX(BGP1,BGP2)) Q:BGP2'=+BGP2  D

 ..S X=BGPCNT_".  "_$P(BGPX(BGP1,BGP2),U,2) D S^BGP4DPED(X,1,1)

 ..S BGPCYN=$P(BGPX(BGP1,BGP2),U,3)

 ..S BGPPRN=$P(BGPX(BGP1,BGP2),U,4)

 ..S BGPBLN=$P(BGPX(BGP1,BGP2),U,5)

 ..S BGPCYP=$P(BGPX(BGP1,BGP2),U,6)

 ..S BGPPRP=$P(BGPX(BGP1,BGP2),U,7)

 ..S BGPBLP=$P(BGPX(BGP1,BGP2),U,8)

 ..D H2^BGP4PDL1

 ;UPPED

 S X=""

 D S^BGP4DPED(" ",1,1) D S^BGP4DPED(" ",1,1) ;S X=$P(^BGPPEIJ(BGPIC,0),U,2) D S^BGP4DPED(X,1,1)

 D H1^BGP4PDL1

 D S^BGP4DPED(" ",1,1)

 S BGPCYD=$$V^BGP4DPED(1,BGPRPT,11,19)

 S BGPPRD=$$V^BGP4DPED(2,BGPRPT,11,19)

 S BGPBLD=$$V^BGP4DPED(3,BGPRPT,11,19)

 I $G(BGPSEAT) S X=$P(^DIBT(BGPSEAT,0),U,1)_" Population w/ Pat Ed" D S^BGP4DPED(X,1,1)

 I '$G(BGPSEAT) S X="# User Pop w/ Pat Ed" D S^BGP4DPED(X,1,1)

 S Y=BGPCYD_"^^"_BGPPRD_"^^^"_BGPBLD D S^BGP4DPED(Y,,2)

 D S^BGP4DPED(" ",1,1)

 S X="Goal Setting" D S^BGP4DPED(X,1,1)

 S N=11,P=20 D SETN^BGP4DPED

 S X="# w/goal set" D S^BGP4DPED(X,1,1)

 D H2^BGP4PDL1

 S N=11,P=21 D SETN^BGP4DPED

 S X="# w/goal not set" D S^BGP4DPED(X,1,1)

 D H2^BGP4PDL1

 S N=11,P=22 D SETN^BGP4DPED

 S X="# w/goal met" D S^BGP4DPED(X,1,1)

 D H2^BGP4PDL1

 S N=11,P=23 D SETN^BGP4DPED

 S X="# w/goal not met" D S^BGP4DPED(X,1,1)

 D H2^BGP4PDL1

BGP4DPEF  ; IHS/CMI/LAB - IHS gpra print ;

 +1       ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114

 +2       ;

 +3       ;

7         ;EP

 +1        SET X=""

 +2       ;S X=$P(^BGPPEIJ(BGPIC,0),U,2) D S^BGP4DPED(X,1,1)

           DO S^BGP4DPED(" ",1,1)

           DO S^BGP4DPED(" ",1,1)

 +3        DO H1^BGP4PDL1

 +4        DO S^BGP4DPED(" ",1,1)

 +5        SET BGPCYD=$$V^BGP4DPED(1,BGPRPT,11,29)

 +6        SET BGPPRD=$$V^BGP4DPED(2,BGPRPT,11,29)

 +7        SET BGPBLD=$$V^BGP4DPED(3,BGPRPT,11,29)

 +8        IF $GET(BGPSEAT)

               SET X=$PIECE(^DIBT(BGPSEAT,0),U,1)_" Population w/ Pat Ed"

               DO S^BGP4DPED(X,1,1)

 +9        IF '$GET(BGPSEAT)

               SET X="# User Pop"

               DO S^BGP4DPED(X,1,1)

 +10       SET Y=BGPCYD_"^^"_BGPPRD_"^^^"_BGPBLD

           DO S^BGP4DPED(Y,,2)

 +11       DO S^BGP4DPED(" ",1,1)

 +12       SET X="Goal Setting"

           DO S^BGP4DPED(X,1,1)

 +13       SET N=11

           SET P=24

           DO SETN^BGP4DPED

 +14       SET X="# w/goal set"

           DO S^BGP4DPED(X,1,1)

 +15       DO H2^BGP4PDL1

 +16       DO S^BGP4DPED(" ",1,1)

 +17       KILL BGPPROVS

 +18       SET N=16

           DO SETNM^BGP4DPEQ

 +19       KILL BGPX

 +20       SET BGPCNT=0

 +21       SET X=""

           SET C=0

FOR

               SET X=$ORDER(BGPPROVS(X))

               IF X=""

                   QUIT

               SET Y=""

FOR

                   SET Y=$ORDER(BGPPROVS(X,Y))

                   IF Y=""

                       QUIT

                   SET C=C+1

                   SET BGPX((9999999-$PIECE(BGPPROVS(X,Y),U,1)),C)=X_U_Y_U_BGPPROVS(X,Y)

 +22       SET BGP1=0

FOR

               SET BGP1=$ORDER(BGPX(BGP1))

               IF BGP1'=+BGP1!(BGPCNT>15)

                   QUIT

               Begin DoDot:1

 +23               SET BGPCNT=BGPCNT+1

                   SET BGP2=0

FOR

                       SET BGP2=$ORDER(BGPX(BGP1,BGP2))

                       IF BGP2'=+BGP2

                           QUIT

                       Begin DoDot:2

 +24                       SET X=BGPCNT_".  "_$PIECE(BGPX(BGP1,BGP2),U,2)

                           DO S^BGP4DPED(X,1,1)

 +25                       SET BGPCYN=$PIECE(BGPX(BGP1,BGP2),U,3)

 +26                       SET BGPPRN=$PIECE(BGPX(BGP1,BGP2),U,4)

 +27                       SET BGPBLN=$PIECE(BGPX(BGP1,BGP2),U,5)

 +28                       SET BGPCYP=$PIECE(BGPX(BGP1,BGP2),U,6)

 +29                       SET BGPPRP=$PIECE(BGPX(BGP1,BGP2),U,7)

 +30                       SET BGPBLP=$PIECE(BGPX(BGP1,BGP2),U,8)

 +31                       DO H2^BGP4PDL1

                       End DoDot:2

               End DoDot:1

NOTSET    ;

 +1        DO S^BGP4DPED(" ",1,1)

 +2        SET BGPCYD=$$V^BGP4DPED(1,BGPRPT,11,29)

 +3        SET BGPPRD=$$V^BGP4DPED(2,BGPRPT,11,29)

 +4        SET BGPBLD=$$V^BGP4DPED(3,BGPRPT,11,29)

 +5        DO S^BGP4DPED(" ",1,1)

 +6        SET N=11

           SET P=25

           DO SETN^BGP4DPED

 +7        SET X="# w/goal not set"

           DO S^BGP4DPED(X,1,1)

 +8        DO H2^BGP4PDL1

 +9        DO S^BGP4DPED(" ",1,1)

 +10       KILL BGPPROVS

 +11       SET N=17

           DO SETNM^BGP4DPEQ

 +12       KILL BGPX

 +13       SET BGPCNT=0

 +14       SET X=""

           SET C=0

FOR

               SET X=$ORDER(BGPPROVS(X))

               IF X=""

                   QUIT

               SET Y=""

FOR

                   SET Y=$ORDER(BGPPROVS(X,Y))

                   IF Y=""

                       QUIT

                   SET C=C+1

                   SET BGPX((9999999-$PIECE(BGPPROVS(X,Y),U,1)),C)=X_U_Y_U_BGPPROVS(X,Y)

 +15       SET BGP1=0

FOR

               SET BGP1=$ORDER(BGPX(BGP1))

               IF BGP1'=+BGP1!(BGPCNT>15)

                   QUIT

               Begin DoDot:1

 +16               SET BGPCNT=BGPCNT+1

                   SET BGP2=0

FOR

                       SET BGP2=$ORDER(BGPX(BGP1,BGP2))

                       IF BGP2'=+BGP2

                           QUIT

                       Begin DoDot:2

 +17                       SET X=BGPCNT_".  "_$PIECE(BGPX(BGP1,BGP2),U,2)

                           DO S^BGP4DPED(X,1,1)

 +18                       SET BGPCYN=$PIECE(BGPX(BGP1,BGP2),U,3)

 +19                       SET BGPPRN=$PIECE(BGPX(BGP1,BGP2),U,4)

 +20                       SET BGPBLN=$PIECE(BGPX(BGP1,BGP2),U,5)

 +21                       SET BGPCYP=$PIECE(BGPX(BGP1,BGP2),U,6)

 +22                       SET BGPPRP=$PIECE(BGPX(BGP1,BGP2),U,7)

 +23                       SET BGPBLP=$PIECE(BGPX(BGP1,BGP2),U,8)

 +24                       DO H2^BGP4PDL1

                       End DoDot:2

               End DoDot:1

MET       ;

 +1        DO S^BGP4DPED(" ",1,1)

 +2        SET BGPCYD=$$V^BGP4DPED(1,BGPRPT,11,29)

 +3        SET BGPPRD=$$V^BGP4DPED(2,BGPRPT,11,29)

 +4        SET BGPBLD=$$V^BGP4DPED(3,BGPRPT,11,29)

 +5        DO S^BGP4DPED(" ",1,1)

 +6        SET N=11

           SET P=26

           DO SETN^BGP4DPED

 +7        SET X="# w/goal met"

           DO S^BGP4DPED(X,1,1)

 +8        DO H2^BGP4PDL1

 +9        DO S^BGP4DPED(" ",1,1)

 +10       KILL BGPPROVS

 +11       SET N=18

           DO SETNM^BGP4DPEQ

 +12       KILL BGPX

 +13       SET BGPCNT=0

 +14       SET X=""

           SET C=0

FOR

               SET X=$ORDER(BGPPROVS(X))

               IF X=""

                   QUIT

               SET Y=""

FOR

                   SET Y=$ORDER(BGPPROVS(X,Y))

                   IF Y=""

                       QUIT

                   SET C=C+1

                   SET BGPX((9999999-$PIECE(BGPPROVS(X,Y),U,1)),C)=X_U_Y_U_BGPPROVS(X,Y)

 +15       SET BGP1=0

FOR

               SET BGP1=$ORDER(BGPX(BGP1))

               IF BGP1'=+BGP1!(BGPCNT>15)

                   QUIT

               Begin DoDot:1

 +16               SET BGPCNT=BGPCNT+1

                   SET BGP2=0

FOR

                       SET BGP2=$ORDER(BGPX(BGP1,BGP2))

                       IF BGP2'=+BGP2

                           QUIT

                       Begin DoDot:2

 +17                       SET X=BGPCNT_".  "_$PIECE(BGPX(BGP1,BGP2),U,2)

                           DO S^BGP4DPED(X,1,1)

 +18                       SET BGPCYN=$PIECE(BGPX(BGP1,BGP2),U,3)

 +19                       SET BGPPRN=$PIECE(BGPX(BGP1,BGP2),U,4)

 +20                       SET BGPBLN=$PIECE(BGPX(BGP1,BGP2),U,5)

 +21                       SET BGPCYP=$PIECE(BGPX(BGP1,BGP2),U,6)

 +22                       SET BGPPRP=$PIECE(BGPX(BGP1,BGP2),U,7)

 +23                       SET BGPBLP=$PIECE(BGPX(BGP1,BGP2),U,8)

 +24                       DO H2^BGP4PDL1

                       End DoDot:2

               End DoDot:1

MAIN      ;

 +1        DO S^BGP4DPED(" ",1,1)

 +2        SET BGPCYD=$$V^BGP4DPED(1,BGPRPT,11,29)

 +3        SET BGPPRD=$$V^BGP4DPED(2,BGPRPT,11,29)

 +4        SET BGPBLD=$$V^BGP4DPED(3,BGPRPT,11,29)

 +5        DO S^BGP4DPED(" ",1,1)

 +6        SET N=11

           SET P=27

           DO SETN^BGP4DPED

 +7        SET X="# w/goal maintained"

           DO S^BGP4DPED(X,1,1)

 +8        DO H2^BGP4PDL1

 +9        DO S^BGP4DPED(" ",1,1)

 +10       KILL BGPPROVS

 +11       SET N=19

           DO SETNM^BGP4DPEQ

 +12       KILL BGPX

 +13       SET BGPCNT=0

 +14       SET X=""

           SET C=0

FOR

               SET X=$ORDER(BGPPROVS(X))

               IF X=""

                   QUIT

               SET Y=""

FOR

                   SET Y=$ORDER(BGPPROVS(X,Y))

                   IF Y=""

                       QUIT

                   SET C=C+1

                   SET BGPX((9999999-$PIECE(BGPPROVS(X,Y),U,1)),C)=X_U_Y_U_BGPPROVS(X,Y)

 +15       SET BGP1=0

FOR

               SET BGP1=$ORDER(BGPX(BGP1))

               IF BGP1'=+BGP1!(BGPCNT>15)

                   QUIT

               Begin DoDot:1

 +16               SET BGPCNT=BGPCNT+1

                   SET BGP2=0

FOR

                       SET BGP2=$ORDER(BGPX(BGP1,BGP2))

                       IF BGP2'=+BGP2

                           QUIT

                       Begin DoDot:2

 +17                       SET X=BGPCNT_".  "_$PIECE(BGPX(BGP1,BGP2),U,2)

                           DO S^BGP4DPED(X,1,1)

 +18                       SET BGPCYN=$PIECE(BGPX(BGP1,BGP2),U,3)

 +19                       SET BGPPRN=$PIECE(BGPX(BGP1,BGP2),U,4)

 +20                       SET BGPBLN=$PIECE(BGPX(BGP1,BGP2),U,5)

 +21                       SET BGPCYP=$PIECE(BGPX(BGP1,BGP2),U,6)

 +22                       SET BGPPRP=$PIECE(BGPX(BGP1,BGP2),U,7)

 +23                       SET BGPBLP=$PIECE(BGPX(BGP1,BGP2),U,8)

 +24                       DO H2^BGP4PDL1

                       End DoDot:2

               End DoDot:1

NOTMET    ;

 +1        DO S^BGP4DPED(" ",1,1)

 +2        SET BGPCYD=$$V^BGP4DPED(1,BGPRPT,11,29)

 +3        SET BGPPRD=$$V^BGP4DPED(2,BGPRPT,11,29)

 +4        SET BGPBLD=$$V^BGP4DPED(3,BGPRPT,11,29)

 +5        DO S^BGP4DPED(" ",1,1)

 +6        SET N=11

           SET P=28

           DO SETN^BGP4DPED

 +7        SET X="# w/goal not met"

           DO S^BGP4DPED(X,1,1)

 +8        DO H2^BGP4PDL1

 +9        DO S^BGP4DPED(" ",1,1)

 +10       KILL BGPPROVS

 +11       SET N=21

           DO SETNM^BGP4DPEQ

 +12       KILL BGPX

 +13       SET BGPCNT=0

 +14       SET X=""

           SET C=0

FOR

               SET X=$ORDER(BGPPROVS(X))

               IF X=""

                   QUIT

               SET Y=""

FOR

                   SET Y=$ORDER(BGPPROVS(X,Y))

                   IF Y=""

                       QUIT

                   SET C=C+1

                   SET BGPX((9999999-$PIECE(BGPPROVS(X,Y),U,1)),C)=X_U_Y_U_BGPPROVS(X,Y)

 +15       SET BGP1=0

FOR

               SET BGP1=$ORDER(BGPX(BGP1))

               IF BGP1'=+BGP1!(BGPCNT>15)

                   QUIT

               Begin DoDot:1

 +16               SET BGPCNT=BGPCNT+1

                   SET BGP2=0

FOR

                       SET BGP2=$ORDER(BGPX(BGP1,BGP2))

                       IF BGP2'=+BGP2

                           QUIT

                       Begin DoDot:2

 +17                       SET X=BGPCNT_".  "_$PIECE(BGPX(BGP1,BGP2),U,2)

                           DO S^BGP4DPED(X,1,1)

 +18                       SET BGPCYN=$PIECE(BGPX(BGP1,BGP2),U,3)

 +19                       SET BGPPRN=$PIECE(BGPX(BGP1,BGP2),U,4)

 +20                       SET BGPBLN=$PIECE(BGPX(BGP1,BGP2),U,5)

 +21                       SET BGPCYP=$PIECE(BGPX(BGP1,BGP2),U,6)

 +22                       SET BGPPRP=$PIECE(BGPX(BGP1,BGP2),U,7)

 +23                       SET BGPBLP=$PIECE(BGPX(BGP1,BGP2),U,8)

 +24                       DO H2^BGP4PDL1

                       End DoDot:2

               End DoDot:1

 +25      ;UPPED

 +26       SET X=""

 +27      ;S X=$P(^BGPPEIJ(BGPIC,0),U,2) D S^BGP4DPED(X,1,1)

           DO S^BGP4DPED(" ",1,1)

           DO S^BGP4DPED(" ",1,1)

 +28       DO H1^BGP4PDL1

 +29       DO S^BGP4DPED(" ",1,1)

 +30       SET BGPCYD=$$V^BGP4DPED(1,BGPRPT,11,19)

 +31       SET BGPPRD=$$V^BGP4DPED(2,BGPRPT,11,19)

 +32       SET BGPBLD=$$V^BGP4DPED(3,BGPRPT,11,19)

 +33       IF $GET(BGPSEAT)

               SET X=$PIECE(^DIBT(BGPSEAT,0),U,1)_" Population w/ Pat Ed"

               DO S^BGP4DPED(X,1,1)

 +34       IF '$GET(BGPSEAT)

               SET X="# User Pop w/ Pat Ed"

               DO S^BGP4DPED(X,1,1)

 +35       SET Y=BGPCYD_"^^"_BGPPRD_"^^^"_BGPBLD

           DO S^BGP4DPED(Y,,2)

 +36       DO S^BGP4DPED(" ",1,1)

 +37       SET X="Goal Setting"

           DO S^BGP4DPED(X,1,1)

 +38       SET N=11

           SET P=20

           DO SETN^BGP4DPED

 +39       SET X="# w/goal set"

           DO S^BGP4DPED(X,1,1)

 +40       DO H2^BGP4PDL1

 +41       SET N=11

           SET P=21

           DO SETN^BGP4DPED

 +42       SET X="# w/goal not set"

           DO S^BGP4DPED(X,1,1)

 +43       DO H2^BGP4PDL1

 +44       SET N=11

           SET P=22

           DO SETN^BGP4DPED

 +45       SET X="# w/goal met"

           DO S^BGP4DPED(X,1,1)

 +46       DO H2^BGP4PDL1

 +47       SET N=11

           SET P=23

           DO SETN^BGP4DPED

 +48       SET X="# w/goal not met"

           DO S^BGP4DPED(X,1,1)

 +49       DO H2^BGP4PDL1

 +50       QUIT

BGP4DPEF.m