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)
+111 SET BGPBLP=$PIECE(BGPX(BGP1,BGP2),U,8)
+112 DO H2^BGP4DPH
End DoDot:2
End DoDot:1
+113 ;not met
+114 IF $Y>(BGPIOSL-6)
DO HEADER^BGP4DPEP
IF BGPQUIT
QUIT
WRITE !,$PIECE(^BGPPEIJ(BGPIC,0),U,2)
DO H1^BGP4DPH
+115 SET BGPCYD=$$V^BGP4DPEP(1,BGPRPT,11,29)
+116 SET BGPPRD=$$V^BGP4DPEP(2,BGPRPT,11,29)
+117 SET BGPBLD=$$V^BGP4DPEP(3,BGPRPT,11,29)
+118 ;I $G(BGPSEAT) W !!,$P(^DIBT(BGPSEAT,0),U,1)," Population"
+119 ;W:'$G(BGPSEAT) ! W !,"Total User Population",!," Patients"
+120 WRITE !!
+121 SET N=11
SET P=28
DO SETN^BGP4DPEP
+122 WRITE !,"# w/ Goal Not Met"
+123 DO H2^BGP4DPH
+124 IF $Y>(BGPIOSL-6)
DO HEADER^BGP4DPEP
IF BGPQUIT
QUIT
WRITE !,$PIECE(^BGPPEIJ(BGPIC,0),U,2)
+125 KILL BGPPROVS
+126 SET N=21
DO SETNM^BGP4DPEQ
+127 KILL BGPX
+128 SET BGPCNT=0
+129 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)
+130 SET BGP1=0
FOR
SET BGP1=$ORDER(BGPX(BGP1))
IF BGP1'=+BGP1!(BGPQUIT)!(BGPCNT>15)
QUIT
Begin DoDot:1
+131 SET BGPCNT=BGPCNT+1
SET BGP2=0
FOR
SET BGP2=$ORDER(BGPX(BGP1,BGP2))
IF BGP2'=+BGP2!(BGPQUIT)
QUIT
Begin DoDot:2
+132 IF $Y>(BGPIOSL-3)
DO HEADER^BGP4DPEP
IF BGPQUIT
QUIT
WRITE !,$PIECE(^BGPPEIJ(BGPIC,0),U,2)
DO H1^BGP4DPH
WRITE !
+133 WRITE !?2,BGPCNT,". ",$EXTRACT($PIECE(BGPX(BGP1,BGP2),U,2),1,15)
+134 SET BGPCYN=$PIECE(BGPX(BGP1,BGP2),U,3)
+135 SET BGPPRN=$PIECE(BGPX(BGP1,BGP2),U,4)
+136 SET BGPBLN=$PIECE(BGPX(BGP1,BGP2),U,5)
+137 SET BGPCYP=$PIECE(BGPX(BGP1,BGP2),U,6)
+138 SET BGPPRP=$PIECE(BGPX(BGP1,BGP2),U,7)
+139 SET BGPBLP=$PIECE(BGPX(BGP1,BGP2),U,8)
+140 DO H2^BGP4DPH
End DoDot:2
End DoDot:1
+141 ;UP PED
+142 IF $Y>(BGPIOSL-6)
DO HEADER^BGP4DPEP
IF BGPQUIT
QUIT
WRITE !,$PIECE(^BGPPEIJ(BGPIC,0),U,2)
+143 DO H1^BGP4DPH
+144 SET BGPCYD=$$V^BGP4DPEP(1,BGPRPT,11,19)
+145 SET BGPPRD=$$V^BGP4DPEP(2,BGPRPT,11,19)
+146 SET BGPBLD=$$V^BGP4DPEP(3,BGPRPT,11,19)
+147 IF '$GET(BGPSEAT)
WRITE !!,"# User Pop w/ Pat Ed"
+148 IF $GET(BGPSEAT)
WRITE !!,$PIECE(^DIBT(BGPSEAT,0),U,1)," Population",!," w/ Pat Ed"
+149 WRITE ?20,$$C^BGP4DPEP(BGPCYD,0,8),?35,$$C^BGP4DPEP(BGPPRD,0,8),?58,$$C^BGP4DPEP(BGPBLD,0,8),!
+150 ;,"Goal Setting"
WRITE !
+151 SET N=11
SET P=20
DO SETN^BGP4DPEP
+152 WRITE !,"# w/goal set"
+153 DO H2^BGP4DPH
+154 SET N=11
SET P=21
DO SETN^BGP4DPEP
+155 WRITE !,"# w/goal not set"
+156 DO H2^BGP4DPH
+157 SET N=11
SET P=22
DO SETN^BGP4DPEP
+158 WRITE !,"# w/goal met"
+159 DO H2^BGP4DPH
+160 SET N=11
SET P=23
DO SETN^BGP4DPEP
+161 WRITE !,"# w/goal not met"
+162 DO H2^BGP4DPH
+163 ;
+164 QUIT
+165 ;----------
SETNM ;EP
+1 KILL BGPPROVS
+2 SET (BGPCYD,BGPPRD,BGPBLD)=0
+3 IF $GET(BGPAREAA)
DO SETNMA
QUIT
+4 SET X=0
FOR
SET X=$ORDER(^BGPPEDCJ(BGPRPT,N,X))
IF X'=+X
QUIT
Begin DoDot:1
+5 SET C=$PIECE(^BGPPEDCJ(BGPRPT,N,X,0),U)
SET L=$PIECE(^BGPPEDCJ(BGPRPT,N,X,0),U,2)
SET M=$PIECE(^BGPPEDCJ(BGPRPT,N,X,0),U,3)
+6 SET $PIECE(BGPPROVS(C,L),U,1)=M
SET BGPCYD=BGPCYD+M
End DoDot:1
+7 SET X=0
FOR
SET X=$ORDER(^BGPPEDPJ(BGPRPT,N,X))
IF X'=+X
QUIT
Begin DoDot:1
+8 SET C=$PIECE(^BGPPEDPJ(BGPRPT,N,X,0),U)
SET L=$PIECE(^BGPPEDPJ(BGPRPT,N,X,0),U,2)
SET M=$PIECE(^BGPPEDPJ(BGPRPT,N,X,0),U,3)
+9 SET $PIECE(BGPPROVS(C,L),U,2)=M
SET BGPPRD=BGPPRD+M
End DoDot:1
+10 SET X=0
FOR
SET X=$ORDER(^BGPPEDBJ(BGPRPT,N,X))
IF X'=+X
QUIT
Begin DoDot:1
+11 SET C=$PIECE(^BGPPEDBJ(BGPRPT,N,X,0),U)
SET L=$PIECE(^BGPPEDBJ(BGPRPT,N,X,0),U,2)
SET M=$PIECE(^BGPPEDBJ(BGPRPT,N,X,0),U,3)
+12 SET $PIECE(BGPPROVS(C,L),U,3)=M
SET BGPBLD=BGPBLD+M
End DoDot:1
+13 ;set %ages
+14 SET X=""
FOR
SET X=$ORDER(BGPPROVS(X))
IF X=""
QUIT
SET Y=""
FOR
SET Y=$ORDER(BGPPROVS(X,Y))
IF Y=""
QUIT
Begin DoDot:1
+15 SET A=$PIECE(BGPPROVS(X,Y),U,1)
SET $PIECE(BGPPROVS(X,Y),U,4)=$SELECT(BGPCYD:((A/BGPCYD)*100),1:"")
+16 SET B=$PIECE(BGPPROVS(X,Y),U,2)
SET $PIECE(BGPPROVS(X,Y),U,5)=$SELECT(BGPPRD:((B/BGPPRD)*100),1:"")
+17 SET C=$PIECE(BGPPROVS(X,Y),U,3)
SET $PIECE(BGPPROVS(X,Y),U,6)=$SELECT(BGPBLD:((C/BGPBLD)*100),1:"")
+18 QUIT
End DoDot:1
+19 QUIT
SETNMA ;
+1 NEW X,V,C
SET Z=0
SET C=""
FOR
SET Z=$ORDER(BGPSUL(Z))
IF Z'=+Z
QUIT
DO SETNMA1
+2 SET X=""
FOR
SET X=$ORDER(BGPPROVS(X))
IF X=""
QUIT
SET Y=""
FOR
SET Y=$ORDER(BGPPROVS(X,Y))
IF Y=""
QUIT
Begin DoDot:1
+3 SET A=$PIECE(BGPPROVS(X,Y),U,1)
SET $PIECE(BGPPROVS(X,Y),U,4)=$SELECT(BGPCYD:((A/BGPCYD)*100),1:"")
+4 SET B=$PIECE(BGPPROVS(X,Y),U,2)
SET $PIECE(BGPPROVS(X,Y),U,5)=$SELECT(BGPPRD:((B/BGPPRD)*100),1:"")
+5 SET C=$PIECE(BGPPROVS(X,Y),U,3)
SET $PIECE(BGPPROVS(X,Y),U,6)=$SELECT(BGPBLD:((C/BGPBLD)*100),1:"")
+6 QUIT
End DoDot:1
+7 QUIT
SETNMA1 ;
+1 SET X=0
FOR
SET X=$ORDER(^BGPPEDCJ(Z,N,X))
IF X'=+X
QUIT
Begin DoDot:1
+2 SET C=$PIECE(^BGPPEDCJ(Z,N,X,0),U)
SET L=$PIECE(^BGPPEDCJ(Z,N,X,0),U,2)
SET M=$PIECE(^BGPPEDCJ(Z,N,X,0),U,3)
+3 SET $PIECE(BGPPROVS(C,L),U,1)=$PIECE($GET(BGPPROVS(C,L)),U,1)+M
SET BGPCYD=BGPCYD+M
End DoDot:1
+4 SET X=0
FOR
SET X=$ORDER(^BGPPEDPJ(Z,N,X))
IF X'=+X
QUIT
Begin DoDot:1
+5 SET C=$PIECE(^BGPPEDPJ(Z,N,X,0),U)
SET L=$PIECE(^BGPPEDPJ(Z,N,X,0),U,2)
SET M=$PIECE(^BGPPEDPJ(Z,N,X,0),U,3)
+6 SET $PIECE(BGPPROVS(C,L),U,2)=$PIECE($GET(BGPPROVS(C,L)),U,2)+M
SET BGPPRD=BGPPRD+M
End DoDot:1
+7 SET X=0
FOR
SET X=$ORDER(^BGPPEDBJ(Z,N,X))
IF X'=+X
QUIT
Begin DoDot:1
+8 SET C=$PIECE(^BGPPEDBJ(Z,N,X,0),U)
SET L=$PIECE(^BGPPEDBJ(Z,N,X,0),U,2)
SET M=$PIECE(^BGPPEDBJ(Z,N,X,0),U,3)
+9 SET $PIECE(BGPPROVS(C,L),U,3)=$PIECE($GET(BGPPROVS(C,L)),U,3)+M
SET BGPBLD=BGPBLD+M
+10 QUIT
End DoDot:1
+11 QUIT
