BGP4DPEQ.m

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

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

 ;

7 ;EP

 I $Y>(BGPIOSL-6) D HEADER^BGP4DPEP Q:BGPQUIT  W !,$P(^BGPPEIJ(BGPIC,0),U,2)

 D H1^BGP4DPH

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

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

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

 I $G(BGPSEAT) W !!,$P(^DIBT(BGPSEAT,0),U,1)," Population"

 W:'$G(BGPSEAT) ! W !,"# User Pop"

 W ?20,$$C^BGP4DPEP(BGPCYD,0,8),?35,$$C^BGP4DPEP(BGPPRD,0,8),?58,$$C^BGP4DPEP(BGPBLD,0,8),!

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

 W !,"# w/ Goal Set"

 D H2^BGP4DPH

 K BGPPROVS

 S N=16 D SETNM

 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!(BGPQUIT)!(BGPCNT>15)  D

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

 ..I $Y>(BGPIOSL-3) D HEADER^BGP4DPEP Q:BGPQUIT  W !,$P(^BGPPEIJ(BGPIC,0),U,2) D H1^BGP4DPH W !

 ..W !?2,BGPCNT,". ",$E($P(BGPX(BGP1,BGP2),U,2),1,15)

 ..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^BGP4DPH

 ;not set

 I $Y>(BGPIOSL-6) D HEADER^BGP4DPEP Q:BGPQUIT  W !,$P(^BGPPEIJ(BGPIC,0),U,2) D H1^BGP4DPH

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

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

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

 ;I $G(BGPSEAT) W !!,$P(^DIBT(BGPSEAT,0),U,1)," Population"

 ;W:'$G(BGPSEAT) ! W !,"Total User Population",!," Patients"

 W !!

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

 W !,"# w/ Goal Not Set"

 D H2^BGP4DPH

 I $Y>(BGPIOSL-6) D HEADER^BGP4DPEP Q:BGPQUIT  W !,$P(^BGPPEIJ(BGPIC,0),U,2)

 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!(BGPQUIT)!(BGPCNT>15)  D

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

 ..I $Y>(BGPIOSL-3) D HEADER^BGP4DPEP Q:BGPQUIT  W !,$P(^BGPPEIJ(BGPIC,0),U,2) D H1^BGP4DPH W !

 ..W !?2,BGPCNT,". ",$E($P(BGPX(BGP1,BGP2),U,2),1,15)

 ..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^BGP4DPH

 ;

 ;met

 I $Y>(BGPIOSL-6) D HEADER^BGP4DPEP Q:BGPQUIT  W !,$P(^BGPPEIJ(BGPIC,0),U,2) D H1^BGP4DPH

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

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

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

 ;I $G(BGPSEAT) W !!,$P(^DIBT(BGPSEAT,0),U,1)," Population"

 ;W:'$G(BGPSEAT) ! W !,"Total User Population",!," Patients"

 W !!

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

 W !,"# w/ Goal Met"

 D H2^BGP4DPH

 I $Y>(BGPIOSL-6) D HEADER^BGP4DPEP Q:BGPQUIT  W !,$P(^BGPPEIJ(BGPIC,0),U,2)

 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!(BGPQUIT)!(BGPCNT>15)  D

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

 ..I $Y>(BGPIOSL-3) D HEADER^BGP4DPEP Q:BGPQUIT  W !,$P(^BGPPEIJ(BGPIC,0),U,2) D H1^BGP4DPH W !

 ..W !?2,BGPCNT,". ",$E($P(BGPX(BGP1,BGP2),U,2),1,15)

 ..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^BGP4DPH

 ;maintain

 I $Y>(BGPIOSL-6) D HEADER^BGP4DPEP Q:BGPQUIT  W !,$P(^BGPPEIJ(BGPIC,0),U,2) D H1^BGP4DPH

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

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

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

 ;I $G(BGPSEAT) W !!,$P(^DIBT(BGPSEAT,0),U,1)," Population"

 ;W:'$G(BGPSEAT) ! W !,"Total User Population",!," Patients"

 W !!

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

 W !,"# w/ Goal Maintained"

 D H2^BGP4DPH

 I $Y>(BGPIOSL-6) D HEADER^BGP4DPEP Q:BGPQUIT  W !,$P(^BGPPEIJ(BGPIC,0),U,2)

 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!(BGPQUIT)!(BGPCNT>15)  D

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

 ..I $Y>(BGPIOSL-3) D HEADER^BGP4DPEP Q:BGPQUIT  W !,$P(^BGPPEIJ(BGPIC,0),U,2) D H1^BGP4DPH W !

 ..W !?2,BGPCNT,". ",$E($P(BGPX(BGP1,BGP2),U,2),1,15)

 ..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^BGP4DPH

 ;not met

 I $Y>(BGPIOSL-6) D HEADER^BGP4DPEP Q:BGPQUIT  W !,$P(^BGPPEIJ(BGPIC,0),U,2) D H1^BGP4DPH

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

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

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

 ;I $G(BGPSEAT) W !!,$P(^DIBT(BGPSEAT,0),U,1)," Population"

 ;W:'$G(BGPSEAT) ! W !,"Total User Population",!," Patients"

 W !!

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

 W !,"# w/ Goal Not Met"

 D H2^BGP4DPH

 I $Y>(BGPIOSL-6) D HEADER^BGP4DPEP Q:BGPQUIT  W !,$P(^BGPPEIJ(BGPIC,0),U,2)

 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!(BGPQUIT)!(BGPCNT>15)  D

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

 ..I $Y>(BGPIOSL-3) D HEADER^BGP4DPEP Q:BGPQUIT  W !,$P(^BGPPEIJ(BGPIC,0),U,2) D H1^BGP4DPH W !

 ..W !?2,BGPCNT,". ",$E($P(BGPX(BGP1,BGP2),U,2),1,15)

 ..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^BGP4DPH

 ;UP PED

 I $Y>(BGPIOSL-6) D HEADER^BGP4DPEP Q:BGPQUIT  W !,$P(^BGPPEIJ(BGPIC,0),U,2)

 D H1^BGP4DPH

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

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

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

 I '$G(BGPSEAT) W !!,"# User Pop w/ Pat Ed"

 I $G(BGPSEAT) W !!,$P(^DIBT(BGPSEAT,0),U,1)," Population",!," w/ Pat Ed"

 W ?20,$$C^BGP4DPEP(BGPCYD,0,8),?35,$$C^BGP4DPEP(BGPPRD,0,8),?58,$$C^BGP4DPEP(BGPBLD,0,8),!

 W ! ;,"Goal Setting"

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

 W !,"# w/goal set"

 D H2^BGP4DPH

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

 W !,"# w/goal not set"

 D H2^BGP4DPH

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

 W !,"# w/goal met"

 D H2^BGP4DPH

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

 W !,"# w/goal not met"

 D H2^BGP4DPH

 ;

 Q

 ;----------

