Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BGP7DPEP

BGP7DPEP.m

Go to the documentation of this file. 
  1. BGP7DPEP ; IHS/CMI/LAB - IHS gpra print 01 Jul 2010 7:54 PM 27 Jan 2017 12:32 PM ; 
  1.  ;;17.1;IHS CLINICAL REPORTING;;MAY 10, 2017;Build 29
  1.  ;
  1.  ;
  1. PRINT ;
  1.  S BGPRTYPE=6,BGPYRPTH=""
  1.  K ^TMP($J)
  1.  K BGPDELIM
  1.  I BGPROT="D" G DEL
  1.  S BGPPTYPE="P"
  1.  S BGPIOSL=$S($G(BGPGUI):55,1:$G(IOSL))
  1.  D ^BGP7DH
  1.  I BGPQHDR D KITM Q
  1.  S BGPGPG=0
  1.  S BGPQUIT=""
  1.  D PRINT1
  1.  K ^TMP($J)
  1.  I BGPROT="P" D KITM Q
  1.  ;
  1. DEL ;create delimited output file
  1.  S BGPPTYPE="D"
  1.  I '$D(BGPGUI) D ^%ZISC
  1.  K ^TMP($J)
  1.  S ^TMP($J,"BGPDEL",0)=0
  1.  S BGPQHDR=0
  1.  D DEL^BGP7DPED
  1.  K ^XTMP("BGP7PE",BGPJ,BGPH)
  1.  K ^TMP($J)
  1.  Q
  1. WP ;
  1.  K ^UTILITY($J,"W")
  1.  S BGPZ=0,BGPLCNT=0
  1.  S DIWL=1,DIWR=80,DIWF="",BGPZ=0 F  S BGPZ=$O(^BGPPEIG(BGPIC,BGPNODE,BGPY,11,BGPZ)) Q:BGPZ'=+BGPZ  D
  1.  .S BGPLCNT=BGPLCNT+1
  1.  .S X=^BGPPEIG(BGPIC,BGPNODE,BGPY,11,BGPZ,0) S:BGPLCNT=1 X=" - "_X D ^DIWP
  1.  .Q
  1. WPS ;
  1.  S Z=0 F  S Z=$O(^UTILITY($J,"W",DIWL,Z)) Q:Z'=+Z  D
  1.  .I $Y>(BGPIOSL-3) D HEADER^BGP7DPH Q:BGPQUIT
  1.  .W !,^UTILITY($J,"W",DIWL,Z,0)
  1.  K DIWL,DIWR,DIWF,Z
  1.  K ^UTILITY($J,"W"),X
  1.  Q
  1.  ;
  1. PRINT1 ;EP
  1.  K ^TMP($J)
  1.  S BGPIC=0 F  S BGPIC=$O(BGPIND(BGPIC)) Q:BGPIC=""!(BGPQUIT)  D
  1.  .D HEADER
  1.  .I $Y>(BGPIOSL-3) D HEADER Q:BGPQUIT
  1.  .W !!,$P(^BGPPEIG(BGPIC,0),U,2)
  1.  .I $G(BGPDNT) G CALC
  1.  .I $Y>(BGPIOSL-3) D HEADER Q:BGPQUIT
  1.  .W !!,"Denominator(s):"
  1.  .S BGPNODE=61
  1.  .S BGPX=0 F  S BGPX=$O(^BGPPEIG(BGPIC,61,"B",BGPX)) Q:BGPX'=+BGPX!(BGPQUIT)  D
  1.  ..S BGPY=0 F  S BGPY=$O(^BGPPEIG(BGPIC,61,"B",BGPX,BGPY)) Q:BGPY'=+BGPY!(BGPQUIT)  D
  1.  ...D WP
  1.  .I $Y>(BGPIOSL-3) D HEADER Q:BGPQUIT
  1.  .W !!,"Numerator(s):"
  1.  .S BGPNODE=62
  1.  .S BGPX=0 F  S BGPX=$O(^BGPPEIG(BGPIC,62,"B",BGPX)) Q:BGPX'=+BGPX!(BGPQUIT)  D
  1.  ..S BGPY=0 F  S BGPY=$O(^BGPPEIG(BGPIC,62,"B",BGPX,BGPY)) Q:BGPY'=+BGPY!(BGPQUIT)  D
  1.  ...D WP
  1.  .S BGPNODE=11
  1.  .W ! S BGPX=0 F  S BGPX=$O(^BGPPEIG(BGPIC,BGPNODE,BGPX)) Q:BGPX'=+BGPX  D
  1.  ..I $Y>(BGPIOSL-3) D HEADER Q:BGPQUIT
  1.  ..W !,^BGPPEIG(BGPIC,BGPNODE,BGPX,0)
  1. CALC .D @BGPIC
  1.  .Q:BGPQUIT
  1.  ;
  1.  D ^BGP7DPEL
  1.  D EXIT
  1.  Q
  1. 1 ;
  1.  I $Y>(BGPIOSL-6) D HEADER Q:BGPQUIT  W !,$P(^BGPPEIG(BGPIC,0),U,2)
  1.  D H1^BGP7DPH
  1.  S BGPCYD=$$V(1,BGPRPT,11,1)
  1.  S BGPPRD=$$V(2,BGPRPT,11,1)
  1.  S BGPBLD=$$V(3,BGPRPT,11,1)
  1.  I '$G(BGPSEAT) W !!,"User Pop"
  1.  I $G(BGPSEAT) W !!,$P(^DIBT(BGPSEAT,0),U,1),!," Population"
  1.  W ?20,$$C(BGPCYD,0,8),?35,$$C(BGPPRD,0,8),?58,$$C(BGPBLD,0,8),!
  1.  S N=11,P=2 D SETN
  1.  W !,"# w/ Patient Ed"
  1.  D H2^BGP7DPH
  1.  Q
  1. 2 ;
  1.  I $Y>(BGPIOSL-6) D HEADER Q:BGPQUIT  W !,$P(^BGPPEIG(BGPIC,0),U,2)
  1.  D H1^BGP7DPH
  1.  S BGPCYD=$$V(1,BGPRPT,11,7)
  1.  S BGPPRD=$$V(2,BGPRPT,11,7)
  1.  S BGPBLD=$$V(3,BGPRPT,11,7)
  1.  I $G(BGPSEAT) W !!,$P(^DIBT(BGPSEAT,0),U,1)," Population"
  1.  W:'$G(BGPSEAT) ! W !,"Total Time Spent",!,"Providing Education",!,"(mins)"
  1.  W ?20,$$C(BGPCYD,0,8),?35,$$C(BGPPRD,0,8),?58,$$C(BGPBLD,0,8),!
  1.  K BGPPROVS
  1.  S N=12 D SETNM
  1.  K BGPX
  1.  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)
  1.  S BGP1=0 F  S BGP1=$O(BGPX(BGP1)) Q:BGP1'=+BGP1!(BGPQUIT)  D
  1.  .S BGP2=0 F  S BGP2=$O(BGPX(BGP1,BGP2)) Q:BGP2'=+BGP2!(BGPQUIT)  D
  1.  ..I $Y>(BGPIOSL-3) D HEADER Q:BGPQUIT  W !,$P(^BGPPEIG(BGPIC,0),U,2) D H1^BGP7DPH W !
  1.  ..W !,$E($P(BGPX(BGP1,BGP2),U,2),1,20)
  1.  ..S BGPCYN=$P(BGPX(BGP1,BGP2),U,3)
  1.  ..S BGPPRN=$P(BGPX(BGP1,BGP2),U,4)
  1.  ..S BGPBLN=$P(BGPX(BGP1,BGP2),U,5)
  1.  ..S BGPCYP=$P(BGPX(BGP1,BGP2),U,6)
  1.  ..S BGPPRP=$P(BGPX(BGP1,BGP2),U,7)
  1.  ..S BGPBLP=$P(BGPX(BGP1,BGP2),U,8)
  1.  ..D H2^BGP7DPH
  1.  I '$G(BGPAREAA) D
  1.  .S BGPAA=$$V(1,BGPRPT,11,7)
  1.  .S BGPAB=$$V(2,BGPRPT,11,7)
  1.  .S BGPAC=$$V(3,BGPRPT,11,7)
  1.  .S BGPCYN=$$V(1,BGPRPT,11,6)
  1.  .S BGPPRN=$$V(2,BGPRPT,11,6)
  1.  .S BGPBLN=$$V(3,BGPRPT,11,6)
  1.  .S BGPCYD=$$V(1,BGPRPT,11,3)
  1.  .S BGPPRD=$$V(2,BGPRPT,11,3)
  1.  .S BGPBLD=$$V(3,BGPRPT,11,3)
  1.  I $G(BGPAREAA) D
  1.  .S BGPAA=$$V(1,BGPRPT,11,7)
  1.  .S BGPAB=$$V(2,BGPRPT,11,7)
  1.  .S BGPAC=$$V(3,BGPRPT,11,7)
  1.  .S BGPCYN=$$V(1,BGPRPT,11,6)
  1.  .S BGPPRN=$$V(2,BGPRPT,11,6)
  1.  .S BGPBLN=$$V(3,BGPRPT,11,6)
  1.  .S BGPCYD=$S(BGPAA:BGPAA/BGPCYN,1:0)
  1.  .S BGPPRD=$S(BGPAB:BGPAB/BGPPRN,1:0)
  1.  .S BGPBLD=$S(BGPAC:BGPAC/BGPBLN,1:0)
  1.  I $Y>(BGPIOSL-6) D HEADER Q:BGPQUIT  W !,$P(^BGPPEIG(BGPIC,0),U,2) D H1^BGP7DPH W !
  1.  W !!,"Total # of Minutes recorded",!,"for All Providers"
  1.  W ?20,$$C(BGPAA,0,8),?35,$$C(BGPAB,0,8),?58,$$C(BGPAC,0,8),!
  1.  W !,"Total # of Pt Ed Codes with Provider",!,"and minutes recorded"
  1.  W ?20,$$C(BGPCYN,0,8),?35,$$C(BGPPRN,0,8),?58,$$C(BGPBLN,0,8)
  1.  W !!,"Average Time Spent",!,"All Providers",!,"(minutes)"
  1.  W ?20,$$C(BGPCYD,0,8),?35,$$C(BGPPRD,0,8),?58,$$C(BGPBLD,0,8),!
  1.  I $G(BGPAREAA) D
  1.  .S BGPCYD=999999999,BGPBLD=999999999,BGPPRD=999999999
  1.  .S X=0 F  S X=$O(BGPSUL(X)) Q:X'=+X  D
  1.  ..I $P($G(^BGPPEDCG(X,11)),U,4)]"",$P($G(^BGPPEDCG(X,11)),U,4)<BGPCYD S BGPCYD=$P($G(^BGPPEDCG(X,11)),U,4)
  1.  ..I $P($G(^BGPPEDPG(X,11)),U,4)]"",$P($G(^BGPPEDPG(X,11)),U,4)<BGPPRD S BGPPRD=$P($G(^BGPPEDPG(X,11)),U,4)
  1.  ..I $P($G(^BGPPEDBG(X,11)),U,4)]"",$P($G(^BGPPEDBG(X,11)),U,4)<BGPBLD S BGPBLD=$P($G(^BGPPEDBG(X,11)),U,4)
  1.  .I BGPCYD=999999999 S BGPCYD=""
  1.  .I BGPBLD=999999999 S BGPBLD=""
  1.  .I BGPPRD=999999999 S BGPPRD=""
  1.  I '$G(BGPAREAA) D
  1.  .S BGPCYD=$$V(1,BGPRPT,11,4)
  1.  .S BGPPRD=$$V(2,BGPRPT,11,4)
  1.  .S BGPBLD=$$V(3,BGPRPT,11,4)
  1.  I $Y>(BGPIOSL-4) D HEADER Q:BGPQUIT  W !,$P(^BGPPEIG(BGPIC,0),U,2) D H1^BGP7DPH W !
  1.  W !,"Minimum Time Spent",!,"All Providers",!,"(minutes)"
  1.  W ?20,$$C(BGPCYD,0,8),?35,$$C(BGPPRD,0,8),?58,$$C(BGPBLD,0,8),!
  1.  I $G(BGPAREAA) D
  1.  .S (BGPCYD,BGPPRD,BGPBLD)=""
  1.  .S X=0 F  S X=$O(BGPSUL(X)) Q:X'=+X  D
  1.  ..I $P($G(^BGPPEDCG(X,11)),U,5)>BGPCYD S BGPCYD=$P($G(^BGPPEDCG(X,11)),U,5)
  1.  ..I $P($G(^BGPPEDPG(X,11)),U,5)>BGPPRD S BGPPRD=$P($G(^BGPPEDPG(X,11)),U,5)
  1.  ..I $P($G(^BGPPEDBG(X,11)),U,5)>BGPBLD S BGPBLD=$P($G(^BGPPEDBG(X,11)),U,5)
  1.  I '$G(BGPAREAA) D
  1.  .S BGPCYD=$$V(1,BGPRPT,11,5)
  1.  .S BGPPRD=$$V(2,BGPRPT,11,5)
  1.  .S BGPBLD=$$V(3,BGPRPT,11,5)
  1.  I $Y>(BGPIOSL-4) D HEADER Q:BGPQUIT  W !,$P(^BGPPEIG(BGPIC,0),U,2) D H1^BGP7DPH W !
  1.  W !!,"Maximum Time Spent",!,"All Providers",!,"(minutes)"
  1.  W ?20,$$C(BGPCYD,0,8),?35,$$C(BGPPRD,0,8),?58,$$C(BGPBLD,0,8),!
  1.  Q
  1. 3 ;
  1.  I $Y>(BGPIOSL-6) D HEADER Q:BGPQUIT  W !,$P(^BGPPEIG(BGPIC,0),U,2)
  1.  D H1^BGP7DPH
  1.  S BGPCYD=$$V(1,BGPRPT,11,8)
  1.  S BGPPRD=$$V(2,BGPRPT,11,8)
  1.  S BGPBLD=$$V(3,BGPRPT,11,8)
  1.  I $G(BGPSEAT) W !!,$P(^DIBT(BGPSEAT,0),U,1)," Population"
  1.  W:'$G(BGPSEAT) ! W !,"Total # Education",!,"Codes"
  1.  W ?20,$$C(BGPCYD,0,8),?35,$$C(BGPPRD,0,8),?58,$$C(BGPBLD,0,8),!
  1.  K BGPPROVS
  1.  S N=13 D SETNM
  1.  K BGPX
  1.  S BGPCNT=0
  1.  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)
  1.  S BGP1=0 F  S BGP1=$O(BGPX(BGP1)) Q:BGP1'=+BGP1!(BGPQUIT)!(BGPCNT>24)  D
  1.  .S BGPCNT=BGPCNT+1 S BGP2=0 F  S BGP2=$O(BGPX(BGP1,BGP2)) Q:BGP2'=+BGP2!(BGPQUIT)  D
  1.  ..I $Y>(BGPIOSL-3) D HEADER Q:BGPQUIT  W !,$P(^BGPPEIG(BGPIC,0),U,2) D H1^BGP7DPH W !
  1.  ..W !,BGPCNT,". ",$E($P(BGPX(BGP1,BGP2),U,2),1,15)
  1.  ..S BGPCYN=$P(BGPX(BGP1,BGP2),U,3)
  1.  ..S BGPPRN=$P(BGPX(BGP1,BGP2),U,4)
  1.  ..S BGPBLN=$P(BGPX(BGP1,BGP2),U,5)
  1.  ..S BGPCYP=$P(BGPX(BGP1,BGP2),U,6)
  1.  ..S BGPPRP=$P(BGPX(BGP1,BGP2),U,7)
  1.  ..S BGPBLP=$P(BGPX(BGP1,BGP2),U,8)
  1.  ..D H2^BGP7DPH
  1.  Q
  1. 4 ;
  1.  I $Y>(BGPIOSL-6) D HEADER Q:BGPQUIT  W !,$P(^BGPPEIG(BGPIC,0),U,2)
  1.  D H1^BGP7DPH
  1.  S BGPCYD=$$V(1,BGPRPT,11,9)
  1.  S BGPPRD=$$V(2,BGPRPT,11,9)
  1.  S BGPBLD=$$V(3,BGPRPT,11,9)
  1.  I $G(BGPSEAT) W !!,$P(^DIBT(BGPSEAT,0),U,1)," Population"
  1.  W:'$G(BGPSEAT) ! W !,"Total # Education",!,"Codes"
  1.  W ?20,$$C(BGPCYD,0,8),?35,$$C(BGPPRD,0,8),?58,$$C(BGPBLD,0,8),!
  1.  K BGPPROVS
  1.  S N=14 D SETNM
  1.  K BGPX
  1.  S BGPCNT=0
  1.  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)
  1.  S BGP1=0 F  S BGP1=$O(BGPX(BGP1)) Q:BGP1'=+BGP1!(BGPQUIT)!(BGPCNT>24)  D
  1.  .S BGPCNT=BGPCNT+1 S BGP2=0 F  S BGP2=$O(BGPX(BGP1,BGP2)) Q:BGP2'=+BGP2!(BGPQUIT)  D
  1.  ..I $Y>(BGPIOSL-3) D HEADER Q:BGPQUIT  W !,$P(^BGPPEIG(BGPIC,0),U,2) D H1^BGP7DPH W !
  1.  ..W !,BGPCNT,". ",$E($P(BGPX(BGP1,BGP2),U,2),1,15)
  1.  ..S BGPCYN=$P(BGPX(BGP1,BGP2),U,3)
  1.  ..S BGPPRN=$P(BGPX(BGP1,BGP2),U,4)
  1.  ..S BGPBLN=$P(BGPX(BGP1,BGP2),U,5)
  1.  ..S BGPCYP=$P(BGPX(BGP1,BGP2),U,6)
  1.  ..S BGPPRP=$P(BGPX(BGP1,BGP2),U,7)
  1.  ..S BGPBLP=$P(BGPX(BGP1,BGP2),U,8)
  1.  ..D H2^BGP7DPH
  1.  Q
  1. 5 ;
  1.  I $Y>(BGPIOSL-6) D HEADER Q:BGPQUIT  W !,$P(^BGPPEIG(BGPIC,0),U,2)
  1.  D H1^BGP7DPH
  1.  S BGPCYD=$$V(1,BGPRPT,11,10)
  1.  S BGPPRD=$$V(2,BGPRPT,11,10)
  1.  S BGPBLD=$$V(3,BGPRPT,11,10)
  1.  I $G(BGPSEAT) W !!,$P(^DIBT(BGPSEAT,0),U,1)," Population"
  1.  W:'$G(BGPSEAT) ! W !,"Total # Education",!,"Codes"
  1.  W ?20,$$C(BGPCYD,0,8),?35,$$C(BGPPRD,0,8),?58,$$C(BGPBLD,0,8),!
  1.  K BGPPROVS
  1.  S N=15 D SETNM
  1.  K BGPX
  1.  S BGPCNT=0
  1.  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)
  1.  S BGP1=0 F  S BGP1=$O(BGPX(BGP1)) Q:BGP1'=+BGP1!(BGPQUIT)!(BGPCNT>15)  D
  1.  .S BGPCNT=BGPCNT+1 S BGP2=0 F  S BGP2=$O(BGPX(BGP1,BGP2)) Q:BGP2'=+BGP2!(BGPQUIT)  D
  1.  ..I $Y>(BGPIOSL-3) D HEADER Q:BGPQUIT  W !,$P(^BGPPEIG(BGPIC,0),U,2) D H1^BGP7DPH W !
  1.  ..W !,BGPCNT,". ",$E($P(BGPX(BGP1,BGP2),U,2),1,15)
  1.  ..S BGPCYN=$P(BGPX(BGP1,BGP2),U,3)
  1.  ..S BGPPRN=$P(BGPX(BGP1,BGP2),U,4)
  1.  ..S BGPBLN=$P(BGPX(BGP1,BGP2),U,5)
  1.  ..S BGPCYP=$P(BGPX(BGP1,BGP2),U,6)
  1.  ..S BGPPRP=$P(BGPX(BGP1,BGP2),U,7)
  1.  ..S BGPBLP=$P(BGPX(BGP1,BGP2),U,8)
  1.  ..D H2^BGP7DPH
  1.  Q
  1. 6 ;
  1.  I $Y>(BGPIOSL-6) D HEADER Q:BGPQUIT  W !,$P(^BGPPEIG(BGPIC,0),U,2)
  1.  D H1^BGP7DPH
  1.  S BGPCYD=$$V(1,BGPRPT,11,12)
  1.  S BGPPRD=$$V(2,BGPRPT,11,12)
  1.  S BGPBLD=$$V(3,BGPRPT,11,12)
  1.  I $G(BGPSEAT) W !!,$P(^DIBT(BGPSEAT,0),U,1)," Population"
  1.  W:'$G(BGPSEAT) ! W !,"Total # Education",!,"Codes"
  1.  W ?20,$$C(BGPCYD,0,8),?35,$$C(BGPPRD,0,8),?58,$$C(BGPBLD,0,8),!
  1.  W !,"Patient Understanding"
  1.  S N=11,P=15 D SETN
  1.  W !,"Good"
  1.  D H2^BGP7DPH
  1.  S N=11,P=14 D SETN
  1.  W !,"Fair"
  1.  D H2^BGP7DPH
  1.  S N=11,P=13 D SETN
  1.  W !,"Poor"
  1.  D H2^BGP7DPH
  1.  S N=11,P=16 D SETN
  1.  W !,"Refused"
  1.  D H2^BGP7DPH
  1.  S N=11,P=17 D SETN
  1.  W !,"Group-No Assessment"
  1.  D H2^BGP7DPH
  1.  S N=11,P=18 D SETN
  1.  W !,"Blank"," (Not recorded)"
  1.  D H2^BGP7DPH
  1.  Q
  1. 7 ;
  1.  D 7^BGP7DPEQ
  1.  Q
  1. KITM ;
  1.  K ^TMP($J)
  1.  K ^XTMP("BGP7PE",BGPJ,BGPH)
  1.  Q
  1.  G:'BGPGPG HEADER1
  1.  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
  1. HEADER1 ;
  1.  W:$D(IOF) @IOF S BGPGPG=BGPGPG+1
  1.  I $G(BGPGUI) W "ZZZZZZZ",!  ;maw
  1.  W $P(^VA(200,DUZ,0),U,2),?35,$$FMTE^XLFDT(DT),?70,"Page ",BGPGPG,!
  1.  I '$G(BGPSEAT) W $$CTR("*** IHS 2017 Patient Education with Community Specified Report ***",80),!
  1.  I $G(BGPSEAT) W $$CTR("*** IHS 2017 Patient Education with Patient Panel Population Report ***",80),!
  1.  I $G(BGPAREAA) W $$CTR("AREA AGGREGATE",80),!
  1.  I '$G(BGPAREAA) W $$CTR($P(^DIC(4,DUZ(2),0),U),80),!
  1.  S X="Report Period: "_$$FMTE^XLFDT(BGPBD)_" to "_$$FMTE^XLFDT(BGPED) W $$CTR(X,80),!
  1.  S X="Previous Year Period:  "_$$FMTE^XLFDT(BGPPBD)_" to "_$$FMTE^XLFDT(BGPPED) W $$CTR(X,80),!
  1.  S X="Baseline Period:  "_$$FMTE^XLFDT(BGPBBD)_" to "_$$FMTE^XLFDT(BGPBED) W $$CTR(X,80),!
  1.  W $TR($J("",80)," ","-")
  1.  Q
  1. EXIT ;
  1.  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
  1.  Q
  1. C(X,X2,X3) ;EP
  1.  D COMMA^%DTC
  1.  Q X
  1. S(Y,F,P) ;EP set up array
  1.  I '$G(F) S F=0
  1.  S %=$P(^TMP($J,"BGPDEL",0),U)+F,$P(^TMP($J,"BGPDEL",0),U)=%
  1.  I '$D(^TMP($J,"BGPDEL",%)) S ^TMP($J,"BGPDEL",%)=""
  1.  S $P(^TMP($J,"BGPDEL",%),U,P)=Y
  1.  Q
  1. CTR(X,Y) ;EP - Center X in a field Y wide.
  1.  Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
  1.  ;----------
  1. EOP ;EP - End of page.
  1.  Q:$E(IOST)'="C"
  1.  Q:$D(ZTQUEUED)!'(IOT="TRM")!$D(IO("S"))
  1.  NEW DIR
  1.  K DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
  1.  S DIR(0)="E" D ^DIR
  1.  Q
  1.  ;----------
  1. USR() ;EP - Return name of current user from ^VA(200.
  1.  Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
  1.  ;----------
  1. SETNM ;
  1.  K BGPPROVS
  1.  I $G(BGPAREAA) D SETNMA Q
  1.  S X=0 F  S X=$O(^BGPPEDCG(BGPRPT,N,X)) Q:X'=+X  D
  1.  .S C=$P(^BGPPEDCG(BGPRPT,N,X,0),U),L=$P(^BGPPEDCG(BGPRPT,N,X,0),U,2),M=$P(^BGPPEDCG(BGPRPT,N,X,0),U,3)
  1.  .S $P(BGPPROVS(C,L),U,1)=M
  1.  S X=0 F  S X=$O(^BGPPEDPG(BGPRPT,N,X)) Q:X'=+X  D
  1.  .S C=$P(^BGPPEDPG(BGPRPT,N,X,0),U),L=$P(^BGPPEDPG(BGPRPT,N,X,0),U,2),M=$P(^BGPPEDPG(BGPRPT,N,X,0),U,3)
  1.  .S $P(BGPPROVS(C,L),U,2)=M
  1.  S X=0 F  S X=$O(^BGPPEDBG(BGPRPT,N,X)) Q:X'=+X  D
  1.  .S C=$P(^BGPPEDBG(BGPRPT,N,X,0),U),L=$P(^BGPPEDBG(BGPRPT,N,X,0),U,2),M=$P(^BGPPEDBG(BGPRPT,N,X,0),U,3)
  1.  .S $P(BGPPROVS(C,L),U,3)=M
  1.  ;set %ages
  1.  S X="" F  S X=$O(BGPPROVS(X)) Q:X=""  S Y="" F  S Y=$O(BGPPROVS(X,Y)) Q:Y=""  D
  1.  .S A=$P(BGPPROVS(X,Y),U,1),$P(BGPPROVS(X,Y),U,4)=$S(BGPCYD:((A/BGPCYD)*100),1:"")
  1.  .S B=$P(BGPPROVS(X,Y),U,2),$P(BGPPROVS(X,Y),U,5)=$S(BGPPRD:((B/BGPPRD)*100),1:"")
  1.  .S C=$P(BGPPROVS(X,Y),U,3),$P(BGPPROVS(X,Y),U,6)=$S(BGPBLD:((C/BGPBLD)*100),1:"")
  1.  .Q
  1.  Q
  1. SETNMA ;
  1.  NEW X,V,C S Z=0,C="" F  S Z=$O(BGPSUL(Z)) Q:Z'=+Z  D SETNMA1
  1.  S X="" F  S X=$O(BGPPROVS(X)) Q:X=""  S Y="" F  S Y=$O(BGPPROVS(X,Y)) Q:Y=""  D
  1.  .S A=$P(BGPPROVS(X,Y),U,1),$P(BGPPROVS(X,Y),U,4)=$S(BGPCYD:((A/BGPCYD)*100),1:"")
  1.  .S B=$P(BGPPROVS(X,Y),U,2),$P(BGPPROVS(X,Y),U,5)=$S(BGPPRD:((B/BGPPRD)*100),1:"")
  1.  .S C=$P(BGPPROVS(X,Y),U,3),$P(BGPPROVS(X,Y),U,6)=$S(BGPBLD:((C/BGPBLD)*100),1:"")
  1.  .Q
  1.  Q
  1. SETNMA1 ;
  1.  S X=0 F  S X=$O(^BGPPEDCG(Z,N,X)) Q:X'=+X  D
  1.  .S C=$P(^BGPPEDCG(Z,N,X,0),U),L=$P(^BGPPEDCG(Z,N,X,0),U,2),M=$P(^BGPPEDCG(Z,N,X,0),U,3)
  1.  .S $P(BGPPROVS(C,L),U,1)=$P($G(BGPPROVS(C,L)),U,1)+M
  1.  S X=0 F  S X=$O(^BGPPEDPG(Z,N,X)) Q:X'=+X  D
  1.  .S C=$P(^BGPPEDPG(Z,N,X,0),U),L=$P(^BGPPEDPG(Z,N,X,0),U,2),M=$P(^BGPPEDPG(Z,N,X,0),U,3)
  1.  .S $P(BGPPROVS(C,L),U,2)=$P($G(BGPPROVS(C,L)),U,2)+M
  1.  S X=0 F  S X=$O(^BGPPEDBG(Z,N,X)) Q:X'=+X  D
  1.  .S C=$P(^BGPPEDBG(Z,N,X,0),U),L=$P(^BGPPEDBG(Z,N,X,0),U,2),M=$P(^BGPPEDBG(Z,N,X,0),U,3)
  1.  .S $P(BGPPROVS(C,L),U,3)=$P($G(BGPPROVS(C,L)),U,3)+M
  1.  .Q
  1.  Q
  1. SETN ;EP - set numerator fields
  1.  S BGPCYN=$$V(1,BGPRPT,N,P,2) ;SPDX
  1.  S BGPPRN=$$V(2,BGPRPT,N,P,2) ;SPDX
  1.  S BGPBLN=$$V(3,BGPRPT,N,P,2) ;SPDX
  1.  S BGPCYP=$S(BGPCYD:((BGPCYN/BGPCYD)*100),1:"")
  1.  S BGPPRP=$S(BGPPRD:((BGPPRN/BGPPRD)*100),1:"")
  1.  S BGPBLP=$S(BGPBLD:((BGPBLN/BGPBLD)*100),1:"")
  1.  Q
  1. SL(V) ;
  1.  I V="" S V=0
  1.  Q $$STRIP^XLFSTR($J(V,5,1)," ")
  1. SETEXA(T,N,P) ;EP - set denominator
  1.  Q:'$G(BGPEXCEL)
  1.  NEW X,Y,Z
  1.  S X=0 F  S X=$O(BGPSUL(X)) Q:X'=+X  D
  1.  .I T=1 S $P(BGPEXCT(X,T),U,2)=$P($G(^BGPPEDCG(X,N)),U,P)
  1.  .I T=2 S $P(BGPEXCT(X,T),U,2)=$P($G(^BGPPEDPG(X,N)),U,P)
  1.  .I T=3 S $P(BGPEXCT(X,T),U,2)=$P($G(^BGPGPDBG(X,N)),U,P)
  1.  Q
  1. V(T,R,N,P,ND) ;EP ;SPDX
  1.  I $G(BGPAREAA) G VA
  1.  NEW X
  1.  I T=1 S X=$P($G(^BGPPEDCG(R,N)),U,P) Q $S(X]"":X,1:0)
  1.  I T=2 S X=$P($G(^BGPPEDPG(R,N)),U,P) Q $S(X]"":X,1:0)
  1.  I T=3 S X=$P($G(^BGPPEDBG(R,N)),U,P) Q $S(X]"":X,1:0)
  1.  Q ""
  1. VA ;
  1.  NEW X,V,C S X=0,C="" F  S X=$O(BGPSUL(X)) Q:X'=+X  D
  1.  .I T=1 S C=C+$P($G(^BGPPEDCG(X,N)),U,P)
  1.  .I T=2 S C=C+$P($G(^BGPPEDPG(X,N)),U,P)
  1.  .I T=3 S C=C+$P($G(^BGPPEDBG(X,N)),U,P)
  1.  .Q
  1.  Q $S(C]"":C,1:0)