BGP9DP1C ; IHS/CMI/LAB - print ind 1 21 Mar 2008 12:55 PM ;
;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009
;
;
PI ;EP
S BGPDENP=0
S BGPPC2=0 F S BGPPC2=$O(^BGPINDNC("ABC",BGPPC1,BGPPC2)) Q:BGPPC2="" S BGPPC=$O(^BGPINDNC("ABC",BGPPC1,BGPPC2,0)) D PI1
Q
PI1 ;EP
K BGPEXCT,BGPSDP,BGPSDPN,BGPSDPO,BGPSDPD
I BGPRTYPE=1,$P(^BGPINDNC(BGPPC,0),U,5)'=1 Q
I BGPRTYPE=7,$P($G(^BGPINDNC(BGPPC,12)),U,12)'=1 Q
I BGPRTYPE=4,$P($G(^BGPINDNC(BGPPC,21)),U,2)=1 Q
I BGPINDT="D",$P(^BGPINDNC(BGPPC,0),U,12)'=1 Q
I BGPINDT="C",$P(^BGPINDNC(BGPPC,0),U,13)'=1 Q
I BGPINDT="W",$P($G(^BGPINDNC(BGPPC,12)),U,2)'=1 Q
I BGPINDT="E",$P($G(^BGPINDNC(BGPPC,12)),U,3)'=1 Q
I $P(^BGPINDNC(BGPPC,0),U,4)="E-2.B.3" D PI1^BGP9DP2 Q
S BGPDF=$P(^BGPINDNC(BGPPC,0),U,8)
;get denom value
S BGPNP=$P(^DD(90536.03,BGPDF,0),U,4),N=$P(BGPNP,";"),P=$P(BGPNP,";",2)
S BGPCYD=$$V(1,BGPRPT,N,P,1) I $G(BGPAREAA) D SETEXA(1,N,P)
S BGPPRD=$$V(2,BGPRPT,N,P,1) I $G(BGPAREAA) D SETEXA(2,N,P)
S BGPBLD=$$V(3,BGPRPT,N,P,1) I $G(BGPAREAA) D SETEXA(3,N,P)
;write out denom
I BGPRTYPE=1,$P(^BGPINDNC(BGPPC,0),U,4)="MS.A.9" S BGPDENP=0
I BGPRTYPE=1,$P(^BGPINDNC(BGPPC,0),U,4)="DM.2.1" S BGPDENP=0
I BGPRTYPE=7,$P(^BGPINDNC(BGPPC,0),U,4)="028.C.4" S BGPDENP=0
I BGPRTYPE=1,$P(^BGPINDNC(BGPPC,0),U,4)="E-2.A.1" S BGPDENP=0
I 'BGPDENP D
.I $P($G(^BGPINDNC(BGPPC,12)),U,14) Q
.I $P(^BGPINDNC(BGPPC,0),U,11),BGPRTYPE=1 I '$G(BGPSUMON) D HEADER^BGP9DPH Q:BGPQUIT W !!,^BGPINDN(BGPIC,53,1,0) W:$D(^BGPINDN(BGPIC,53,2,0)) !,^BGPINDN(BGPIC,53,2,0) D H1^BGP9DPH
.I $P(^BGPINDNC(BGPPC,0),U,24),BGPRTYPE=4 I '$G(BGPSUMON) D HEADER^BGP9DPH Q:BGPQUIT W !!,^BGPINDN(BGPIC,53,1,0) W:$D(^BGPINDN(BGPIC,53,2,0)) !,^BGPINDN(BGPIC,53,2,0) D H1^BGP9DPH
.I $P($G(^BGPINDNC(BGPPC,12)),U,15),BGPRTYPE=7 I '$G(BGPSUMON) D HEADER^BGP9DPH Q:BGPQUIT W !!,^BGPINDN(BGPIC,53,1,0) W:$D(^BGPINDN(BGPIC,53,2,0)) !,^BGPINDN(BGPIC,53,2,0) D H1^BGP9DPH
.I $Y>(BGPIOSL-15),'$G(BGPSUMON) D HEADER^BGP9DPH Q:BGPQUIT W !!,^BGPINDN(BGPIC,53,1,0) W:$D(^BGPINDN(BGPIC,53,2,0)) !,^BGPINDN(BGPIC,53,2,0) D H1^BGP9DPH
.I BGPRTYPE=1,$P($G(^BGPINDNC(BGPPC,20)),U,4)]"" D I 1
..W:'$G(BGPSUMON) !!,$P(^BGPINDNC(BGPPC,20),U,4)
..I $P(^BGPINDNC(BGPPC,20),U,5)]"" W:'$G(BGPSUMON) !,$P(^BGPINDNC(BGPPC,20),U,5)
..I $P(^BGPINDNC(BGPPC,20),U,6)]"" W:'$G(BGPSUMON) !,$P(^BGPINDNC(BGPPC,20),U,6)
.E D
..W:'$G(BGPSUMON) !!,$P(^BGPINDNC(BGPPC,0),U,17)
..I $P(^BGPINDNC(BGPPC,0),U,18)]"" D C18
..I $P(^BGPINDNC(BGPPC,0),U,21)]"" D C21
.W:'$G(BGPSUMON) ?20,$$C(BGPCYD,0,8),?35,$$C(BGPPRD,0,8),?58,$$C(BGPBLD,0,8),!
.S BGPDENP=1
I $E($P(^BGPINDNC(BGPPC,0),U,4),1,2)="I." D
.S BGPDF=$P(^BGPINDNC(BGPPC,0),U,8)
.;get denominator value
.S BGPNP=$P(^DD(90536.03,BGPDF,0),U,4),N=$P(BGPNP,";"),P=$P(BGPNP,";",2)
.S BGPCYD=$$V(1,BGPRPT,N,P,1) I $G(BGPAREAA) D SETEXA(1,N,P)
.S BGPPRD=$$V(2,BGPRPT,N,P,1) I $G(BGPAREAA) D SETEXA(2,N,P)
.S BGPBLD=$$V(3,BGPRPT,N,P,1) I $G(BGPAREAA) D SETEXA(3,N,P)
S BGPNF=$P(^BGPINDNC(BGPPC,0),U,9)
S BGPNP=$P(^DD(90536.03,BGPNF,0),U,4),N=$P(BGPNP,";"),P=$P(BGPNP,";",2)
D SETN
;write header
I $P(^BGPINDNC(BGPPC,0),U,22) W:'$G(BGPSUMON) !
I $P($G(^BGPINDNC(BGPPC,12)),U,8),BGPRTYPE=4 I '$G(BGPSUMON) D HEADER^BGP9DPH Q:BGPQUIT W !!,^BGPINDN(BGPIC,53,1,0) W:$D(^BGPINDN(BGPIC,53,2,0)) !,^BGPINDN(BGPIC,53,2,0) D H1^BGP9DPH
I $P($G(^BGPINDNC(BGPPC,21)),U,5),BGPRTYPE=1 I '$G(BGPSUMON) D HEADER^BGP9DPH Q:BGPQUIT W !!,^BGPINDN(BGPIC,53,1,0) W:$D(^BGPINDN(BGPIC,53,2,0)) !,^BGPINDN(BGPIC,53,2,0) D H1^BGP9DPH
I BGPRTYPE=1,$P($G(^BGPINDNC(BGPPC,20)),U,1)]"",'$G(BGPSUMON) D G N
.W !,$P(^BGPINDNC(BGPPC,20),U,1)
.I $P(^BGPINDNC(BGPPC,20),U,2)]"" W !,$P(^BGPINDNC(BGPPC,20),U,2)
.I $P(^BGPINDNC(BGPPC,20),U,3)]"" W !,$P(^BGPINDNC(BGPPC,20),U,3)
W:'$G(BGPSUMON) !,$P(^BGPINDNC(BGPPC,0),U,15) I BGPRTYPE=4,$P($G(^BGPINDNC(BGPPC,12)),U,5) W:'$G(BGPSUMON) " (GPRA)"
I $P(^BGPINDNC(BGPPC,0),U,16)]"" W:'$G(BGPSUMON) !?1,$P(^BGPINDNC(BGPPC,0),U,16)
I BGPRTYPE=4,$P($G(^BGPINDNC(BGPPC,12)),U,6) W:$P(^BGPINDNC(BGPPC,0),U,16)="" ! W:'$G(BGPSUMON) " (GPRA)"
I $P(^BGPINDNC(BGPPC,0),U,19)]"" W:'$G(BGPSUMON) !?1,$P(^BGPINDNC(BGPPC,0),U,19)
I BGPRTYPE=4,$P($G(^BGPINDNC(BGPPC,12)),U,7) W:$P(^BGPINDNC(BGPPC,0),U,19)="" ! W:'$G(BGPSUMON) " (GPRA)"
N D H2^BGP9DPH
Q
C18 ;
W:'$G(BGPSUMON) !,$P(^BGPINDNC(BGPPC,0),U,18)
Q
C21 ;
W:'$G(BGPSUMON) !,$P(^BGPINDNC(BGPPC,0),U,21)
Q
I1AGE ;EP - age tallies
D I1AGE^BGP9DP11
Q
SETN ;EP - set numerator fields
S BGPCYN=$$V^BGP9DP1C(1,BGPRPT,N,P,2) ;SPDX
S BGPPRN=$$V^BGP9DP1C(2,BGPRPT,N,P,2) ;SPDX
S BGPBLN=$$V^BGP9DP1C(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:"")
I $G(BGPAREAA) D SDP
;GPRA MEASURES SUMMARY SHEET
I $P($G(^BGPINDNC(BGPPC,14)),U),'$G(BGPNOSUM) D
.S ^TMP($J,"SUMMARY",$P(^BGPSCAT($P(^BGPINDNC(BGPPC,14),U,5),0),U,2),$P(^BGPINDNC(BGPPC,14),U,6),BGPPC)=BGPCYP_U_BGPPRP_U_BGPBLP
.I $G(BGPAREAA) D ;SDPX
..S X=0 F S X=$O(BGPSDP(X)) Q:X'=+X D ;SDPX
...S ^TMP($J,"SUMMARY DETAIL PAGE",$P(^BGPSCAT($P(^BGPINDNC(BGPPC,14),U,5),0),U,2),$P(^BGPINDNC(BGPPC,14),U,6),BGPPC,X)=$P($G(BGPSDP(X,1)),U,3)_U_$P($G(BGPSDP(X,2)),U,3)_U_$P($G(BGPSDP(X,3)),U,3)_U_$J(BGPCYP,5,1)
.S ^TMP($J,"SUMMARYDEL",$P(^BGPSCAT($P(^BGPINDNC(BGPPC,14),U,5),0),U,2),$P(^BGPINDNC(BGPPC,14),U,6),BGPPC)=$$SB($J(BGPCYP,5,1))_U_$$SB($J(BGPPRP,5,1))_U_$$SB($J(BGPBLP,5,1))
.I $G(BGPAREAA) D ;SDPX
..S X=0 F S X=$O(BGPSDP(X)) Q:X'=+X D ;SDPX
...S A=$P(^BGPSCAT($P(^BGPINDNC(BGPPC,14),U,5),0),U,2)
...S B=$P(^BGPINDNC(BGPPC,14),U,6)
...S ^TMP($J,"SUMMARYDEL DETAIL PAGE",A,B,BGPPC,X)=$$SB($J($P($G(BGPSDP(X,1)),U,3),5,1))_U_$$SB($J($P($G(BGPSDP(X,2)),U,3),5,1))_U_$$SB($J($P($G(BGPSDP(X,3)),U,3),5,1))_U_$$SB($J(BGPCYP,5,1))
;NON GRPA MEASURES
I $P($G(^BGPINDNC(BGPPC,15)),U),'$G(BGPNOSUM) D
.S ^TMP($J,"SUMMARY NON",$P(^BGPSCAT($P(^BGPINDNC(BGPPC,15),U,5),0),U,2),$P(^BGPINDNC(BGPPC,15),U,6),BGPPC)=BGPCYP_U_BGPPRP_U_BGPBLP
.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(^BGPINDNC(BGPPC,15),U,5),0),U,2),$P(^BGPINDNC(BGPPC,15),U,6),BGPPC,X)=$P($G(BGPSDPN(X,1)),U,3)_U_$P($G(BGPSDPN(X,2)),U,3)_U_$P($G(BGPSDPN(X,3)),U,3)_U_$J(BGPCYP,5,1)
I $P($G(^BGPINDNC(BGPPC,15)),U),'$G(BGPNOSUM) D
.S ^TMP($J,"SUMMARYDEL NON",$P(^BGPSCAT($P(^BGPINDNC(BGPPC,15),U,5),0),U,2),$P(^BGPINDNC(BGPPC,15),U,6),BGPPC)=$$SB($J(BGPCYP,5,1))_U_$$SB($J(BGPPRP,5,1))_U_$$SB($J(BGPBLP,5,1))
.I $G(BGPAREAA) D ;SDPX
..S X=0 F S X=$O(BGPSDPN(X)) Q:X'=+X D ;SDPX
...S A=$P(^BGPSCAT($P(^BGPINDNC(BGPPC,15),U,5),0),U,2)
...S B=$P(^BGPINDNC(BGPPC,15),U,6)
...S ^TMP($J,"SUMMARYDEL DETAIL PAGE NON",A,B,BGPPC,X)=$$SB($J($P($G(BGPSDPN(X,1)),U,3),5,1))_U_$$SB($J($P($G(BGPSDPN(X,2)),U,3),5,1))_U_$$SB($J($P($G(BGPSDPN(X,3)),U,3),5,1))_U_$$SB($J(BGPCYP,5,1))
;DEVELOP
D SETDEV^BGP9DP1E
;OTHER NATIONAL REPORT SUMMARY
I $P($G(^BGPINDNC(BGPPC,19)),U),'$G(BGPNOSUM) D
.S ^TMP($J,"SUMMARY OTHER",$P(^BGPSCAT($P(^BGPINDNC(BGPPC,19),U,5),0),U,3),$P(^BGPINDNC(BGPPC,19),U,6),BGPPC)=BGPCYP_U_BGPPRP_U_BGPBLP
.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(^BGPINDNC(BGPPC,19),U,5),0),U,3),$P(^BGPINDNC(BGPPC,19),U,6),BGPPC,X)=$P($G(BGPSDPO(X,1)),U,3)_U_$P($G(BGPSDPO(X,2)),U,3)_U_$P($G(BGPSDPO(X,3)),U,3)_U_$J(BGPCYP,5,1)
I $P($G(^BGPINDNC(BGPPC,19)),U),'$G(BGPNOSUM) D
.S ^TMP($J,"SUMMARYDEL OTHER",$P(^BGPSCAT($P(^BGPINDNC(BGPPC,19),U,5),0),U,3),$P(^BGPINDNC(BGPPC,19),U,6),BGPPC)=$$SB($J(BGPCYP,5,1))_U_$$SB($J(BGPPRP,5,1))_U_$$SB($J(BGPBLP,5,1))
.I $G(BGPAREAA) D ;SDPX
..S X=0 F S X=$O(BGPSDPO(X)) Q:X'=+X D ;SDPX
...S A=$P(^BGPSCAT($P(^BGPINDNC(BGPPC,19),U,5),0),U,3)
...S B=$P(^BGPINDNC(BGPPC,19),U,6)
...S ^TMP($J,"SUMMARYDEL DETAIL PAGE OTHER",A,B,BGPPC,X)=$$SB($J($P($G(BGPSDPO(X,1)),U,3),5,1))_U_$$SB($J($P($G(BGPSDPO(X,2)),U,3),5,1))_U_$$SB($J($P($G(BGPSDPO(X,3)),U,3),5,1))_U_$$SB($J(BGPCYP,5,1))
I $G(BGPIIDEL),BGPROT="B" Q
GPRANT1 ;
I $G(BGPAREAA),$G(BGPEXCEL) D
.Q:$P(^BGPINDNC(BGPPC,0),U,14)=""
.;set each numerator and percent,then set BGPEI
.NEW X S X=0 F S X=$O(BGPSUL(X)) Q:X'=+X D
..S $P(BGPEXCT(X,1),U,1)=$P($G(^BGPGPDCN(X,N)),U,P),$P(BGPEXCT(X,1),U,3)=$S($P(BGPEXCT(X,1),U,2):(($P(BGPEXCT(X,1),U,1)/$P(BGPEXCT(X,1),U,2))*100),1:"")
..S $P(BGPEXCT(X,2),U,1)=$P($G(^BGPGPDPN(X,N)),U,P),$P(BGPEXCT(X,2),U,3)=$S($P(BGPEXCT(X,2),U,2):(($P(BGPEXCT(X,2),U,1)/$P(BGPEXCT(X,2),U,2))*100),1:"")
..S $P(BGPEXCT(X,3),U,1)=$P($G(^BGPGPDBN(X,N)),U,P),$P(BGPEXCT(X,3),U,3)=$S($P(BGPEXCT(X,3),U,2):(($P(BGPEXCT(X,3),U,1)/$P(BGPEXCT(X,3),U,2))*100),1:"")
.S X=0 F S X=$O(BGPEXCT(X)) Q:X'=+X D
..S A=$P(BGPEXCT(X,1),U,1),B=$P(BGPEXCT(X,1),U,2),C=$P(BGPEXCT(X,1),U,3)
..S D=$P(BGPEXCT(X,2),U,1),E=$P(BGPEXCT(X,2),U,2),F=$P(BGPEXCT(X,2),U,3)
..S G=$P(BGPEXCT(X,3),U,1),H=$P(BGPEXCT(X,3),U,2),I=$P(BGPEXCT(X,3),U,3)
..I $P($P(^BGPINDNC(BGPPC,0),U,4),".")="023" S Y=$P(^BGPINDNC(BGPPC,0),U,14),$P(BGPEI(X),U,Y)=$S(B:B,1:0),$P(BGPEI(X),U,(Y+3))=$S(E:E,1:0),$P(BGPEI(X),U,(Y+6))=$S(H:H,1:0) Q
..I $P($P(^BGPINDNC(BGPPC,0),U,4),".")="014" S Y=$P(^BGPINDNC(BGPPC,0),U,14),$P(BGPEI(X),U,Y)=$S(B:B,1:0),$P(BGPEI(X),U,(Y+3))=$S(E:E,1:0),$P(BGPEI(X),U,(Y+6))=$S(H:H,1:0) Q
..I $P($P(^BGPINDNC(BGPPC,0),U,4),".")="016" S Y=$P(^BGPINDNC(BGPPC,0),U,14),$P(BGPEI(X),U,Y)=$S(B:B,1:0),$P(BGPEI(X),U,(Y+3))=$S(E:E,1:0),$P(BGPEI(X),U,(Y+6))=$S(H:H,1:0) Q
..I $P($G(^BGPINDNC(BGPPC,19)),U,13) S Y=$P(^BGPINDNC(BGPPC,0),U,14),$P(BGPEI(X),U,Y)=$S(B:B,1:0),$P(BGPEI(X),U,(Y+3))=$S(E:E,1:0),$P(BGPEI(X),U,(Y+6))=$S(H:H,1:0) Q
..S Y=$P(^BGPINDNC(BGPPC,0),U,14)
..S $P(BGPEI(X),U,$P(^BGPINDNC(BGPPC,0),U,14))=$S(A:A,1:0),$P(BGPEI(X),U,(Y+1))=$S(B:B,1:0),$P(BGPEI(X),U,(Y+2))=$$SL(C)
..S $P(BGPEI(X),U,(Y+3))=$S(D:D,1:0),$P(BGPEI(X),U,(Y+4))=$S(E:E,1:0),$P(BGPEI(X),U,(Y+5))=$$SL(F),$P(BGPEI(X),U,(Y+6))=$S(G:G,1:0),$P(BGPEI(X),U,(Y+7))=$S(H:H,1:0),$P(BGPEI(X),U,(Y+8))=$$SL(I)
GPRANT2 ;
I $G(BGPAREAA),$G(BGPEXCEL) D
.Q:$P($G(^BGPINDNC(BGPPC,12)),U,13)=""
.;set each numerator and percent,then set BGPEI2
.NEW X S X=0 F S X=$O(BGPSUL(X)) Q:X'=+X D
..S $P(BGPEXCT(X,1),U,1)=$P($G(^BGPGPDCN(X,N)),U,P),$P(BGPEXCT(X,1),U,3)=$S($P(BGPEXCT(X,1),U,2):(($P(BGPEXCT(X,1),U,1)/$P(BGPEXCT(X,1),U,2))*100),1:"")
..S $P(BGPEXCT(X,2),U,1)=$P($G(^BGPGPDPN(X,N)),U,P),$P(BGPEXCT(X,2),U,3)=$S($P(BGPEXCT(X,2),U,2):(($P(BGPEXCT(X,2),U,1)/$P(BGPEXCT(X,2),U,2))*100),1:"")
..S $P(BGPEXCT(X,3),U,1)=$P($G(^BGPGPDBN(X,N)),U,P),$P(BGPEXCT(X,3),U,3)=$S($P(BGPEXCT(X,3),U,2):(($P(BGPEXCT(X,3),U,1)/$P(BGPEXCT(X,3),U,2))*100),1:"")
.S X=0 F S X=$O(BGPEXCT(X)) Q:X'=+X D
..S A=$P(BGPEXCT(X,1),U,1),B=$P(BGPEXCT(X,1),U,2),C=$P(BGPEXCT(X,1),U,3)
..S D=$P(BGPEXCT(X,2),U,1),E=$P(BGPEXCT(X,2),U,2),F=$P(BGPEXCT(X,2),U,3)
..S G=$P(BGPEXCT(X,3),U,1),H=$P(BGPEXCT(X,3),U,2),I=$P(BGPEXCT(X,3),U,3)
..I $P($P(^BGPINDNC(BGPPC,0),U,4),".")="023" S Y=$P(^BGPINDNC(BGPPC,12),U,13),$P(BGPEI2(X),U,Y)=$S(B:B,1:0),$P(BGPEI2(X),U,(Y+3))=$S(E:E,1:0),$P(BGPEI2(X),U,(Y+6))=$S(H:H,1:0) Q
..I $P($P(^BGPINDNC(BGPPC,0),U,4),".")="014" S Y=$P(^BGPINDNC(BGPPC,12),U,13),$P(BGPEI2(X),U,Y)=$S(B:B,1:0),$P(BGPEI2(X),U,(Y+3))=$S(E:E,1:0),$P(BGPEI2(X),U,(Y+6))=$S(H:H,1:0) Q
..I $P($P(^BGPINDNC(BGPPC,0),U,4),".")="016" S Y=$P(^BGPINDNC(BGPPC,12),U,13),$P(BGPEI2(X),U,Y)=$S(B:B,1:0),$P(BGPEI2(X),U,(Y+3))=$S(E:E,1:0),$P(BGPEI2(X),U,(Y+6))=$S(H:H,1:0) Q
..I $P($G(^BGPINDNC(BGPPC,19)),U,13) S Y=$P(^BGPINDNC(BGPPC,12),U,13),$P(BGPEI2(X),U,Y)=$S(B:B,1:0),$P(BGPEI2(X),U,(Y+3))=$S(E:E,1:0),$P(BGPEI2(X),U,(Y+6))=$S(H:H,1:0) Q
..S Y=$P(^BGPINDNC(BGPPC,12),U,13)
..S $P(BGPEI2(X),U,$P(^BGPINDNC(BGPPC,12),U,13))=$S(A:A,1:0),$P(BGPEI2(X),U,(Y+1))=$S(B:B,1:0),$P(BGPEI2(X),U,(Y+2))=$$SL(C)
..S $P(BGPEI2(X),U,(Y+3))=$S(D:D,1:0),$P(BGPEI2(X),U,(Y+4))=$S(E:E,1:0),$P(BGPEI2(X),U,(Y+5))=$$SL(F),$P(BGPEI2(X),U,(Y+6))=$S(G:G,1:0),$P(BGPEI2(X),U,(Y+7))=$S(H:H,1:0),$P(BGPEI2(X),U,(Y+8))=$$SL(I)
I $G(BGPAREAA),$G(BGPEXCEL) D GPRANT3^BGP9DP1D
ONN1 ;
D ONM1^BGP9DP1D
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(^BGPGPDCN(X,N)),U,P)
.I T=2 S $P(BGPEXCT(X,T),U,2)=$P($G(^BGPGPDPN(X,N)),U,P)
.I T=3 S $P(BGPEXCT(X,T),U,2)=$P($G(^BGPGPDBN(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(^BGPGPDCN(R,N)),U,P) Q $S(X]"":X,1:0)
I T=2 S X=$P($G(^BGPGPDPN(R,N)),U,P) Q $S(X]"":X,1:0)
I T=3 S X=$P($G(^BGPGPDBN(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(^BGPGPDCN(X,N)),U,P)
.I T=2 S C=C+$P($G(^BGPGPDPN(X,N)),U,P)
.I T=3 S C=C+$P($G(^BGPGPDBN(X,N)),U,P)
.I $G(BGPAREAA),$P($G(^BGPINDNC(BGPPC,14)),U) D ;SPDX
..I T=1 S $P(BGPSDP(X,T),U,ND)=$P($G(^BGPGPDCN(X,N)),U,P) ;SPDX
..I T=2 S $P(BGPSDP(X,T),U,ND)=$P($G(^BGPGPDPN(X,N)),U,P) ;SPDX
..I T=3 S $P(BGPSDP(X,T),U,ND)=$P($G(^BGPGPDBN(X,N)),U,P) ;SPDX
.I $G(BGPAREAA),$P($G(^BGPINDNC(BGPPC,15)),U) D ;SPDX
..I T=1 S $P(BGPSDPN(X,T),U,ND)=$P($G(^BGPGPDCN(X,N)),U,P) ;SPDX
..I T=2 S $P(BGPSDPN(X,T),U,ND)=$P($G(^BGPGPDPN(X,N)),U,P) ;SPDX
..I T=3 S $P(BGPSDPN(X,T),U,ND)=$P($G(^BGPGPDBN(X,N)),U,P) ;SPDX
.I $G(BGPAREAA),$P($G(^BGPINDNC(BGPPC,19)),U) D ;SPDX
..I T=1 S $P(BGPSDPO(X,T),U,ND)=$P($G(^BGPGPDCN(X,N)),U,P) ;SPDX
..I T=2 S $P(BGPSDPO(X,T),U,ND)=$P($G(^BGPGPDPN(X,N)),U,P) ;SPDX
..I T=3 S $P(BGPSDPO(X,T),U,ND)=$P($G(^BGPGPDBN(X,N)),U,P) ;SPDX
.I $G(BGPAREAA),$P($G(^BGPINDNC(BGPPC,22)),U) D ;SPDX
..I T=1 S $P(BGPSDPD(X,T),U,ND)=$P($G(^BGPGPDCN(X,N)),U,P) ;SPDX
..I T=2 S $P(BGPSDPD(X,T),U,ND)=$P($G(^BGPGPDPN(X,N)),U,P) ;SPDX
..I T=3 S $P(BGPSDPD(X,T),U,ND)=$P($G(^BGPGPDBN(X,N)),U,P) ;SPDX
.Q
Q $S(C]"":C,1:0)
C(X,X2,X3) ;
D COMMA^%DTC
Q X
SDP ;SDPX
;loop thru each BGPSDP and set 3rd piece
NEW X,Y,T,D,N
S X=0 F S X=$O(BGPSDP(X)) Q:X'=+X D
.S T=0 F S T=$O(BGPSDP(X,T)) Q:T'=+T D
..S D=$P(BGPSDP(X,T),U,1),N=$P(BGPSDP(X,T),U,2)
..S $P(BGPSDP(X,T),U,3)=$S(D:((N/D)*100),1:"")
S X=0 F S X=$O(BGPSDPN(X)) Q:X'=+X D
.S T=0 F S T=$O(BGPSDPN(X,T)) Q:T'=+T D
..S D=$P(BGPSDPN(X,T),U,1),N=$P(BGPSDPN(X,T),U,2)
..S $P(BGPSDPN(X,T),U,3)=$S(D:((N/D)*100),1:"")
S X=0 F S X=$O(BGPSDPO(X)) Q:X'=+X D
.S T=0 F S T=$O(BGPSDPO(X,T)) Q:T'=+T D
..S D=$P(BGPSDPO(X,T),U,1),N=$P(BGPSDPO(X,T),U,2)
..S $P(BGPSDPO(X,T),U,3)=$S(D:((N/D)*100),1:"")
S X=0 F S X=$O(BGPSDPD(X)) Q:X'=+X D
.S T=0 F S T=$O(BGPSDPD(X,T)) Q:T'=+T D
..S D=$P(BGPSDPD(X,T),U,1),N=$P(BGPSDPD(X,T),U,2)
..S $P(BGPSDPD(X,T),U,3)=$S(D:((N/D)*100),1:"")
Q
SB(X) ;EP - Strip leading and trailing blanks from X.
NEW %
X ^DD("FUNC",$O(^DD("FUNC","B","STRIPBLANKS",0)),1)
Q X
BGP9DP1C ; IHS/CMI/LAB - print ind 1 21 Mar 2008 12:55 PM ;
+1 ;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009
+2 ;
+3 ;
PI ;EP
+1 SET BGPDENP=0
+2 SET BGPPC2=0
FOR
SET BGPPC2=$ORDER(^BGPINDNC("ABC",BGPPC1,BGPPC2))
IF BGPPC2=""
QUIT
SET BGPPC=$ORDER(^BGPINDNC("ABC",BGPPC1,BGPPC2,0))
DO PI1
+3 QUIT
PI1 ;EP
+1 KILL BGPEXCT,BGPSDP,BGPSDPN,BGPSDPO,BGPSDPD
+2 IF BGPRTYPE=1
IF $PIECE(^BGPINDNC(BGPPC,0),U,5)'=1
QUIT
+3 IF BGPRTYPE=7
IF $PIECE($GET(^BGPINDNC(BGPPC,12)),U,12)'=1
QUIT
+4 IF BGPRTYPE=4
IF $PIECE($GET(^BGPINDNC(BGPPC,21)),U,2)=1
QUIT
+5 IF BGPINDT="D"
IF $PIECE(^BGPINDNC(BGPPC,0),U,12)'=1
QUIT
+6 IF BGPINDT="C"
IF $PIECE(^BGPINDNC(BGPPC,0),U,13)'=1
QUIT
+7 IF BGPINDT="W"
IF $PIECE($GET(^BGPINDNC(BGPPC,12)),U,2)'=1
QUIT
+8 IF BGPINDT="E"
IF $PIECE($GET(^BGPINDNC(BGPPC,12)),U,3)'=1
QUIT
+9 IF $PIECE(^BGPINDNC(BGPPC,0),U,4)="E-2.B.3"
DO PI1^BGP9DP2
QUIT
+10 SET BGPDF=$PIECE(^BGPINDNC(BGPPC,0),U,8)
+11 ;get denom value
+12 SET BGPNP=$PIECE(^DD(90536.03,BGPDF,0),U,4)
SET N=$PIECE(BGPNP,";")
SET P=$PIECE(BGPNP,";",2)
+13 SET BGPCYD=$$V(1,BGPRPT,N,P,1)
IF $GET(BGPAREAA)
DO SETEXA(1,N,P)
+14 SET BGPPRD=$$V(2,BGPRPT,N,P,1)
IF $GET(BGPAREAA)
DO SETEXA(2,N,P)
+15 SET BGPBLD=$$V(3,BGPRPT,N,P,1)
IF $GET(BGPAREAA)
DO SETEXA(3,N,P)
+16 ;write out denom
+17 IF BGPRTYPE=1
IF $PIECE(^BGPINDNC(BGPPC,0),U,4)="MS.A.9"
SET BGPDENP=0
+18 IF BGPRTYPE=1
IF $PIECE(^BGPINDNC(BGPPC,0),U,4)="DM.2.1"
SET BGPDENP=0
+19 IF BGPRTYPE=7
IF $PIECE(^BGPINDNC(BGPPC,0),U,4)="028.C.4"
SET BGPDENP=0
+20 IF BGPRTYPE=1
IF $PIECE(^BGPINDNC(BGPPC,0),U,4)="E-2.A.1"
SET BGPDENP=0
+21 IF 'BGPDENP
Begin DoDot:1
+22 IF $PIECE($GET(^BGPINDNC(BGPPC,12)),U,14)
QUIT
+23 IF $PIECE(^BGPINDNC(BGPPC,0),U,11)
IF BGPRTYPE=1
IF '$GET(BGPSUMON)
DO HEADER^BGP9DPH
IF BGPQUIT
QUIT
WRITE !!,^BGPINDN(BGPIC,53,1,0)
IF $DATA(^BGPINDN(BGPIC,53,2,0))
WRITE !,^BGPINDN(BGPIC,53,2,0)
DO H1^BGP9DPH
+24 IF $PIECE(^BGPINDNC(BGPPC,0),U,24)
IF BGPRTYPE=4
IF '$GET(BGPSUMON)
DO HEADER^BGP9DPH
IF BGPQUIT
QUIT
WRITE !!,^BGPINDN(BGPIC,53,1,0)
IF $DATA(^BGPINDN(BGPIC,53,2,0))
WRITE !,^BGPINDN(BGPIC,53,2,0)
DO H1^BGP9DPH
+25 IF $PIECE($GET(^BGPINDNC(BGPPC,12)),U,15)
IF BGPRTYPE=7
IF '$GET(BGPSUMON)
DO HEADER^BGP9DPH
IF BGPQUIT
QUIT
WRITE !!,^BGPINDN(BGPIC,53,1,0)
IF $DATA(^BGPINDN(BGPIC,53,2,0))
WRITE !,^BGPINDN(BGPIC,53,2,0)
DO H1^BGP9DPH
+26 IF $Y>(BGPIOSL-15)
IF '$GET(BGPSUMON)
DO HEADER^BGP9DPH
IF BGPQUIT
QUIT
WRITE !!,^BGPINDN(BGPIC,53,1,0)
IF $DATA(^BGPINDN(BGPIC,53,2,0))
WRITE !,^BGPINDN(BGPIC,53,2,0)
DO H1^BGP9DPH
+27 IF BGPRTYPE=1
IF $PIECE($GET(^BGPINDNC(BGPPC,20)),U,4)]""
Begin DoDot:2
+28 IF '$GET(BGPSUMON)
WRITE !!,$PIECE(^BGPINDNC(BGPPC,20),U,4)
+29 IF $PIECE(^BGPINDNC(BGPPC,20),U,5)]""
IF '$GET(BGPSUMON)
WRITE !,$PIECE(^BGPINDNC(BGPPC,20),U,5)
+30 IF $PIECE(^BGPINDNC(BGPPC,20),U,6)]""
IF '$GET(BGPSUMON)
WRITE !,$PIECE(^BGPINDNC(BGPPC,20),U,6)
End DoDot:2
IF 1
+31 IF '$TEST
Begin DoDot:2
+32 IF '$GET(BGPSUMON)
WRITE !!,$PIECE(^BGPINDNC(BGPPC,0),U,17)
+33 IF $PIECE(^BGPINDNC(BGPPC,0),U,18)]""
DO C18
+34 IF $PIECE(^BGPINDNC(BGPPC,0),U,21)]""
DO C21
End DoDot:2
+35 IF '$GET(BGPSUMON)
WRITE ?20,$$C(BGPCYD,0,8),?35,$$C(BGPPRD,0,8),?58,$$C(BGPBLD,0,8),!
+36 SET BGPDENP=1
End DoDot:1
+37 IF $EXTRACT($PIECE(^BGPINDNC(BGPPC,0),U,4),1,2)="I."
Begin DoDot:1
+38 SET BGPDF=$PIECE(^BGPINDNC(BGPPC,0),U,8)
+39 ;get denominator value
+40 SET BGPNP=$PIECE(^DD(90536.03,BGPDF,0),U,4)
SET N=$PIECE(BGPNP,";")
SET P=$PIECE(BGPNP,";",2)
+41 SET BGPCYD=$$V(1,BGPRPT,N,P,1)
IF $GET(BGPAREAA)
DO SETEXA(1,N,P)
+42 SET BGPPRD=$$V(2,BGPRPT,N,P,1)
IF $GET(BGPAREAA)
DO SETEXA(2,N,P)
+43 SET BGPBLD=$$V(3,BGPRPT,N,P,1)
IF $GET(BGPAREAA)
DO SETEXA(3,N,P)
End DoDot:1
+44 SET BGPNF=$PIECE(^BGPINDNC(BGPPC,0),U,9)
+45 SET BGPNP=$PIECE(^DD(90536.03,BGPNF,0),U,4)
SET N=$PIECE(BGPNP,";")
SET P=$PIECE(BGPNP,";",2)
+46 DO SETN
+47 ;write header
+48 IF $PIECE(^BGPINDNC(BGPPC,0),U,22)
IF '$GET(BGPSUMON)
WRITE !
+49 IF $PIECE($GET(^BGPINDNC(BGPPC,12)),U,8)
IF BGPRTYPE=4
IF '$GET(BGPSUMON)
DO HEADER^BGP9DPH
IF BGPQUIT
QUIT
WRITE !!,^BGPINDN(BGPIC,53,1,0)
IF $DATA(^BGPINDN(BGPIC,53,2,0))
WRITE !,^BGPINDN(BGPIC,53,2,0)
DO H1^BGP9DPH
+50 IF $PIECE($GET(^BGPINDNC(BGPPC,21)),U,5)
IF BGPRTYPE=1
IF '$GET(BGPSUMON)
DO HEADER^BGP9DPH
IF BGPQUIT
QUIT
WRITE !!,^BGPINDN(BGPIC,53,1,0)
IF $DATA(^BGPINDN(BGPIC,53,2,0))
WRITE !,^BGPINDN(BGPIC,53,2,0)
DO H1^BGP9DPH
+51 IF BGPRTYPE=1
IF $PIECE($GET(^BGPINDNC(BGPPC,20)),U,1)]""
IF '$GET(BGPSUMON)
Begin DoDot:1
+52 WRITE !,$PIECE(^BGPINDNC(BGPPC,20),U,1)
+53 IF $PIECE(^BGPINDNC(BGPPC,20),U,2)]""
WRITE !,$PIECE(^BGPINDNC(BGPPC,20),U,2)
+54 IF $PIECE(^BGPINDNC(BGPPC,20),U,3)]""
WRITE !,$PIECE(^BGPINDNC(BGPPC,20),U,3)
End DoDot:1
GOTO N
+55 IF '$GET(BGPSUMON)
WRITE !,$PIECE(^BGPINDNC(BGPPC,0),U,15)
IF BGPRTYPE=4
IF $PIECE($GET(^BGPINDNC(BGPPC,12)),U,5)
IF '$GET(BGPSUMON)
WRITE " (GPRA)"
+56 IF $PIECE(^BGPINDNC(BGPPC,0),U,16)]""
IF '$GET(BGPSUMON)
WRITE !?1,$PIECE(^BGPINDNC(BGPPC,0),U,16)
+57 IF BGPRTYPE=4
IF $PIECE($GET(^BGPINDNC(BGPPC,12)),U,6)
IF $PIECE(^BGPINDNC(BGPPC,0),U,16)=""
WRITE !
IF '$GET(BGPSUMON)
WRITE " (GPRA)"
+58 IF $PIECE(^BGPINDNC(BGPPC,0),U,19)]""
IF '$GET(BGPSUMON)
WRITE !?1,$PIECE(^BGPINDNC(BGPPC,0),U,19)
+59 IF BGPRTYPE=4
IF $PIECE($GET(^BGPINDNC(BGPPC,12)),U,7)
IF $PIECE(^BGPINDNC(BGPPC,0),U,19)=""
WRITE !
IF '$GET(BGPSUMON)
WRITE " (GPRA)"
N DO H2^BGP9DPH
+1 QUIT
C18 ;
+1 IF '$GET(BGPSUMON)
WRITE !,$PIECE(^BGPINDNC(BGPPC,0),U,18)
+2 QUIT
C21 ;
+1 IF '$GET(BGPSUMON)
WRITE !,$PIECE(^BGPINDNC(BGPPC,0),U,21)
+2 QUIT
I1AGE ;EP - age tallies
+1 DO I1AGE^BGP9DP11
+2 QUIT
SETN ;EP - set numerator fields
+1 ;SPDX
SET BGPCYN=$$V^BGP9DP1C(1,BGPRPT,N,P,2)
+2 ;SPDX
SET BGPPRN=$$V^BGP9DP1C(2,BGPRPT,N,P,2)
+3 ;SPDX
SET BGPBLN=$$V^BGP9DP1C(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 IF $GET(BGPAREAA)
DO SDP
+8 ;GPRA MEASURES SUMMARY SHEET
+9 IF $PIECE($GET(^BGPINDNC(BGPPC,14)),U)
IF '$GET(BGPNOSUM)
Begin DoDot:1
+10 SET ^TMP($JOB,"SUMMARY",$PIECE(^BGPSCAT($PIECE(^BGPINDNC(BGPPC,14),U,5),0),U,2),$PIECE(^BGPINDNC(BGPPC,14),U,6),BGPPC)=BGPCYP_U_BGPPRP_U_BGPBLP
+11 ;SDPX
IF $GET(BGPAREAA)
Begin DoDot:2
+12 ;SDPX
SET X=0
FOR
SET X=$ORDER(BGPSDP(X))
IF X'=+X
QUIT
Begin DoDot:3
+13 SET ^TMP($JOB,"SUMMARY DETAIL PAGE",$PIECE(^BGPSCAT($PIECE(^BGPINDNC(BGPPC,14),U,5),0),U,2),$PIECE(^BGPINDNC(BGPPC,14),U,6),BGPPC,X)=$PIECE($GET(BGPSDP(X,1)),U,3)_U_$PIECE($GET(BGPSDP(X,2)),U,3)_U_$PIECE($GET(BGPSDP(
X,3)),U,3)_U_$JUSTIFY(BGPCYP,5,1)
End DoDot:3
End DoDot:2
+14 SET ^TMP($JOB,"SUMMARYDEL",$PIECE(^BGPSCAT($PIECE(^BGPINDNC(BGPPC,14),U,5),0),U,2),$PIECE(^BGPINDNC(BGPPC,14),U,6),BGPPC)=$$SB($JUSTIFY(BGPCYP,5,1))_U_$$SB($JUSTIFY(BGPPRP,5,1))_U_$$SB($JUSTIFY(BGPBLP,5,1))
+15 ;SDPX
IF $GET(BGPAREAA)
Begin DoDot:2
+16 ;SDPX
SET X=0
FOR
SET X=$ORDER(BGPSDP(X))
IF X'=+X
QUIT
Begin DoDot:3
+17 SET A=$PIECE(^BGPSCAT($PIECE(^BGPINDNC(BGPPC,14),U,5),0),U,2)
+18 SET B=$PIECE(^BGPINDNC(BGPPC,14),U,6)
+19 SET ^TMP($JOB,"SUMMARYDEL DETAIL PAGE",A,B,BGPPC,X)=$$SB($JUSTIFY($PIECE($GET(BGPSDP(X,1)),U,3),5,1))_U_$$SB($JUSTIFY($PIECE($GET(BGPSDP(X,2)),U,3),5,1))_U_$$SB($JUSTIFY($PIECE($GET(BGPSDP(X,3)),U,3),5,1))_U_$$SB($JU
STIFY(BGPCYP,5,1))
End DoDot:3
End DoDot:2
End DoDot:1
+20 ;NON GRPA MEASURES
+21 IF $PIECE($GET(^BGPINDNC(BGPPC,15)),U)
IF '$GET(BGPNOSUM)
Begin DoDot:1
+22 SET ^TMP($JOB,"SUMMARY NON",$PIECE(^BGPSCAT($PIECE(^BGPINDNC(BGPPC,15),U,5),0),U,2),$PIECE(^BGPINDNC(BGPPC,15),U,6),BGPPC)=BGPCYP_U_BGPPRP_U_BGPBLP
+23 ;SDPX
IF $GET(BGPAREAA)
Begin DoDot:2
+24 ;SDPX
SET X=0
FOR
SET X=$ORDER(BGPSDPN(X))
IF X'=+X
QUIT
Begin DoDot:3
+25 SET ^TMP($JOB,"SUMMARY DETAIL PAGE NON",$PIECE(^BGPSCAT($PIECE(^BGPINDNC(BGPPC,15),U,5),0),U,2),$PIECE(^BGPINDNC(BGPPC,15),U,6),BGPPC,X)=$PIECE($GET(BGPSDPN(X,1)),U,3)_U_$PIECE($GET(BGPSDPN(X,2)),U,3)_U_$PIECE($GET(BG
PSDPN(X,3)),U,3)_U_...
... $JUSTIFY(BGPCYP,5,1)
End DoDot:3
End DoDot:2
End DoDot:1
+26 IF $PIECE($GET(^BGPINDNC(BGPPC,15)),U)
IF '$GET(BGPNOSUM)
Begin DoDot:1
+27 SET ^TMP($JOB,"SUMMARYDEL NON",$PIECE(^BGPSCAT($PIECE(^BGPINDNC(BGPPC,15),U,5),0),U,2),$PIECE(^BGPINDNC(BGPPC,15),U,6),BGPPC)=$$SB($JUSTIFY(BGPCYP,5,1))_U_$$SB($JUSTIFY(BGPPRP,5,1))_U_$$SB($JUSTIFY(BGPBLP,5,1))
+28 ;SDPX
IF $GET(BGPAREAA)
Begin DoDot:2
+29 ;SDPX
SET X=0
FOR
SET X=$ORDER(BGPSDPN(X))
IF X'=+X
QUIT
Begin DoDot:3
+30 SET A=$PIECE(^BGPSCAT($PIECE(^BGPINDNC(BGPPC,15),U,5),0),U,2)
+31 SET B=$PIECE(^BGPINDNC(BGPPC,15),U,6)
+32 SET ^TMP($JOB,"SUMMARYDEL DETAIL PAGE NON",A,B,BGPPC,X)=$$SB($JUSTIFY($PIECE($GET(BGPSDPN(X,1)),U,3),5,1))_U_$$SB($JUSTIFY($PIECE($GET(BGPSDPN(X,2)),U,3),5,1))_U_$$SB($JUSTIFY($PIECE($GET(BGPSDPN(X,3)),U,3),5,1))_U_$
$SB($JUSTIFY(BGPCYP,5,1))
End DoDot:3
End DoDot:2
End DoDot:1
+33 ;DEVELOP
+34 DO SETDEV^BGP9DP1E
+35 ;OTHER NATIONAL REPORT SUMMARY
+36 IF $PIECE($GET(^BGPINDNC(BGPPC,19)),U)
IF '$GET(BGPNOSUM)
Begin DoDot:1
+37 SET ^TMP($JOB,"SUMMARY OTHER",$PIECE(^BGPSCAT($PIECE(^BGPINDNC(BGPPC,19),U,5),0),U,3),$PIECE(^BGPINDNC(BGPPC,19),U,6),BGPPC)=BGPCYP_U_BGPPRP_U_BGPBLP
+38 ;SDPX
IF $GET(BGPAREAA)
Begin DoDot:2
+39 ;SDPX
SET X=0
FOR
SET X=$ORDER(BGPSDPO(X))
IF X'=+X
QUIT
Begin DoDot:3
+40 SET ^TMP($JOB,"SUMMARY DETAIL PAGE OTHER",$PIECE(^BGPSCAT($PIECE(^BGPINDNC(BGPPC,19),U,5),0),U,3),$PIECE(^BGPINDNC(BGPPC,19),U,6),BGPPC,X)=$PIECE($GET(BGPSDPO(X,1)),U,3)_U_$PIECE($GET(BGPSDPO(X,2)),U,3)_U_$PIECE(...
... $GET(BGPSDPO(X,3)),U,3)_U_$JUSTIFY(BGPCYP,5,1)
End DoDot:3
End DoDot:2
End DoDot:1
+41 IF $PIECE($GET(^BGPINDNC(BGPPC,19)),U)
IF '$GET(BGPNOSUM)
Begin DoDot:1
+42 SET ^TMP($JOB,"SUMMARYDEL OTHER",$PIECE(^BGPSCAT($PIECE(^BGPINDNC(BGPPC,19),U,5),0),U,3),$PIECE(^BGPINDNC(BGPPC,19),U,6),BGPPC)=$$SB($JUSTIFY(BGPCYP,5,1))_U_$$SB($JUSTIFY(BGPPRP,5,1))_U_$$SB($JUSTIFY(BGPBLP,5,1))
+43 ;SDPX
IF $GET(BGPAREAA)
Begin DoDot:2
+44 ;SDPX
SET X=0
FOR
SET X=$ORDER(BGPSDPO(X))
IF X'=+X
QUIT
Begin DoDot:3
+45 SET A=$PIECE(^BGPSCAT($PIECE(^BGPINDNC(BGPPC,19),U,5),0),U,3)
+46 SET B=$PIECE(^BGPINDNC(BGPPC,19),U,6)
+47 SET ^TMP($JOB,"SUMMARYDEL DETAIL PAGE OTHER",A,B,BGPPC,X)=$$SB($JUSTIFY($PIECE($GET(BGPSDPO(X,1)),U,3),5,1))_U_$$SB($JUSTIFY($PIECE($GET(BGPSDPO(X,2)),U,3),5,1))_U_$$SB($JUSTIFY($PIECE($GET(BGPSDPO(X,3)),U,3),5,1))_U
_$$SB($JUSTIFY(BGPCYP,5,1))
End DoDot:3
End DoDot:2
End DoDot:1
+48 IF $GET(BGPIIDEL)
IF BGPROT="B"
QUIT
GPRANT1 ;
+1 IF $GET(BGPAREAA)
IF $GET(BGPEXCEL)
Begin DoDot:1
+2 IF $PIECE(^BGPINDNC(BGPPC,0),U,14)=""
QUIT
+3 ;set each numerator and percent,then set BGPEI
+4 NEW X
SET X=0
FOR
SET X=$ORDER(BGPSUL(X))
IF X'=+X
QUIT
Begin DoDot:2
+5 SET $PIECE(BGPEXCT(X,1),U,1)=$PIECE($GET(^BGPGPDCN(X,N)),U,P)
SET $PIECE(BGPEXCT(X,1),U,3)=$SELECT($PIECE(BGPEXCT(X,1),U,2):(($PIECE(BGPEXCT(X,1),U,1)/$PIECE(BGPEXCT(X,1),U,2))*100),1:"")
+6 SET $PIECE(BGPEXCT(X,2),U,1)=$PIECE($GET(^BGPGPDPN(X,N)),U,P)
SET $PIECE(BGPEXCT(X,2),U,3)=$SELECT($PIECE(BGPEXCT(X,2),U,2):(($PIECE(BGPEXCT(X,2),U,1)/$PIECE(BGPEXCT(X,2),U,2))*100),1:"")
+7 SET $PIECE(BGPEXCT(X,3),U,1)=$PIECE($GET(^BGPGPDBN(X,N)),U,P)
SET $PIECE(BGPEXCT(X,3),U,3)=$SELECT($PIECE(BGPEXCT(X,3),U,2):(($PIECE(BGPEXCT(X,3),U,1)/$PIECE(BGPEXCT(X,3),U,2))*100),1:"")
End DoDot:2
+8 SET X=0
FOR
SET X=$ORDER(BGPEXCT(X))
IF X'=+X
QUIT
Begin DoDot:2
+9 SET A=$PIECE(BGPEXCT(X,1),U,1)
SET B=$PIECE(BGPEXCT(X,1),U,2)
SET C=$PIECE(BGPEXCT(X,1),U,3)
+10 SET D=$PIECE(BGPEXCT(X,2),U,1)
SET E=$PIECE(BGPEXCT(X,2),U,2)
SET F=$PIECE(BGPEXCT(X,2),U,3)
+11 SET G=$PIECE(BGPEXCT(X,3),U,1)
SET H=$PIECE(BGPEXCT(X,3),U,2)
SET I=$PIECE(BGPEXCT(X,3),U,3)
+12 IF $PIECE($PIECE(^BGPINDNC(BGPPC,0),U,4),".")="023"
SET Y=$PIECE(^BGPINDNC(BGPPC,0),U,14)
SET $PIECE(BGPEI(X),U,Y)=$SELECT(B:B,1:0)
SET $PIECE(BGPEI(X),U,(Y+3))=$SELECT(E:E,1:0)
SET $PIECE(BGPEI(X),U,(Y+6))=$SELECT(H:H,1:0)
QUIT
+13 IF $PIECE($PIECE(^BGPINDNC(BGPPC,0),U,4),".")="014"
SET Y=$PIECE(^BGPINDNC(BGPPC,0),U,14)
SET $PIECE(BGPEI(X),U,Y)=$SELECT(B:B,1:0)
SET $PIECE(BGPEI(X),U,(Y+3))=$SELECT(E:E,1:0)
SET $PIECE(BGPEI(X),U,(Y+6))=$SELECT(H:H,1:0)
QUIT
+14 IF $PIECE($PIECE(^BGPINDNC(BGPPC,0),U,4),".")="016"
SET Y=$PIECE(^BGPINDNC(BGPPC,0),U,14)
SET $PIECE(BGPEI(X),U,Y)=$SELECT(B:B,1:0)
SET $PIECE(BGPEI(X),U,(Y+3))=$SELECT(E:E,1:0)
SET $PIECE(BGPEI(X),U,(Y+6))=$SELECT(H:H,1:0)
QUIT
+15 IF $PIECE($GET(^BGPINDNC(BGPPC,19)),U,13)
SET Y=$PIECE(^BGPINDNC(BGPPC,0),U,14)
SET $PIECE(BGPEI(X),U,Y)=$SELECT(B:B,1:0)
SET $PIECE(BGPEI(X),U,(Y+3))=$SELECT(E:E,1:0)
SET $PIECE(BGPEI(X),U,(Y+6))=$SELECT(H:H,1:0)
QUIT
+16 SET Y=$PIECE(^BGPINDNC(BGPPC,0),U,14)
+17 SET $PIECE(BGPEI(X),U,$PIECE(^BGPINDNC(BGPPC,0),U,14))=$SELECT(A:A,1:0)
SET $PIECE(BGPEI(X),U,(Y+1))=$SELECT(B:B,1:0)
SET $PIECE(BGPEI(X),U,(Y+2))=$$SL(C)
+18 SET $PIECE(BGPEI(X),U,(Y+3))=$SELECT(D:D,1:0)
SET $PIECE(BGPEI(X),U,(Y+4))=$SELECT(E:E,1:0)
SET $PIECE(BGPEI(X),U,(Y+5))=$$SL(F)
SET $PIECE(BGPEI(X),U,(Y+6))=$SELECT(G:G,1:0)
SET $PIECE(BGPEI(X),U,(Y+7))=$SELECT(H:H,1:0)
SET $PIECE(BGPEI(X),U,(Y+8))=$$SL(I)
End DoDot:2
End DoDot:1
GPRANT2 ;
+1 IF $GET(BGPAREAA)
IF $GET(BGPEXCEL)
Begin DoDot:1
+2 IF $PIECE($GET(^BGPINDNC(BGPPC,12)),U,13)=""
QUIT
+3 ;set each numerator and percent,then set BGPEI2
+4 NEW X
SET X=0
FOR
SET X=$ORDER(BGPSUL(X))
IF X'=+X
QUIT
Begin DoDot:2
+5 SET $PIECE(BGPEXCT(X,1),U,1)=$PIECE($GET(^BGPGPDCN(X,N)),U,P)
SET $PIECE(BGPEXCT(X,1),U,3)=$SELECT($PIECE(BGPEXCT(X,1),U,2):(($PIECE(BGPEXCT(X,1),U,1)/$PIECE(BGPEXCT(X,1),U,2))*100),1:"")
+6 SET $PIECE(BGPEXCT(X,2),U,1)=$PIECE($GET(^BGPGPDPN(X,N)),U,P)
SET $PIECE(BGPEXCT(X,2),U,3)=$SELECT($PIECE(BGPEXCT(X,2),U,2):(($PIECE(BGPEXCT(X,2),U,1)/$PIECE(BGPEXCT(X,2),U,2))*100),1:"")
+7 SET $PIECE(BGPEXCT(X,3),U,1)=$PIECE($GET(^BGPGPDBN(X,N)),U,P)
SET $PIECE(BGPEXCT(X,3),U,3)=$SELECT($PIECE(BGPEXCT(X,3),U,2):(($PIECE(BGPEXCT(X,3),U,1)/$PIECE(BGPEXCT(X,3),U,2))*100),1:"")
End DoDot:2
+8 SET X=0
FOR
SET X=$ORDER(BGPEXCT(X))
IF X'=+X
QUIT
Begin DoDot:2
+9 SET A=$PIECE(BGPEXCT(X,1),U,1)
SET B=$PIECE(BGPEXCT(X,1),U,2)
SET C=$PIECE(BGPEXCT(X,1),U,3)
+10 SET D=$PIECE(BGPEXCT(X,2),U,1)
SET E=$PIECE(BGPEXCT(X,2),U,2)
SET F=$PIECE(BGPEXCT(X,2),U,3)
+11 SET G=$PIECE(BGPEXCT(X,3),U,1)
SET H=$PIECE(BGPEXCT(X,3),U,2)
SET I=$PIECE(BGPEXCT(X,3),U,3)
+12 IF $PIECE($PIECE(^BGPINDNC(BGPPC,0),U,4),".")="023"
SET Y=$PIECE(^BGPINDNC(BGPPC,12),U,13)
SET $PIECE(BGPEI2(X),U,Y)=$SELECT(B:B,1:0)
SET $PIECE(BGPEI2(X),U,(Y+3))=$SELECT(E:E,1:0)
SET $PIECE(BGPEI2(X),U,(Y+6))=$SELECT(H:H,1:0)
QUIT
+13 IF $PIECE($PIECE(^BGPINDNC(BGPPC,0),U,4),".")="014"
SET Y=$PIECE(^BGPINDNC(BGPPC,12),U,13)
SET $PIECE(BGPEI2(X),U,Y)=$SELECT(B:B,1:0)
SET $PIECE(BGPEI2(X),U,(Y+3))=$SELECT(E:E,1:0)
SET $PIECE(BGPEI2(X),U,(Y+6))=$SELECT(H:H,1:0)
QUIT
+14 IF $PIECE($PIECE(^BGPINDNC(BGPPC,0),U,4),".")="016"
SET Y=$PIECE(^BGPINDNC(BGPPC,12),U,13)
SET $PIECE(BGPEI2(X),U,Y)=$SELECT(B:B,1:0)
SET $PIECE(BGPEI2(X),U,(Y+3))=$SELECT(E:E,1:0)
SET $PIECE(BGPEI2(X),U,(Y+6))=$SELECT(H:H,1:0)
QUIT
+15 IF $PIECE($GET(^BGPINDNC(BGPPC,19)),U,13)
SET Y=$PIECE(^BGPINDNC(BGPPC,12),U,13)
SET $PIECE(BGPEI2(X),U,Y)=$SELECT(B:B,1:0)
SET $PIECE(BGPEI2(X),U,(Y+3))=$SELECT(E:E,1:0)
SET $PIECE(BGPEI2(X),U,(Y+6))=$SELECT(H:H,1:0)
QUIT
+16 SET Y=$PIECE(^BGPINDNC(BGPPC,12),U,13)
+17 SET $PIECE(BGPEI2(X),U,$PIECE(^BGPINDNC(BGPPC,12),U,13))=$SELECT(A:A,1:0)
SET $PIECE(BGPEI2(X),U,(Y+1))=$SELECT(B:B,1:0)
SET $PIECE(BGPEI2(X),U,(Y+2))=$$SL(C)
+18 SET $PIECE(BGPEI2(X),U,(Y+3))=$SELECT(D:D,1:0)
SET $PIECE(BGPEI2(X),U,(Y+4))=$SELECT(E:E,1:0)
SET $PIECE(BGPEI2(X),U,(Y+5))=$$SL(F)
SET $PIECE(BGPEI2(X),U,(Y+6))=$SELECT(G:G,1:0)
SET $PIECE(BGPEI2(X),U,(Y+7))=$SELECT(H:H,1:0)
SET $PIECE(BGPEI2(X),U,(Y+8))=$$SL(I)
End DoDot:2
End DoDot:1
+19 IF $GET(BGPAREAA)
IF $GET(BGPEXCEL)
DO GPRANT3^BGP9DP1D
ONN1 ;
+1 DO ONM1^BGP9DP1D
+2 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(^BGPGPDCN(X,N)),U,P)
+5 IF T=2
SET $PIECE(BGPEXCT(X,T),U,2)=$PIECE($GET(^BGPGPDPN(X,N)),U,P)
+6 IF T=3
SET $PIECE(BGPEXCT(X,T),U,2)=$PIECE($GET(^BGPGPDBN(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(^BGPGPDCN(R,N)),U,P)
QUIT $SELECT(X]"":X,1:0)
+4 IF T=2
SET X=$PIECE($GET(^BGPGPDPN(R,N)),U,P)
QUIT $SELECT(X]"":X,1:0)
+5 IF T=3
SET X=$PIECE($GET(^BGPGPDBN(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(^BGPGPDCN(X,N)),U,P)
+3 IF T=2
SET C=C+$PIECE($GET(^BGPGPDPN(X,N)),U,P)
+4 IF T=3
SET C=C+$PIECE($GET(^BGPGPDBN(X,N)),U,P)
+5 ;SPDX
IF $GET(BGPAREAA)
IF $PIECE($GET(^BGPINDNC(BGPPC,14)),U)
Begin DoDot:2
+6 ;SPDX
IF T=1
SET $PIECE(BGPSDP(X,T),U,ND)=$PIECE($GET(^BGPGPDCN(X,N)),U,P)
+7 ;SPDX
IF T=2
SET $PIECE(BGPSDP(X,T),U,ND)=$PIECE($GET(^BGPGPDPN(X,N)),U,P)
+8 ;SPDX
IF T=3
SET $PIECE(BGPSDP(X,T),U,ND)=$PIECE($GET(^BGPGPDBN(X,N)),U,P)
End DoDot:2
+9 ;SPDX
IF $GET(BGPAREAA)
IF $PIECE($GET(^BGPINDNC(BGPPC,15)),U)
Begin DoDot:2
+10 ;SPDX
IF T=1
SET $PIECE(BGPSDPN(X,T),U,ND)=$PIECE($GET(^BGPGPDCN(X,N)),U,P)
+11 ;SPDX
IF T=2
SET $PIECE(BGPSDPN(X,T),U,ND)=$PIECE($GET(^BGPGPDPN(X,N)),U,P)
+12 ;SPDX
IF T=3
SET $PIECE(BGPSDPN(X,T),U,ND)=$PIECE($GET(^BGPGPDBN(X,N)),U,P)
End DoDot:2
+13 ;SPDX
IF $GET(BGPAREAA)
IF $PIECE($GET(^BGPINDNC(BGPPC,19)),U)
Begin DoDot:2
+14 ;SPDX
IF T=1
SET $PIECE(BGPSDPO(X,T),U,ND)=$PIECE($GET(^BGPGPDCN(X,N)),U,P)
+15 ;SPDX
IF T=2
SET $PIECE(BGPSDPO(X,T),U,ND)=$PIECE($GET(^BGPGPDPN(X,N)),U,P)
+16 ;SPDX
IF T=3
SET $PIECE(BGPSDPO(X,T),U,ND)=$PIECE($GET(^BGPGPDBN(X,N)),U,P)
End DoDot:2
+17 ;SPDX
IF $GET(BGPAREAA)
IF $PIECE($GET(^BGPINDNC(BGPPC,22)),U)
Begin DoDot:2
+18 ;SPDX
IF T=1
SET $PIECE(BGPSDPD(X,T),U,ND)=$PIECE($GET(^BGPGPDCN(X,N)),U,P)
+19 ;SPDX
IF T=2
SET $PIECE(BGPSDPD(X,T),U,ND)=$PIECE($GET(^BGPGPDPN(X,N)),U,P)
+20 ;SPDX
IF T=3
SET $PIECE(BGPSDPD(X,T),U,ND)=$PIECE($GET(^BGPGPDBN(X,N)),U,P)
End DoDot:2
+21 QUIT
End DoDot:1
+22 QUIT $SELECT(C]"":C,1:0)
C(X,X2,X3) ;
+1 DO COMMA^%DTC
+2 QUIT X
SDP ;SDPX
+1 ;loop thru each BGPSDP and set 3rd piece
+2 NEW X,Y,T,D,N
+3 SET X=0
FOR
SET X=$ORDER(BGPSDP(X))
IF X'=+X
QUIT
Begin DoDot:1
+4 SET T=0
FOR
SET T=$ORDER(BGPSDP(X,T))
IF T'=+T
QUIT
Begin DoDot:2
+5 SET D=$PIECE(BGPSDP(X,T),U,1)
SET N=$PIECE(BGPSDP(X,T),U,2)
+6 SET $PIECE(BGPSDP(X,T),U,3)=$SELECT(D:((N/D)*100),1:"")
End DoDot:2
End DoDot:1
+7 SET X=0
FOR
SET X=$ORDER(BGPSDPN(X))
IF X'=+X
QUIT
Begin DoDot:1
+8 SET T=0
FOR
SET T=$ORDER(BGPSDPN(X,T))
IF T'=+T
QUIT
Begin DoDot:2
+9 SET D=$PIECE(BGPSDPN(X,T),U,1)
SET N=$PIECE(BGPSDPN(X,T),U,2)
+10 SET $PIECE(BGPSDPN(X,T),U,3)=$SELECT(D:((N/D)*100),1:"")
End DoDot:2
End DoDot:1
+11 SET X=0
FOR
SET X=$ORDER(BGPSDPO(X))
IF X'=+X
QUIT
Begin DoDot:1
+12 SET T=0
FOR
SET T=$ORDER(BGPSDPO(X,T))
IF T'=+T
QUIT
Begin DoDot:2
+13 SET D=$PIECE(BGPSDPO(X,T),U,1)
SET N=$PIECE(BGPSDPO(X,T),U,2)
+14 SET $PIECE(BGPSDPO(X,T),U,3)=$SELECT(D:((N/D)*100),1:"")
End DoDot:2
End DoDot:1
+15 SET X=0
FOR
SET X=$ORDER(BGPSDPD(X))
IF X'=+X
QUIT
Begin DoDot:1
+16 SET T=0
FOR
SET T=$ORDER(BGPSDPD(X,T))
IF T'=+T
QUIT
Begin DoDot:2
+17 SET D=$PIECE(BGPSDPD(X,T),U,1)
SET N=$PIECE(BGPSDPD(X,T),U,2)
+18 SET $PIECE(BGPSDPD(X,T),U,3)=$SELECT(D:((N/D)*100),1:"")
End DoDot:2
End DoDot:1
+19 QUIT
SB(X) ;EP - Strip leading and trailing blanks from X.
+1 NEW %
+2 XECUTE ^DD("FUNC",$ORDER(^DD("FUNC","B","STRIPBLANKS",0)),1)
+3 QUIT X