SETNM ;EP

 K BGPPROVS

 S (BGPCYD,BGPPRD,BGPBLD)=0

 I $G(BGPAREAA) D SETNMA Q

 S X=0 F  S X=$O(^BGPPEDCJ(BGPRPT,N,X)) Q:X'=+X  D

 .S C=$P(^BGPPEDCJ(BGPRPT,N,X,0),U),L=$P(^BGPPEDCJ(BGPRPT,N,X,0),U,2),M=$P(^BGPPEDCJ(BGPRPT,N,X,0),U,3)

 .S $P(BGPPROVS(C,L),U,1)=M,BGPCYD=BGPCYD+M

 S X=0 F  S X=$O(^BGPPEDPJ(BGPRPT,N,X)) Q:X'=+X  D

 .S C=$P(^BGPPEDPJ(BGPRPT,N,X,0),U),L=$P(^BGPPEDPJ(BGPRPT,N,X,0),U,2),M=$P(^BGPPEDPJ(BGPRPT,N,X,0),U,3)

 .S $P(BGPPROVS(C,L),U,2)=M,BGPPRD=BGPPRD+M

 S X=0 F  S X=$O(^BGPPEDBJ(BGPRPT,N,X)) Q:X'=+X  D

 .S C=$P(^BGPPEDBJ(BGPRPT,N,X,0),U),L=$P(^BGPPEDBJ(BGPRPT,N,X,0),U,2),M=$P(^BGPPEDBJ(BGPRPT,N,X,0),U,3)

 .S $P(BGPPROVS(C,L),U,3)=M,BGPBLD=BGPBLD+M

 ;set %ages

 S X="" F  S X=$O(BGPPROVS(X)) Q:X=""  S Y="" F  S Y=$O(BGPPROVS(X,Y)) Q:Y=""  D

 .S A=$P(BGPPROVS(X,Y),U,1),$P(BGPPROVS(X,Y),U,4)=$S(BGPCYD:((A/BGPCYD)*100),1:"")

 .S B=$P(BGPPROVS(X,Y),U,2),$P(BGPPROVS(X,Y),U,5)=$S(BGPPRD:((B/BGPPRD)*100),1:"")

 .S C=$P(BGPPROVS(X,Y),U,3),$P(BGPPROVS(X,Y),U,6)=$S(BGPBLD:((C/BGPBLD)*100),1:"")

 .Q

 Q

