BGP9DPEP.m

BGP9DPEP ; IHS/CMI/LAB - IHS gpra print 01 Jul 2008 7:54 PM ; 

 ;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009

 ;

 ;

PRINT ;

 S BGPRTYPE=6,BGP9RPTH=""

 K ^TMP($J)

 K BGPDELIM

 I BGPROT="D" G DEL

 S BGPIOSL=$S($G(BGPGUI):55,1:$G(IOSL))

 D ^BGP9DH

 I BGPQHDR D KITM Q

 S BGPGPG=0

 S BGPQUIT=""

 D PRINT1

 K ^TMP($J)

 I BGPROT="P" D KITM Q

 ;

DEL ;create delimited output file

 I '$D(BGPGUI) D ^%ZISC ;close printer device

 K ^TMP($J)

 D DEL^BGP9DPED

 K ^XTMP("BGP9PE",BGPJ,BGPH)

 K ^TMP($J)

 Q

 ;

PRINT1 ;EP

 K ^TMP($J)

 S BGPIC=0 F  S BGPIC=$O(BGPIND(BGPIC)) Q:BGPIC=""!(BGPQUIT)  D

 .D HEADER

 .I $Y>(BGPIOSL-3) D HEADER Q:BGPQUIT

 .W !!,$P(^BGPPEIN(BGPIC,0),U,2)

 .I $Y>(BGPIOSL-3) D HEADER Q:BGPQUIT

 .W !!,"Denominator(s):"

 .S BGPX=0 F  S BGPX=$O(^BGPPEIN(BGPIC,61,"B",BGPX)) Q:BGPX'=+BGPX!(BGPQUIT)  D

 ..S BGPY=0 F  S BGPY=$O(^BGPPEIN(BGPIC,61,"B",BGPX,BGPY)) Q:BGPY'=+BGPY!(BGPQUIT)  D

 ...S BGPZ=0 F  S BGPZ=$O(^BGPPEIN(BGPIC,61,BGPY,11,BGPZ)) Q:BGPZ'=+BGPZ!(BGPQUIT)  D

 ....I $Y>(BGPIOSL-3) D HEADER Q:BGPQUIT

 ....W !,^BGPPEIN(BGPIC,61,BGPY,11,BGPZ,0)

 ....Q

 ...Q

 ..Q

 .I $Y>(BGPIOSL-3) D HEADER Q:BGPQUIT

 .W !!,"Numerator(s):"

 .S BGPX=0 F  S BGPX=$O(^BGPPEIN(BGPIC,62,"B",BGPX)) Q:BGPX'=+BGPX!(BGPQUIT)  D

 ..S BGPY=0 F  S BGPY=$O(^BGPPEIN(BGPIC,62,"B",BGPX,BGPY)) Q:BGPY'=+BGPY!(BGPQUIT)  D

 ...S BGPZ=0 F  S BGPZ=$O(^BGPPEIN(BGPIC,62,BGPY,11,BGPZ)) Q:BGPZ'=+BGPZ!(BGPQUIT)  D

 ....I $Y>(BGPIOSL-3) D HEADER Q:BGPQUIT

 ....W !,^BGPPEIN(BGPIC,62,BGPY,11,BGPZ,0)

 ....Q

 ...;W !

 ...Q

 ..Q

 .S BGPNODE=11

 .W ! S BGPX=0 F  S BGPX=$O(^BGPPEIN(BGPIC,BGPNODE,BGPX)) Q:BGPX'=+BGPX  D

 ..I $Y>(BGPIOSL-3) D HEADER Q:BGPQUIT

 ..W !,^BGPPEIN(BGPIC,BGPNODE,BGPX,0)

 .D @BGPIC

 .Q:BGPQUIT

 ;

 D ^BGP9DPEL

 D EXIT

 Q

1 ;

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

 D H1^BGP9DPH

 S BGPCYD=$$V(1,BGPRPT,11,1)

 S BGPPRD=$$V(2,BGPRPT,11,1)

 S BGPBLD=$$V(3,BGPRPT,11,1)

 W !!,"User Pop"

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

 S N=11,P=2 D SETN

 W !,"# w/ patient ed"

 D H2^BGP9DPH

 Q

