BGP8DP1L.m

BGP8DP1L ; IHS/CMI/LAB - print ind 1 12 Nov 2010 7:38 AM ;

 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66

 ;

 ;HIV SCREENING AGE DIST

I1AGE ;EP  special age tallies

 Q:$G(BGPSUMON)

 S BGPHD1="Active Clinical Pts 5+ w/Persistent Asthma",BGPHD2="Active Clinical Pts 5+ ",BGPHD3=" w/ Persistent Asthma"

 K BGPDAC,BGPDAP,BGPDAB

 S (BGPX,BGPDD)=0 F BGPXX=12:1:22 D I1AGE1

 D I1AGEP

 Q

I1AGE1 ;

 ;

 I BGPXX=12 S BGPP1=2,BGPP2=3

 I BGPXX=13 S BGPP1=4,BGPP2=5

 I BGPXX=14 S BGPP1=6,BGPP2=7

 I BGPXX=15 S BGPP1=8,BGPP2=9

 I BGPXX=16 S BGPP1=10,BGPP2=11

 I BGPXX=17 S BGPP1=12,BGPP2=13

 I BGPXX=18 S BGPP1=14,BGPP2=15

 I BGPXX=19 S BGPP1=16,BGPP2=17

 I BGPXX=20 S BGPP1=18,BGPP2=19

 I BGPXX=21 S BGPP1=20,BGPP2=21

 I BGPXX=22 S BGPP1=22,BGPP2=23

 S BGPZ="A",BGPX=1 D AGES

 S BGPZ="B",BGPX=2 D AGES

 S BGPZ="C",BGPX=3 D AGES

 S BGPZ="D",BGPX=4 D AGES

 Q