SETNMA ;

 NEW X,V,C S Z=0,C="" F  S Z=$O(BGPSUL(Z)) Q:Z'=+Z  D SETNMA1

 S X="" F  S X=$O(BGPPROVS(X)) Q:X=""  S Y="" F  S Y=$O(BGPPROVS(X,Y)) Q:Y=""  D

 .S A=$P(BGPPROVS(X,Y),U,1),$P(BGPPROVS(X,Y),U,4)=$S(BGPCYD:((A/BGPCYD)*100),1:"")

 .S B=$P(BGPPROVS(X,Y),U,2),$P(BGPPROVS(X,Y),U,5)=$S(BGPPRD:((B/BGPPRD)*100),1:"")

 .S C=$P(BGPPROVS(X,Y),U,3),$P(BGPPROVS(X,Y),U,6)=$S(BGPBLD:((C/BGPBLD)*100),1:"")

 .Q

 Q

SETNMA1 ;

 S X=0 F  S X=$O(^BGPPEDCJ(Z,N,X)) Q:X'=+X  D

 .S C=$P(^BGPPEDCJ(Z,N,X,0),U),L=$P(^BGPPEDCJ(Z,N,X,0),U,2),M=$P(^BGPPEDCJ(Z,N,X,0),U,3)

 .S $P(BGPPROVS(C,L),U,1)=$P($G(BGPPROVS(C,L)),U,1)+M,BGPCYD=BGPCYD+M

 S X=0 F  S X=$O(^BGPPEDPJ(Z,N,X)) Q:X'=+X  D

 .S C=$P(^BGPPEDPJ(Z,N,X,0),U),L=$P(^BGPPEDPJ(Z,N,X,0),U,2),M=$P(^BGPPEDPJ(Z,N,X,0),U,3)

 .S $P(BGPPROVS(C,L),U,2)=$P($G(BGPPROVS(C,L)),U,2)+M,BGPPRD=BGPPRD+M

 S X=0 F  S X=$O(^BGPPEDBJ(Z,N,X)) Q:X'=+X  D

 .S C=$P(^BGPPEDBJ(Z,N,X,0),U),L=$P(^BGPPEDBJ(Z,N,X,0),U,2),M=$P(^BGPPEDBJ(Z,N,X,0),U,3)

 .S $P(BGPPROVS(C,L),U,3)=$P($G(BGPPROVS(C,L)),U,3)+M,BGPBLD=BGPBLD+M

 .Q

 Q

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

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

 +2       ;