2 ;

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

 D H1^BGP9DPH

 S BGPCYD=$$V(1,BGPRPT,11,7)

 S BGPPRD=$$V(2,BGPRPT,11,7)

 S BGPBLD=$$V(3,BGPRPT,11,7)

 W !!,"Total Time Spent",!,"Providing Education",!,"(mins)"

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

 K BGPPROVS

 S N=12 D SETNM

 K BGPX

 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)  D

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

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

 ..W !,$E($P(BGPX(BGP1,BGP2),U,2),1,20)

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

 I '$G(BGPAREAA) D

 .S BGPAA=$$V(1,BGPRPT,11,7)

 .S BGPAB=$$V(2,BGPRPT,11,7)

 .S BGPAC=$$V(3,BGPRPT,11,7)

 .S BGPCYN=$$V(1,BGPRPT,11,6)

 .S BGPPRN=$$V(2,BGPRPT,11,6)

 .S BGPBLN=$$V(3,BGPRPT,11,6)

 .S BGPCYD=$$V(1,BGPRPT,11,3)

 .S BGPPRD=$$V(2,BGPRPT,11,3)

 .S BGPBLD=$$V(3,BGPRPT,11,3)

 I $G(BGPAREAA) D

 .S BGPAA=$$V(1,BGPRPT,11,7)

 .S BGPAB=$$V(2,BGPRPT,11,7)

 .S BGPAC=$$V(3,BGPRPT,11,7)

 .S BGPCYN=$$V(1,BGPRPT,11,6)

 .S BGPPRN=$$V(2,BGPRPT,11,6)

 .S BGPBLN=$$V(3,BGPRPT,11,6)

 .S BGPCYD=$S(BGPAA:BGPAA/BGPCYN,1:0)

 .S BGPPRD=$S(BGPAB:BGPAB/BGPPRN,1:0)

 .S BGPBLD=$S(BGPAC:BGPAC/BGPBLN,1:0)

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

 W !!,"Total # of Minutes recorded",!,"for All Providers"

 W ?20,$$C(BGPAA,0,8),?35,$$C(BGPAB,0,8),?58,$$C(BGPAC,0,8),!

 W !,"Total # of Pt Ed Codes with Provider",!,"and minutes recorded"

 W ?20,$$C(BGPCYN,0,8),?35,$$C(BGPPRN,0,8),?58,$$C(BGPBLN,0,8)

 W !!,"Average Time Spent",!,"All Providers",!,"(minutes)"

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

 I $G(BGPAREAA) D

 .S BGPCYD=999999999,BGPBLD=999999999,BGPPRD=999999999

 .S X=0 F  S X=$O(BGPSUL(X)) Q:X'=+X  D

 ..I $P($G(^BGPPEDCN(X,11)),U,4)]"",$P($G(^BGPPEDCN(X,11)),U,4)<BGPCYD S BGPCYD=$P($G(^BGPPEDCN(X,11)),U,4)

 ..I $P($G(^BGPPEDPN(X,11)),U,4)]"",$P($G(^BGPPEDPN(X,11)),U,4)<BGPPRD S BGPPRD=$P($G(^BGPPEDPN(X,11)),U,4)

 ..I $P($G(^BGPPEDBN(X,11)),U,4)]"",$P($G(^BGPPEDBN(X,11)),U,4)<BGPBLD S BGPBLD=$P($G(^BGPPEDBN(X,11)),U,4)

 .I BGPCYD=999999999 S BGPCYD=""

 .I BGPBLD=999999999 S BGPBLD=""

 .I BGPPRD=999999999 S BGPPRD=""

 I '$G(BGPAREAA) D

 .S BGPCYD=$$V(1,BGPRPT,11,4)

 .S BGPPRD=$$V(2,BGPRPT,11,4)

 .S BGPBLD=$$V(3,BGPRPT,11,4)

 I $Y>(BGPIOSL-4) D HEADER Q:BGPQUIT  W !,$P(^BGPPEIN(BGPIC,0),U,2) D H1^BGP9DPH W !

 W !,"Minimum Time Spent",!,"All Providers",!,"(minutes)"

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

 I $G(BGPAREAA) D

 .S (BGPCYD,BGPPRD,BGPBLD)=""

 .S X=0 F  S X=$O(BGPSUL(X)) Q:X'=+X  D

 ..I $P($G(^BGPPEDCN(X,11)),U,5)>BGPCYD S BGPCYD=$P($G(^BGPPEDCN(X,11)),U,5)

 ..I $P($G(^BGPPEDPN(X,11)),U,5)>BGPPRD S BGPPRD=$P($G(^BGPPEDPN(X,11)),U,5)

 ..I $P($G(^BGPPEDBN(X,11)),U,5)>BGPBLD S BGPBLD=$P($G(^BGPPEDBN(X,11)),U,5)

 I '$G(BGPAREAA) D

 .S BGPCYD=$$V(1,BGPRPT,11,5)

 .S BGPPRD=$$V(2,BGPRPT,11,5)

 .S BGPBLD=$$V(3,BGPRPT,11,5)

 I $Y>(BGPIOSL-4) D HEADER Q:BGPQUIT  W !,$P(^BGPPEIN(BGPIC,0),U,2) D H1^BGP9DPH W !

 W !!,"Maximum Time Spent",!,"All Providers",!,"(minutes)"

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

 Q

