BGP1DPEP ; IHS/CMI/LAB - IHS gpra print 01 Jul 2010 7:54 PM ;
;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
;
;
PRINT ;
S BGPRTYPE=6,BGP1RPTH=""
K ^TMP($J)
K BGPDELIM
I BGPROT="D" G DEL
S BGPPTYPE="P"
S BGPIOSL=$S($G(BGPGUI):55,1:$G(IOSL))
D ^BGP1DH
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
S BGPPTYPE="D"
I '$D(BGPGUI) D ^%ZISC
K ^TMP($J)
S ^TMP($J,"BGPDEL",0)=0
S BGPQHDR=0
D DEL^BGP1DPED
K ^XTMP("BGP1PE",BGPJ,BGPH)
K ^TMP($J)
Q
WP ;
K ^UTILITY($J,"W")
S BGPZ=0,BGPLCNT=0
S DIWL=1,DIWR=80,DIWF="",BGPZ=0 F S BGPZ=$O(^BGPPEIB(BGPIC,BGPNODE,BGPY,11,BGPZ)) Q:BGPZ'=+BGPZ D
.S BGPLCNT=BGPLCNT+1
.S X=^BGPPEIB(BGPIC,BGPNODE,BGPY,11,BGPZ,0) S:BGPLCNT=1 X=" - "_X D ^DIWP
.Q
WPS ;
S Z=0 F S Z=$O(^UTILITY($J,"W",DIWL,Z)) Q:Z'=+Z D
.I $Y>(BGPIOSL-3) D HEADER^BGP1DPH Q:BGPQUIT
.W !,^UTILITY($J,"W",DIWL,Z,0)
K DIWL,DIWR,DIWF,Z
K ^UTILITY($J,"W"),X
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(^BGPPEIB(BGPIC,0),U,2)
.I $Y>(BGPIOSL-3) D HEADER Q:BGPQUIT
.W !!,"Denominator(s):"
.S BGPNODE=61
.S BGPX=0 F S BGPX=$O(^BGPPEIB(BGPIC,61,"B",BGPX)) Q:BGPX'=+BGPX!(BGPQUIT) D
..S BGPY=0 F S BGPY=$O(^BGPPEIB(BGPIC,61,"B",BGPX,BGPY)) Q:BGPY'=+BGPY!(BGPQUIT) D
...D WP
.I $Y>(BGPIOSL-3) D HEADER Q:BGPQUIT
.W !!,"Numerator(s):"
.S BGPNODE=62
.S BGPX=0 F S BGPX=$O(^BGPPEIB(BGPIC,62,"B",BGPX)) Q:BGPX'=+BGPX!(BGPQUIT) D
..S BGPY=0 F S BGPY=$O(^BGPPEIB(BGPIC,62,"B",BGPX,BGPY)) Q:BGPY'=+BGPY!(BGPQUIT) D
...D WP
.S BGPNODE=11
.W ! S BGPX=0 F S BGPX=$O(^BGPPEIB(BGPIC,BGPNODE,BGPX)) Q:BGPX'=+BGPX D
..I $Y>(BGPIOSL-3) D HEADER Q:BGPQUIT
..W !,^BGPPEIB(BGPIC,BGPNODE,BGPX,0)
.D @BGPIC
.Q:BGPQUIT
;
D ^BGP1DPEL
D EXIT
Q
1 ;
I $Y>(BGPIOSL-6) D HEADER Q:BGPQUIT W !,$P(^BGPPEIB(BGPIC,0),U,2)
D H1^BGP1DPH
S BGPCYD=$$V(1,BGPRPT,11,1)
S BGPPRD=$$V(2,BGPRPT,11,1)
S BGPBLD=$$V(3,BGPRPT,11,1)
I '$G(BGPSEAT) W !!,"User Pop"
I $G(BGPSEAT) W !!,$P(^DIBT(BGPSEAT,0),U,1),!," Population"
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^BGP1DPH
Q
2 ;
I $Y>(BGPIOSL-6) D HEADER Q:BGPQUIT W !,$P(^BGPPEIB(BGPIC,0),U,2)
D H1^BGP1DPH
S BGPCYD=$$V(1,BGPRPT,11,7)
S BGPPRD=$$V(2,BGPRPT,11,7)
S BGPBLD=$$V(3,BGPRPT,11,7)
I $G(BGPSEAT) W !!,$P(^DIBT(BGPSEAT,0),U,1)," Population"
W:'$G(BGPSEAT) ! 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(^BGPPEIB(BGPIC,0),U,2) D H1^BGP1DPH 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^BGP1DPH
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(^BGPPEIB(BGPIC,0),U,2) D H1^BGP1DPH 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(^BGPPEDCB(X,11)),U,4)]"",$P($G(^BGPPEDCB(X,11)),U,4)<BGPCYD S BGPCYD=$P($G(^BGPPEDCB(X,11)),U,4)
..I $P($G(^BGPPEDPB(X,11)),U,4)]"",$P($G(^BGPPEDPB(X,11)),U,4)<BGPPRD S BGPPRD=$P($G(^BGPPEDPB(X,11)),U,4)
..I $P($G(^BGPPEDBB(X,11)),U,4)]"",$P($G(^BGPPEDBB(X,11)),U,4)<BGPBLD S BGPBLD=$P($G(^BGPPEDBB(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(^BGPPEIB(BGPIC,0),U,2) D H1^BGP1DPH 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(^BGPPEDCB(X,11)),U,5)>BGPCYD S BGPCYD=$P($G(^BGPPEDCB(X,11)),U,5)
..I $P($G(^BGPPEDPB(X,11)),U,5)>BGPPRD S BGPPRD=$P($G(^BGPPEDPB(X,11)),U,5)
..I $P($G(^BGPPEDBB(X,11)),U,5)>BGPBLD S BGPBLD=$P($G(^BGPPEDBB(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(^BGPPEIB(BGPIC,0),U,2) D H1^BGP1DPH 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(^BGPPEIB(BGPIC,0),U,2)
D H1^BGP1DPH
S BGPCYD=$$V(1,BGPRPT,11,8)
S BGPPRD=$$V(2,BGPRPT,11,8)
S BGPBLD=$$V(3,BGPRPT,11,8)
I $G(BGPSEAT) W !!,$P(^DIBT(BGPSEAT,0),U,1)," Population"
W:'$G(BGPSEAT) ! 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(^BGPPEIB(BGPIC,0),U,2) D H1^BGP1DPH 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^BGP1DPH
Q
4 ;
I $Y>(BGPIOSL-6) D HEADER Q:BGPQUIT W !,$P(^BGPPEIB(BGPIC,0),U,2)
D H1^BGP1DPH
S BGPCYD=$$V(1,BGPRPT,11,9)
S BGPPRD=$$V(2,BGPRPT,11,9)
S BGPBLD=$$V(3,BGPRPT,11,9)
I $G(BGPSEAT) W !!,$P(^DIBT(BGPSEAT,0),U,1)," Population"
W:'$G(BGPSEAT) ! 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(^BGPPEIB(BGPIC,0),U,2) D H1^BGP1DPH 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^BGP1DPH
Q
5 ;
I $Y>(BGPIOSL-6) D HEADER Q:BGPQUIT W !,$P(^BGPPEIB(BGPIC,0),U,2)
D H1^BGP1DPH
S BGPCYD=$$V(1,BGPRPT,11,10)
S BGPPRD=$$V(2,BGPRPT,11,10)
S BGPBLD=$$V(3,BGPRPT,11,10)
I $G(BGPSEAT) W !!,$P(^DIBT(BGPSEAT,0),U,1)," Population"
W:'$G(BGPSEAT) ! 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(^BGPPEIB(BGPIC,0),U,2) D H1^BGP1DPH 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^BGP1DPH
Q
6 ;
I $Y>(BGPIOSL-6) D HEADER Q:BGPQUIT W !,$P(^BGPPEIB(BGPIC,0),U,2)
D H1^BGP1DPH
S BGPCYD=$$V(1,BGPRPT,11,12)
S BGPPRD=$$V(2,BGPRPT,11,12)
S BGPBLD=$$V(3,BGPRPT,11,12)
I $G(BGPSEAT) W !!,$P(^DIBT(BGPSEAT,0),U,1)," Population"
W:'$G(BGPSEAT) ! 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^BGP1DPH
S N=11,P=14 D SETN
W !,"Fair"
D H2^BGP1DPH
S N=11,P=13 D SETN
W !,"Poor"
D H2^BGP1DPH
S N=11,P=16 D SETN
W !,"Refused"
D H2^BGP1DPH
S N=11,P=17 D SETN
W !,"Group-No Assessment"
D H2^BGP1DPH
S N=11,P=18 D SETN
W !,"Blank"," (Not recorded)"
D H2^BGP1DPH
Q
7 ;
D 7^BGP1DPEQ
Q
KITM ;
K ^TMP($J)
K ^XTMP("BGP1PE",BGPJ,BGPH)
Q
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
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 2011 Patient Education with Community Specified Report ***",80),!
I $G(BGPSEAT) W $$CTR("*** IHS 2011 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(^BGPPEDCB(BGPRPT,N,X)) Q:X'=+X D
.S C=$P(^BGPPEDCB(BGPRPT,N,X,0),U),L=$P(^BGPPEDCB(BGPRPT,N,X,0),U,2),M=$P(^BGPPEDCB(BGPRPT,N,X,0),U,3)
.S $P(BGPPROVS(C,L),U,1)=M
S X=0 F S X=$O(^BGPPEDPB(BGPRPT,N,X)) Q:X'=+X D
.S C=$P(^BGPPEDPB(BGPRPT,N,X,0),U),L=$P(^BGPPEDPB(BGPRPT,N,X,0),U,2),M=$P(^BGPPEDPB(BGPRPT,N,X,0),U,3)
.S $P(BGPPROVS(C,L),U,2)=M
S X=0 F S X=$O(^BGPPEDBB(BGPRPT,N,X)) Q:X'=+X D
.S C=$P(^BGPPEDBB(BGPRPT,N,X,0),U),L=$P(^BGPPEDBB(BGPRPT,N,X,0),U,2),M=$P(^BGPPEDBB(BGPRPT,N,X,0),U,3)
.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(^BGPPEDCB(Z,N,X)) Q:X'=+X D
.S C=$P(^BGPPEDCB(Z,N,X,0),U),L=$P(^BGPPEDCB(Z,N,X,0),U,2),M=$P(^BGPPEDCB(Z,N,X,0),U,3)
.S $P(BGPPROVS(C,L),U,1)=$P($G(BGPPROVS(C,L)),U,1)+M
S X=0 F S X=$O(^BGPPEDPB(Z,N,X)) Q:X'=+X D
.S C=$P(^BGPPEDPB(Z,N,X,0),U),L=$P(^BGPPEDPB(Z,N,X,0),U,2),M=$P(^BGPPEDPB(Z,N,X,0),U,3)
.S $P(BGPPROVS(C,L),U,2)=$P($G(BGPPROVS(C,L)),U,2)+M
S X=0 F S X=$O(^BGPPEDBB(Z,N,X)) Q:X'=+X D
.S C=$P(^BGPPEDBB(Z,N,X,0),U),L=$P(^BGPPEDBB(Z,N,X,0),U,2),M=$P(^BGPPEDBB(Z,N,X,0),U,3)
.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(^BGPPEDCB(X,N)),U,P)
.I T=2 S $P(BGPEXCT(X,T),U,2)=$P($G(^BGPPEDPB(X,N)),U,P)
.I T=3 S $P(BGPEXCT(X,T),U,2)=$P($G(^BGPGPDBB(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(^BGPPEDCB(R,N)),U,P) Q $S(X]"":X,1:0)
I T=2 S X=$P($G(^BGPPEDPB(R,N)),U,P) Q $S(X]"":X,1:0)
I T=3 S X=$P($G(^BGPPEDBB(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(^BGPPEDCB(X,N)),U,P)
.I T=2 S C=C+$P($G(^BGPPEDPB(X,N)),U,P)
.I T=3 S C=C+$P($G(^BGPPEDBB(X,N)),U,P)
.Q
Q $S(C]"":C,1:0)
BGP1DPEP ; IHS/CMI/LAB - IHS gpra print 01 Jul 2010 7:54 PM ;
+1 ;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
+2 ;
+3 ;
PRINT ;
+1 SET BGPRTYPE=6
SET BGP1RPTH=""
+2 KILL ^TMP($JOB)
+3 KILL BGPDELIM
+4 IF BGPROT="D"
GOTO DEL
+5 SET BGPPTYPE="P"
+6 SET BGPIOSL=$SELECT($GET(BGPGUI):55,1:$GET(IOSL))
+7 DO ^BGP1DH
+8 IF BGPQHDR
DO KITM
QUIT
+9 SET BGPGPG=0
+10 SET BGPQUIT=""
+11 DO PRINT1
+12 KILL ^TMP($JOB)
+13 IF BGPROT="P"
DO KITM
QUIT
+14 ;
DEL ;create delimited output file
+1 SET BGPPTYPE="D"
+2 IF '$DATA(BGPGUI)
DO ^%ZISC
+3 KILL ^TMP($JOB)
+4 SET ^TMP($JOB,"BGPDEL",0)=0
+5 SET BGPQHDR=0
+6 DO DEL^BGP1DPED
+7 KILL ^XTMP("BGP1PE",BGPJ,BGPH)
+8 KILL ^TMP($JOB)
+9 QUIT
WP ;
+1 KILL ^UTILITY($JOB,"W")
+2 SET BGPZ=0
SET BGPLCNT=0
+3 SET DIWL=1
SET DIWR=80
SET DIWF=""
SET BGPZ=0
FOR
SET BGPZ=$ORDER(^BGPPEIB(BGPIC,BGPNODE,BGPY,11,BGPZ))
IF BGPZ'=+BGPZ
QUIT
Begin DoDot:1
+4 SET BGPLCNT=BGPLCNT+1
+5 SET X=^BGPPEIB(BGPIC,BGPNODE,BGPY,11,BGPZ,0)
IF BGPLCNT=1
SET X=" - "_X
DO ^DIWP
+6 QUIT
End DoDot:1
WPS ;
+1 SET Z=0
FOR
SET Z=$ORDER(^UTILITY($JOB,"W",DIWL,Z))
IF Z'=+Z
QUIT
Begin DoDot:1
+2 IF $Y>(BGPIOSL-3)
DO HEADER^BGP1DPH
IF BGPQUIT
QUIT
+3 WRITE !,^UTILITY($JOB,"W",DIWL,Z,0)
End DoDot:1
+4 KILL DIWL,DIWR,DIWF,Z
+5 KILL ^UTILITY($JOB,"W"),X
+6 QUIT
+7 ;
PRINT1 ;EP
+1 KILL ^TMP($JOB)
+2 SET BGPIC=0
FOR
SET BGPIC=$ORDER(BGPIND(BGPIC))
IF BGPIC=""!(BGPQUIT)
QUIT
Begin DoDot:1
+3 DO HEADER
+4 IF $Y>(BGPIOSL-3)
DO HEADER
IF BGPQUIT
QUIT
+5 WRITE !!,$PIECE(^BGPPEIB(BGPIC,0),U,2)
+6 IF $Y>(BGPIOSL-3)
DO HEADER
IF BGPQUIT
QUIT
+7 WRITE !!,"Denominator(s):"
+8 SET BGPNODE=61
+9 SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPPEIB(BGPIC,61,"B",BGPX))
IF BGPX'=+BGPX!(BGPQUIT)
QUIT
Begin DoDot:2
+10 SET BGPY=0
FOR
SET BGPY=$ORDER(^BGPPEIB(BGPIC,61,"B",BGPX,BGPY))
IF BGPY'=+BGPY!(BGPQUIT)
QUIT
Begin DoDot:3
+11 DO WP
End DoDot:3
End DoDot:2
+12 IF $Y>(BGPIOSL-3)
DO HEADER
IF BGPQUIT
QUIT
+13 WRITE !!,"Numerator(s):"
+14 SET BGPNODE=62
+15 SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPPEIB(BGPIC,62,"B",BGPX))
IF BGPX'=+BGPX!(BGPQUIT)
QUIT
Begin DoDot:2
+16 SET BGPY=0
FOR
SET BGPY=$ORDER(^BGPPEIB(BGPIC,62,"B",BGPX,BGPY))
IF BGPY'=+BGPY!(BGPQUIT)
QUIT
Begin DoDot:3
+17 DO WP
End DoDot:3
End DoDot:2
+18 SET BGPNODE=11
+19 WRITE !
SET BGPX=0
FOR
SET BGPX=$ORDER(^BGPPEIB(BGPIC,BGPNODE,BGPX))
IF BGPX'=+BGPX
QUIT
Begin DoDot:2
+20 IF $Y>(BGPIOSL-3)
DO HEADER
IF BGPQUIT
QUIT
+21 WRITE !,^BGPPEIB(BGPIC,BGPNODE,BGPX,0)
End DoDot:2
+22 DO @BGPIC
+23 IF BGPQUIT
QUIT
End DoDot:1
+24 ;
+25 DO ^BGP1DPEL
+26 DO EXIT
+27 QUIT
1 ;
+1 IF $Y>(BGPIOSL-6)
DO HEADER
IF BGPQUIT
QUIT
WRITE !,$PIECE(^BGPPEIB(BGPIC,0),U,2)
+2 DO H1^BGP1DPH
+3 SET BGPCYD=$$V(1,BGPRPT,11,1)
+4 SET BGPPRD=$$V(2,BGPRPT,11,1)
+5 SET BGPBLD=$$V(3,BGPRPT,11,1)
+6 IF '$GET(BGPSEAT)
WRITE !!,"User Pop"
+7 IF $GET(BGPSEAT)
WRITE !!,$PIECE(^DIBT(BGPSEAT,0),U,1),!," Population"
+8 WRITE ?20,$$C(BGPCYD,0,8),?35,$$C(BGPPRD,0,8),?58,$$C(BGPBLD,0,8),!
+9 SET N=11
SET P=2
DO SETN
+10 WRITE !,"# w/ patient ed"
+11 DO H2^BGP1DPH
+12 QUIT
2 ;
+1 IF $Y>(BGPIOSL-6)
DO HEADER
IF BGPQUIT
QUIT
WRITE !,$PIECE(^BGPPEIB(BGPIC,0),U,2)
+2 DO H1^BGP1DPH
+3 SET BGPCYD=$$V(1,BGPRPT,11,7)
+4 SET BGPPRD=$$V(2,BGPRPT,11,7)
+5 SET BGPBLD=$$V(3,BGPRPT,11,7)
+6 IF $GET(BGPSEAT)
WRITE !!,$PIECE(^DIBT(BGPSEAT,0),U,1)," Population"
+7 IF '$GET(BGPSEAT)
WRITE !
WRITE !,"Total Time Spent",!,"Providing Education",!,"(mins)"
+8 WRITE ?20,$$C(BGPCYD,0,8),?35,$$C(BGPPRD,0,8),?58,$$C(BGPBLD,0,8),!
+9 KILL BGPPROVS
+10 SET N=12
DO SETNM
+11 KILL BGPX
+12 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)
+13 SET BGP1=0
FOR
SET BGP1=$ORDER(BGPX(BGP1))
IF BGP1'=+BGP1!(BGPQUIT)
QUIT
Begin DoDot:1
+14 SET BGP2=0
FOR
SET BGP2=$ORDER(BGPX(BGP1,BGP2))
IF BGP2'=+BGP2!(BGPQUIT)
QUIT
Begin DoDot:2
+15 IF $Y>(BGPIOSL-3)
DO HEADER
IF BGPQUIT
QUIT
WRITE !,$PIECE(^BGPPEIB(BGPIC,0),U,2)
DO H1^BGP1DPH
WRITE !
+16 WRITE !,$EXTRACT($PIECE(BGPX(BGP1,BGP2),U,2),1,20)
+17 SET BGPCYN=$PIECE(BGPX(BGP1,BGP2),U,3)
+18 SET BGPPRN=$PIECE(BGPX(BGP1,BGP2),U,4)
+19 SET BGPBLN=$PIECE(BGPX(BGP1,BGP2),U,5)
+20 SET BGPCYP=$PIECE(BGPX(BGP1,BGP2),U,6)
+21 SET BGPPRP=$PIECE(BGPX(BGP1,BGP2),U,7)
+22 SET BGPBLP=$PIECE(BGPX(BGP1,BGP2),U,8)
+23 DO H2^BGP1DPH
End DoDot:2
End DoDot:1
+24 IF '$GET(BGPAREAA)
Begin DoDot:1
+25 SET BGPAA=$$V(1,BGPRPT,11,7)
+26 SET BGPAB=$$V(2,BGPRPT,11,7)
+27 SET BGPAC=$$V(3,BGPRPT,11,7)
+28 SET BGPCYN=$$V(1,BGPRPT,11,6)
+29 SET BGPPRN=$$V(2,BGPRPT,11,6)
+30 SET BGPBLN=$$V(3,BGPRPT,11,6)
+31 SET BGPCYD=$$V(1,BGPRPT,11,3)
+32 SET BGPPRD=$$V(2,BGPRPT,11,3)
+33 SET BGPBLD=$$V(3,BGPRPT,11,3)
End DoDot:1
+34 IF $GET(BGPAREAA)
Begin DoDot:1
+35 SET BGPAA=$$V(1,BGPRPT,11,7)
+36 SET BGPAB=$$V(2,BGPRPT,11,7)
+37 SET BGPAC=$$V(3,BGPRPT,11,7)
+38 SET BGPCYN=$$V(1,BGPRPT,11,6)
+39 SET BGPPRN=$$V(2,BGPRPT,11,6)
+40 SET BGPBLN=$$V(3,BGPRPT,11,6)
+41 SET BGPCYD=$SELECT(BGPAA:BGPAA/BGPCYN,1:0)
+42 SET BGPPRD=$SELECT(BGPAB:BGPAB/BGPPRN,1:0)
+43 SET BGPBLD=$SELECT(BGPAC:BGPAC/BGPBLN,1:0)
End DoDot:1
+44 IF $Y>(BGPIOSL-6)
DO HEADER
IF BGPQUIT
QUIT
WRITE !,$PIECE(^BGPPEIB(BGPIC,0),U,2)
DO H1^BGP1DPH
WRITE !
+45 WRITE !!,"Total # of Minutes recorded",!,"for All Providers"
+46 WRITE ?20,$$C(BGPAA,0,8),?35,$$C(BGPAB,0,8),?58,$$C(BGPAC,0,8),!
+47 WRITE !,"Total # of Pt Ed Codes with Provider",!,"and minutes recorded"
+48 WRITE ?20,$$C(BGPCYN,0,8),?35,$$C(BGPPRN,0,8),?58,$$C(BGPBLN,0,8)
+49 WRITE !!,"Average Time Spent",!,"All Providers",!,"(minutes)"
+50 WRITE ?20,$$C(BGPCYD,0,8),?35,$$C(BGPPRD,0,8),?58,$$C(BGPBLD,0,8),!
+51 IF $GET(BGPAREAA)
Begin DoDot:1
+52 SET BGPCYD=999999999
SET BGPBLD=999999999
SET BGPPRD=999999999
+53 SET X=0
FOR
SET X=$ORDER(BGPSUL(X))
IF X'=+X
QUIT
Begin DoDot:2
+54 IF $PIECE($GET(^BGPPEDCB(X,11)),U,4)]""
IF $PIECE($GET(^BGPPEDCB(X,11)),U,4)<BGPCYD
SET BGPCYD=$PIECE($GET(^BGPPEDCB(X,11)),U,4)
+55 IF $PIECE($GET(^BGPPEDPB(X,11)),U,4)]""
IF $PIECE($GET(^BGPPEDPB(X,11)),U,4)<BGPPRD
SET BGPPRD=$PIECE($GET(^BGPPEDPB(X,11)),U,4)
+56 IF $PIECE($GET(^BGPPEDBB(X,11)),U,4)]""
IF $PIECE($GET(^BGPPEDBB(X,11)),U,4)<BGPBLD
SET BGPBLD=$PIECE($GET(^BGPPEDBB(X,11)),U,4)
End DoDot:2
+57 IF BGPCYD=999999999
SET BGPCYD=""
+58 IF BGPBLD=999999999
SET BGPBLD=""
+59 IF BGPPRD=999999999
SET BGPPRD=""
End DoDot:1
+60 IF '$GET(BGPAREAA)
Begin DoDot:1
+61 SET BGPCYD=$$V(1,BGPRPT,11,4)
+62 SET BGPPRD=$$V(2,BGPRPT,11,4)
+63 SET BGPBLD=$$V(3,BGPRPT,11,4)
End DoDot:1
+64 IF $Y>(BGPIOSL-4)
DO HEADER
IF BGPQUIT
QUIT
WRITE !,$PIECE(^BGPPEIB(BGPIC,0),U,2)
DO H1^BGP1DPH
WRITE !
+65 WRITE !,"Minimum Time Spent",!,"All Providers",!,"(minutes)"
+66 WRITE ?20,$$C(BGPCYD,0,8),?35,$$C(BGPPRD,0,8),?58,$$C(BGPBLD,0,8),!
+67 IF $GET(BGPAREAA)
Begin DoDot:1
+68 SET (BGPCYD,BGPPRD,BGPBLD)=""
+69 SET X=0
FOR
SET X=$ORDER(BGPSUL(X))
IF X'=+X
QUIT
Begin DoDot:2
+70 IF $PIECE($GET(^BGPPEDCB(X,11)),U,5)>BGPCYD
SET BGPCYD=$PIECE($GET(^BGPPEDCB(X,11)),U,5)
+71 IF $PIECE($GET(^BGPPEDPB(X,11)),U,5)>BGPPRD
SET BGPPRD=$PIECE($GET(^BGPPEDPB(X,11)),U,5)
+72 IF $PIECE($GET(^BGPPEDBB(X,11)),U,5)>BGPBLD
SET BGPBLD=$PIECE($GET(^BGPPEDBB(X,11)),U,5)
End DoDot:2
End DoDot:1
+73 IF '$GET(BGPAREAA)
Begin DoDot:1
+74 SET BGPCYD=$$V(1,BGPRPT,11,5)
+75 SET BGPPRD=$$V(2,BGPRPT,11,5)
+76 SET BGPBLD=$$V(3,BGPRPT,11,5)
End DoDot:1
+77 IF $Y>(BGPIOSL-4)
DO HEADER
IF BGPQUIT
QUIT
WRITE !,$PIECE(^BGPPEIB(BGPIC,0),U,2)
DO H1^BGP1DPH
WRITE !
+78 WRITE !!,"Maximum Time Spent",!,"All Providers",!,"(minutes)"
+79 WRITE ?20,$$C(BGPCYD,0,8),?35,$$C(BGPPRD,0,8),?58,$$C(BGPBLD,0,8),!
+80 QUIT
3 ;
+1 IF $Y>(BGPIOSL-6)
DO HEADER
IF BGPQUIT
QUIT
WRITE !,$PIECE(^BGPPEIB(BGPIC,0),U,2)
+2 DO H1^BGP1DPH
+3 SET BGPCYD=$$V(1,BGPRPT,11,8)
+4 SET BGPPRD=$$V(2,BGPRPT,11,8)
+5 SET BGPBLD=$$V(3,BGPRPT,11,8)
+6 IF $GET(BGPSEAT)
WRITE !!,$PIECE(^DIBT(BGPSEAT,0),U,1)," Population"
+7 IF '$GET(BGPSEAT)
WRITE !
WRITE !,"Total # Education",!,"Codes"
+8 WRITE ?20,$$C(BGPCYD,0,8),?35,$$C(BGPPRD,0,8),?58,$$C(BGPBLD,0,8),!
+9 KILL BGPPROVS
+10 SET N=13
DO SETNM
+11 KILL BGPX
+12 SET BGPCNT=0
+13 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)
+14 SET BGP1=0
FOR
SET BGP1=$ORDER(BGPX(BGP1))
IF BGP1'=+BGP1!(BGPQUIT)!(BGPCNT>24)
QUIT
Begin DoDot:1
+15 SET BGPCNT=BGPCNT+1
SET BGP2=0
FOR
SET BGP2=$ORDER(BGPX(BGP1,BGP2))
IF BGP2'=+BGP2!(BGPQUIT)
QUIT
Begin DoDot:2
+16 IF $Y>(BGPIOSL-3)
DO HEADER
IF BGPQUIT
QUIT
WRITE !,$PIECE(^BGPPEIB(BGPIC,0),U,2)
DO H1^BGP1DPH
WRITE !
+17 WRITE !,BGPCNT,". ",$EXTRACT($PIECE(BGPX(BGP1,BGP2),U,2),1,15)
+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^BGP1DPH
End DoDot:2
End DoDot:1
+25 QUIT
4 ;
+1 IF $Y>(BGPIOSL-6)
DO HEADER
IF BGPQUIT
QUIT
WRITE !,$PIECE(^BGPPEIB(BGPIC,0),U,2)
+2 DO H1^BGP1DPH
+3 SET BGPCYD=$$V(1,BGPRPT,11,9)
+4 SET BGPPRD=$$V(2,BGPRPT,11,9)
+5 SET BGPBLD=$$V(3,BGPRPT,11,9)
+6 IF $GET(BGPSEAT)
WRITE !!,$PIECE(^DIBT(BGPSEAT,0),U,1)," Population"
+7 IF '$GET(BGPSEAT)
WRITE !
WRITE !,"Total # Education",!,"Codes"
+8 WRITE ?20,$$C(BGPCYD,0,8),?35,$$C(BGPPRD,0,8),?58,$$C(BGPBLD,0,8),!
+9 KILL BGPPROVS
+10 SET N=14
DO SETNM
+11 KILL BGPX
+12 SET BGPCNT=0
+13 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)
+14 SET BGP1=0
FOR
SET BGP1=$ORDER(BGPX(BGP1))
IF BGP1'=+BGP1!(BGPQUIT)!(BGPCNT>24)
QUIT
Begin DoDot:1
+15 SET BGPCNT=BGPCNT+1
SET BGP2=0
FOR
SET BGP2=$ORDER(BGPX(BGP1,BGP2))
IF BGP2'=+BGP2!(BGPQUIT)
QUIT
Begin DoDot:2
+16 IF $Y>(BGPIOSL-3)
DO HEADER
IF BGPQUIT
QUIT
WRITE !,$PIECE(^BGPPEIB(BGPIC,0),U,2)
DO H1^BGP1DPH
WRITE !
+17 WRITE !,BGPCNT,". ",$EXTRACT($PIECE(BGPX(BGP1,BGP2),U,2),1,15)
+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^BGP1DPH
End DoDot:2
End DoDot:1
+25 QUIT
5 ;
+1 IF $Y>(BGPIOSL-6)
DO HEADER
IF BGPQUIT
QUIT
WRITE !,$PIECE(^BGPPEIB(BGPIC,0),U,2)
+2 DO H1^BGP1DPH
+3 SET BGPCYD=$$V(1,BGPRPT,11,10)
+4 SET BGPPRD=$$V(2,BGPRPT,11,10)
+5 SET BGPBLD=$$V(3,BGPRPT,11,10)
+6 IF $GET(BGPSEAT)
WRITE !!,$PIECE(^DIBT(BGPSEAT,0),U,1)," Population"
+7 IF '$GET(BGPSEAT)
WRITE !
WRITE !,"Total # Education",!,"Codes"
+8 WRITE ?20,$$C(BGPCYD,0,8),?35,$$C(BGPPRD,0,8),?58,$$C(BGPBLD,0,8),!
+9 KILL BGPPROVS
+10 SET N=15
DO SETNM
+11 KILL BGPX
+12 SET BGPCNT=0
+13 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)
+14 SET BGP1=0
FOR
SET BGP1=$ORDER(BGPX(BGP1))
IF BGP1'=+BGP1!(BGPQUIT)!(BGPCNT>15)
QUIT
Begin DoDot:1
+15 SET BGPCNT=BGPCNT+1
SET BGP2=0
FOR
SET BGP2=$ORDER(BGPX(BGP1,BGP2))
IF BGP2'=+BGP2!(BGPQUIT)
QUIT
Begin DoDot:2
+16 IF $Y>(BGPIOSL-3)
DO HEADER
IF BGPQUIT
QUIT
WRITE !,$PIECE(^BGPPEIB(BGPIC,0),U,2)
DO H1^BGP1DPH
WRITE !
+17 WRITE !,BGPCNT,". ",$EXTRACT($PIECE(BGPX(BGP1,BGP2),U,2),1,15)
+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^BGP1DPH
End DoDot:2
End DoDot:1
+25 QUIT
6 ;
+1 IF $Y>(BGPIOSL-6)
DO HEADER
IF BGPQUIT
QUIT
WRITE !,$PIECE(^BGPPEIB(BGPIC,0),U,2)
+2 DO H1^BGP1DPH
+3 SET BGPCYD=$$V(1,BGPRPT,11,12)
+4 SET BGPPRD=$$V(2,BGPRPT,11,12)
+5 SET BGPBLD=$$V(3,BGPRPT,11,12)
+6 IF $GET(BGPSEAT)
WRITE !!,$PIECE(^DIBT(BGPSEAT,0),U,1)," Population"
+7 IF '$GET(BGPSEAT)
WRITE !
WRITE !,"Total # Education",!,"Codes"
+8 WRITE ?20,$$C(BGPCYD,0,8),?35,$$C(BGPPRD,0,8),?58,$$C(BGPBLD,0,8),!
+9 WRITE !,"Patient Understanding"
+10 SET N=11
SET P=15
DO SETN
+11 WRITE !,"Good"
+12 DO H2^BGP1DPH
+13 SET N=11
SET P=14
DO SETN
+14 WRITE !,"Fair"
+15 DO H2^BGP1DPH
+16 SET N=11
SET P=13
DO SETN
+17 WRITE !,"Poor"
+18 DO H2^BGP1DPH
+19 SET N=11
SET P=16
DO SETN
+20 WRITE !,"Refused"
+21 DO H2^BGP1DPH
+22 SET N=11
SET P=17
DO SETN
+23 WRITE !,"Group-No Assessment"
+24 DO H2^BGP1DPH
+25 SET N=11
SET P=18
DO SETN
+26 WRITE !,"Blank"," (Not recorded)"
+27 DO H2^BGP1DPH
+28 QUIT
7 ;
+1 DO 7^BGP1DPEQ
+2 QUIT
KITM ;
+1 KILL ^TMP($JOB)
+2 KILL ^XTMP("BGP1PE",BGPJ,BGPH)
+3 QUIT
+1 IF 'BGPGPG
GOTO HEADER1
+2 KILL DIR
IF $EXTRACT(IOST)="C"
IF IO=IO(0)
IF '$DATA(ZTQUEUED)
WRITE !
SET DIR(0)="EO"
DO ^DIR
KILL DIR
IF Y=0!(Y="^")!($DATA(DTOUT))
SET BGPQUIT=1
QUIT
+1 IF $DATA(IOF)
WRITE @IOF
SET BGPGPG=BGPGPG+1
+2 ;maw
IF $GET(BGPGUI)
WRITE "ZZZZZZZ",!
+3 WRITE $PIECE(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",BGPGPG,!
+4 IF '$GET(BGPSEAT)
WRITE $$CTR("*** IHS 2011 Patient Education with Community Specified Report ***",80),!
+5 IF $GET(BGPSEAT)
WRITE $$CTR("*** IHS 2011 Patient Education with Patient Panel Population Report ***",80),!
+6 IF $GET(BGPAREAA)
WRITE $$CTR("AREA AGGREGATE",80),!
+7 IF '$GET(BGPAREAA)
WRITE $$CTR($PIECE(^DIC(4,DUZ(2),0),U),80),!
+8 SET X="Report Period: "_$$FMTE^XLFDT(BGPBD)_" to "_$$FMTE^XLFDT(BGPED)
WRITE $$CTR(X,80),!
+9 SET X="Previous Year Period: "_$$FMTE^XLFDT(BGPPBD)_" to "_$$FMTE^XLFDT(BGPPED)
WRITE $$CTR(X,80),!
+10 SET X="Baseline Period: "_$$FMTE^XLFDT(BGPBBD)_" to "_$$FMTE^XLFDT(BGPBED)
WRITE $$CTR(X,80),!
+11 WRITE $TRANSLATE($JUSTIFY("",80)," ","-")
+12 QUIT
EXIT ;
+1 IF $EXTRACT(IOST)="C"
IF IO=IO(0)
IF '$DATA(ZTQUEUED)
WRITE !
SET DIR(0)="EO"
SET DIR("A")="End of report. Press ENTER"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 QUIT
C(X,X2,X3) ;EP
+1 DO COMMA^%DTC
+2 QUIT X
S(Y,F,P) ;EP set up array
+1 IF '$GET(F)
SET F=0
+2 SET %=$PIECE(^TMP($JOB,"BGPDEL",0),U)+F
SET $PIECE(^TMP($JOB,"BGPDEL",0),U)=%
+3 IF '$DATA(^TMP($JOB,"BGPDEL",%))
SET ^TMP($JOB,"BGPDEL",%)=""
+4 SET $PIECE(^TMP($JOB,"BGPDEL",%),U,P)=Y
+5 QUIT
CTR(X,Y) ;EP - Center X in a field Y wide.
+1 QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X
+2 ;----------
EOP ;EP - End of page.
+1 IF $EXTRACT(IOST)'="C"
QUIT
+2 IF $DATA(ZTQUEUED)!'(IOT="TRM")!$DATA(IO("S"))
QUIT
+3 NEW DIR
+4 KILL DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
+5 SET DIR(0)="E"
DO ^DIR
+6 QUIT
+7 ;----------
USR() ;EP - Return name of current user from ^VA(200.
+1 QUIT $SELECT($GET(DUZ):$SELECT($DATA(^VA(200,DUZ,0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
+2 ;----------
SETNM ;
+1 KILL BGPPROVS
+2 IF $GET(BGPAREAA)
DO SETNMA
QUIT
+3 SET X=0
FOR
SET X=$ORDER(^BGPPEDCB(BGPRPT,N,X))
IF X'=+X
QUIT
Begin DoDot:1
+4 SET C=$PIECE(^BGPPEDCB(BGPRPT,N,X,0),U)
SET L=$PIECE(^BGPPEDCB(BGPRPT,N,X,0),U,2)
SET M=$PIECE(^BGPPEDCB(BGPRPT,N,X,0),U,3)
+5 SET $PIECE(BGPPROVS(C,L),U,1)=M
End DoDot:1
+6 SET X=0
FOR
SET X=$ORDER(^BGPPEDPB(BGPRPT,N,X))
IF X'=+X
QUIT
Begin DoDot:1
+7 SET C=$PIECE(^BGPPEDPB(BGPRPT,N,X,0),U)
SET L=$PIECE(^BGPPEDPB(BGPRPT,N,X,0),U,2)
SET M=$PIECE(^BGPPEDPB(BGPRPT,N,X,0),U,3)
+8 SET $PIECE(BGPPROVS(C,L),U,2)=M
End DoDot:1
+9 SET X=0
FOR
SET X=$ORDER(^BGPPEDBB(BGPRPT,N,X))
IF X'=+X
QUIT
Begin DoDot:1
+10 SET C=$PIECE(^BGPPEDBB(BGPRPT,N,X,0),U)
SET L=$PIECE(^BGPPEDBB(BGPRPT,N,X,0),U,2)
SET M=$PIECE(^BGPPEDBB(BGPRPT,N,X,0),U,3)
+11 SET $PIECE(BGPPROVS(C,L),U,3)=M
End DoDot:1
+12 ;set %ages
+13 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
+14 SET A=$PIECE(BGPPROVS(X,Y),U,1)
SET $PIECE(BGPPROVS(X,Y),U,4)=$SELECT(BGPCYD:((A/BGPCYD)*100),1:"")
+15 SET B=$PIECE(BGPPROVS(X,Y),U,2)
SET $PIECE(BGPPROVS(X,Y),U,5)=$SELECT(BGPPRD:((B/BGPPRD)*100),1:"")
+16 SET C=$PIECE(BGPPROVS(X,Y),U,3)
SET $PIECE(BGPPROVS(X,Y),U,6)=$SELECT(BGPBLD:((C/BGPBLD)*100),1:"")
+17 QUIT
End DoDot:1
+18 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(^BGPPEDCB(Z,N,X))
IF X'=+X
QUIT
Begin DoDot:1
+2 SET C=$PIECE(^BGPPEDCB(Z,N,X,0),U)
SET L=$PIECE(^BGPPEDCB(Z,N,X,0),U,2)
SET M=$PIECE(^BGPPEDCB(Z,N,X,0),U,3)
+3 SET $PIECE(BGPPROVS(C,L),U,1)=$PIECE($GET(BGPPROVS(C,L)),U,1)+M
End DoDot:1
+4 SET X=0
FOR
SET X=$ORDER(^BGPPEDPB(Z,N,X))
IF X'=+X
QUIT
Begin DoDot:1
+5 SET C=$PIECE(^BGPPEDPB(Z,N,X,0),U)
SET L=$PIECE(^BGPPEDPB(Z,N,X,0),U,2)
SET M=$PIECE(^BGPPEDPB(Z,N,X,0),U,3)
+6 SET $PIECE(BGPPROVS(C,L),U,2)=$PIECE($GET(BGPPROVS(C,L)),U,2)+M
End DoDot:1
+7 SET X=0
FOR
SET X=$ORDER(^BGPPEDBB(Z,N,X))
IF X'=+X
QUIT
Begin DoDot:1
+8 SET C=$PIECE(^BGPPEDBB(Z,N,X,0),U)
SET L=$PIECE(^BGPPEDBB(Z,N,X,0),U,2)
SET M=$PIECE(^BGPPEDBB(Z,N,X,0),U,3)
+9 SET $PIECE(BGPPROVS(C,L),U,3)=$PIECE($GET(BGPPROVS(C,L)),U,3)+M
+10 QUIT
End DoDot:1
+11 QUIT
SETN ;EP - set numerator fields
+1 ;SPDX
SET BGPCYN=$$V(1,BGPRPT,N,P,2)
+2 ;SPDX
SET BGPPRN=$$V(2,BGPRPT,N,P,2)
+3 ;SPDX
SET BGPBLN=$$V(3,BGPRPT,N,P,2)
+4 SET BGPCYP=$SELECT(BGPCYD:((BGPCYN/BGPCYD)*100),1:"")
+5 SET BGPPRP=$SELECT(BGPPRD:((BGPPRN/BGPPRD)*100),1:"")
+6 SET BGPBLP=$SELECT(BGPBLD:((BGPBLN/BGPBLD)*100),1:"")
+7 QUIT
SL(V) ;
+1 IF V=""
SET V=0
+2 QUIT $$STRIP^XLFSTR($JUSTIFY(V,5,1)," ")
SETEXA(T,N,P) ;EP - set denominator
+1 IF '$GET(BGPEXCEL)
QUIT
+2 NEW X,Y,Z
+3 SET X=0
FOR
SET X=$ORDER(BGPSUL(X))
IF X'=+X
QUIT
Begin DoDot:1
+4 IF T=1
SET $PIECE(BGPEXCT(X,T),U,2)=$PIECE($GET(^BGPPEDCB(X,N)),U,P)
+5 IF T=2
SET $PIECE(BGPEXCT(X,T),U,2)=$PIECE($GET(^BGPPEDPB(X,N)),U,P)
+6 IF T=3
SET $PIECE(BGPEXCT(X,T),U,2)=$PIECE($GET(^BGPGPDBB(X,N)),U,P)
End DoDot:1
+7 QUIT
V(T,R,N,P,ND) ;EP ;SPDX
+1 IF $GET(BGPAREAA)
GOTO VA
+2 NEW X
+3 IF T=1
SET X=$PIECE($GET(^BGPPEDCB(R,N)),U,P)
QUIT $SELECT(X]"":X,1:0)
+4 IF T=2
SET X=$PIECE($GET(^BGPPEDPB(R,N)),U,P)
QUIT $SELECT(X]"":X,1:0)
+5 IF T=3
SET X=$PIECE($GET(^BGPPEDBB(R,N)),U,P)
QUIT $SELECT(X]"":X,1:0)
+6 QUIT ""
VA ;
+1 NEW X,V,C
SET X=0
SET C=""
FOR
SET X=$ORDER(BGPSUL(X))
IF X'=+X
QUIT
Begin DoDot:1
+2 IF T=1
SET C=C+$PIECE($GET(^BGPPEDCB(X,N)),U,P)
+3 IF T=2
SET C=C+$PIECE($GET(^BGPPEDPB(X,N)),U,P)
+4 IF T=3
SET C=C+$PIECE($GET(^BGPPEDBB(X,N)),U,P)
+5 QUIT
End DoDot:1
+6 QUIT $SELECT(C]"":C,1:0)