7         ;EP

 +1        IF $Y>(BGPIOSL-6)

               DO HEADER^BGP4DPEP

               IF BGPQUIT

                   QUIT 

               WRITE !,$PIECE(^BGPPEIJ(BGPIC,0),U,2)

 +2        DO H1^BGP4DPH

 +3        SET BGPCYD=$$V^BGP4DPEP(1,BGPRPT,11,29)

 +4        SET BGPPRD=$$V^BGP4DPEP(2,BGPRPT,11,29)

 +5        SET BGPBLD=$$V^BGP4DPEP(3,BGPRPT,11,29)

 +6        IF $GET(BGPSEAT)

               WRITE !!,$PIECE(^DIBT(BGPSEAT,0),U,1)," Population"

 +7        IF '$GET(BGPSEAT)

               WRITE !

           WRITE !,"# User Pop"

 +8        WRITE ?20,$$C^BGP4DPEP(BGPCYD,0,8),?35,$$C^BGP4DPEP(BGPPRD,0,8),?58,$$C^BGP4DPEP(BGPBLD,0,8),!

 +9        SET N=11

           SET P=24

           DO SETN^BGP4DPEP

 +10       WRITE !,"# w/ Goal Set"

 +11       DO H2^BGP4DPH

 +12       KILL BGPPROVS

 +13       SET N=16

           DO SETNM

 +14       KILL BGPX

 +15       SET BGPCNT=0

 +16       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)

 +17       SET BGP1=0

           FOR 

               SET BGP1=$ORDER(BGPX(BGP1))

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

                   QUIT 

               Begin DoDot:1

 +18               SET BGPCNT=BGPCNT+1

                   SET BGP2=0

                   FOR 

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

                       IF BGP2'=+BGP2!(BGPQUIT)

                           QUIT 

                       Begin DoDot:2

 +19                       IF $Y>(BGPIOSL-3)

                               DO HEADER^BGP4DPEP

                               IF BGPQUIT

                                   QUIT 

                               WRITE !,$PIECE(^BGPPEIJ(BGPIC,0),U,2)

                               DO H1^BGP4DPH

                               WRITE !

 +20                       WRITE !?2,BGPCNT,". ",$EXTRACT($PIECE(BGPX(BGP1,BGP2),U,2),1,15)

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

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

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

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

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

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

 +27                       DO H2^BGP4DPH

                       End DoDot:2

               End DoDot:1

 +28      ;not set

 +29       IF $Y>(BGPIOSL-6)

               DO HEADER^BGP4DPEP

               IF BGPQUIT

                   QUIT 

               WRITE !,$PIECE(^BGPPEIJ(BGPIC,0),U,2)

               DO H1^BGP4DPH

 +30       SET BGPCYD=$$V^BGP4DPEP(1,BGPRPT,11,29)

 +31       SET BGPPRD=$$V^BGP4DPEP(2,BGPRPT,11,29)

 +32       SET BGPBLD=$$V^BGP4DPEP(3,BGPRPT,11,29)

 +33      ;I $G(BGPSEAT) W !!,$P(^DIBT(BGPSEAT,0),U,1)," Population"

 +34      ;W:'$G(BGPSEAT) ! W !,"Total User Population",!," Patients"

 +35       WRITE !!

 +36       SET N=11

           SET P=25

           DO SETN^BGP4DPEP

 +37       WRITE !,"# w/ Goal Not Set"

 +38       DO H2^BGP4DPH

 +39       IF $Y>(BGPIOSL-6)

               DO HEADER^BGP4DPEP

               IF BGPQUIT

                   QUIT 

               WRITE !,$PIECE(^BGPPEIJ(BGPIC,0),U,2)

 +40       KILL BGPPROVS

 +41       SET N=17

           DO SETNM^BGP4DPEQ

 +42       KILL BGPX

 +43       SET BGPCNT=0

 +44       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)

 +45       SET BGP1=0

           FOR 

               SET BGP1=$ORDER(BGPX(BGP1))

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

                   QUIT 

               Begin DoDot:1

 +46               SET BGPCNT=BGPCNT+1

                   SET BGP2=0

                   FOR 

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

                       IF BGP2'=+BGP2!(BGPQUIT)

                           QUIT 

                       Begin DoDot:2

 +47                       IF $Y>(BGPIOSL-3)

                               DO HEADER^BGP4DPEP

                               IF BGPQUIT

                                   QUIT 

                               WRITE !,$PIECE(^BGPPEIJ(BGPIC,0),U,2)

                               DO H1^BGP4DPH

                               WRITE !

 +48                       WRITE !?2,BGPCNT,". ",$EXTRACT($PIECE(BGPX(BGP1,BGP2),U,2),1,15)

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

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

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

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

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

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

 +55                       DO H2^BGP4DPH

                       End DoDot:2

               End DoDot:1

 +56      ;

 +57      ;met

 +58       IF $Y>(BGPIOSL-6)

               DO HEADER^BGP4DPEP

               IF BGPQUIT

                   QUIT 

               WRITE !,$PIECE(^BGPPEIJ(BGPIC,0),U,2)

               DO H1^BGP4DPH

 +59       SET BGPCYD=$$V^BGP4DPEP(1,BGPRPT,11,29)

 +60       SET BGPPRD=$$V^BGP4DPEP(2,BGPRPT,11,29)

 +61       SET BGPBLD=$$V^BGP4DPEP(3,BGPRPT,11,29)

 +62      ;I $G(BGPSEAT) W !!,$P(^DIBT(BGPSEAT,0),U,1)," Population"

 +63      ;W:'$G(BGPSEAT) ! W !,"Total User Population",!," Patients"

 +64       WRITE !!

 +65       SET N=11

           SET P=26

           DO SETN^BGP4DPEP

 +66       WRITE !,"# w/ Goal Met"

 +67       DO H2^BGP4DPH

 +68       IF $Y>(BGPIOSL-6)

               DO HEADER^BGP4DPEP

               IF BGPQUIT

                   QUIT 

               WRITE !,$PIECE(^BGPPEIJ(BGPIC,0),U,2)

 +69       KILL BGPPROVS

 +70       SET N=18

           DO SETNM^BGP4DPEQ

 +71       KILL BGPX

 +72       SET BGPCNT=0

 +73       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)

 +74       SET BGP1=0

           FOR 

               SET BGP1=$ORDER(BGPX(BGP1))

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

                   QUIT 

               Begin DoDot:1

 +75               SET BGPCNT=BGPCNT+1

                   SET BGP2=0

                   FOR 

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

                       IF BGP2'=+BGP2!(BGPQUIT)

                           QUIT 

                       Begin DoDot:2

 +76                       IF $Y>(BGPIOSL-3)

                               DO HEADER^BGP4DPEP

                               IF BGPQUIT

                                   QUIT 

                               WRITE !,$PIECE(^BGPPEIJ(BGPIC,0),U,2)

                               DO H1^BGP4DPH

                               WRITE !

 +77                       WRITE !?2,BGPCNT,". ",$EXTRACT($PIECE(BGPX(BGP1,BGP2),U,2),1,15)

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

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

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

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

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

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

 +84                       DO H2^BGP4DPH

                       End DoDot:2

               End DoDot:1

 +85      ;maintain

 +86       IF $Y>(BGPIOSL-6)

               DO HEADER^BGP4DPEP

               IF BGPQUIT

                   QUIT 

               WRITE !,$PIECE(^BGPPEIJ(BGPIC,0),U,2)

               DO H1^BGP4DPH

 +87       SET BGPCYD=$$V^BGP4DPEP(1,BGPRPT,11,29)

 +88       SET BGPPRD=$$V^BGP4DPEP(2,BGPRPT,11,29)

 +89       SET BGPBLD=$$V^BGP4DPEP(3,BGPRPT,11,29)

 +90      ;I $G(BGPSEAT) W !!,$P(^DIBT(BGPSEAT,0),U,1)," Population"

 +91      ;W:'$G(BGPSEAT) ! W !,"Total User Population",!," Patients"

 +92       WRITE !!

 +93       SET N=11

           SET P=27

           DO SETN^BGP4DPEP

 +94       WRITE !,"# w/ Goal Maintained"

 +95       DO H2^BGP4DPH

 +96       IF $Y>(BGPIOSL-6)

               DO HEADER^BGP4DPEP

               IF BGPQUIT

                   QUIT 

               WRITE !,$PIECE(^BGPPEIJ(BGPIC,0),U,2)

 +97       KILL BGPPROVS

 +98       SET N=19

           DO SETNM^BGP4DPEQ

 +99       KILL BGPX

 +100      SET BGPCNT=0

 +101      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)

 +102      SET BGP1=0

           FOR 

               SET BGP1=$ORDER(BGPX(BGP1))

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

                   QUIT 

               Begin DoDot:1

 +103              SET BGPCNT=BGPCNT+1

                   SET BGP2=0

                   FOR 

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

                       IF BGP2'=+BGP2!(BGPQUIT)

                           QUIT 

                       Begin DoDot:2

 +104                      IF $Y>(BGPIOSL-3)

                               DO HEADER^BGP4DPEP

                               IF BGPQUIT

                                   QUIT 

                               WRITE !,$PIECE(^BGPPEIJ(BGPIC,0),U,2)

                               DO H1^BGP4DPH

                               WRITE !

 +105                      WRITE !?2,BGPCNT,". ",$EXTRACT($PIECE(BGPX(BGP1,BGP2),U,2),1,15)

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

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

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

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

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