BGP6DP1O ; IHS/CMI/LAB - print ind 1 12 Nov 2010 7:38 AM ;
;;16.1;IHS CLINICAL REPORTING;;MAR 22, 2016;Build 170
;
;SBIRT
SBI ;EP
;I '$G(BGPSUMON),BGPPTYPE="P" D HEADER^BGP6DPH Q:BGPQUIT D W^BGP6DP(^BGPINDM(BGPIC,53,1,0),0,1,BGPPTYPE) D:$D(^BGPINDM(BGPIC,53,2,0)) W^BGP6DP(^BGPINDM(BGPIC,53,2,0),0,1,BGPPTYPE)
I BGPPTYPE="P" D H1^BGP6DPH
I BGPPTYPE="D" D H1^BGP6PDL1
S BGPORDP=$P(^BGPINDM(BGPIC,12),U,6) F BGPORDP1=1,2,3 S BGPPC1=BGPORDP_"."_BGPORDP1 Q:BGPQUIT D:BGPPTYPE="P" PI^BGP6DP1C D:BGPPTYPE="D" PI^BGP6PDL1
Q:BGPQUIT
D I1AGE
Q:BGPQUIT
S BGPORDP=$P(^BGPINDM(BGPIC,12),U,6) F BGPORDP1=7,8,9 S BGPPC1=BGPORDP_"."_BGPORDP1 Q:BGPQUIT D:BGPPTYPE="P" PI^BGP6DP1C D:BGPPTYPE="D" PI^BGP6PDL1
D I2AGE
Q
I1AGE ;EP special age tallies
Q:$G(BGPSUMON)
Q:BGPRTYPE'=4
I BGPINDM="W",BGPRTYPE=4 G FEM
S BGPHD1="AC+BH Pts 9-75",BGPHD2="AC+BH Pts 9-75",BGPHD3=""
;I '$G(BGPSUMON),BGPPTYPE="P" D HEADER^BGP6DPH Q:BGPQUIT D W^BGP6DP(^BGPINDM(BGPIC,53,1,0),0,1,BGPPTYPE) D:$D(^BGPINDM(BGPIC,53,2,0)) W^BGP6DP(^BGPINDM(BGPIC,53,2,0),0,1,BGPPTYPE) D H3
K BGPDAC,BGPDAP,BGPDAB
S BGPORX=4 F BGPORXX=1,2,3 F BGPX="A","B","C","D","E","F","G","H" D AGES
D I1AGEP
Q:BGPQUIT
S BGPHD1="Male AC+BH Pts 9-75",BGPHD2="Male AC+BH Pts 9-75",BGPHD3=""
;I '$G(BGPSUMON),BGPPTYPE="P" D HEADER^BGP6DPH Q:BGPQUIT W !,^BGPINDM(BGPIC,53,1,0) W:$D(^BGPINDM(BGPIC,53,2,0)) !,^BGPINDM(BGPIC,53,2,0) D H3
K BGPDAC,BGPDAP,BGPDAB S BGPORX=5 F BGPORXX=1,2,3 F BGPX="A","B","C","D","E","F","G","H" D AGES
D I1AGEP
Q:BGPQUIT
FEM ;
S BGPHD1="Female AC+BH Pts 9-75",BGPHD2="Female AC+BH Pts 9-75",BGPHD3=""
;I '$G(BGPSUMON),BGPPTYPE="P" D HEADER^BGP6DPH Q:BGPQUIT W !,^BGPINDM(BGPIC,53,1,0) W:$D(^BGPINDM(BGPIC,53,2,0)) !,^BGPINDM(BGPIC,53,2,0) D H3
K BGPDAC,BGPDAP,BGPDAB S BGPORX=6 F BGPORXX=1,2,3 F BGPX="A","B","C","D","E","F","G","H" D AGES
D I1AGEP
K BGPHD3
Q
AGES ;
I BGPX="A" S BGPPP1=1
I BGPX="B" S BGPPP1=2
I BGPX="C" S BGPPP1=3
I BGPX="D" S BGPPP1=4
I BGPX="E" S BGPPP1=5
I BGPX="F" S BGPPP1=6
I BGPX="G" S BGPPP1=7
I BGPX="H" S BGPPP1=8
S BGPF="SBI."_BGPORX_"."_BGPORXX_BGPX S BGPPC=$O(^BGPINDMC("C",BGPF,0))
I BGPORXX=1 D
.S BGPDF=$P(^BGPINDMC(BGPPC,0),U,8)
.S BGPNP=$P(^DD(90556.03,BGPDF,0),U,4),N=$P(BGPNP,";"),P=$P(BGPNP,";",2)
.S $P(BGPDAC(1),U,BGPPP1)=$$V^BGP6DP1C(1,BGPRPT,N,P)
.S $P(BGPDAP(1),U,BGPPP1)=$$V^BGP6DP1C(2,BGPRPT,N,P)
.S $P(BGPDAB(1),U,BGPPP1)=$$V^BGP6DP1C(3,BGPRPT,N,P)
;
S BGPNF=$P(^BGPINDMC(BGPPC,0),U,9)
S BGPNP=$P(^DD(90556.03,BGPNF,0),U,4),N=$P(BGPNP,";"),P=$P(BGPNP,";",2)
S $P(BGPDAC(BGPORXX,1),U,BGPPP1)=$$V^BGP6DP1C(1,BGPRPT,N,P)
S $P(BGPDAC(BGPORXX,2),U,BGPPP1)=$S($P(BGPDAC(1),U,BGPPP1):($P(BGPDAC(BGPORXX,1),U,BGPPP1)/$P(BGPDAC(1),U,BGPPP1)*100),1:"")
S $P(BGPDAP(BGPORXX,1),U,BGPPP1)=$$V^BGP6DP1C(2,BGPRPT,N,P)
S $P(BGPDAP(BGPORXX,2),U,BGPPP1)=$S($P(BGPDAP(1),U,BGPPP1):($P(BGPDAP(BGPORXX,1),U,BGPPP1)/$P(BGPDAP(1),U,BGPPP1)*100),1:"")
S $P(BGPDAB(BGPORXX,1),U,BGPPP1)=$$V^BGP6DP1C(3,BGPRPT,N,P)
S $P(BGPDAB(BGPORXX,2),U,BGPPP1)=$S($P(BGPDAB(1),U,BGPPP1):($P(BGPDAB(BGPORXX,1),U,BGPPP1)/$P(BGPDAB(1),U,BGPPP1)*100),1:"")
Q
I1AGEP ;
S BGPYSTP=1
I '$G(BGPSUMON),BGPPTYPE="P" D HEADER^BGP6DPH Q:BGPQUIT D W^BGP6DP(^BGPINDM(BGPIC,53,1,0),0,1,BGPPTYPE) D:$D(^BGPINDM(BGPIC,53,2,0)) W^BGP6DP(^BGPINDM(BGPIC,53,2,0),0,1,BGPPTYPE) D H3
I BGPPTYPE'="P" D W^BGP6DP("",0,2,BGPPTYPE) D H3
D W^BGP6DP("CURRENT REPORT PERIOD",0,1,BGPPTYPE)
;I BGPPTYPE="P" D W^BGP6DP(BGPHD3,0,1,BGPPTYPE)
S BGPARR="BGPDAC" D I1AGEP1
;I '$G(BGPSUMON),BGPPTYPE="P" D HEADER^BGP6DPH Q:BGPQUIT D W^BGP6DP(^BGPINDM(BGPIC,53,1,0),0,1,BGPPTYPE) D:$D(^BGPINDM(BGPIC,53,2,0)) W^BGP6DP(^BGPINDM(BGPIC,53,2,0),0,1,BGPPTYPE) D H3
D W^BGP6DP("",0,2,BGPPTYPE) ;D H3
D W^BGP6DP("PREVIOUS REPORT PERIOD",0,1,BGPPTYPE)
;D W^BGP6DP($S(BGPPTYPE="P":BGPHD2,1:BGPHD1),0,1,BGPPTYPE)
;I BGPPTYPE="P" D W^BGP6DP(BGPHD3,0,1,BGPPTYPE)
S BGPARR="BGPDAP" D I1AGEP1
I '$G(BGPSUMON),BGPPTYPE="P" D HEADER^BGP6DPH Q:BGPQUIT D W^BGP6DP(^BGPINDM(BGPIC,53,1,0),0,1,BGPPTYPE) D:$D(^BGPINDM(BGPIC,53,2,0)) W^BGP6DP(^BGPINDM(BGPIC,53,2,0),0,1,BGPPTYPE) D H3
D W^BGP6DP("",0,2,BGPPTYPE)
D W^BGP6DP("BASELINE REPORT PERIOD",0,1,BGPPTYPE)
;D W^BGP6DP($S(BGPPTYPE="P":BGPHD2,1:BGPHD1),0,1,BGPPTYPE)
I BGPPTYPE="P" D W^BGP6DP(BGPHD3,0,1,BGPPTYPE)
S BGPARR="BGPDAB" D I1AGEP1
Q
P1 ;
I BGPPTYPE="D" D W^BGP6DP(BGPDL(BGPX,1),0,2,BGPPTYPE)
I BGPPTYPE="P" D W^BGP6DP(BGPPL(BGPX,1),0,2,BGPPTYPE),W^BGP6DP(BGPPL(BGPX,2),0,1,BGPPTYPE)
S T=23 F X=1:1:8 S V=$P(@BGPARR@(BGPX,1),U,X) D W^BGP6DP($S(BGPPTYPE="P":$$C(V,0,6),1:$S(V:V,1:0)),0,0,BGPPTYPE,X+1,T) S T=T+7
I BGPPTYPE="D" D W^BGP6DP(BGPDL(BGPX,2),0,1,BGPPTYPE)
I BGPPTYPE="P" D W^BGP6DP(BGPPL(BGPX,3),0,1,BGPPTYPE),W^BGP6DP($G(BGPPL(BGPX,4)),0,1,BGPPTYPE)
S T=23 F X=1:1:8 S V=$P(@BGPARR@(BGPX,2),U,X) D W^BGP6DP($S(BGPPTYPE="P":$J(V,6,1),1:$$SB($J(V,6,1))),0,0,BGPPTYPE,X+1,T) S T=T+7
Q
I1AGEP1 ;
NEW BGPX
NEW BGPPL,BGPDL
I BGPPTYPE="D" D W^BGP6DP(BGPHD1,0,1,BGPPTYPE)
I BGPPTYPE="P" D W^BGP6DP(BGPHD2,0,1,BGPPTYPE)
I BGPPTYPE="P",BGPHD3]"" D W^BGP6DP(BGPHD3,1,1,BGPPTYPE)
S T=23 F X=1:1:8 S V=$P(@BGPARR@(1),U,X) D W^BGP6DP($S(BGPPTYPE="P":$$C(V,0,6),1:$S(V:V,1:0)),0,0,BGPPTYPE,X+1,T) S T=T+7
S BGPX=1,BGPDL(BGPX,1)="# w/ Screening for Alcohol Use",BGPPL(BGPX,1)="# w/ Screening for",BGPPL(BGPX,2)=" Alcohol Use",BGPDL(BGPX,2)="% w/ Screening for Alcohol Use",BGPPL(BGPX,3)="% w/ Screening for",BGPPL(BGPX,4)=" Alcohol Use" D P1
S BGPX=2,BGPDL(BGPX,1)="A. # w/ Positive Screen w/ % of Total Screened",BGPPL(BGPX,1)="A. # w/ Positive Screen",BGPPL(BGPX,2)=" w/ % of Total Screened",BGPDL(BGPX,2)="% A. w/ Positive Screen w/ % of Total Screened" D
.S BGPPL(BGPX,3)="% A. w/ Positive Screen w/ ",BGPPL(BGPX,4)=" % of Total Screened" D P1
S BGPX=3,BGPDL(BGPX,1)="B. # w/ BNI/BI in 7 days of screen w/ % of Total Screened",BGPPL(BGPX,1)="B. # w/ BNI/BI in 7 days of screen",BGPPL(BGPX,2)=" w/ % of Total Screened" D
.S BGPDL(BGPX,2)="% B. w/ BNI/BI in 7 days of screen w/ %of Total Screened",BGPPL(BGPX,3)="% B. w/ BNI/BI in 7 days of screen",BGPPL(BGPX,4)=" w/ % of Total Screened" D P1
;change from baseline/previous year
I BGPARR="BGPDAP"!(BGPARR="BGPDAB") D
.D W^BGP6DP("CHANGE FROM "_$S(BGPARR="BGPDAP":"PREVIOUS YR %",1:"BASELINE YR %"),0,2,BGPPTYPE)
.F BGPX=1,2,3 D
..I BGPPTYPE="P" D W^BGP6DP(BGPPL(BGPX,1),0,1,BGPPTYPE) S L=BGPPL(BGPX,2) D PBY
..I BGPPTYPE="D" S L=BGPDL(BGPX,1) D PBY
Q
PBY ;
D W^BGP6DP(L,0,1,BGPPTYPE)
S T=23 F P=1:1:8 S N=$P(BGPDAC(BGPX,2),U,P),O=$P(@BGPARR@(BGPX,2),U,P) S:N="" N=0 S:O="" O=0 S Y=$S(BGPPTYPE="P":$J($FN((N-O),"+,",1),6),1:$$SB($J((N-O),6,1))) D W^BGP6DP(Y,0,0,BGPPTYPE,P+1,T) S T=T+7
Q
C(X,X2,X3) ;
D COMMA^%DTC
Q X
H3 ;EP
Q:$G(BGPSUMON)
D W^BGP6DP(BGPHD1,1,2,BGPPTYPE)
D W^BGP6DP("Age Distribution",0,1,BGPPTYPE,1,40)
D W^BGP6DP(" 9-12",0,1,BGPPTYPE,2,23)
D W^BGP6DP("13-18",0,0,BGPPTYPE,3,30)
D W^BGP6DP("19-24",0,0,BGPPTYPE,4,37)
D W^BGP6DP("25-34",0,0,BGPPTYPE,5,44)
D W^BGP6DP("35-44",0,0,BGPPTYPE,6,51)
D W^BGP6DP("45-54",0,0,BGPPTYPE,7,58)
D W^BGP6DP("55-64",0,0,BGPPTYPE,8,65)
D W^BGP6DP("65-75",0,0,BGPPTYPE,9,72)
Q
SB(X) ;EP - Strip
X ^DD("FUNC",$O(^DD("FUNC","B","STRIPBLANKS",0)),1)
Q X
I2AGE ;EP special age tallies
Q:$G(BGPSUMON)
Q:BGPRTYPE'=4
I BGPINDM="W",BGPRTYPE=4 G FEM2
S BGPHD1="ACTIVE CLINICAL PLUS BH PATIENTS W/ POSITIVE ALCOHOL SCREEN AGES 9-75",BGPHD2="AC+BH Pts 9-75 w/ Positive",BGPHD3=" Alcohol Screen"
;I '$G(BGPSUMON),BGPPTYPE="P" D HEADER^BGP6DPH Q:BGPQUIT D W^BGP6DP(^BGPINDM(BGPIC,53,1,0),0,1,BGPPTYPE) D:$D(^BGPINDM(BGPIC,53,2,0)) W^BGP6DP(^BGPINDM(BGPIC,53,2,0),0,1,BGPPTYPE) D H3
K BGPDAC,BGPDAP,BGPDAB
S BGPORX=10 F BGPORXX=1:1:5 F BGPX="A","B","C","D","E","F","G","H" D AGES
D I2AGEP
Q:BGPQUIT
S BGPHD1="MALE ACTIVE CLINICAL PLUS BH PATIENTS W/ POSITIVE ALCOHOL SCREEN AGES 9-75",BGPHD2="MALE AC+BH Pts 9-75 w/ Positive",BGPHD3=" Alcohol Screen"
;I '$G(BGPSUMON),BGPPTYPE="P" D HEADER^BGP6DPH Q:BGPQUIT W !,^BGPINDM(BGPIC,53,1,0) W:$D(^BGPINDM(BGPIC,53,2,0)) !,^BGPINDM(BGPIC,53,2,0) D H3
K BGPDAC,BGPDAP,BGPDAB S BGPORX=11 F BGPORXX=1:1:5 F BGPX="A","B","C","D","E","F","G","H" D AGES
D I2AGEP
Q:BGPQUIT
FEM2 ;
S BGPHD1="FEMALE ACTIVE CLINICAL PLUS BH PATIENTS W/ POSITIVE ALCOHOL SCREEN AGES 9-75",BGPHD2="FEMALE AC+BH Pts 9-75 w/ Positive",BGPHD3=" Alcohol Screen"
;I '$G(BGPSUMON),BGPPTYPE="P" D HEADER^BGP6DPH Q:BGPQUIT W !,^BGPINDM(BGPIC,53,1,0) W:$D(^BGPINDM(BGPIC,53,2,0)) !,^BGPINDM(BGPIC,53,2,0) D H3
K BGPDAC,BGPDAP,BGPDAB S BGPORX=12 F BGPORXX=1:1:5 F BGPX="A","B","C","D","E","F","G","H" D AGES
D I2AGEP
K BGPHD3
Q
I2AGEP1 ;
NEW BGPX
NEW BGPPL,BGPDL
I BGPPTYPE="D" D W^BGP6DP(BGPHD1,0,1,BGPPTYPE)
I BGPPTYPE="P" D W^BGP6DP(BGPHD2,0,1,BGPPTYPE)
I BGPPTYPE="P",BGPHD3]"" D W^BGP6DP(BGPHD3,0,1,BGPPTYPE)
S T=23 F X=1:1:8 S V=$P(@BGPARR@(1),U,X) D W^BGP6DP($S(BGPPTYPE="P":$$C(V,0,6),1:$S(V:V,1:0)),0,0,BGPPTYPE,X+1,T) S T=T+7
S BGPX=1,BGPDL(BGPX,1)="# w/ BNI/BI in 7 days of screen",BGPPL(BGPX,1)="# w/ BNI/BI in",BGPPL(BGPX,2)=" 7 days of screen" D
.S BGPDL(BGPX,2)="% w/ BNI/BI in 7 days of screen",BGPPL(BGPX,3)="% w/ BNI/BI in",BGPPL(BGPX,4)="7 days of screen" D P1
S BGPX=2,BGPDL(BGPX,1)="A. # w/ BNI/BI on same day w/ % of Total BNI/BI",BGPPL(BGPX,1)="A. # w/ BNI/BI on same day" D
.S (BGPPL(BGPX,4),BGPPL(BGPX,2))=" w/ % of Total BNI/BI",BGPDL(BGPX,2)="% A. w/ BNI/BI on same day w/ % of Total BNI/BI",BGPPL(BGPX,3)="% A. w/ BNI/BI on same day" D P1
S BGPX=3,BGPDL(BGPX,1)="B. # w/ BNI/BI in 1-3 days w/ % of Total BNI/BI",BGPPL(BGPX,1)="B. # w/ BNI/BI in 1-3 days" D
.S (BGPPL(BGPX,4),BGPPL(BGPX,2))=" w/ % of Total BNI/BI",BGPDL(BGPX,2)="% B. w/ BNI/BI in 1-3 days w/ % of Total BNI/BI",BGPPL(BGPX,3)="% B. w/ BNI/BI in 1-3 days" D P1
S BGPX=4,BGPDL(BGPX,1)="C. # w/ BNI/BI in 4-7 days w/ % of Total BNI/BI",BGPPL(BGPX,1)="C. # w/ BNI/BI in 4-7 days" D
.S (BGPPL(BGPX,4),BGPPL(BGPX,2))=" w/ % of Total BNI/BI",BGPDL(BGPX,2)="% C. w/ BNI/BI in 4-7 days w/ % of Total BNI/BI",BGPPL(BGPX,3)="% C. w/ BNI/BI in 4-7 days" D P1
S BGPX=5,BGPDL(BGPX,1)="D. # w/ Referral in 7 days of screen w/ % of Total BNI/BI",BGPPL(BGPX,1)="D. # w/ Referral in 7 days of Screen" D
.S (BGPPL(BGPX,4),BGPPL(BGPX,2))=" w/ % of Total BNI/BI",BGPDL(BGPX,2)="% D. w/ Referral in 7 days of screen w/ % of Total BNI/BI",BGPPL(BGPX,3)="% D. w/ Referral in 7 days of screen",BGPPL(BGPX,4)=" w/ % of Total BNI/BI" D P1
;change from baseline/previous year
I BGPARR="BGPDAP"!(BGPARR="BGPDAB") D
.D W^BGP6DP("CHANGE FROM "_$S(BGPARR="BGPDAP":"PREVIOUS YR %",1:"BASELINE YR %"),0,2,BGPPTYPE)
.F BGPX=1,2,3,4,5 D
..I BGPPTYPE="P" D W^BGP6DP(BGPPL(BGPX,1),0,1,BGPPTYPE) S L=BGPPL(BGPX,2) D PBY
..I BGPPTYPE="D" S L=BGPDL(BGPX,1) D PBY
Q
I2AGEP ;
S BGPYSTP=1
I '$G(BGPSUMON),BGPPTYPE="P" D HEADER^BGP6DPH Q:BGPQUIT D W^BGP6DP(^BGPINDM(BGPIC,53,1,0),0,1,BGPPTYPE) D:$D(^BGPINDM(BGPIC,53,2,0)) W^BGP6DP(^BGPINDM(BGPIC,53,2,0),0,1,BGPPTYPE) D H3
I BGPPTYPE'="P" D W^BGP6DP("",0,2,BGPPTYPE) D H3
D W^BGP6DP("CURRENT REPORT PERIOD",0,2,BGPPTYPE)
;I BGPPTYPE="P" D W^BGP6DP(BGPHD3,0,1,BGPPTYPE)
S BGPARR="BGPDAC" D I2AGEP1
I '$G(BGPSUMON),BGPPTYPE="P" D HEADER^BGP6DPH Q:BGPQUIT D W^BGP6DP(^BGPINDM(BGPIC,53,1,0),0,1,BGPPTYPE) D:$D(^BGPINDM(BGPIC,53,2,0)) W^BGP6DP(^BGPINDM(BGPIC,53,2,0),0,1,BGPPTYPE) D H3
D W^BGP6DP("",0,2,BGPPTYPE)
D W^BGP6DP("PREVIOUS REPORT PERIOD",0,1,BGPPTYPE)
;D W^BGP6DP($S(BGPPTYPE="P":BGPHD2,1:BGPHD1),0,1,BGPPTYPE)
;I BGPPTYPE="P" D W^BGP6DP(BGPHD3,0,1,BGPPTYPE)
S BGPARR="BGPDAP" D I2AGEP1
I '$G(BGPSUMON),BGPPTYPE="P" D HEADER^BGP6DPH Q:BGPQUIT D W^BGP6DP(^BGPINDM(BGPIC,53,1,0),0,1,BGPPTYPE) D:$D(^BGPINDM(BGPIC,53,2,0)) W^BGP6DP(^BGPINDM(BGPIC,53,2,0),0,1,BGPPTYPE) D H3
D W^BGP6DP("",0,2,BGPPTYPE)
D W^BGP6DP("BASELINE REPORT PERIOD",0,1,BGPPTYPE)
;D W^BGP6DP($S(BGPPTYPE="P":BGPHD2,1:BGPHD1),0,1,BGPPTYPE)
;I BGPPTYPE="P" D W^BGP6DP(BGPHD3,0,1,BGPPTYPE)
S BGPARR="BGPDAB" D I2AGEP1
Q
BGP6DP1O ; IHS/CMI/LAB - print ind 1 12 Nov 2010 7:38 AM ;
+1 ;;16.1;IHS CLINICAL REPORTING;;MAR 22, 2016;Build 170
+2 ;
+3 ;SBIRT
SBI ;EP
+1 ;I '$G(BGPSUMON),BGPPTYPE="P" D HEADER^BGP6DPH Q:BGPQUIT D W^BGP6DP(^BGPINDM(BGPIC,53,1,0),0,1,BGPPTYPE) D:$D(^BGPINDM(BGPIC,53,2,0)) W^BGP6DP(^BGPINDM(BGPIC,53,2,0),0,1,BGPPTYPE)
+2 IF BGPPTYPE="P"
DO H1^BGP6DPH
+3 IF BGPPTYPE="D"
DO H1^BGP6PDL1
+4 SET BGPORDP=$PIECE(^BGPINDM(BGPIC,12),U,6)
FOR BGPORDP1=1,2,3
SET BGPPC1=BGPORDP_"."_BGPORDP1
IF BGPQUIT
QUIT
IF BGPPTYPE="P"
DO PI^BGP6DP1C
IF BGPPTYPE="D"
DO PI^BGP6PDL1
+5 IF BGPQUIT
QUIT
+6 DO I1AGE
+7 IF BGPQUIT
QUIT
+8 SET BGPORDP=$PIECE(^BGPINDM(BGPIC,12),U,6)
FOR BGPORDP1=7,8,9
SET BGPPC1=BGPORDP_"."_BGPORDP1
IF BGPQUIT
QUIT
IF BGPPTYPE="P"
DO PI^BGP6DP1C
IF BGPPTYPE="D"
DO PI^BGP6PDL1
+9 DO I2AGE
+10 QUIT
I1AGE ;EP special age tallies
+1 IF $GET(BGPSUMON)
QUIT
+2 IF BGPRTYPE'=4
QUIT
+3 IF BGPINDM="W"
IF BGPRTYPE=4
GOTO FEM
+4 SET BGPHD1="AC+BH Pts 9-75"
SET BGPHD2="AC+BH Pts 9-75"
SET BGPHD3=""
+5 ;I '$G(BGPSUMON),BGPPTYPE="P" D HEADER^BGP6DPH Q:BGPQUIT D W^BGP6DP(^BGPINDM(BGPIC,53,1,0),0,1,BGPPTYPE) D:$D(^BGPINDM(BGPIC,53,2,0)) W^BGP6DP(^BGPINDM(BGPIC,53,2,0),0,1,BGPPTYPE) D H3
+6 KILL BGPDAC,BGPDAP,BGPDAB
+7 SET BGPORX=4
FOR BGPORXX=1,2,3
FOR BGPX="A","B","C","D","E","F","G","H"
DO AGES
+8 DO I1AGEP
+9 IF BGPQUIT
QUIT
+10 SET BGPHD1="Male AC+BH Pts 9-75"
SET BGPHD2="Male AC+BH Pts 9-75"
SET BGPHD3=""
+11 ;I '$G(BGPSUMON),BGPPTYPE="P" D HEADER^BGP6DPH Q:BGPQUIT W !,^BGPINDM(BGPIC,53,1,0) W:$D(^BGPINDM(BGPIC,53,2,0)) !,^BGPINDM(BGPIC,53,2,0) D H3
+12 KILL BGPDAC,BGPDAP,BGPDAB
SET BGPORX=5
FOR BGPORXX=1,2,3
FOR BGPX="A","B","C","D","E","F","G","H"
DO AGES
+13 DO I1AGEP
+14 IF BGPQUIT
QUIT
FEM ;
+1 SET BGPHD1="Female AC+BH Pts 9-75"
SET BGPHD2="Female AC+BH Pts 9-75"
SET BGPHD3=""
+2 ;I '$G(BGPSUMON),BGPPTYPE="P" D HEADER^BGP6DPH Q:BGPQUIT W !,^BGPINDM(BGPIC,53,1,0) W:$D(^BGPINDM(BGPIC,53,2,0)) !,^BGPINDM(BGPIC,53,2,0) D H3
+3 KILL BGPDAC,BGPDAP,BGPDAB
SET BGPORX=6
FOR BGPORXX=1,2,3
FOR BGPX="A","B","C","D","E","F","G","H"
DO AGES
+4 DO I1AGEP
+5 KILL BGPHD3
+6 QUIT
AGES ;
+1 IF BGPX="A"
SET BGPPP1=1
+2 IF BGPX="B"
SET BGPPP1=2
+3 IF BGPX="C"
SET BGPPP1=3
+4 IF BGPX="D"
SET BGPPP1=4
+5 IF BGPX="E"
SET BGPPP1=5
+6 IF BGPX="F"
SET BGPPP1=6
+7 IF BGPX="G"
SET BGPPP1=7
+8 IF BGPX="H"
SET BGPPP1=8
+9 SET BGPF="SBI."_BGPORX_"."_BGPORXX_BGPX
SET BGPPC=$ORDER(^BGPINDMC("C",BGPF,0))
+10 IF BGPORXX=1
Begin DoDot:1
+11 SET BGPDF=$PIECE(^BGPINDMC(BGPPC,0),U,8)
+12 SET BGPNP=$PIECE(^DD(90556.03,BGPDF,0),U,4)
SET N=$PIECE(BGPNP,";")
SET P=$PIECE(BGPNP,";",2)
+13 SET $PIECE(BGPDAC(1),U,BGPPP1)=$$V^BGP6DP1C(1,BGPRPT,N,P)
+14 SET $PIECE(BGPDAP(1),U,BGPPP1)=$$V^BGP6DP1C(2,BGPRPT,N,P)
+15 SET $PIECE(BGPDAB(1),U,BGPPP1)=$$V^BGP6DP1C(3,BGPRPT,N,P)
End DoDot:1
+16 ;
+17 SET BGPNF=$PIECE(^BGPINDMC(BGPPC,0),U,9)
+18 SET BGPNP=$PIECE(^DD(90556.03,BGPNF,0),U,4)
SET N=$PIECE(BGPNP,";")
SET P=$PIECE(BGPNP,";",2)
+19 SET $PIECE(BGPDAC(BGPORXX,1),U,BGPPP1)=$$V^BGP6DP1C(1,BGPRPT,N,P)
+20 SET $PIECE(BGPDAC(BGPORXX,2),U,BGPPP1)=$SELECT($PIECE(BGPDAC(1),U,BGPPP1):($PIECE(BGPDAC(BGPORXX,1),U,BGPPP1)/$PIECE(BGPDAC(1),U,BGPPP1)*100),1:"")
+21 SET $PIECE(BGPDAP(BGPORXX,1),U,BGPPP1)=$$V^BGP6DP1C(2,BGPRPT,N,P)
+22 SET $PIECE(BGPDAP(BGPORXX,2),U,BGPPP1)=$SELECT($PIECE(BGPDAP(1),U,BGPPP1):($PIECE(BGPDAP(BGPORXX,1),U,BGPPP1)/$PIECE(BGPDAP(1),U,BGPPP1)*100),1:"")
+23 SET $PIECE(BGPDAB(BGPORXX,1),U,BGPPP1)=$$V^BGP6DP1C(3,BGPRPT,N,P)
+24 SET $PIECE(BGPDAB(BGPORXX,2),U,BGPPP1)=$SELECT($PIECE(BGPDAB(1),U,BGPPP1):($PIECE(BGPDAB(BGPORXX,1),U,BGPPP1)/$PIECE(BGPDAB(1),U,BGPPP1)*100),1:"")
+25 QUIT
I1AGEP ;
+1 SET BGPYSTP=1
+2 IF '$GET(BGPSUMON)
IF BGPPTYPE="P"
DO HEADER^BGP6DPH
IF BGPQUIT
QUIT
DO W^BGP6DP(^BGPINDM(BGPIC,53,1,0),0,1,BGPPTYPE)
IF $DATA(^BGPINDM(BGPIC,53,2,0))
DO W^BGP6DP(^BGPINDM(BGPIC,53,2,0),0,1,BGPPTYPE)
DO H3
+3 IF BGPPTYPE'="P"
DO W^BGP6DP("",0,2,BGPPTYPE)
DO H3
+4 DO W^BGP6DP("CURRENT REPORT PERIOD",0,1,BGPPTYPE)
+5 ;I BGPPTYPE="P" D W^BGP6DP(BGPHD3,0,1,BGPPTYPE)
+6 SET BGPARR="BGPDAC"
DO I1AGEP1
+7 ;I '$G(BGPSUMON),BGPPTYPE="P" D HEADER^BGP6DPH Q:BGPQUIT D W^BGP6DP(^BGPINDM(BGPIC,53,1,0),0,1,BGPPTYPE) D:$D(^BGPINDM(BGPIC,53,2,0)) W^BGP6DP(^BGPINDM(BGPIC,53,2,0),0,1,BGPPTYPE) D H3
+8 ;D H3
DO W^BGP6DP("",0,2,BGPPTYPE)
+9 DO W^BGP6DP("PREVIOUS REPORT PERIOD",0,1,BGPPTYPE)
+10 ;D W^BGP6DP($S(BGPPTYPE="P":BGPHD2,1:BGPHD1),0,1,BGPPTYPE)
+11 ;I BGPPTYPE="P" D W^BGP6DP(BGPHD3,0,1,BGPPTYPE)
+12 SET BGPARR="BGPDAP"
DO I1AGEP1
+13 IF '$GET(BGPSUMON)
IF BGPPTYPE="P"
DO HEADER^BGP6DPH
IF BGPQUIT
QUIT
DO W^BGP6DP(^BGPINDM(BGPIC,53,1,0),0,1,BGPPTYPE)
IF $DATA(^BGPINDM(BGPIC,53,2,0))
DO W^BGP6DP(^BGPINDM(BGPIC,53,2,0),0,1,BGPPTYPE)
DO H3
+14 DO W^BGP6DP("",0,2,BGPPTYPE)
+15 DO W^BGP6DP("BASELINE REPORT PERIOD",0,1,BGPPTYPE)
+16 ;D W^BGP6DP($S(BGPPTYPE="P":BGPHD2,1:BGPHD1),0,1,BGPPTYPE)
+17 IF BGPPTYPE="P"
DO W^BGP6DP(BGPHD3,0,1,BGPPTYPE)
+18 SET BGPARR="BGPDAB"
DO I1AGEP1
+19 QUIT
P1 ;
+1 IF BGPPTYPE="D"
DO W^BGP6DP(BGPDL(BGPX,1),0,2,BGPPTYPE)
+2 IF BGPPTYPE="P"
DO W^BGP6DP(BGPPL(BGPX,1),0,2,BGPPTYPE)
DO W^BGP6DP(BGPPL(BGPX,2),0,1,BGPPTYPE)
+3 SET T=23
FOR X=1:1:8
SET V=$PIECE(@BGPARR@(BGPX,1),U,X)
DO W^BGP6DP($SELECT(BGPPTYPE="P":$$C(V,0,6),1:$SELECT(V:V,1:0)),0,0,BGPPTYPE,X+1,T)
SET T=T+7
+4 IF BGPPTYPE="D"
DO W^BGP6DP(BGPDL(BGPX,2),0,1,BGPPTYPE)
+5 IF BGPPTYPE="P"
DO W^BGP6DP(BGPPL(BGPX,3),0,1,BGPPTYPE)
DO W^BGP6DP($GET(BGPPL(BGPX,4)),0,1,BGPPTYPE)
+6 SET T=23
FOR X=1:1:8
SET V=$PIECE(@BGPARR@(BGPX,2),U,X)
DO W^BGP6DP($SELECT(BGPPTYPE="P":$JUSTIFY(V,6,1),1:$$SB($JUSTIFY(V,6,1))),0,0,BGPPTYPE,X+1,T)
SET T=T+7
+7 QUIT
I1AGEP1 ;
+1 NEW BGPX
+2 NEW BGPPL,BGPDL
+3 IF BGPPTYPE="D"
DO W^BGP6DP(BGPHD1,0,1,BGPPTYPE)
+4 IF BGPPTYPE="P"
DO W^BGP6DP(BGPHD2,0,1,BGPPTYPE)
+5 IF BGPPTYPE="P"
IF BGPHD3]""
DO W^BGP6DP(BGPHD3,1,1,BGPPTYPE)
+6 SET T=23
FOR X=1:1:8
SET V=$PIECE(@BGPARR@(1),U,X)
DO W^BGP6DP($SELECT(BGPPTYPE="P":$$C(V,0,6),1:$SELECT(V:V,1:0)),0,0,BGPPTYPE,X+1,T)
SET T=T+7
+7 SET BGPX=1
SET BGPDL(BGPX,1)="# w/ Screening for Alcohol Use"
SET BGPPL(BGPX,1)="# w/ Screening for"
SET BGPPL(BGPX,2)=" Alcohol Use"
SET BGPDL(BGPX,2)="% w/ Screening for Alcohol Use"
SET BGPPL(BGPX,3)="% w/ Screening for"
SET BGPPL(BGPX,4)=" Alcohol Use"
DO P1
+8 SET BGPX=2
SET BGPDL(BGPX,1)="A. # w/ Positive Screen w/ % of Total Screened"
SET BGPPL(BGPX,1)="A. # w/ Positive Screen"
SET BGPPL(BGPX,2)=" w/ % of Total Screened"
SET BGPDL(BGPX,2)="% A. w/ Positive Screen w/ % of Total Screened"
Begin DoDot:1
+9 SET BGPPL(BGPX,3)="% A. w/ Positive Screen w/ "
SET BGPPL(BGPX,4)=" % of Total Screened"
DO P1
End DoDot:1
+10 SET BGPX=3
SET BGPDL(BGPX,1)="B. # w/ BNI/BI in 7 days of screen w/ % of Total Screened"
SET BGPPL(BGPX,1)="B. # w/ BNI/BI in 7 days of screen"
SET BGPPL(BGPX,2)=" w/ % of Total Screened"
Begin DoDot:1
+11 SET BGPDL(BGPX,2)="% B. w/ BNI/BI in 7 days of screen w/ %of Total Screened"
SET BGPPL(BGPX,3)="% B. w/ BNI/BI in 7 days of screen"
SET BGPPL(BGPX,4)=" w/ % of Total Screened"
DO P1
End DoDot:1
+12 ;change from baseline/previous year
+13 IF BGPARR="BGPDAP"!(BGPARR="BGPDAB")
Begin DoDot:1
+14 DO W^BGP6DP("CHANGE FROM "_$SELECT(BGPARR="BGPDAP":"PREVIOUS YR %",1:"BASELINE YR %"),0,2,BGPPTYPE)
+15 FOR BGPX=1,2,3
Begin DoDot:2
+16 IF BGPPTYPE="P"
DO W^BGP6DP(BGPPL(BGPX,1),0,1,BGPPTYPE)
SET L=BGPPL(BGPX,2)
DO PBY
+17 IF BGPPTYPE="D"
SET L=BGPDL(BGPX,1)
DO PBY
End DoDot:2
End DoDot:1
+18 QUIT
PBY ;
+1 DO W^BGP6DP(L,0,1,BGPPTYPE)
+2 SET T=23
FOR P=1:1:8
SET N=$PIECE(BGPDAC(BGPX,2),U,P)
SET O=$PIECE(@BGPARR@(BGPX,2),U,P)
IF N=""
SET N=0
IF O=""
SET O=0
SET Y=$SELECT(BGPPTYPE="P":$JUSTIFY($FNUMBER((N-O),"+,",1),6),1:$$SB($JUSTIFY((N-O),6,1)))
DO W^BGP6DP(Y,0,0,BGPPTYPE,P+1,T)
SET T=T+7
+3 QUIT
C(X,X2,X3) ;
+1 DO COMMA^%DTC
+2 QUIT X
H3 ;EP
+1 IF $GET(BGPSUMON)
QUIT
+2 DO W^BGP6DP(BGPHD1,1,2,BGPPTYPE)
+3 DO W^BGP6DP("Age Distribution",0,1,BGPPTYPE,1,40)
+4 DO W^BGP6DP(" 9-12",0,1,BGPPTYPE,2,23)
+5 DO W^BGP6DP("13-18",0,0,BGPPTYPE,3,30)
+6 DO W^BGP6DP("19-24",0,0,BGPPTYPE,4,37)
+7 DO W^BGP6DP("25-34",0,0,BGPPTYPE,5,44)
+8 DO W^BGP6DP("35-44",0,0,BGPPTYPE,6,51)
+9 DO W^BGP6DP("45-54",0,0,BGPPTYPE,7,58)
+10 DO W^BGP6DP("55-64",0,0,BGPPTYPE,8,65)
+11 DO W^BGP6DP("65-75",0,0,BGPPTYPE,9,72)
+12 QUIT
SB(X) ;EP - Strip
+1 XECUTE ^DD("FUNC",$ORDER(^DD("FUNC","B","STRIPBLANKS",0)),1)
+2 QUIT X
I2AGE ;EP special age tallies
+1 IF $GET(BGPSUMON)
QUIT
+2 IF BGPRTYPE'=4
QUIT
+3 IF BGPINDM="W"
IF BGPRTYPE=4
GOTO FEM2
+4 SET BGPHD1="ACTIVE CLINICAL PLUS BH PATIENTS W/ POSITIVE ALCOHOL SCREEN AGES 9-75"
SET BGPHD2="AC+BH Pts 9-75 w/ Positive"
SET BGPHD3=" Alcohol Screen"
+5 ;I '$G(BGPSUMON),BGPPTYPE="P" D HEADER^BGP6DPH Q:BGPQUIT D W^BGP6DP(^BGPINDM(BGPIC,53,1,0),0,1,BGPPTYPE) D:$D(^BGPINDM(BGPIC,53,2,0)) W^BGP6DP(^BGPINDM(BGPIC,53,2,0),0,1,BGPPTYPE) D H3
+6 KILL BGPDAC,BGPDAP,BGPDAB
+7 SET BGPORX=10
FOR BGPORXX=1:1:5
FOR BGPX="A","B","C","D","E","F","G","H"
DO AGES
+8 DO I2AGEP
+9 IF BGPQUIT
QUIT
+10 SET BGPHD1="MALE ACTIVE CLINICAL PLUS BH PATIENTS W/ POSITIVE ALCOHOL SCREEN AGES 9-75"
SET BGPHD2="MALE AC+BH Pts 9-75 w/ Positive"
SET BGPHD3=" Alcohol Screen"
+11 ;I '$G(BGPSUMON),BGPPTYPE="P" D HEADER^BGP6DPH Q:BGPQUIT W !,^BGPINDM(BGPIC,53,1,0) W:$D(^BGPINDM(BGPIC,53,2,0)) !,^BGPINDM(BGPIC,53,2,0) D H3
+12 KILL BGPDAC,BGPDAP,BGPDAB
SET BGPORX=11
FOR BGPORXX=1:1:5
FOR BGPX="A","B","C","D","E","F","G","H"
DO AGES
+13 DO I2AGEP
+14 IF BGPQUIT
QUIT
FEM2 ;
+1 SET BGPHD1="FEMALE ACTIVE CLINICAL PLUS BH PATIENTS W/ POSITIVE ALCOHOL SCREEN AGES 9-75"
SET BGPHD2="FEMALE AC+BH Pts 9-75 w/ Positive"
SET BGPHD3=" Alcohol Screen"
+2 ;I '$G(BGPSUMON),BGPPTYPE="P" D HEADER^BGP6DPH Q:BGPQUIT W !,^BGPINDM(BGPIC,53,1,0) W:$D(^BGPINDM(BGPIC,53,2,0)) !,^BGPINDM(BGPIC,53,2,0) D H3
+3 KILL BGPDAC,BGPDAP,BGPDAB
SET BGPORX=12
FOR BGPORXX=1:1:5
FOR BGPX="A","B","C","D","E","F","G","H"
DO AGES
+4 DO I2AGEP
+5 KILL BGPHD3
+6 QUIT
I2AGEP1 ;
+1 NEW BGPX
+2 NEW BGPPL,BGPDL
+3 IF BGPPTYPE="D"
DO W^BGP6DP(BGPHD1,0,1,BGPPTYPE)
+4 IF BGPPTYPE="P"
DO W^BGP6DP(BGPHD2,0,1,BGPPTYPE)
+5 IF BGPPTYPE="P"
IF BGPHD3]""
DO W^BGP6DP(BGPHD3,0,1,BGPPTYPE)
+6 SET T=23
FOR X=1:1:8
SET V=$PIECE(@BGPARR@(1),U,X)
DO W^BGP6DP($SELECT(BGPPTYPE="P":$$C(V,0,6),1:$SELECT(V:V,1:0)),0,0,BGPPTYPE,X+1,T)
SET T=T+7
+7 SET BGPX=1
SET BGPDL(BGPX,1)="# w/ BNI/BI in 7 days of screen"
SET BGPPL(BGPX,1)="# w/ BNI/BI in"
SET BGPPL(BGPX,2)=" 7 days of screen"
Begin DoDot:1
+8 SET BGPDL(BGPX,2)="% w/ BNI/BI in 7 days of screen"
SET BGPPL(BGPX,3)="% w/ BNI/BI in"
SET BGPPL(BGPX,4)="7 days of screen"
DO P1
End DoDot:1
+9 SET BGPX=2
SET BGPDL(BGPX,1)="A. # w/ BNI/BI on same day w/ % of Total BNI/BI"
SET BGPPL(BGPX,1)="A. # w/ BNI/BI on same day"
Begin DoDot:1
+10 SET (BGPPL(BGPX,4),BGPPL(BGPX,2))=" w/ % of Total BNI/BI"
SET BGPDL(BGPX,2)="% A. w/ BNI/BI on same day w/ % of Total BNI/BI"
SET BGPPL(BGPX,3)="% A. w/ BNI/BI on same day"
DO P1
End DoDot:1
+11 SET BGPX=3
SET BGPDL(BGPX,1)="B. # w/ BNI/BI in 1-3 days w/ % of Total BNI/BI"
SET BGPPL(BGPX,1)="B. # w/ BNI/BI in 1-3 days"
Begin DoDot:1
+12 SET (BGPPL(BGPX,4),BGPPL(BGPX,2))=" w/ % of Total BNI/BI"
SET BGPDL(BGPX,2)="% B. w/ BNI/BI in 1-3 days w/ % of Total BNI/BI"
SET BGPPL(BGPX,3)="% B. w/ BNI/BI in 1-3 days"
DO P1
End DoDot:1
+13 SET BGPX=4
SET BGPDL(BGPX,1)="C. # w/ BNI/BI in 4-7 days w/ % of Total BNI/BI"
SET BGPPL(BGPX,1)="C. # w/ BNI/BI in 4-7 days"
Begin DoDot:1
+14 SET (BGPPL(BGPX,4),BGPPL(BGPX,2))=" w/ % of Total BNI/BI"
SET BGPDL(BGPX,2)="% C. w/ BNI/BI in 4-7 days w/ % of Total BNI/BI"
SET BGPPL(BGPX,3)="% C. w/ BNI/BI in 4-7 days"
DO P1
End DoDot:1
+15 SET BGPX=5
SET BGPDL(BGPX,1)="D. # w/ Referral in 7 days of screen w/ % of Total BNI/BI"
SET BGPPL(BGPX,1)="D. # w/ Referral in 7 days of Screen"
Begin DoDot:1
+16 SET (BGPPL(BGPX,4),BGPPL(BGPX,2))=" w/ % of Total BNI/BI"
SET BGPDL(BGPX,2)="% D. w/ Referral in 7 days of screen w/ % of Total BNI/BI"
SET BGPPL(BGPX,3)="% D. w/ Referral in 7 days of screen"
SET BGPPL(BGPX,4)=" w/ % of Total BNI/BI"
DO P1
End DoDot:1
+17 ;change from baseline/previous year
+18 IF BGPARR="BGPDAP"!(BGPARR="BGPDAB")
Begin DoDot:1
+19 DO W^BGP6DP("CHANGE FROM "_$SELECT(BGPARR="BGPDAP":"PREVIOUS YR %",1:"BASELINE YR %"),0,2,BGPPTYPE)
+20 FOR BGPX=1,2,3,4,5
Begin DoDot:2
+21 IF BGPPTYPE="P"
DO W^BGP6DP(BGPPL(BGPX,1),0,1,BGPPTYPE)
SET L=BGPPL(BGPX,2)
DO PBY
+22 IF BGPPTYPE="D"
SET L=BGPDL(BGPX,1)
DO PBY
End DoDot:2
End DoDot:1
+23 QUIT
I2AGEP ;
+1 SET BGPYSTP=1
+2 IF '$GET(BGPSUMON)
IF BGPPTYPE="P"
DO HEADER^BGP6DPH
IF BGPQUIT
QUIT
DO W^BGP6DP(^BGPINDM(BGPIC,53,1,0),0,1,BGPPTYPE)
IF $DATA(^BGPINDM(BGPIC,53,2,0))
DO W^BGP6DP(^BGPINDM(BGPIC,53,2,0),0,1,BGPPTYPE)
DO H3
+3 IF BGPPTYPE'="P"
DO W^BGP6DP("",0,2,BGPPTYPE)
DO H3
+4 DO W^BGP6DP("CURRENT REPORT PERIOD",0,2,BGPPTYPE)
+5 ;I BGPPTYPE="P" D W^BGP6DP(BGPHD3,0,1,BGPPTYPE)
+6 SET BGPARR="BGPDAC"
DO I2AGEP1
+7 IF '$GET(BGPSUMON)
IF BGPPTYPE="P"
DO HEADER^BGP6DPH
IF BGPQUIT
QUIT
DO W^BGP6DP(^BGPINDM(BGPIC,53,1,0),0,1,BGPPTYPE)
IF $DATA(^BGPINDM(BGPIC,53,2,0))
DO W^BGP6DP(^BGPINDM(BGPIC,53,2,0),0,1,BGPPTYPE)
DO H3
+8 DO W^BGP6DP("",0,2,BGPPTYPE)
+9 DO W^BGP6DP("PREVIOUS REPORT PERIOD",0,1,BGPPTYPE)
+10 ;D W^BGP6DP($S(BGPPTYPE="P":BGPHD2,1:BGPHD1),0,1,BGPPTYPE)
+11 ;I BGPPTYPE="P" D W^BGP6DP(BGPHD3,0,1,BGPPTYPE)
+12 SET BGPARR="BGPDAP"
DO I2AGEP1
+13 IF '$GET(BGPSUMON)
IF BGPPTYPE="P"
DO HEADER^BGP6DPH
IF BGPQUIT
QUIT
DO W^BGP6DP(^BGPINDM(BGPIC,53,1,0),0,1,BGPPTYPE)
IF $DATA(^BGPINDM(BGPIC,53,2,0))
DO W^BGP6DP(^BGPINDM(BGPIC,53,2,0),0,1,BGPPTYPE)
DO H3
+14 DO W^BGP6DP("",0,2,BGPPTYPE)
+15 DO W^BGP6DP("BASELINE REPORT PERIOD",0,1,BGPPTYPE)
+16 ;D W^BGP6DP($S(BGPPTYPE="P":BGPHD2,1:BGPHD1),0,1,BGPPTYPE)
+17 ;I BGPPTYPE="P" D W^BGP6DP(BGPHD3,0,1,BGPPTYPE)
+18 SET BGPARR="BGPDAB"
DO I2AGEP1
+19 QUIT
