BGP8DP2 ; IHS/CMI/LAB - print ind 10 02 Jul 2010 9:25 AM ;
;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
;
;
;
I10 ;EP
I $Y>(BGPIOSL-13),'$G(BGPSUMON) D HEADER^BGP8DPH Q:BGPQUIT W !!,^BGPINDR(BGPIC,53,1,0) W:$D(^BGPINDR(BGPIC,53,2,0)) !,^BGPINDR(BGPIC,53,2,0)
D H1^BGP8DPH
S BGPORDP=$P(^BGPINDR(BGPIC,12),U,6) F BGPORDP1=1:1:$P(^BGPINDR(BGPIC,0),U,13) S BGPPC1=BGPORDP_"."_BGPORDP1 Q:BGPQUIT D PI^BGP8DP1
W !
S BGPNODEN=1
F BGPPC1=$P(^BGPINDR(BGPIC,12),U,6)_".7" D PI Q:BGPQUIT
K BGPNODEN
F BGPPC1=BGPORDP_".8" D PI^BGP8DP1 Q:BGPQUIT
Q
I11 ;EP
S BGPORDP=$P(^BGPINDR(BGPIC,12),U,6)
F BGPORDP1=1:1:$P(^BGPINDR(BGPIC,0),U,13) S BGPPC1=BGPORDP_"."_BGPORDP1 Q:BGPQUIT D PI^BGP8DP1
D H1 ;S BGPNODEN=1
;F BGPPC1=BGPORXX_".1" D PI^BGP8DP1C Q:BGPQUIT
;I '$G(BGPSUMON) D HEADER^BGP8DPH Q:BGPQUIT W !!,^BGPINDR(BGPIC,53,1,0)
S BGPNODEN=1
F BGPPC1=BGPORDP_".8" D PI Q:BGPQUIT
F BGPPC1=BGPORDP_".9" D PI Q:BGPQUIT
K BGPNODEN
F BGPPC1=BGPORDP_".10" D PI^BGP8DP1 Q:BGPQUIT
Q
ISTI ;EP
S BGPORXX=$P(^BGPINDR(BGPIC,12),U,6)
I $Y>(BGPIOSL-13),'$G(BGPSUMON) D HEADER^BGP8DPH Q:BGPQUIT W !!,^BGPINDR(BGPIC,53,1,0) W:$D(^BGPINDR(BGPIC,53,2,0)) !,^BGPINDR(BGPIC,53,2,0)
D H1 S BGPNODEN=1
F BGPPC1=BGPORXX_".1",BGPORXX_".2",BGPORXX_".3" D PI Q:BGPQUIT
Q:BGPQUIT
I $Y>(BGPIOSL-13),'$G(BGPSUMON) D HEADER^BGP8DPH Q:BGPQUIT W !!,^BGPINDR(BGPIC,53,1,0) W:$D(^BGPINDR(BGPIC,53,2,0)) !,^BGPINDR(BGPIC,53,2,0) D H1
S BGPNODEN=1
F BGPPC1=BGPORXX_".4" D PI Q:BGPQUIT
Q:BGPQUIT
;
K BGPNODEN
F BGPPC1=BGPORXX_".5" D PI^BGP8DP1 Q:BGPQUIT
Q:BGPQUIT
;Q:BGPRTYPE=7
F BGPPC1=BGPORXX_".6",BGPORXX_".7" D PI^BGP8DP1 Q:BGPQUIT
Q
Q:BGPQUIT
F BGPPC1=BGPORXX_".10",BGPORXX_".11",BGPORXX_".12" D PI^BGP8DP1 Q:BGPQUIT
Q:BGPQUIT
F BGPPC1=BGPORXX_".13",BGPORXX_".14",BGPORXX_".15" D PI^BGP8DP1 Q:BGPQUIT
Q:BGPQUIT
F BGPPC1=BGPORXX_".16",BGPORXX_".17",BGPORXX_".18" D PI^BGP8DP1 Q:BGPQUIT
Q:BGPQUIT
F BGPPC1=BGPORXX_".19",BGPORXX_".20",BGPORXX_".21" D PI^BGP8DP1 Q:BGPQUIT
Q:BGPQUIT
;USER POP
I $Y>(BGPIOSL-13),'$G(BGPSUMON) D HEADER^BGP8DPH Q:BGPQUIT W !!,^BGPINDR(BGPIC,53,1,0) W:$D(^BGPINDR(BGPIC,53,2,0)) !,^BGPINDR(BGPIC,53,2,0) D H1
S BGPNODEN=1
F BGPPC1=BGPORXX_".22",BGPORXX_".23",BGPORXX_".24" D PI Q:BGPQUIT
Q:BGPQUIT
I $Y>(BGPIOSL-13),'$G(BGPSUMON) D HEADER^BGP8DPH Q:BGPQUIT W !!,^BGPINDR(BGPIC,53,1,0) W:$D(^BGPINDR(BGPIC,53,2,0)) !,^BGPINDR(BGPIC,53,2,0) D H1
S BGPNODEN=1
F BGPPC1=BGPORXX_".25",BGPORXX_".26",BGPORXX_".27" D PI Q:BGPQUIT
K BGPNODEN
F BGPPC1=BGPORXX_".28",BGPORXX_".29",BGPORXX_".30" D PI^BGP8DP1 Q:BGPQUIT
Q:BGPQUIT
F BGPPC1=BGPORXX_".31",BGPORXX_".32",BGPORXX_".33" D PI^BGP8DP1 Q:BGPQUIT
Q:BGPQUIT
F BGPPC1=BGPORXX_".34",BGPORXX_".35",BGPORXX_".36" D PI^BGP8DP1 Q:BGPQUIT
Q:BGPQUIT
F BGPPC1=BGPORXX_".37",BGPORXX_".38",BGPORXX_".39" D PI^BGP8DP1 Q:BGPQUIT
Q:BGPQUIT
F BGPPC1=BGPORXX_".40",BGPORXX_".41",BGPORXX_".42" D PI^BGP8DP1 Q:BGPQUIT
Q:BGPQUIT
Q
IPC ;EP
S BGPORXX=$P(^BGPINDR(BGPIC,12),U,6)
I $Y>(BGPIOSL-13),'$G(BGPSUMON) D HEADER^BGP8DPH Q:BGPQUIT W !!,^BGPINDR(BGPIC,53,1,0) W:$D(^BGPINDR(BGPIC,53,2,0)) !,^BGPINDR(BGPIC,53,2,0)
D H1 S BGPNODEN=1
F BGPPC1=BGPORXX_".1",BGPORXX_".2",BGPORXX_".3",BGPORXX_".4" D PI Q:BGPQUIT
Q:BGPQUIT
I $Y>(BGPIOSL-13),'$G(BGPSUMON) D HEADER^BGP8DPH Q:BGPQUIT W !!,^BGPINDR(BGPIC,53,1,0) W:$D(^BGPINDR(BGPIC,53,2,0)) !,^BGPINDR(BGPIC,53,2,0) D H1
S BGPNODEN=1
F BGPPC1=BGPORXX_".5",BGPORXX_".6",BGPORXX_".7",BGPORXX_".8" D PI Q:BGPQUIT
S BGPORDP=$P(^BGPINDR(BGPIC,12),U,6) F BGPORDP1=9:1:17 S BGPPC1=BGPORDP_"."_BGPORDP1 Q:BGPQUIT D PI^BGP8DP1
Q
PI ;EP
S BGPDENP=0
K BGPDHOLD
K BGPCYP,BGPBLP,BGPPRP
S BGPPC2=0 F S BGPPC2=$O(^BGPINDRC("AB",BGPPC1,BGPPC2)) Q:BGPPC2="" S BGPPC=$O(^BGPINDRC("AB",BGPPC1,BGPPC2,0)) D PI1
Q
PI1 ;EP
K BGPEXCT,BGPSDP,BGPSDPN,BGPSDPO,BGPSDPN
Q:'$$CHECK^BGP8DP1E(BGPPC)
;get numerator value of measure and calc %
S BGPDF=$P(^BGPINDRC(BGPPC,0),U,9)
;I $P(^BGPINDRC(BGPPC,0),U,4)[".1" S BGPDHOLD=BGPDF
;I $P(^BGPINDRC(BGPPC,0),U,4)'[".1" S BGPDF=BGPDHOLD
S BGPNP=$P(^DD(90560.03,BGPDF,0),U,4),N=$P(BGPNP,";"),P=$P(BGPNP,";",2)
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)
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)
D SETN
D SETSUM
;
;write header for 1.A.1
I $Y>(BGPIOSL-6),'$G(BGPSUMON) D HEADER^BGP8DPH Q:BGPQUIT W !!,^BGPINDR(BGPIC,53,1,0) W:$D(^BGPINDR(BGPIC,53,2,0)) !,^BGPINDR(BGPIC,53,2,0) D H1
I '$G(BGPSUMON) D
.S X=$$LABEL^BGP8UTL1(BGPPC,BGPRTYPE,BGPPTYPE,$G(BGPINDG),"N")
.W !,$P(X,U,1)
.F I=2:1 S Y=$P(X,U,I) Q:Y="" W !," ",Y
D H2
Q
SETSUM ;EP
I $P($G(^BGPINDRC(BGPPC,14)),U) D
.S ^TMP($J,"SUMMARY",$P(^BGPSCAT($P(^BGPINDRC(BGPPC,14),U,5),0),U,2),$P(^BGPINDRC(BGPPC,14),U,6),BGPPC)=BGPCYN_U_BGPPRN_U_BGPBLN
.Q:'$G(BGPAREAA)
.S X=0 F S X=$O(BGPSDP(X)) Q:X'=+X D ;SDPX
..S ^TMP($J,"SUMMARY DETAIL PAGE",$P(^BGPSCAT($P(^BGPINDRC(BGPPC,14),U,5),0),U,2),$P(^BGPINDRC(BGPPC,14),U,6),BGPPC,X)=$P($G(BGPSDP(X,1)),U,2)_U_$P($G(BGPSDP(X,2)),U,2)_U_$P($G(BGPSDP(X,3)),U,2)_U_BGPCYN
;NON
I $P($G(^BGPINDRC(BGPPC,15)),U) D
.S ^TMP($J,"SUMMARY NON",$P(^BGPSCAT($P(^BGPINDRC(BGPPC,15),U,5),0),U,3),$P(^BGPINDRC(BGPPC,15),U,6),BGPPC)=BGPCYN_U_BGPPRN_U_BGPBLN
.I $G(BGPAREAA) D ;SDPX
..S X=0 F S X=$O(BGPSDPN(X)) Q:X'=+X D ;SDPX
...S ^TMP($J,"SUMMARY DETAIL PAGE NON",$P(^BGPSCAT($P(^BGPINDRC(BGPPC,15),U,5),0),U,3),$P(^BGPINDRC(BGPPC,15),U,6),BGPPC,X)=$P($G(BGPSDPN(X,1)),U,2)_U_$P($G(BGPSDPN(X,2)),U,2)_U_$P($G(BGPSDPN(X,3)),U,2)_U_BGPCYN
;DEVEL
I $P($G(^BGPINDRC(BGPPC,22)),U) D
.S ^TMP($J,"SUMMARY DEVEL",$P(^BGPSCAT($P(^BGPINDRC(BGPPC,22),U,5),0),U,3),$P(^BGPINDRC(BGPPC,22),U,6),BGPPC)=BGPCYN_U_BGPPRN_U_BGPBLN
.I $G(BGPAREAA) D ;SDPX
..S X=0 F S X=$O(BGPSDPD(X)) Q:X'=+X D ;SDPX
...S ^TMP($J,"SUMMARY DETAIL PAGE DEVEL",$P(^BGPSCAT($P(^BGPINDRC(BGPPC,22),U,5),0),U,3),$P(^BGPINDRC(BGPPC,22),U,6),BGPPC,X)=$P($G(BGPSDPD(X,1)),U,2)_U_$P($G(BGPSDPD(X,2)),U,2)_U_$P($G(BGPSDPD(X,3)),U,2)_U_BGPCYN
;OTHER
I $P($G(^BGPINDRC(BGPPC,19)),U) D
.S ^TMP($J,"SUMMARY OTHER",$P(^BGPSCAT($P(^BGPINDRC(BGPPC,19),U,5),0),U,3),$P(^BGPINDRC(BGPPC,19),U,6),BGPPC)=BGPCYN_U_BGPPRN_U_BGPBLN
.I $G(BGPAREAA) D ;SDPX
..S X=0 F S X=$O(BGPSDPO(X)) Q:X'=+X D ;SDPX
...S ^TMP($J,"SUMMARY DETAIL PAGE OTHER",$P(^BGPSCAT($P(^BGPINDRC(BGPPC,19),U,5),0),U,3),$P(^BGPINDRC(BGPPC,19),U,6),BGPPC,X)=$P($G(BGPSDPO(X,1)),U,2)_U_$P($G(BGPSDPO(X,2)),U,2)_U_$P($G(BGPSDPO(X,3)),U,2)_U_BGPCYN
;I $P(^BGPINDRC(BGPPC,0),U,4)="E-2.B.3",BGPROT="D"!(BGPROT="P") D SETSUM^BGP8PDL2
Q
H2 ;EP
Q:$G(BGPSUMON)
S BGPX="",BGPX=$$C(BGPCYN,0,8),$E(BGPX,9)=$S(BGPCYP]"":$J($G(BGPCYP),5,1),1:""),$E(BGPX,16)=$$C(BGPPRN,0,8),$E(BGPX,24)=$S(BGPPRP]"":$J($G(BGPPRP),5,1),1:""),$E(BGPX,32)=$$CALC(BGPCYN,BGPPRN)
S $E(BGPX,39)=$$C(BGPBLN,0,8),$E(BGPX,47)=$S(BGPBLP]"":$J($G(BGPBLP),5,1),1:""),$E(BGPX,55)=$$CALC(BGPCYN,BGPBLN)
W:'$G(BGPSUMON) ?20,BGPX
Q
H1 ;EP
Q:$G(BGPSUMON)
W !!?21,"REPORT",?31,"",?35,"PREV YR",?46,"",?49,"CHG from",?59,"BASE",?69,"",?72,"CHG from"
W !?21,"PERIOD ",?35,"PERIOD ",?49,"PREV YR ",?59,"PERIOD ",?72,"BASE "
Q
CALC(N,O) ;ENTRY POINT
NEW Z
S Z=N-O,Z=$FN(Z,"+,",0)
Q Z
C(X,X2,X3) ;
D COMMA^%DTC
Q X
SETN ;set numerator fields
S BGPNOSUM=1
D SETN^BGP8DP1C
;I $P(^BGPINDRC(BGPPC,0),U,4)[".1"
K BGPNOSUM
S (BGPCYP,BGPPRP,BGPBLP)=""
Q
BGP8DP2 ; IHS/CMI/LAB - print ind 10 02 Jul 2010 9:25 AM ;
+1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
+2 ;
+3 ;
+4 ;
I10 ;EP
+1 IF $Y>(BGPIOSL-13)
IF '$GET(BGPSUMON)
DO HEADER^BGP8DPH
IF BGPQUIT
QUIT
WRITE !!,^BGPINDR(BGPIC,53,1,0)
IF $DATA(^BGPINDR(BGPIC,53,2,0))
WRITE !,^BGPINDR(BGPIC,53,2,0)
+2 DO H1^BGP8DPH
+3 SET BGPORDP=$PIECE(^BGPINDR(BGPIC,12),U,6)
FOR BGPORDP1=1:1:$PIECE(^BGPINDR(BGPIC,0),U,13)
SET BGPPC1=BGPORDP_"."_BGPORDP1
IF BGPQUIT
QUIT
DO PI^BGP8DP1
+4 WRITE !
+5 SET BGPNODEN=1
+6 FOR BGPPC1=$PIECE(^BGPINDR(BGPIC,12),U,6)_".7"
DO PI
IF BGPQUIT
QUIT
+7 KILL BGPNODEN
+8 FOR BGPPC1=BGPORDP_".8"
DO PI^BGP8DP1
IF BGPQUIT
QUIT
+9 QUIT
I11 ;EP
+1 SET BGPORDP=$PIECE(^BGPINDR(BGPIC,12),U,6)
+2 FOR BGPORDP1=1:1:$PIECE(^BGPINDR(BGPIC,0),U,13)
SET BGPPC1=BGPORDP_"."_BGPORDP1
IF BGPQUIT
QUIT
DO PI^BGP8DP1
+3 ;S BGPNODEN=1
DO H1
+4 ;F BGPPC1=BGPORXX_".1" D PI^BGP8DP1C Q:BGPQUIT
+5 ;I '$G(BGPSUMON) D HEADER^BGP8DPH Q:BGPQUIT W !!,^BGPINDR(BGPIC,53,1,0)
+6 SET BGPNODEN=1
+7 FOR BGPPC1=BGPORDP_".8"
DO PI
IF BGPQUIT
QUIT
+8 FOR BGPPC1=BGPORDP_".9"
DO PI
IF BGPQUIT
QUIT
+9 KILL BGPNODEN
+10 FOR BGPPC1=BGPORDP_".10"
DO PI^BGP8DP1
IF BGPQUIT
QUIT
+11 QUIT
ISTI ;EP
+1 SET BGPORXX=$PIECE(^BGPINDR(BGPIC,12),U,6)
+2 IF $Y>(BGPIOSL-13)
IF '$GET(BGPSUMON)
DO HEADER^BGP8DPH
IF BGPQUIT
QUIT
WRITE !!,^BGPINDR(BGPIC,53,1,0)
IF $DATA(^BGPINDR(BGPIC,53,2,0))
WRITE !,^BGPINDR(BGPIC,53,2,0)
+3 DO H1
SET BGPNODEN=1
+4 FOR BGPPC1=BGPORXX_".1",BGPORXX_".2",BGPORXX_".3"
DO PI
IF BGPQUIT
QUIT
+5 IF BGPQUIT
QUIT
+6 IF $Y>(BGPIOSL-13)
IF '$GET(BGPSUMON)
DO HEADER^BGP8DPH
IF BGPQUIT
QUIT
WRITE !!,^BGPINDR(BGPIC,53,1,0)
IF $DATA(^BGPINDR(BGPIC,53,2,0))
WRITE !,^BGPINDR(BGPIC,53,2,0)
DO H1
+7 SET BGPNODEN=1
+8 FOR BGPPC1=BGPORXX_".4"
DO PI
IF BGPQUIT
QUIT
+9 IF BGPQUIT
QUIT
+10 ;
+11 KILL BGPNODEN
+12 FOR BGPPC1=BGPORXX_".5"
DO PI^BGP8DP1
IF BGPQUIT
QUIT
+13 IF BGPQUIT
QUIT
+14 ;Q:BGPRTYPE=7
+15 FOR BGPPC1=BGPORXX_".6",BGPORXX_".7"
DO PI^BGP8DP1
IF BGPQUIT
QUIT
+16 QUIT
+17 IF BGPQUIT
QUIT
+18 FOR BGPPC1=BGPORXX_".10",BGPORXX_".11",BGPORXX_".12"
DO PI^BGP8DP1
IF BGPQUIT
QUIT
+19 IF BGPQUIT
QUIT
+20 FOR BGPPC1=BGPORXX_".13",BGPORXX_".14",BGPORXX_".15"
DO PI^BGP8DP1
IF BGPQUIT
QUIT
+21 IF BGPQUIT
QUIT
+22 FOR BGPPC1=BGPORXX_".16",BGPORXX_".17",BGPORXX_".18"
DO PI^BGP8DP1
IF BGPQUIT
QUIT
+23 IF BGPQUIT
QUIT
+24 FOR BGPPC1=BGPORXX_".19",BGPORXX_".20",BGPORXX_".21"
DO PI^BGP8DP1
IF BGPQUIT
QUIT
+25 IF BGPQUIT
QUIT
+26 ;USER POP
+27 IF $Y>(BGPIOSL-13)
IF '$GET(BGPSUMON)
DO HEADER^BGP8DPH
IF BGPQUIT
QUIT
WRITE !!,^BGPINDR(BGPIC,53,1,0)
IF $DATA(^BGPINDR(BGPIC,53,2,0))
WRITE !,^BGPINDR(BGPIC,53,2,0)
DO H1
+28 SET BGPNODEN=1
+29 FOR BGPPC1=BGPORXX_".22",BGPORXX_".23",BGPORXX_".24"
DO PI
IF BGPQUIT
QUIT
+30 IF BGPQUIT
QUIT
+31 IF $Y>(BGPIOSL-13)
IF '$GET(BGPSUMON)
DO HEADER^BGP8DPH
IF BGPQUIT
QUIT
WRITE !!,^BGPINDR(BGPIC,53,1,0)
IF $DATA(^BGPINDR(BGPIC,53,2,0))
WRITE !,^BGPINDR(BGPIC,53,2,0)
DO H1
+32 SET BGPNODEN=1
+33 FOR BGPPC1=BGPORXX_".25",BGPORXX_".26",BGPORXX_".27"
DO PI
IF BGPQUIT
QUIT
+34 KILL BGPNODEN
+35 FOR BGPPC1=BGPORXX_".28",BGPORXX_".29",BGPORXX_".30"
DO PI^BGP8DP1
IF BGPQUIT
QUIT
+36 IF BGPQUIT
QUIT
+37 FOR BGPPC1=BGPORXX_".31",BGPORXX_".32",BGPORXX_".33"
DO PI^BGP8DP1
IF BGPQUIT
QUIT
+38 IF BGPQUIT
QUIT
+39 FOR BGPPC1=BGPORXX_".34",BGPORXX_".35",BGPORXX_".36"
DO PI^BGP8DP1
IF BGPQUIT
QUIT
+40 IF BGPQUIT
QUIT
+41 FOR BGPPC1=BGPORXX_".37",BGPORXX_".38",BGPORXX_".39"
DO PI^BGP8DP1
IF BGPQUIT
QUIT
+42 IF BGPQUIT
QUIT
+43 FOR BGPPC1=BGPORXX_".40",BGPORXX_".41",BGPORXX_".42"
DO PI^BGP8DP1
IF BGPQUIT
QUIT
+44 IF BGPQUIT
QUIT
+45 QUIT
IPC ;EP
+1 SET BGPORXX=$PIECE(^BGPINDR(BGPIC,12),U,6)
+2 IF $Y>(BGPIOSL-13)
IF '$GET(BGPSUMON)
DO HEADER^BGP8DPH
IF BGPQUIT
QUIT
WRITE !!,^BGPINDR(BGPIC,53,1,0)
IF $DATA(^BGPINDR(BGPIC,53,2,0))
WRITE !,^BGPINDR(BGPIC,53,2,0)
+3 DO H1
SET BGPNODEN=1
+4 FOR BGPPC1=BGPORXX_".1",BGPORXX_".2",BGPORXX_".3",BGPORXX_".4"
DO PI
IF BGPQUIT
QUIT
+5 IF BGPQUIT
QUIT
+6 IF $Y>(BGPIOSL-13)
IF '$GET(BGPSUMON)
DO HEADER^BGP8DPH
IF BGPQUIT
QUIT
WRITE !!,^BGPINDR(BGPIC,53,1,0)
IF $DATA(^BGPINDR(BGPIC,53,2,0))
WRITE !,^BGPINDR(BGPIC,53,2,0)
DO H1
+7 SET BGPNODEN=1
+8 FOR BGPPC1=BGPORXX_".5",BGPORXX_".6",BGPORXX_".7",BGPORXX_".8"
DO PI
IF BGPQUIT
QUIT
+9 SET BGPORDP=$PIECE(^BGPINDR(BGPIC,12),U,6)
FOR BGPORDP1=9:1:17
SET BGPPC1=BGPORDP_"."_BGPORDP1
IF BGPQUIT
QUIT
DO PI^BGP8DP1
+10 QUIT
PI ;EP
+1 SET BGPDENP=0
+2 KILL BGPDHOLD
+3 KILL BGPCYP,BGPBLP,BGPPRP
+4 SET BGPPC2=0
FOR
SET BGPPC2=$ORDER(^BGPINDRC("AB",BGPPC1,BGPPC2))
IF BGPPC2=""
QUIT
SET BGPPC=$ORDER(^BGPINDRC("AB",BGPPC1,BGPPC2,0))
DO PI1
+5 QUIT
PI1 ;EP
+1 KILL BGPEXCT,BGPSDP,BGPSDPN,BGPSDPO,BGPSDPN
+2 IF '$$CHECK^BGP8DP1E(BGPPC)
QUIT
+3 ;get numerator value of measure and calc %
+4 SET BGPDF=$PIECE(^BGPINDRC(BGPPC,0),U,9)
+5 ;I $P(^BGPINDRC(BGPPC,0),U,4)[".1" S BGPDHOLD=BGPDF
+6 ;I $P(^BGPINDRC(BGPPC,0),U,4)'[".1" S BGPDF=BGPDHOLD
+7 SET BGPNP=$PIECE(^DD(90560.03,BGPDF,0),U,4)
SET N=$PIECE(BGPNP,";")
SET P=$PIECE(BGPNP,";",2)
+8 SET BGPCYD=$$V^BGP8DP1C(1,BGPRPT,N,P,1)
IF $GET(BGPAREAA)
DO SETEXA^BGP8DP1C(1,N,P)
+9 SET BGPPRD=$$V^BGP8DP1C(2,BGPRPT,N,P,1)
IF $GET(BGPAREAA)
DO SETEXA^BGP8DP1C(2,N,P)
+10 SET BGPBLD=$$V^BGP8DP1C(3,BGPRPT,N,P,1)
IF $GET(BGPAREAA)
DO SETEXA^BGP8DP1C(3,N,P)
+11 SET BGPNF=$PIECE(^BGPINDRC(BGPPC,0),U,9)
+12 SET BGPNP=$PIECE(^DD(90560.03,BGPNF,0),U,4)
SET N=$PIECE(BGPNP,";")
SET P=$PIECE(BGPNP,";",2)
+13 DO SETN
+14 DO SETSUM
+15 ;
+16 ;write header for 1.A.1
+17 IF $Y>(BGPIOSL-6)
IF '$GET(BGPSUMON)
DO HEADER^BGP8DPH
IF BGPQUIT
QUIT
WRITE !!,^BGPINDR(BGPIC,53,1,0)
IF $DATA(^BGPINDR(BGPIC,53,2,0))
WRITE !,^BGPINDR(BGPIC,53,2,0)
DO H1
+18 IF '$GET(BGPSUMON)
Begin DoDot:1
+19 SET X=$$LABEL^BGP8UTL1(BGPPC,BGPRTYPE,BGPPTYPE,$GET(BGPINDG),"N")
+20 WRITE !,$PIECE(X,U,1)
+21 FOR I=2:1
SET Y=$PIECE(X,U,I)
IF Y=""
QUIT
WRITE !," ",Y
End DoDot:1
+22 DO H2
+23 QUIT
SETSUM ;EP
+1 IF $PIECE($GET(^BGPINDRC(BGPPC,14)),U)
Begin DoDot:1
+2 SET ^TMP($JOB,"SUMMARY",$PIECE(^BGPSCAT($PIECE(^BGPINDRC(BGPPC,14),U,5),0),U,2),$PIECE(^BGPINDRC(BGPPC,14),U,6),BGPPC)=BGPCYN_U_BGPPRN_U_BGPBLN
+3 IF '$GET(BGPAREAA)
QUIT
+4 ;SDPX
SET X=0
FOR
SET X=$ORDER(BGPSDP(X))
IF X'=+X
QUIT
Begin DoDot:2
+5 SET ^TMP($JOB,"SUMMARY DETAIL PAGE",$PIECE(^BGPSCAT($PIECE(^BGPINDRC(BGPPC,14),U,5),0),U,2),$PIECE(^BGPINDRC(BGPPC,14),U,6),BGPPC,X)=$PIECE($GET(BGPSDP(X,1)),U,2)_U_$PIECE($GET(BGPSDP(X,2)),U,2)_U_$PIECE($GET(BGPSDP(X,3)),U,2)_U
_BGPCYN
End DoDot:2
End DoDot:1
+6 ;NON
+7 IF $PIECE($GET(^BGPINDRC(BGPPC,15)),U)
Begin DoDot:1
+8 SET ^TMP($JOB,"SUMMARY NON",$PIECE(^BGPSCAT($PIECE(^BGPINDRC(BGPPC,15),U,5),0),U,3),$PIECE(^BGPINDRC(BGPPC,15),U,6),BGPPC)=BGPCYN_U_BGPPRN_U_BGPBLN
+9 ;SDPX
IF $GET(BGPAREAA)
Begin DoDot:2
+10 ;SDPX
SET X=0
FOR
SET X=$ORDER(BGPSDPN(X))
IF X'=+X
QUIT
Begin DoDot:3
+11 SET ^TMP($JOB,"SUMMARY DETAIL PAGE NON",$PIECE(^BGPSCAT($PIECE(^BGPINDRC(BGPPC,15),U,5),0),U,3),$PIECE(^BGPINDRC(BGPPC,15),U,6),BGPPC,X)=$PIECE($GET(BGPSDPN(X,1)),U,2)_U_$PIECE($GET(BGPSDPN(X,2)),U,2)_U_$PIECE($GET(BGPSD
PN(X,3)),U,2)_U_BGPCYN
End DoDot:3
End DoDot:2
End DoDot:1
+12 ;DEVEL
+13 IF $PIECE($GET(^BGPINDRC(BGPPC,22)),U)
Begin DoDot:1
+14 SET ^TMP($JOB,"SUMMARY DEVEL",$PIECE(^BGPSCAT($PIECE(^BGPINDRC(BGPPC,22),U,5),0),U,3),$PIECE(^BGPINDRC(BGPPC,22),U,6),BGPPC)=BGPCYN_U_BGPPRN_U_BGPBLN
+15 ;SDPX
IF $GET(BGPAREAA)
Begin DoDot:2
+16 ;SDPX
SET X=0
FOR
SET X=$ORDER(BGPSDPD(X))
IF X'=+X
QUIT
Begin DoDot:3
+17 SET ^TMP($JOB,"SUMMARY DETAIL PAGE DEVEL",$PIECE(^BGPSCAT($PIECE(^BGPINDRC(BGPPC,22),U,5),0),U,3),$PIECE(^BGPINDRC(BGPPC,22),U,6),BGPPC,X)=$PIECE($GET(BGPSDPD(X,1)),U,2)_U_$PIECE($GET(BGPSDPD(X,2)),U,2)_U_$PIECE($GET(BGP
SDPD(X,3)),U,2)_U_BGPCYN
End DoDot:3
End DoDot:2
End DoDot:1
+18 ;OTHER
+19 IF $PIECE($GET(^BGPINDRC(BGPPC,19)),U)
Begin DoDot:1
+20 SET ^TMP($JOB,"SUMMARY OTHER",$PIECE(^BGPSCAT($PIECE(^BGPINDRC(BGPPC,19),U,5),0),U,3),$PIECE(^BGPINDRC(BGPPC,19),U,6),BGPPC)=BGPCYN_U_BGPPRN_U_BGPBLN
+21 ;SDPX
IF $GET(BGPAREAA)
Begin DoDot:2
+22 ;SDPX
SET X=0
FOR
SET X=$ORDER(BGPSDPO(X))
IF X'=+X
QUIT
Begin DoDot:3
+23 SET ^TMP($JOB,"SUMMARY DETAIL PAGE OTHER",$PIECE(^BGPSCAT($PIECE(^BGPINDRC(BGPPC,19),U,5),0),U,3),$PIECE(^BGPINDRC(BGPPC,19),U,6),BGPPC,X)=$PIECE($GET(BGPSDPO(X,1)),U,2)_U_$PIECE($GET(BGPSDPO(X,2)),U,2)_U_$PIECE($GET(BGP
SDPO(X,3)),U,2)_U_BGPCYN
End DoDot:3
End DoDot:2
End DoDot:1
+24 ;I $P(^BGPINDRC(BGPPC,0),U,4)="E-2.B.3",BGPROT="D"!(BGPROT="P") D SETSUM^BGP8PDL2
+25 QUIT
H2 ;EP
+1 IF $GET(BGPSUMON)
QUIT
+2 SET BGPX=""
SET BGPX=$$C(BGPCYN,0,8)
SET $EXTRACT(BGPX,9)=$SELECT(BGPCYP]"":$JUSTIFY($GET(BGPCYP),5,1),1:"")
SET $EXTRACT(BGPX,16)=$$C(BGPPRN,0,8)
SET $EXTRACT(BGPX,24)=$SELECT(BGPPRP]"":$JUSTIFY($GET(BGPPRP),5,1),1:"")
SET $EXTRACT(BGPX,32)=$$CALC(BGPCYN,BGPPRN)
+3 SET $EXTRACT(BGPX,39)=$$C(BGPBLN,0,8)
SET $EXTRACT(BGPX,47)=$SELECT(BGPBLP]"":$JUSTIFY($GET(BGPBLP),5,1),1:"")
SET $EXTRACT(BGPX,55)=$$CALC(BGPCYN,BGPBLN)
+4 IF '$GET(BGPSUMON)
WRITE ?20,BGPX
+5 QUIT
H1 ;EP
+1 IF $GET(BGPSUMON)
QUIT
+2 WRITE !!?21,"REPORT",?31,"",?35,"PREV YR",?46,"",?49,"CHG from",?59,"BASE",?69,"",?72,"CHG from"
+3 WRITE !?21,"PERIOD ",?35,"PERIOD ",?49,"PREV YR ",?59,"PERIOD ",?72,"BASE "
+4 QUIT
CALC(N,O) ;ENTRY POINT
+1 NEW Z
+2 SET Z=N-O
SET Z=$FNUMBER(Z,"+,",0)
+3 QUIT Z
C(X,X2,X3) ;
+1 DO COMMA^%DTC
+2 QUIT X
SETN ;set numerator fields
+1 SET BGPNOSUM=1
+2 DO SETN^BGP8DP1C
+3 ;I $P(^BGPINDRC(BGPPC,0),U,4)[".1"
+4 KILL BGPNOSUM
+5 SET (BGPCYP,BGPPRP,BGPBLP)=""
+6 QUIT