3 ;

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

 D H1^BGP9DPH

 S BGPCYD=$$V(1,BGPRPT,11,8)

 S BGPPRD=$$V(2,BGPRPT,11,8)

 S BGPBLD=$$V(3,BGPRPT,11,8)

 W !!,"Total # Education",!,"Codes"

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

 K BGPPROVS

 S N=13 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>24)  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 Q:BGPQUIT  W !,$P(^BGPPEIN(BGPIC,0),U,2) D H1^BGP9DPH W !

 ..W !,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^BGP9DPH

 Q

4 ;

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

 D H1^BGP9DPH

 S BGPCYD=$$V(1,BGPRPT,11,9)

 S BGPPRD=$$V(2,BGPRPT,11,9)

 S BGPBLD=$$V(3,BGPRPT,11,9)

 W !!,"Total # Education",!,"Codes"

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

 K BGPPROVS

 S N=14 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>24)  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 Q:BGPQUIT  W !,$P(^BGPPEIN(BGPIC,0),U,2) D H1^BGP9DPH W !

 ..W !,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^BGP9DPH

 Q

5 ;

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

 D H1^BGP9DPH

 S BGPCYD=$$V(1,BGPRPT,11,10)

 S BGPPRD=$$V(2,BGPRPT,11,10)

 S BGPBLD=$$V(3,BGPRPT,11,10)

 W !!,"Total # Education",!,"Codes"

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

 K BGPPROVS

 S N=15 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 Q:BGPQUIT  W !,$P(^BGPPEIN(BGPIC,0),U,2) D H1^BGP9DPH W !

 ..W !,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^BGP9DPH

 Q

6 ;

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

 D H1^BGP9DPH

 S BGPCYD=$$V(1,BGPRPT,11,12)

 S BGPPRD=$$V(2,BGPRPT,11,12)

 S BGPBLD=$$V(3,BGPRPT,11,12)

 W !!,"Total # Education",!,"Codes"

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

 W !,"Patient Understanding"

 S N=11,P=15 D SETN

 W !,"Good"

 D H2^BGP9DPH

 S N=11,P=14 D SETN

 W !,"Fair"

 D H2^BGP9DPH

 S N=11,P=13 D SETN

 W !,"Poor"

 D H2^BGP9DPH

 S N=11,P=16 D SETN

 W !,"Refused"

 D H2^BGP9DPH

 S N=11,P=17 D SETN

 W !,"Group-No Assessment"

 D H2^BGP9DPH

 S N=11,P=18 D SETN

 W !,"Blank"," (Not recorded)"

 D H2^BGP9DPH

 Q

7 ;

 D 7^BGP9DPEQ

 Q

KITM ;

 K ^TMP($J)

 K ^XTMP("BGP9PE",BGPJ,BGPH)

 Q

HEADER ;EP

 G:'BGPGPG HEADER1

 K DIR I $E(IOST)="C",IO=IO(0),'$D(ZTQUEUED) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S BGPQUIT=1 Q