AGES ;

 S BGPF="AA.A."_BGPXX_BGPZ S BGPPC=$O(^BGPINDRC("C",BGPF,0))

 D

 .S BGPDF=$P(^BGPINDRC(BGPPC,0),U,8)

 .S BGPNP=$P(^DD(90560.03,BGPDF,0),U,4),N=$P(BGPNP,";"),P=$P(BGPNP,";",2)

 .S $P(BGPDAC(BGPX),U)=$$V^BGP8DP1C(1,BGPRPT,N,P)

 .S $P(BGPDAP(BGPX),U)=$$V^BGP8DP1C(2,BGPRPT,N,P)

 .S $P(BGPDAB(BGPX),U)=$$V^BGP8DP1C(3,BGPRPT,N,P)

 ;S BGPCYD=$$V^BGP8DP1C(1,BGPRPT,N,P,1) I $G(BGPAREAA) D SETEXA^BGP8DP1C(1,N,P)

 ;S BGPPRD=$$V^BGP8DP1C(2,BGPRPT,N,P,1) I $G(BGPAREAA) D SETEXA^BGP8DP1C(2,N,P)

 ;S BGPBLD=$$V^BGP8DP1C(3,BGPRPT,N,P,1) I $G(BGPAREAA) D SETEXA^BGP8DP1C(3,N,P)

 ;set 2nd piece to numerator and 3rd to %

 S J=$P(BGPF,".",3)

 S Q=1

 ;I J["B" S Q=2

 ;I J["C" S Q=2

 ;I J["D" S Q=2

 S BGPNF=$P(^BGPINDRC(BGPPC,0),U,9)

 S BGPNP=$P(^DD(90560.03,BGPNF,0),U,4),N=$P(BGPNP,";"),P=$P(BGPNP,";",2)

 S $P(BGPDAC(BGPX),U,BGPP1)=$$V^BGP8DP1C(1,BGPRPT,N,P),$P(BGPDAC(BGPX),U,BGPP2)=$S($P(BGPDAC(BGPX),U,Q):($P(BGPDAC(BGPX),U,BGPP1)/$P(BGPDAC(BGPX),U,Q)*100),1:"")

 S $P(BGPDAP(BGPX),U,BGPP1)=$$V^BGP8DP1C(2,BGPRPT,N,P),$P(BGPDAP(BGPX),U,BGPP2)=$S($P(BGPDAP(BGPX),U,Q):($P(BGPDAP(BGPX),U,BGPP1)/$P(BGPDAP(BGPX),U,Q)*100),1:"")

 S $P(BGPDAB(BGPX),U,BGPP1)=$$V^BGP8DP1C(3,BGPRPT,N,P),$P(BGPDAB(BGPX),U,BGPP2)=$S($P(BGPDAB(BGPX),U,Q):($P(BGPDAB(BGPX),U,BGPP1)/$P(BGPDAB(BGPX),U,Q)*100),1:"")

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

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

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

 ;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

I1AGEP ;

 S BGPYSTP=1

 I '$G(BGPSUMON),BGPPTYPE="P" D HEADER^BGP8DPH Q:BGPQUIT  D W^BGP8DP(^BGPINDR(BGPIC,53,1,0),0,1,BGPPTYPE) D:$D(^BGPINDR(BGPIC,53,2,0)) W^BGP8DP(^BGPINDR(BGPIC,53,2,0),0,1,BGPPTYPE) D AH

 I BGPPTYPE'="P" D W^BGP8DP("",0,2,BGPPTYPE) D AH

 D W^BGP8DP("CURRENT REPORT PERIOD",0,1,BGPPTYPE)

 D W^BGP8DP($S(BGPPTYPE="P":BGPHD2,1:BGPHD1),0,1,BGPPTYPE)

 I BGPPTYPE="P" D W^BGP8DP(BGPHD3,0,1,BGPPTYPE)

 S BGPARR="BGPDAC" D I1AGEP1

 I '$G(BGPSUMON),BGPPTYPE="P" D HEADER^BGP8DPH Q:BGPQUIT  D W^BGP8DP(^BGPINDR(BGPIC,53,1,0),0,1,BGPPTYPE) D:$D(^BGPINDR(BGPIC,53,2,0)) W^BGP8DP(^BGPINDR(BGPIC,53,2,0),0,1,BGPPTYPE) D AH

 I BGPPTYPE'="P" D W^BGP8DP("",0,2,BGPPTYPE) D AH

 D W^BGP8DP("PREVIOUS REPORT PERIOD",0,1,BGPPTYPE)

 D W^BGP8DP($S(BGPPTYPE="P":BGPHD2,1:BGPHD1),0,1,BGPPTYPE)

 I BGPPTYPE="P" D W^BGP8DP(BGPHD3,0,1,BGPPTYPE)

 S BGPARR="BGPDAP" D I1AGEP1

 I '$G(BGPSUMON),BGPPTYPE="P" D HEADER^BGP8DPH Q:BGPQUIT  D W^BGP8DP(^BGPINDR(BGPIC,53,1,0),0,1,BGPPTYPE) D:$D(^BGPINDR(BGPIC,53,2,0)) W^BGP8DP(^BGPINDR(BGPIC,53,2,0),0,1,BGPPTYPE) D AH

 I BGPPTYPE'="P" D W^BGP8DP("",0,2,BGPPTYPE) D AH

 D W^BGP8DP("BASELINE REPORT PERIOD",0,1,BGPPTYPE)

 D W^BGP8DP($S(BGPPTYPE="P":BGPHD2,1:BGPHD1),0,1,BGPPTYPE)

 I BGPPTYPE="P" D W^BGP8DP(BGPHD3,0,1,BGPPTYPE)

 S BGPARR="BGPDAB" D I1AGEP1

 Q

I1AGEP1 ;

 S T=30 F X=1:1:4 S V=$P(@BGPARR@(X),U) D W^BGP8DP($S(BGPPTYPE="P":$$C(V,0,6),1:$S(V:V,1:0)),0,0,BGPPTYPE,X+1,T) S T=T+11

 D W^BGP8DP("# w/ Management Plan",0,2,BGPPTYPE)

 S T=31 F X=1:1:4 S V=$P(@BGPARR@(X),U,2) D W^BGP8DP($S(BGPPTYPE="P":$$C(V,0,6),1:$S(V:V,1:0)),0,0,BGPPTYPE,X+1,T) S T=T+11

 D W^BGP8DP("% w/ Management Plan",0,1,BGPPTYPE)

 S T=30 F X=1:1:4 S V=$P(@BGPARR@(X),U,3) D W^BGP8DP($S(BGPPTYPE="P":$J(V,6,1),1:$$SB($J(V,6,1))),0,0,BGPPTYPE,X+1,T) S T=T+11

 D W^BGP8DP("# w/ Severity Documented",0,2,BGPPTYPE)

 S T=31 F X=1:1:4 S V=$P(@BGPARR@(X),U,4) D W^BGP8DP($S(BGPPTYPE="P":$$C(V,0,6),1:$S(V:V,1:0)),0,0,BGPPTYPE,X+1,T) S T=T+11

 D W^BGP8DP("% w/ Severity Documented",0,1,BGPPTYPE)

 S T=30 F X=1:1:4 S V=$P(@BGPARR@(X),U,5) D W^BGP8DP($S(BGPPTYPE="P":$J(V,6,1),1:$$SB($J(V,6,1))),0,0,BGPPTYPE,X+1,T) S T=T+11

 D W^BGP8DP("% w/ Control Documented",0,2,BGPPTYPE)

 S T=31 F X=1:1:4 S V=$P(@BGPARR@(X),U,6) D W^BGP8DP($S(BGPPTYPE="P":$$C(V,0,6),1:$S(V:V,1:0)),0,0,BGPPTYPE,X+1,T) S T=T+11

 D W^BGP8DP("% w/ Control Documented",0,1,BGPPTYPE)

 S T=30 F X=1:1:4 S V=$P(@BGPARR@(X),U,7) D W^BGP8DP($S(BGPPTYPE="P":$J(V,6,1),1:$$SB($J(V,6,1))),0,0,BGPPTYPE,X+1,T) S T=T+11

 D W^BGP8DP("# w/ Symptom Free Days Assessed",0,2,BGPPTYPE)

 S T=31 F X=1:1:4 S V=$P(@BGPARR@(X),U,8) D W^BGP8DP($S(BGPPTYPE="P":$$C(V,0,6),1:$S(V:V,1:0)),0,0,BGPPTYPE,X+1,T) S T=T+11

 D W^BGP8DP("% w/ Symptom Free Days Assessed",0,1,BGPPTYPE)

 S T=30 F X=1:1:4 S V=$P(@BGPARR@(X),U,9) D W^BGP8DP($S(BGPPTYPE="P":$J(V,6,1),1:$$SB($J(V,6,1))),0,0,BGPPTYPE,X+1,T) S T=T+11

 D W^BGP8DP("# w/ Symptom Free Days 0-5",0,2,BGPPTYPE)

 S T=31 F X=1:1:4 S V=$P(@BGPARR@(X),U,10) D W^BGP8DP($S(BGPPTYPE="P":$$C(V,0,6),1:$S(V:V,1:0)),0,0,BGPPTYPE,X+1,T) S T=T+11

 D W^BGP8DP("% w/ Symptom Free Days 0-5",0,1,BGPPTYPE)

 S T=30 F X=1:1:4 S V=$P(@BGPARR@(X),U,11) D W^BGP8DP($S(BGPPTYPE="P":$J(V,6,1),1:$$SB($J(V,6,1))),0,0,BGPPTYPE,X+1,T) S T=T+11

 D W^BGP8DP("# w/ Symptom Free Days 6-12",0,2,BGPPTYPE)

 S T=31 F X=1:1:4 S V=$P(@BGPARR@(X),U,12) D W^BGP8DP($S(BGPPTYPE="P":$$C(V,0,6),1:$S(V:V,1:0)),0,0,BGPPTYPE,X+1,T) S T=T+11

 D W^BGP8DP("% w/ Symptom Free Days 6-12",0,1,BGPPTYPE)

 S T=30 F X=1:1:4 S V=$P(@BGPARR@(X),U,13) D W^BGP8DP($S(BGPPTYPE="P":$J(V,6,1),1:$$SB($J(V,6,1))),0,0,BGPPTYPE,X+1,T) S T=T+11

 D W^BGP8DP("# w/ Symptom Free Days 13-14",0,2,BGPPTYPE)

 S T=31 F X=1:1:4 S V=$P(@BGPARR@(X),U,14) D W^BGP8DP($S(BGPPTYPE="P":$$C(V,0,6),1:$S(V:V,1:0)),0,0,BGPPTYPE,X+1,T) S T=T+11

 D W^BGP8DP("% w/ Symptom Free Days 13-14",0,1,BGPPTYPE)

 S T=30 F X=1:1:4 S V=$P(@BGPARR@(X),U,15) D W^BGP8DP($S(BGPPTYPE="P":$J(V,6,1),1:$$SB($J(V,6,1))),0,0,BGPPTYPE,X+1,T) S T=T+11

 I BGPPTYPE="D" D W^BGP8DP("# w/ School/Work Days Missed",0,2,BGPPTYPE)

 I BGPPTYPE="P" D W^BGP8DP("# w/ School/Work Days",0,2,BGPPTYPE),W^BGP8DP(" Missed",0,1,BGPPTYPE)

 S T=31 F X=1:1:4 S V=$P(@BGPARR@(X),U,16) D W^BGP8DP($S(BGPPTYPE="P":$$C(V,0,6),1:$S(V:V,1:0)),0,0,BGPPTYPE,X+1,T) S T=T+11

 I BGPPTYPE="D" D W^BGP8DP("% w/ School/Work Days Missed",0,1,BGPPTYPE)

 I BGPPTYPE="P" D W^BGP8DP("% w/ School/Work Days",0,1,BGPPTYPE),W^BGP8DP(" Missed",0,1,BGPPTYPE)

 S T=30 F X=1:1:4 S V=$P(@BGPARR@(X),U,17) D W^BGP8DP($S(BGPPTYPE="P":$J(V,6,1),1:$$SB($J(V,6,1))),0,0,BGPPTYPE,X+1,T) S T=T+11

 I BGPPTYPE="D" D W^BGP8DP("# w/ School/Work Days Missed 0-2",0,2,BGPPTYPE)

 I BGPPTYPE="P" D W^BGP8DP("# w/ School/Work Days",0,2,BGPPTYPE),W^BGP8DP(" Missed 0-2",0,1,BGPPTYPE)

 S T=31 F X=1:1:4 S V=$P(@BGPARR@(X),U,18) D W^BGP8DP($S(BGPPTYPE="P":$$C(V,0,6),1:$S(V:V,1:0)),0,0,BGPPTYPE,X+1,T) S T=T+11

 I BGPPTYPE="D" D W^BGP8DP("% w/ School/Work Days Missed 0-2",0,1,BGPPTYPE)

 I BGPPTYPE="P" D W^BGP8DP("% w/ School/Work Days",0,1,BGPPTYPE),W^BGP8DP(" Missed 0-2",0,1,BGPPTYPE)

 S T=30 F X=1:1:4 S V=$P(@BGPARR@(X),U,19) D W^BGP8DP($S(BGPPTYPE="P":$J(V,6,1),1:$$SB($J(V,6,1))),0,0,BGPPTYPE,X+1,T) S T=T+11

 I BGPPTYPE="D" D W^BGP8DP("# w/ School/Work Days Missed 3-7",0,2,BGPPTYPE)

 I BGPPTYPE="P" D W^BGP8DP("# w/ School/Work Days",0,2,BGPPTYPE),W^BGP8DP(" Missed 3-7",0,1,BGPPTYPE)

 S T=31 F X=1:1:4 S V=$P(@BGPARR@(X),U,20) D W^BGP8DP($S(BGPPTYPE="P":$$C(V,0,6),1:$S(V:V,1:0)),0,0,BGPPTYPE,X+1,T) S T=T+11

 I BGPPTYPE="D" D W^BGP8DP("% w/ School/Work Days Missed 3-7",0,1,BGPPTYPE)

 I BGPPTYPE="P" D W^BGP8DP("% w/ School/Work Days",0,1,BGPPTYPE),W^BGP8DP(" Missed 3-7",0,1,BGPPTYPE)

 S T=30 F X=1:1:4 S V=$P(@BGPARR@(X),U,21) D W^BGP8DP($S(BGPPTYPE="P":$J(V,6,1),1:$$SB($J(V,6,1))),0,0,BGPPTYPE,X+1,T) S T=T+11

 I BGPPTYPE="D" D W^BGP8DP("# w/ School/Work Days Missed 8-14",0,2,BGPPTYPE)

 I BGPPTYPE="P" D W^BGP8DP("# w/ School/Work Days",0,2,BGPPTYPE),W^BGP8DP(" Missed 8-14",0,1,BGPPTYPE)

 S T=31 F X=1:1:4 S V=$P(@BGPARR@(X),U,22) D W^BGP8DP($S(BGPPTYPE="P":$$C(V,0,6),1:$S(V:V,1:0)),0,0,BGPPTYPE,X+1,T) S T=T+11

 I BGPPTYPE="D" D W^BGP8DP("% w/ School/Work Days Missed 8-14",0,1,BGPPTYPE)

 I BGPPTYPE="P" D W^BGP8DP("% w/ School/Work Days",0,1,BGPPTYPE),W^BGP8DP(" Missed 8-14",0,1,BGPPTYPE)

 S T=30 F X=1:1:4 S V=$P(@BGPARR@(X),U,23) D W^BGP8DP($S(BGPPTYPE="P":$J(V,6,1),1:$$SB($J(V,6,1))),0,0,BGPPTYPE,X+1,T) S T=T+11

 I BGPARR="BGPDAP"!(BGPARR="BGPDAB") D

 .D W^BGP8DP("CHANGE FROM "_$S(BGPARR="BGPDAP":"PREVIOUS YR %",1:"BASELINE YR %"),0,2,BGPPTYPE)

 .S L="# w/ Management Plan",P=3 D PBY

 .S L="# w/ Severity Documented",P=5 D PBY

 .S L="# w/ Control Documented",P=7 D PBY

 .I BGPPTYPE="P" D W^BGP8DP("# w/ Symptom Free Days",0,1,BGPPTYPE) S L=" Assessed",P=9 D PBY

 .I BGPPTYPE="D" S L="# w/ Symptom Free Days",P=9 D PBY

 .S L="# w/ Symptom Free Days 0-5",P=11 D PBY

 .S L="# w/ Symptom Free Days 6-12",P=13 D PBY

 .S L="# w/ Symptom Free Days 13-14",P=15 D PBY

 .I BGPPTYPE="P" D W^BGP8DP("# w/School/Work Days",0,1,BGPPTYPE) S L=" Missed",P=17 D PBY

 .I BGPPTYPE="D" S L="# w/School/Work Days Missed",P=17 D PBY

 .I BGPPTYPE="P" D W^BGP8DP("# w/School/Work Days",0,1,BGPPTYPE) S L=" Missed 0-2",P=19 D PBY

 .I BGPPTYPE="D" S L="# w/School/Work Days Missed 0-2",P=19 D PBY

 .I BGPPTYPE="P" D W^BGP8DP("# w/School/Work Days",0,1,BGPPTYPE) S L=" Missed 3-7",P=21 D PBY

 .I BGPPTYPE="D" S L="# w/School/Work Days Missed 3-7",P=21 D PBY

 .I BGPPTYPE="P" D W^BGP8DP("# w/School/Work Days",0,1,BGPPTYPE) S L=" Missed 8-14",P=23 D PBY

 .I BGPPTYPE="D" S L="# w/School/Work Days Missed 8-14",P=23 D PBY

 .Q

 Q

PBY ;

 D W^BGP8DP(L,0,1,BGPPTYPE)

 S T=30 F X=1:1:4 S N=$P(BGPDAC(X),U,P),O=$P(@BGPARR@(X),U,3) 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^BGP8DP(Y,0,0,BGPPTYPE,X+1,T) S T=T+11

 Q

C(X,X2,X3) ;

 D COMMA^%DTC

 Q X

AH ;EP

 Q:$G(BGPSUMON)

 D W^BGP8DP(BGPHD1,1,2,BGPPTYPE)

 ;D W^BGP8DP("Asthma Assessments",0,1,BGPPTYPE)

 D W^BGP8DP(" 5-14",0,1,BGPPTYPE,2,34)

 D W^BGP8DP("15-34",0,0,BGPPTYPE,3,45)

 D W^BGP8DP("35-64",0,0,BGPPTYPE,4,56)

 D W^BGP8DP("65+",0,0,BGPPTYPE,5,67)

 Q

SB(X) ;EP - Strip

 X ^DD("FUNC",$O(^DD("FUNC","B","STRIPBLANKS",0)),1)

 Q X

BGP8DP1L  ; IHS/CMI/LAB - print ind 1 12 Nov 2010 7:38 AM ;

 +1       ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66

 +2       ;

 +3       ;HIV SCREENING AGE DIST

I1AGE     ;EP  special age tallies

 +1        IF $GET(BGPSUMON)

               QUIT 

 +2        SET BGPHD1="Active Clinical Pts 5+ w/Persistent Asthma"

           SET BGPHD2="Active Clinical Pts 5+ "

           SET BGPHD3=" w/ Persistent Asthma"

 +3        KILL BGPDAC,BGPDAP,BGPDAB

 +4        SET (BGPX,BGPDD)=0

           FOR BGPXX=12:1:22

               DO I1AGE1

 +5        DO I1AGEP

 +6        QUIT 

I1AGE1    ;

 +1       ;

 +2        IF BGPXX=12

               SET BGPP1=2

               SET BGPP2=3

 +3        IF BGPXX=13

               SET BGPP1=4

               SET BGPP2=5

 +4        IF BGPXX=14

               SET BGPP1=6

               SET BGPP2=7

 +5        IF BGPXX=15

               SET BGPP1=8

               SET BGPP2=9

 +6        IF BGPXX=16

               SET BGPP1=10

               SET BGPP2=11

 +7        IF BGPXX=17

               SET BGPP1=12

               SET BGPP2=13

 +8        IF BGPXX=18

               SET BGPP1=14

               SET BGPP2=15

 +9        IF BGPXX=19

               SET BGPP1=16

               SET BGPP2=17

 +10       IF BGPXX=20

               SET BGPP1=18

               SET BGPP2=19

 +11       IF BGPXX=21

               SET BGPP1=20

               SET BGPP2=21

 +12       IF BGPXX=22

               SET BGPP1=22

               SET BGPP2=23

 +13       SET BGPZ="A"

           SET BGPX=1

           DO AGES

 +14       SET BGPZ="B"

           SET BGPX=2

           DO AGES

 +15       SET BGPZ="C"

           SET BGPX=3

           DO AGES

 +16       SET BGPZ="D"

           SET BGPX=4

           DO AGES

 +17       QUIT 

AGES      ;

 +1        SET BGPF="AA.A."_BGPXX_BGPZ

           SET BGPPC=$ORDER(^BGPINDRC("C",BGPF,0))

 +2        Begin DoDot:1

 +3            SET BGPDF=$PIECE(^BGPINDRC(BGPPC,0),U,8)

 +4            SET BGPNP=$PIECE(^DD(90560.03,BGPDF,0),U,4)

               SET N=$PIECE(BGPNP,";")

               SET P=$PIECE(BGPNP,";",2)

 +5            SET $PIECE(BGPDAC(BGPX),U)=$$V^BGP8DP1C(1,BGPRPT,N,P)

 +6            SET $PIECE(BGPDAP(BGPX),U)=$$V^BGP8DP1C(2,BGPRPT,N,P)

 +7            SET $PIECE(BGPDAB(BGPX),U)=$$V^BGP8DP1C(3,BGPRPT,N,P)

           End DoDot:1

 +8       ;S BGPCYD=$$V^BGP8DP1C(1,BGPRPT,N,P,1) I $G(BGPAREAA) D SETEXA^BGP8DP1C(1,N,P)

 +9       ;S BGPPRD=$$V^BGP8DP1C(2,BGPRPT,N,P,1) I $G(BGPAREAA) D SETEXA^BGP8DP1C(2,N,P)

 +10      ;S BGPBLD=$$V^BGP8DP1C(3,BGPRPT,N,P,1) I $G(BGPAREAA) D SETEXA^BGP8DP1C(3,N,P)

 +11      ;set 2nd piece to numerator and 3rd to %

 +12       SET J=$PIECE(BGPF,".",3)

 +13       SET Q=1

 +14      ;I J["B" S Q=2

 +15      ;I J["C" S Q=2

 +16      ;I J["D" S Q=2

 +17       SET BGPNF=$PIECE(^BGPINDRC(BGPPC,0),U,9)

 +18       SET BGPNP=$PIECE(^DD(90560.03,BGPNF,0),U,4)

           SET N=$PIECE(BGPNP,";")

           SET P=$PIECE(BGPNP,";",2)

 +19       SET $PIECE(BGPDAC(BGPX),U,BGPP1)=$$V^BGP8DP1C(1,BGPRPT,N,P)

           SET $PIECE(BGPDAC(BGPX),U,BGPP2)=$SELECT($PIECE(BGPDAC(BGPX),U,Q):($PIECE(BGPDAC(BGPX),U,BGPP1)/$PIECE(BGPDAC(BGPX),U,Q)*100),1:"")

 +20       SET $PIECE(BGPDAP(BGPX),U,BGPP1)=$$V^BGP8DP1C(2,BGPRPT,N,P)

           SET $PIECE(BGPDAP(BGPX),U,BGPP2)=$SELECT($PIECE(BGPDAP(BGPX),U,Q):($PIECE(BGPDAP(BGPX),U,BGPP1)/$PIECE(BGPDAP(BGPX),U,Q)*100),1:"")

 +21       SET $PIECE(BGPDAB(BGPX),U,BGPP1)=$$V^BGP8DP1C(3,BGPRPT,N,P)

           SET $PIECE(BGPDAB(BGPX),U,BGPP2)=$SELECT($PIECE(BGPDAB(BGPX),U,Q):($PIECE(BGPDAB(BGPX),U,BGPP1)/$PIECE(BGPDAB(BGPX),U,Q)*100),1:"")

 +22      ;S BGPCYN=$$V^BGP8DP1C(1,BGPRPT,N,P,2)

 +23      ;S BGPPRN=$$V^BGP8DP1C(2,BGPRPT,N,P,2)

 +24      ;S BGPBLN=$$V^BGP8DP1C(3,BGPRPT,N,P,2)

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

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

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

 +28       QUIT 

I1AGEP    ;

 +1        SET BGPYSTP=1

 +2        IF '$GET(BGPSUMON)

               IF BGPPTYPE="P"

                   DO HEADER^BGP8DPH

                   IF BGPQUIT

                       QUIT 

                   DO W^BGP8DP(^BGPINDR(BGPIC,53,1,0),0,1,BGPPTYPE)

                   IF $DATA(^BGPINDR(BGPIC,53,2,0))

                       DO W^BGP8DP(^BGPINDR(BGPIC,53,2,0),0,1,BGPPTYPE)

                   DO AH

 +3        IF BGPPTYPE'="P"

               DO W^BGP8DP("",0,2,BGPPTYPE)

               DO AH

 +4        DO W^BGP8DP("CURRENT REPORT PERIOD",0,1,BGPPTYPE)

 +5        DO W^BGP8DP($SELECT(BGPPTYPE="P":BGPHD2,1:BGPHD1),0,1,BGPPTYPE)

 +6        IF BGPPTYPE="P"

               DO W^BGP8DP(BGPHD3,0,1,BGPPTYPE)

 +7        SET BGPARR="BGPDAC"

           DO I1AGEP1

 +8        IF '$GET(BGPSUMON)

               IF BGPPTYPE="P"

                   DO HEADER^BGP8DPH

                   IF BGPQUIT

                       QUIT 

                   DO W^BGP8DP(^BGPINDR(BGPIC,53,1,0),0,1,BGPPTYPE)

                   IF $DATA(^BGPINDR(BGPIC,53,2,0))

                       DO W^BGP8DP(^BGPINDR(BGPIC,53,2,0),0,1,BGPPTYPE)

                   DO AH

 +9        IF BGPPTYPE'="P"

               DO W^BGP8DP("",0,2,BGPPTYPE)

               DO AH

 +10       DO W^BGP8DP("PREVIOUS REPORT PERIOD",0,1,BGPPTYPE)

 +11       DO W^BGP8DP($SELECT(BGPPTYPE="P":BGPHD2,1:BGPHD1),0,1,BGPPTYPE)

 +12       IF BGPPTYPE="P"

               DO W^BGP8DP(BGPHD3,0,1,BGPPTYPE)

 +13       SET BGPARR="BGPDAP"

           DO I1AGEP1

 +14       IF '$GET(BGPSUMON)

               IF BGPPTYPE="P"

                   DO HEADER^BGP8DPH

                   IF BGPQUIT

                       QUIT 

                   DO W^BGP8DP(^BGPINDR(BGPIC,53,1,0),0,1,BGPPTYPE)

                   IF $DATA(^BGPINDR(BGPIC,53,2,0))

                       DO W^BGP8DP(^BGPINDR(BGPIC,53,2,0),0,1,BGPPTYPE)

                   DO AH

 +15       IF BGPPTYPE'="P"

               DO W^BGP8DP("",0,2,BGPPTYPE)

               DO AH

 +16       DO W^BGP8DP("BASELINE REPORT PERIOD",0,1,BGPPTYPE)

 +17       DO W^BGP8DP($SELECT(BGPPTYPE="P":BGPHD2,1:BGPHD1),0,1,BGPPTYPE)

 +18       IF BGPPTYPE="P"

               DO W^BGP8DP(BGPHD3,0,1,BGPPTYPE)

 +19       SET BGPARR="BGPDAB"

           DO I1AGEP1

 +20       QUIT 

I1AGEP1   ;

 +1        SET T=30

           FOR X=1:1:4

               SET V=$PIECE(@BGPARR@(X),U)

               DO W^BGP8DP($SELECT(BGPPTYPE="P":$$C(V,0,6),1:$SELECT(V:V,1:0)),0,0,BGPPTYPE,X+1,T)

               SET T=T+11

 +2        DO W^BGP8DP("# w/ Management Plan",0,2,BGPPTYPE)

 +3        SET T=31

           FOR X=1:1:4

               SET V=$PIECE(@BGPARR@(X),U,2)

               DO W^BGP8DP($SELECT(BGPPTYPE="P":$$C(V,0,6),1:$SELECT(V:V,1:0)),0,0,BGPPTYPE,X+1,T)

               SET T=T+11

 +4        DO W^BGP8DP("% w/ Management Plan",0,1,BGPPTYPE)

 +5        SET T=30

           FOR X=1:1:4

               SET V=$PIECE(@BGPARR@(X),U,3)

               DO W^BGP8DP($SELECT(BGPPTYPE="P":$JUSTIFY(V,6,1),1:$$SB($JUSTIFY(V,6,1))),0,0,BGPPTYPE,X+1,T)

               SET T=T+11

 +6        DO W^BGP8DP("# w/ Severity Documented",0,2,BGPPTYPE)

 +7        SET T=31

           FOR X=1:1:4

               SET V=$PIECE(@BGPARR@(X),U,4)

               DO W^BGP8DP($SELECT(BGPPTYPE="P":$$C(V,0,6),1:$SELECT(V:V,1:0)),0,0,BGPPTYPE,X+1,T)

               SET T=T+11

 +8        DO W^BGP8DP("% w/ Severity Documented",0,1,BGPPTYPE)

 +9        SET T=30

           FOR X=1:1:4

               SET V=$PIECE(@BGPARR@(X),U,5)

               DO W^BGP8DP($SELECT(BGPPTYPE="P":$JUSTIFY(V,6,1),1:$$SB($JUSTIFY(V,6,1))),0,0,BGPPTYPE,X+1,T)

               SET T=T+11

 +10       DO W^BGP8DP("% w/ Control Documented",0,2,BGPPTYPE)

 +11       SET T=31

           FOR X=1:1:4

               SET V=$PIECE(@BGPARR@(X),U,6)

               DO W^BGP8DP($SELECT(BGPPTYPE="P":$$C(V,0,6),1:$SELECT(V:V,1:0)),0,0,BGPPTYPE,X+1,T)

               SET T=T+11

 +12       DO W^BGP8DP("% w/ Control Documented",0,1,BGPPTYPE)

 +13       SET T=30

           FOR X=1:1:4

               SET V=$PIECE(@BGPARR@(X),U,7)

               DO W^BGP8DP($SELECT(BGPPTYPE="P":$JUSTIFY(V,6,1),1:$$SB($JUSTIFY(V,6,1))),0,0,BGPPTYPE,X+1,T)

               SET T=T+11

 +14       DO W^BGP8DP("# w/ Symptom Free Days Assessed",0,2,BGPPTYPE)

 +15       SET T=31

           FOR X=1:1:4

               SET V=$PIECE(@BGPARR@(X),U,8)

               DO W^BGP8DP($SELECT(BGPPTYPE="P":$$C(V,0,6),1:$SELECT(V:V,1:0)),0,0,BGPPTYPE,X+1,T)