HEADER1 ;

 W:$D(IOF) @IOF S BGPGPG=BGPGPG+1

 I $G(BGPGUI) W "ZZZZZZZ",!  ;maw

 W $P(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",BGPGPG,!

 I '$G(BGPSEAT) W $$CTR("*** IHS 2009 Patient Education with Community Specified Report ***",80),!

 I $G(BGPSEAT) W $$CTR("*** IHS 2009 Patient Education with Patient Panel Population Report ***",80),!

 I $G(BGPAREAA) W $$CTR("AREA AGGREGATE",80),!

 I '$G(BGPAREAA) W $$CTR($P(^DIC(4,DUZ(2),0),U),80),!

 S X="Report Period: "_$$FMTE^XLFDT(BGPBD)_" to "_$$FMTE^XLFDT(BGPED) W $$CTR(X,80),!

 S X="Previous Year Period:  "_$$FMTE^XLFDT(BGPPBD)_" to "_$$FMTE^XLFDT(BGPPED) W $$CTR(X,80),!

 S X="Baseline Period:  "_$$FMTE^XLFDT(BGPBBD)_" to "_$$FMTE^XLFDT(BGPBED) W $$CTR(X,80),!

 W $TR($J("",80)," ","-")

 Q

EXIT ;

 I $E(IOST)="C",IO=IO(0),'$D(ZTQUEUED) W ! S DIR(0)="EO",DIR("A")="End of report.  Press ENTER" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 Q

C(X,X2,X3) ;EP

 D COMMA^%DTC

 Q X

S(Y,F,P) ;EP set up array

 I '$G(F) S F=0

 S %=$P(^TMP($J,"BGPDEL",0),U)+F,$P(^TMP($J,"BGPDEL",0),U)=%

 I '$D(^TMP($J,"BGPDEL",%)) S ^TMP($J,"BGPDEL",%)=""

 S $P(^TMP($J,"BGPDEL",%),U,P)=Y

 Q

CTR(X,Y) ;EP - Center X in a field Y wide.

 Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X

 ;----------

EOP ;EP - End of page.

 Q:$E(IOST)'="C"

 Q:$D(ZTQUEUED)!'(IOT="TRM")!$D(IO("S"))

 NEW DIR

 K DIRUT,DFOUT,DLOUT,DTOUT,DUOUT

 S DIR(0)="E" D ^DIR

 Q

 ;----------

USR() ;EP - Return name of current user from ^VA(200.

 Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")

 ;----------

SETNM ;

 K BGPPROVS

 I $G(BGPAREAA) D SETNMA Q

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

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

 .;I $D(BGPPROVS(C,L)) S $P(BGPPROVS(C,L),U,1)=M Q

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

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

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

 .;I $D(BGPPROVS(C,L)) S $P(BGPPROVS(C,L),U,2)=M Q

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

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

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

 .;I $D(BGPPROVS(C,L)) S $P(BGPPROVS(C,L),U,3)=M Q

 .S $P(BGPPROVS(C,L),U,3)=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(^BGPPEDCN(Z,N,X)) Q:X'=+X  D

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

 .;I $D(BGPPROVS(C,L)) S $P(BGPPROVS(C,L),U,1)=M Q

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

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

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

 .;I $D(BGPPROVS(C,L)) S $P(BGPPROVS(C,L),U,2)=M Q

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

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

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

 .;I $D(BGPPROVS(C,L)) S $P(BGPPROVS(C,L),U,3)=M Q

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

 .Q

 Q

SETN ;EP - set numerator fields

 S BGPCYN=$$V(1,BGPRPT,N,P,2) ;SPDX

 S BGPPRN=$$V(2,BGPRPT,N,P,2) ;SPDX

 S BGPBLN=$$V(3,BGPRPT,N,P,2) ;SPDX

 S BGPCYP=$S(BGPCYD:((BGPCYN/BGPCYD)*100),1:"")

 S BGPPRP=$S(BGPPRD:((BGPPRN/BGPPRD)*100),1:"")

 S BGPBLP=$S(BGPBLD:((BGPBLN/BGPBLD)*100),1:"")

 Q

SL(V) ;

 I V="" S V=0

 Q $$STRIP^XLFSTR($J(V,5,1)," ")

SETEXA(T,N,P) ;EP - set denominator

 Q:'$G(BGPEXCEL)

 NEW X,Y,Z

 S X=0 F  S X=$O(BGPSUL(X)) Q:X'=+X  D

 .I T=1 S $P(BGPEXCT(X,T),U,2)=$P($G(^BGPPEDCN(X,N)),U,P)

 .I T=2 S $P(BGPEXCT(X,T),U,2)=$P($G(^BGPPEDPN(X,N)),U,P)

 .I T=3 S $P(BGPEXCT(X,T),U,2)=$P($G(^BGPGPDBN(X,N)),U,P)

 Q

V(T,R,N,P,ND) ;EP ;SPDX

 I $G(BGPAREAA) G VA

 NEW X

 I T=1 S X=$P($G(^BGPPEDCN(R,N)),U,P) Q $S(X]"":X,1:0)

 I T=2 S X=$P($G(^BGPPEDPN(R,N)),U,P) Q $S(X]"":X,1:0)

 I T=3 S X=$P($G(^BGPPEDBN(R,N)),U,P) Q $S(X]"":X,1:0)

 Q ""

VA ;

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

 .I T=1 S C=C+$P($G(^BGPPEDCN(X,N)),U,P)

 .I T=2 S C=C+$P($G(^BGPPEDPN(X,N)),U,P)

 .I T=3 S C=C+$P($G(^BGPPEDBN(X,N)),U,P)

 .Q

 Q $S(C]"":C,1:0)

BGP9DPEP  ; IHS/CMI/LAB - IHS gpra print 01 Jul 2008 7:54 PM ; 

 +1       ;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009

 +2       ;

 +3       ;

PRINT     ;

 +1        SET BGPRTYPE=6

           SET BGP9RPTH=""

 +2        KILL ^TMP($JOB)

 +3        KILL BGPDELIM

 +4        IF BGPROT="D"

               GOTO DEL

 +5        SET BGPIOSL=$SELECT($GET(BGPGUI):55,1:$GET(IOSL))

 +6        DO ^BGP9DH

 +7        IF BGPQHDR

               DO KITM

               QUIT 

 +8        SET BGPGPG=0

 +9        SET BGPQUIT=""

 +10       DO PRINT1

 +11       KILL ^TMP($JOB)

 +12       IF BGPROT="P"