BGP0DP1C ; IHS/CMI/LAB - print ind 1 21 Mar 2009 12:55 PM ;
;;10.0;IHS CLINICAL REPORTING;;JUN 18, 2010
;
;
PI ;EP
S BGPDENP=0
S BGPPC2=0 F S BGPPC2=$O(^BGPINDTC("ABC",BGPPC1,BGPPC2)) Q:BGPPC2="" S BGPPC=$O(^BGPINDTC("ABC",BGPPC1,BGPPC2,0)) D PI1
Q
CHECK(I) ;EP
I BGPRTYPE=1,$P(^BGPINDTC(I,0),U,5)'=1 Q ""
I BGPRTYPE=1,$P($G(^BGPINDTC(I,21)),U,6) Q "" ;gpra dev only
I BGPRTYPE=7,$P($G(^BGPINDTC(I,12)),U,12)'=1 Q ""
I BGPRTYPE=4,$P($G(^BGPINDTC(I,21)),U,2)=1 Q "" ;skip selected report
I BGPRTYPE=9,$P($G(^BGPINDTC(I,21)),U,6)'=1 Q "" ;gpra dev only
I BGPINDT="D",$P(^BGPINDTC(I,0),U,12)'=1 Q ""
I BGPINDT="C",$P(^BGPINDTC(I,0),U,13)'=1 Q ""
I BGPINDT="W",$P($G(^BGPINDTC(I,12)),U,2)'=1 Q ""
I BGPINDT="E",$P($G(^BGPINDTC(I,12)),U,3)'=1 Q ""
Q 1
PI1 ;EP
K BGPEXCT,BGPSDP,BGPSDPN,BGPSDPO,BGPSDPD
Q:'$$CHECK(BGPPC)
I $P(^BGPINDTC(BGPPC,0),U,4)="E-2.B.3" D:BGPPTYPE="D" W^BGP0DP("",0,1,BGPPTYPE) D PI1^BGP0DP2 Q ;1217??
S BGPDF=$P(^BGPINDTC(BGPPC,0),U,8)
;get denom value
S BGPNP=$P(^DD(90377.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)
;denom
I BGPRTYPE=1,$P(^BGPINDTC(BGPPC,0),U,4)="MS.A.9" S BGPDENP=0
I BGPRTYPE=1,$P(^BGPINDTC(BGPPC,0),U,4)="DM.2.1" S BGPDENP=0
I BGPRTYPE=7,$P(^BGPINDTC(BGPPC,0),U,4)="028.C.4" S BGPDENP=0
I BGPRTYPE=1,$P(^BGPINDTC(BGPPC,0),U,4)="E-2.A.1" S BGPDENP=0
I BGPRTYPE=9,$P(^BGPINDTC(BGPPC,0),U,4)="027.C.36" S BGPDENP=0
I 'BGPDENP D
.I $P($G(^BGPINDTC(BGPPC,12)),U,14) Q
.I $P(^BGPINDTC(BGPPC,0),U,11),BGPRTYPE=1 I '$G(BGPSUMON) D HEADER^BGP0DPH Q:BGPQUIT D W^BGP0DP(^BGPINDT(BGPIC,53,1,0),0,2,BGPPTYPE) D:$D(^BGPINDT(BGPIC,53,2,0)) W^BGP0DP(^BGPINDT(BGPIC,53,2,0),0,1,BGPPTYPE) D H1^BGP0DPH
.I $P(^BGPINDTC(BGPPC,0),U,24),BGPRTYPE=4 I '$G(BGPSUMON) D HEADER^BGP0DPH Q:BGPQUIT W !!,^BGPINDT(BGPIC,53,1,0) W:$D(^BGPINDT(BGPIC,53,2,0)) !,^BGPINDT(BGPIC,53,2,0) D H1^BGP0DPH
.I $P($G(^BGPINDTC(BGPPC,12)),U,15),BGPRTYPE=7 I '$G(BGPSUMON) D HEADER^BGP0DPH Q:BGPQUIT W !!,^BGPINDT(BGPIC,53,1,0) W:$D(^BGPINDT(BGPIC,53,2,0)) !,^BGPINDT(BGPIC,53,2,0) D H1^BGP0DPH
.I $Y>(BGPIOSL-10),'$G(BGPSUMON) D HEADER^BGP0DPH Q:BGPQUIT W !!,^BGPINDT(BGPIC,53,1,0) W:$D(^BGPINDT(BGPIC,53,2,0)) !,^BGPINDT(BGPIC,53,2,0) D H1^BGP0DPH
.I BGPRTYPE=1,$P($G(^BGPINDTC(BGPPC,20)),U,4)]"" D I 1
..W:'$G(BGPSUMON) !!,$P(^BGPINDTC(BGPPC,20),U,4)
..I $P(^BGPINDTC(BGPPC,20),U,5)]"" W:'$G(BGPSUMON) !,$P(^BGPINDTC(BGPPC,20),U,5)
..I $P(^BGPINDTC(BGPPC,20),U,6)]"" W:'$G(BGPSUMON) !,$P(^BGPINDTC(BGPPC,20),U,6)
.E D
..I BGPRTYPE=4,BGP0RPTH="P" W !!,$P(^DIBT(BGPSEAT,0),U)," Population"
..I '$G(BGPSUMON) D
...I BGPRTYPE=4,BGP0RPTH="P" W !,$P(^BGPINDTC(BGPPC,0),U,17) I 1
...E W !!,$P(^BGPINDTC(BGPPC,0),U,17)
..I $P(^BGPINDTC(BGPPC,0),U,18)]"" D C18
..I $P(^BGPINDTC(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(^BGPINDTC(BGPPC,0),U,4),1,2)="I." D
.S BGPDF=$P(^BGPINDTC(BGPPC,0),U,8)
.;get denom
.S BGPNP=$P(^DD(90377.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(^BGPINDTC(BGPPC,0),U,9)
S BGPNP=$P(^DD(90377.03,BGPNF,0),U,4),N=$P(BGPNP,";"),P=$P(BGPNP,";",2)
D SETN
I $P(^BGPINDTC(BGPPC,0),U,22) W:'$G(BGPSUMON) !
I $P($G(^BGPINDTC(BGPPC,12)),U,8),BGPRTYPE=4 I '$G(BGPSUMON) D HEADER^BGP0DPH Q:BGPQUIT W !!,^BGPINDT(BGPIC,53,1,0) W:$D(^BGPINDT(BGPIC,53,2,0)) !,^BGPINDT(BGPIC,53,2,0) D H1^BGP0DPH
I $P($G(^BGPINDTC(BGPPC,21)),U,5),BGPRTYPE=1 I '$G(BGPSUMON) D HEADER^BGP0DPH Q:BGPQUIT W !!,^BGPINDT(BGPIC,53,1,0) W:$D(^BGPINDT(BGPIC,53,2,0)) !,^BGPINDT(BGPIC,53,2,0) D H1^BGP0DPH
I BGPRTYPE=1,$P($G(^BGPINDTC(BGPPC,20)),U,1)]"",'$G(BGPSUMON) D G N
.W !,$P(^BGPINDTC(BGPPC,20),U,1)
.I $P(^BGPINDTC(BGPPC,20),U,2)]"" W !,$P(^BGPINDTC(BGPPC,20),U,2)
.I $P(^BGPINDTC(BGPPC,20),U,3)]"" W !,$P(^BGPINDTC(BGPPC,20),U,3)
W:'$G(BGPSUMON) !,$P(^BGPINDTC(BGPPC,0),U,15) I BGPRTYPE=4,$P($G(^BGPINDTC(BGPPC,12)),U,5) W:'$G(BGPSUMON) " (GPRA)"
I $P(^BGPINDTC(BGPPC,0),U,16)]"" W:'$G(BGPSUMON) !?1,$P(^BGPINDTC(BGPPC,0),U,16)
I BGPRTYPE=4,$P($G(^BGPINDTC(BGPPC,12)),U,6) W:$P(^BGPINDTC(BGPPC,0),U,16)="" ! W:'$G(BGPSUMON) " (GPRA)"
I $P(^BGPINDTC(BGPPC,0),U,19)]"" W:'$G(BGPSUMON) !?1,$P(^BGPINDTC(BGPPC,0),U,19)
I BGPRTYPE=4,$P($G(^BGPINDTC(BGPPC,12)),U,7) W:$P(^BGPINDTC(BGPPC,0),U,19)="" ! W:'$G(BGPSUMON) " (GPRA)"
N D H2^BGP0DPH
Q
C18 ;
W:'$G(BGPSUMON) !,$P(^BGPINDTC(BGPPC,0),U,18)
Q
C21 ;
W:'$G(BGPSUMON) !,$P(^BGPINDTC(BGPPC,0),U,21)
Q
I1AGE ;EP - age tallies
D I1AGE^BGP0DP11
Q
SETN ;EP - set numerator fields
S BGPCYN=$$V^BGP0DP1C(1,BGPRPT,N,P,2)
S BGPPRN=$$V^BGP0DP1C(2,BGPRPT,N,P,2)
S BGPBLN=$$V^BGP0DP1C(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:"")
I $G(BGPAREAA) D SDP
;GPRA
I $P($G(^BGPINDTC(BGPPC,14)),U),'$G(BGPNOSUM) D
.S ^TMP($J,"SUMMARY",$P(^BGPSCAT($P(^BGPINDTC(BGPPC,14),U,5),0),U,2),$P(^BGPINDTC(BGPPC,14),U,6),BGPPC)=BGPCYP_U_BGPPRP_U_BGPBLP
.I $G(BGPAREAA) D
..S X=0 F S X=$O(BGPSDP(X)) Q:X'=+X D
...S ^TMP($J,"SUMMARY DETAIL PAGE",$P(^BGPSCAT($P(^BGPINDTC(BGPPC,14),U,5),0),U,2),$P(^BGPINDTC(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(^BGPINDTC(BGPPC,14),U,5),0),U,2),$P(^BGPINDTC(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
..S X=0 F S X=$O(BGPSDP(X)) Q:X'=+X D
...S A=$P(^BGPSCAT($P(^BGPINDTC(BGPPC,14),U,5),0),U,2)
...S B=$P(^BGPINDTC(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
I $P($G(^BGPINDTC(BGPPC,15)),U),'$G(BGPNOSUM) D
.S ^TMP($J,"SUMMARY NON",$P(^BGPSCAT($P(^BGPINDTC(BGPPC,15),U,5),0),U,2),$P(^BGPINDTC(BGPPC,15),U,6),BGPPC)=BGPCYP_U_BGPPRP_U_BGPBLP
.I $G(BGPAREAA) D
..S X=0 F S X=$O(BGPSDPN(X)) Q:X'=+X D
...S ^TMP($J,"SUMMARY DETAIL PAGE NON",$P(^BGPSCAT($P(^BGPINDTC(BGPPC,15),U,5),0),U,2),$P(^BGPINDTC(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(^BGPINDTC(BGPPC,15)),U),'$G(BGPNOSUM) D
.S ^TMP($J,"SUMMARYDEL NON",$P(^BGPSCAT($P(^BGPINDTC(BGPPC,15),U,5),0),U,2),$P(^BGPINDTC(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
..S X=0 F S X=$O(BGPSDPN(X)) Q:X'=+X D
...S A=$P(^BGPSCAT($P(^BGPINDTC(BGPPC,15),U,5),0),U,2)
...S B=$P(^BGPINDTC(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))
D SETDEV^BGP0DP1E
;OTHER
I $P($G(^BGPINDTC(BGPPC,19)),U),'$G(BGPNOSUM) D
.S ^TMP($J,"SUMMARY OTHER",$P(^BGPSCAT($P(^BGPINDTC(BGPPC,19),U,5),0),U,3),$P(^BGPINDTC(BGPPC,19),U,6),BGPPC)=BGPCYP_U_BGPPRP_U_BGPBLP
.I $G(BGPAREAA) D
..S X=0 F S X=$O(BGPSDPO(X)) Q:X'=+X D
...S ^TMP($J,"SUMMARY DETAIL PAGE OTHER",$P(^BGPSCAT($P(^BGPINDTC(BGPPC,19),U,5),0),U,3),$P(^BGPINDTC(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(^BGPINDTC(BGPPC,19)),U),'$G(BGPNOSUM) D
.S ^TMP($J,"SUMMARYDEL OTHER",$P(^BGPSCAT($P(^BGPINDTC(BGPPC,19),U,5),0),U,3),$P(^BGPINDTC(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
..S X=0 F S X=$O(BGPSDPO(X)) Q:X'=+X D
...S A=$P(^BGPSCAT($P(^BGPINDTC(BGPPC,19),U,5),0),U,3)
...S B=$P(^BGPINDTC(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(^BGPINDTC(BGPPC,0),U,14)=""
.NEW X S X=0 F S X=$O(BGPSUL(X)) Q:X'=+X D
..S $P(BGPEXCT(X,1),U,1)=$P($G(^BGPGPDCT(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(^BGPGPDPT(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(^BGPGPDBT(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(^BGPINDTC(BGPPC,0),U,4),".")="023" S Y=$P(^BGPINDTC(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(^BGPINDTC(BGPPC,0),U,4),".",1,2)="014.A" S Y=$P(^BGPINDTC(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(^BGPINDTC(BGPPC,0),U,4)="016.A.1" S Y=$P(^BGPINDTC(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(^BGPINDTC(BGPPC,19)),U,13) S Y=$P(^BGPINDTC(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(^BGPINDTC(BGPPC,0),U,14)
..S $P(BGPEI(X),U,$P(^BGPINDTC(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(^BGPINDTC(BGPPC,12)),U,13)=""
.NEW X S X=0 F S X=$O(BGPSUL(X)) Q:X'=+X D
..S $P(BGPEXCT(X,1),U,1)=$P($G(^BGPGPDCT(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(^BGPGPDPT(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(^BGPGPDBT(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(^BGPINDTC(BGPPC,0),U,4),".")="023" S Y=$P(^BGPINDTC(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(^BGPINDTC(BGPPC,0),U,4),".",1,2)="014.A" S Y=$P(^BGPINDTC(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(^BGPINDTC(BGPPC,0),U,4)="016.A.1" S Y=$P(^BGPINDTC(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(^BGPINDTC(BGPPC,19)),U,13) S Y=$P(^BGPINDTC(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(^BGPINDTC(BGPPC,12),U,13)
..S $P(BGPEI2(X),U,$P(^BGPINDTC(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 DEVEL1^BGP0DP1D
ONN1 ;
D ONM1^BGP0DP1D
Q
SL(V) ;
I V="" S V=0
Q $$STRIP^XLFSTR($J(V,5,1)," ")
SETEXA(T,N,P) ;EP
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(^BGPGPDCT(X,N)),U,P)
.I T=2 S $P(BGPEXCT(X,T),U,2)=$P($G(^BGPGPDPT(X,N)),U,P)
.I T=3 S $P(BGPEXCT(X,T),U,2)=$P($G(^BGPGPDBT(X,N)),U,P)
Q
V(T,R,N,P,ND) ;EP
I $G(BGPAREAA) G VA
NEW X
I T=1 S X=$P($G(^BGPGPDCT(R,N)),U,P) Q $S(X]"":X,1:0)
I T=2 S X=$P($G(^BGPGPDPT(R,N)),U,P) Q $S(X]"":X,1:0)
I T=3 S X=$P($G(^BGPGPDBT(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(^BGPGPDCT(X,N)),U,P)
.I T=2 S C=C+$P($G(^BGPGPDPT(X,N)),U,P)
.I T=3 S C=C+$P($G(^BGPGPDBT(X,N)),U,P)
.I $G(BGPAREAA),$P($G(^BGPINDTC(BGPPC,14)),U) D
..I T=1 S $P(BGPSDP(X,T),U,ND)=$P($G(^BGPGPDCT(X,N)),U,P)
..I T=2 S $P(BGPSDP(X,T),U,ND)=$P($G(^BGPGPDPT(X,N)),U,P)
..I T=3 S $P(BGPSDP(X,T),U,ND)=$P($G(^BGPGPDBT(X,N)),U,P)
.I $G(BGPAREAA),$P($G(^BGPINDTC(BGPPC,15)),U) D
..I T=1 S $P(BGPSDPN(X,T),U,ND)=$P($G(^BGPGPDCT(X,N)),U,P)
..I T=2 S $P(BGPSDPN(X,T),U,ND)=$P($G(^BGPGPDPT(X,N)),U,P)
..I T=3 S $P(BGPSDPN(X,T),U,ND)=$P($G(^BGPGPDBT(X,N)),U,P)
.I $G(BGPAREAA),$P($G(^BGPINDTC(BGPPC,19)),U) D
..I T=1 S $P(BGPSDPO(X,T),U,ND)=$P($G(^BGPGPDCT(X,N)),U,P)
..I T=2 S $P(BGPSDPO(X,T),U,ND)=$P($G(^BGPGPDPT(X,N)),U,P)
..I T=3 S $P(BGPSDPO(X,T),U,ND)=$P($G(^BGPGPDBT(X,N)),U,P)
.I $G(BGPAREAA),$P($G(^BGPINDTC(BGPPC,22)),U) D
..I T=1 S $P(BGPSDPD(X,T),U,ND)=$P($G(^BGPGPDCT(X,N)),U,P)
..I T=2 S $P(BGPSDPD(X,T),U,ND)=$P($G(^BGPGPDPT(X,N)),U,P)
..I T=3 S $P(BGPSDPD(X,T),U,ND)=$P($G(^BGPGPDBT(X,N)),U,P)
.Q
Q $S(C]"":C,1:0)
C(X,X2,X3) ;
D COMMA^%DTC
Q X
SDP ;
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
NEW %
X ^DD("FUNC",$O(^DD("FUNC","B","STRIPBLANKS",0)),1)
Q X
BGP0DP1C ; IHS/CMI/LAB - print ind 1 21 Mar 2009 12:55 PM ;
+1 ;;10.0;IHS CLINICAL REPORTING;;JUN 18, 2010
+2 ;
+3 ;
PI ;EP
+1 SET BGPDENP=0
+2 SET BGPPC2=0
FOR
SET BGPPC2=$ORDER(^BGPINDTC("ABC",BGPPC1,BGPPC2))
IF BGPPC2=""
QUIT
SET BGPPC=$ORDER(^BGPINDTC("ABC",BGPPC1,BGPPC2,0))
DO PI1
+3 QUIT
CHECK(I) ;EP
+1 IF BGPRTYPE=1
IF $PIECE(^BGPINDTC(I,0),U,5)'=1
QUIT ""
+2 ;gpra dev only
IF BGPRTYPE=1
IF $PIECE($GET(^BGPINDTC(I,21)),U,6)
QUIT ""
+3 IF BGPRTYPE=7
IF $PIECE($GET(^BGPINDTC(I,12)),U,12)'=1
QUIT ""
+4 ;skip selected report
IF BGPRTYPE=4
IF $PIECE($GET(^BGPINDTC(I,21)),U,2)=1
QUIT ""
+5 ;gpra dev only
IF BGPRTYPE=9
IF $PIECE($GET(^BGPINDTC(I,21)),U,6)'=1
QUIT ""
+6 IF BGPINDT="D"
IF $PIECE(^BGPINDTC(I,0),U,12)'=1
QUIT ""
+7 IF BGPINDT="C"
IF $PIECE(^BGPINDTC(I,0),U,13)'=1
QUIT ""
+8 IF BGPINDT="W"
IF $PIECE($GET(^BGPINDTC(I,12)),U,2)'=1
QUIT ""
+9 IF BGPINDT="E"
IF $PIECE($GET(^BGPINDTC(I,12)),U,3)'=1
QUIT ""
+10 QUIT 1
PI1 ;EP
+1 KILL BGPEXCT,BGPSDP,BGPSDPN,BGPSDPO,BGPSDPD
+2 IF '$$CHECK(BGPPC)
QUIT
+3 ;1217??
IF $PIECE(^BGPINDTC(BGPPC,0),U,4)="E-2.B.3"
IF BGPPTYPE="D"
DO W^BGP0DP("",0,1,BGPPTYPE)
DO PI1^BGP0DP2
QUIT
+4 SET BGPDF=$PIECE(^BGPINDTC(BGPPC,0),U,8)
+5 ;get denom value
+6 SET BGPNP=$PIECE(^DD(90377.03,BGPDF,0),U,4)
SET N=$PIECE(BGPNP,";")
SET P=$PIECE(BGPNP,";",2)
+7 SET BGPCYD=$$V(1,BGPRPT,N,P,1)
IF $GET(BGPAREAA)
DO SETEXA(1,N,P)
+8 SET BGPPRD=$$V(2,BGPRPT,N,P,1)
IF $GET(BGPAREAA)
DO SETEXA(2,N,P)
+9 SET BGPBLD=$$V(3,BGPRPT,N,P,1)
IF $GET(BGPAREAA)
DO SETEXA(3,N,P)
+10 ;denom
+11 IF BGPRTYPE=1
IF $PIECE(^BGPINDTC(BGPPC,0),U,4)="MS.A.9"
SET BGPDENP=0
+12 IF BGPRTYPE=1
IF $PIECE(^BGPINDTC(BGPPC,0),U,4)="DM.2.1"
SET BGPDENP=0
+13 IF BGPRTYPE=7
IF $PIECE(^BGPINDTC(BGPPC,0),U,4)="028.C.4"
SET BGPDENP=0
+14 IF BGPRTYPE=1
IF $PIECE(^BGPINDTC(BGPPC,0),U,4)="E-2.A.1"
SET BGPDENP=0
+15 IF BGPRTYPE=9
IF $PIECE(^BGPINDTC(BGPPC,0),U,4)="027.C.36"
SET BGPDENP=0
+16 IF 'BGPDENP
Begin DoDot:1
+17 IF $PIECE($GET(^BGPINDTC(BGPPC,12)),U,14)
QUIT
+18 IF $PIECE(^BGPINDTC(BGPPC,0),U,11)
IF BGPRTYPE=1
IF '$GET(BGPSUMON)
DO HEADER^BGP0DPH
IF BGPQUIT
QUIT
DO W^BGP0DP(^BGPINDT(BGPIC,53,1,0),0,2,BGPPTYPE)
IF $DATA(^BGPINDT(BGPIC,53,2,0))
DO W^BGP0DP(^BGPINDT(BGPIC,53,2,0),0,1,BGPPTYPE)
DO H1^BGP0DPH
+19 IF $PIECE(^BGPINDTC(BGPPC,0),U,24)
IF BGPRTYPE=4
IF '$GET(BGPSUMON)
DO HEADER^BGP0DPH
IF BGPQUIT
QUIT
WRITE !!,^BGPINDT(BGPIC,53,1,0)
IF $DATA(^BGPINDT(BGPIC,53,2,0))
WRITE !,^BGPINDT(BGPIC,53,2,0)
DO H1^BGP0DPH
+20 IF $PIECE($GET(^BGPINDTC(BGPPC,12)),U,15)
IF BGPRTYPE=7
IF '$GET(BGPSUMON)
DO HEADER^BGP0DPH
IF BGPQUIT
QUIT
WRITE !!,^BGPINDT(BGPIC,53,1,0)
IF $DATA(^BGPINDT(BGPIC,53,2,0))
WRITE !,^BGPINDT(BGPIC,53,2,0)
DO H1^BGP0DPH
+21 IF $Y>(BGPIOSL-10)
IF '$GET(BGPSUMON)
DO HEADER^BGP0DPH
IF BGPQUIT
QUIT
WRITE !!,^BGPINDT(BGPIC,53,1,0)
IF $DATA(^BGPINDT(BGPIC,53,2,0))
WRITE !,^BGPINDT(BGPIC,53,2,0)
DO H1^BGP0DPH
+22 IF BGPRTYPE=1
IF $PIECE($GET(^BGPINDTC(BGPPC,20)),U,4)]""
Begin DoDot:2
+23 IF '$GET(BGPSUMON)
WRITE !!,$PIECE(^BGPINDTC(BGPPC,20),U,4)
+24 IF $PIECE(^BGPINDTC(BGPPC,20),U,5)]""
IF '$GET(BGPSUMON)
WRITE !,$PIECE(^BGPINDTC(BGPPC,20),U,5)
+25 IF $PIECE(^BGPINDTC(BGPPC,20),U,6)]""
IF '$GET(BGPSUMON)
WRITE !,$PIECE(^BGPINDTC(BGPPC,20),U,6)
End DoDot:2
IF 1
+26 IF '$TEST
Begin DoDot:2
+27 IF BGPRTYPE=4
IF BGP0RPTH="P"
WRITE !!,$PIECE(^DIBT(BGPSEAT,0),U)," Population"
+28 IF '$GET(BGPSUMON)
Begin DoDot:3
+29 IF BGPRTYPE=4
IF BGP0RPTH="P"
WRITE !,$PIECE(^BGPINDTC(BGPPC,0),U,17)
IF 1
+30 IF '$TEST
WRITE !!,$PIECE(^BGPINDTC(BGPPC,0),U,17)
End DoDot:3
+31 IF $PIECE(^BGPINDTC(BGPPC,0),U,18)]""
DO C18
+32 IF $PIECE(^BGPINDTC(BGPPC,0),U,21)]""
DO C21
End DoDot:2
+33 IF '$GET(BGPSUMON)
WRITE ?20,$$C(BGPCYD,0,8),?35,$$C(BGPPRD,0,8),?58,$$C(BGPBLD,0,8),!
+34 SET BGPDENP=1
End DoDot:1
+35 IF $EXTRACT($PIECE(^BGPINDTC(BGPPC,0),U,4),1,2)="I."
Begin DoDot:1
+36 SET BGPDF=$PIECE(^BGPINDTC(BGPPC,0),U,8)
+37 ;get denom
+38 SET BGPNP=$PIECE(^DD(90377.03,BGPDF,0),U,4)
SET N=$PIECE(BGPNP,";")
SET P=$PIECE(BGPNP,";",2)
+39 SET BGPCYD=$$V(1,BGPRPT,N,P,1)
IF $GET(BGPAREAA)
DO SETEXA(1,N,P)
+40 SET BGPPRD=$$V(2,BGPRPT,N,P,1)
IF $GET(BGPAREAA)
DO SETEXA(2,N,P)
+41 SET BGPBLD=$$V(3,BGPRPT,N,P,1)
IF $GET(BGPAREAA)
DO SETEXA(3,N,P)
End DoDot:1
+42 SET BGPNF=$PIECE(^BGPINDTC(BGPPC,0),U,9)
+43 SET BGPNP=$PIECE(^DD(90377.03,BGPNF,0),U,4)
SET N=$PIECE(BGPNP,";")
SET P=$PIECE(BGPNP,";",2)
+44 DO SETN
+45 IF $PIECE(^BGPINDTC(BGPPC,0),U,22)
IF '$GET(BGPSUMON)
WRITE !
+46 IF $PIECE($GET(^BGPINDTC(BGPPC,12)),U,8)
IF BGPRTYPE=4
IF '$GET(BGPSUMON)
DO HEADER^BGP0DPH
IF BGPQUIT
QUIT
WRITE !!,^BGPINDT(BGPIC,53,1,0)
IF $DATA(^BGPINDT(BGPIC,53,2,0))
WRITE !,^BGPINDT(BGPIC,53,2,0)
DO H1^BGP0DPH
+47 IF $PIECE($GET(^BGPINDTC(BGPPC,21)),U,5)
IF BGPRTYPE=1
IF '$GET(BGPSUMON)
DO HEADER^BGP0DPH
IF BGPQUIT
QUIT
WRITE !!,^BGPINDT(BGPIC,53,1,0)
IF $DATA(^BGPINDT(BGPIC,53,2,0))
WRITE !,^BGPINDT(BGPIC,53,2,0)
DO H1^BGP0DPH
+48 IF BGPRTYPE=1
IF $PIECE($GET(^BGPINDTC(BGPPC,20)),U,1)]""
IF '$GET(BGPSUMON)
Begin DoDot:1
+49 WRITE !,$PIECE(^BGPINDTC(BGPPC,20),U,1)
+50 IF $PIECE(^BGPINDTC(BGPPC,20),U,2)]""
WRITE !,$PIECE(^BGPINDTC(BGPPC,20),U,2)
+51 IF $PIECE(^BGPINDTC(BGPPC,20),U,3)]""
WRITE !,$PIECE(^BGPINDTC(BGPPC,20),U,3)
End DoDot:1
GOTO N
+52 IF '$GET(BGPSUMON)
WRITE !,$PIECE(^BGPINDTC(BGPPC,0),U,15)
IF BGPRTYPE=4
IF $PIECE($GET(^BGPINDTC(BGPPC,12)),U,5)
IF '$GET(BGPSUMON)
WRITE " (GPRA)"
+53 IF $PIECE(^BGPINDTC(BGPPC,0),U,16)]""
IF '$GET(BGPSUMON)
WRITE !?1,$PIECE(^BGPINDTC(BGPPC,0),U,16)
+54 IF BGPRTYPE=4
IF $PIECE($GET(^BGPINDTC(BGPPC,12)),U,6)
IF $PIECE(^BGPINDTC(BGPPC,0),U,16)=""
WRITE !
IF '$GET(BGPSUMON)
WRITE " (GPRA)"
+55 IF $PIECE(^BGPINDTC(BGPPC,0),U,19)]""
IF '$GET(BGPSUMON)
WRITE !?1,$PIECE(^BGPINDTC(BGPPC,0),U,19)
+56 IF BGPRTYPE=4
IF $PIECE($GET(^BGPINDTC(BGPPC,12)),U,7)
IF $PIECE(^BGPINDTC(BGPPC,0),U,19)=""
WRITE !
IF '$GET(BGPSUMON)
WRITE " (GPRA)"
N DO H2^BGP0DPH
+1 QUIT
C18 ;
+1 IF '$GET(BGPSUMON)
WRITE !,$PIECE(^BGPINDTC(BGPPC,0),U,18)
+2 QUIT
C21 ;
+1 IF '$GET(BGPSUMON)
WRITE !,$PIECE(^BGPINDTC(BGPPC,0),U,21)
+2 QUIT
I1AGE ;EP - age tallies
+1 DO I1AGE^BGP0DP11
+2 QUIT
SETN ;EP - set numerator fields
+1 SET BGPCYN=$$V^BGP0DP1C(1,BGPRPT,N,P,2)
+2 SET BGPPRN=$$V^BGP0DP1C(2,BGPRPT,N,P,2)
+3 SET BGPBLN=$$V^BGP0DP1C(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
+9 IF $PIECE($GET(^BGPINDTC(BGPPC,14)),U)
IF '$GET(BGPNOSUM)
Begin DoDot:1
+10 SET ^TMP($JOB,"SUMMARY",$PIECE(^BGPSCAT($PIECE(^BGPINDTC(BGPPC,14),U,5),0),U,2),$PIECE(^BGPINDTC(BGPPC,14),U,6),BGPPC)=BGPCYP_U_BGPPRP_U_BGPBLP
+11 IF $GET(BGPAREAA)
Begin DoDot:2
+12 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(^BGPINDTC(BGPPC,14),U,5),0),U,2),$PIECE(^BGPINDTC(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(^BGPINDTC(BGPPC,14),U,5),0),U,2),$PIECE(^BGPINDTC(BGPPC,14),U,6),BGPPC)=$$SB($JUSTIFY(BGPCYP,5,1))_U_$$SB($JUSTIFY(BGPPRP,5,1))_U_$$SB($JUSTIFY(BGPBLP,5,1))
+15 IF $GET(BGPAREAA)
Begin DoDot:2
+16 SET X=0
FOR
SET X=$ORDER(BGPSDP(X))
IF X'=+X
QUIT
Begin DoDot:3
+17 SET A=$PIECE(^BGPSCAT($PIECE(^BGPINDTC(BGPPC,14),U,5),0),U,2)
+18 SET B=$PIECE(^BGPINDTC(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
+21 IF $PIECE($GET(^BGPINDTC(BGPPC,15)),U)
IF '$GET(BGPNOSUM)
Begin DoDot:1
+22 SET ^TMP($JOB,"SUMMARY NON",$PIECE(^BGPSCAT($PIECE(^BGPINDTC(BGPPC,15),U,5),0),U,2),$PIECE(^BGPINDTC(BGPPC,15),U,6),BGPPC)=BGPCYP_U_BGPPRP_U_BGPBLP
+23 IF $GET(BGPAREAA)
Begin DoDot:2
+24 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(^BGPINDTC(BGPPC,15),U,5),0),U,2),$PIECE(^BGPINDTC(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(^BGPINDTC(BGPPC,15)),U)
IF '$GET(BGPNOSUM)
Begin DoDot:1
+27 SET ^TMP($JOB,"SUMMARYDEL NON",$PIECE(^BGPSCAT($PIECE(^BGPINDTC(BGPPC,15),U,5),0),U,2),$PIECE(^BGPINDTC(BGPPC,15),U,6),BGPPC)=$$SB($JUSTIFY(BGPCYP,5,1))_U_$$SB($JUSTIFY(BGPPRP,5,1))_U_$$SB($JUSTIFY(BGPBLP,5,1))
+28 IF $GET(BGPAREAA)
Begin DoDot:2
+29 SET X=0
FOR
SET X=$ORDER(BGPSDPN(X))
IF X'=+X
QUIT
Begin DoDot:3
+30 SET A=$PIECE(^BGPSCAT($PIECE(^BGPINDTC(BGPPC,15),U,5),0),U,2)
+31 SET B=$PIECE(^BGPINDTC(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 DO SETDEV^BGP0DP1E
+34 ;OTHER
+35 IF $PIECE($GET(^BGPINDTC(BGPPC,19)),U)
IF '$GET(BGPNOSUM)
Begin DoDot:1
+36 SET ^TMP($JOB,"SUMMARY OTHER",$PIECE(^BGPSCAT($PIECE(^BGPINDTC(BGPPC,19),U,5),0),U,3),$PIECE(^BGPINDTC(BGPPC,19),U,6),BGPPC)=BGPCYP_U_BGPPRP_U_BGPBLP
+37 IF $GET(BGPAREAA)
Begin DoDot:2
+38 SET X=0
FOR
SET X=$ORDER(BGPSDPO(X))
IF X'=+X
QUIT
Begin DoDot:3
+39 SET ^TMP($JOB,"SUMMARY DETAIL PAGE OTHER",$PIECE(^BGPSCAT($PIECE(^BGPINDTC(BGPPC,19),U,5),0),U,3),$PIECE(^BGPINDTC(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
+40 IF $PIECE($GET(^BGPINDTC(BGPPC,19)),U)
IF '$GET(BGPNOSUM)
Begin DoDot:1
+41 SET ^TMP($JOB,"SUMMARYDEL OTHER",$PIECE(^BGPSCAT($PIECE(^BGPINDTC(BGPPC,19),U,5),0),U,3),$PIECE(^BGPINDTC(BGPPC,19),U,6),BGPPC)=$$SB($JUSTIFY(BGPCYP,5,1))_U_$$SB($JUSTIFY(BGPPRP,5,1))_U_$$SB($JUSTIFY(BGPBLP,5,1))
+42 IF $GET(BGPAREAA)
Begin DoDot:2
+43 SET X=0
FOR
SET X=$ORDER(BGPSDPO(X))
IF X'=+X
QUIT
Begin DoDot:3
+44 SET A=$PIECE(^BGPSCAT($PIECE(^BGPINDTC(BGPPC,19),U,5),0),U,3)
+45 SET B=$PIECE(^BGPINDTC(BGPPC,19),U,6)
+46 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
+47 IF $GET(BGPIIDEL)
IF BGPROT="B"
QUIT
GPRANT1 ;
+1 IF $GET(BGPAREAA)
IF $GET(BGPEXCEL)
Begin DoDot:1
+2 IF $PIECE(^BGPINDTC(BGPPC,0),U,14)=""
QUIT
+3 NEW X
SET X=0
FOR
SET X=$ORDER(BGPSUL(X))
IF X'=+X
QUIT
Begin DoDot:2
+4 SET $PIECE(BGPEXCT(X,1),U,1)=$PIECE($GET(^BGPGPDCT(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:"")
+5 SET $PIECE(BGPEXCT(X,2),U,1)=$PIECE($GET(^BGPGPDPT(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:"")
+6 SET $PIECE(BGPEXCT(X,3),U,1)=$PIECE($GET(^BGPGPDBT(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
+7 SET X=0
FOR
SET X=$ORDER(BGPEXCT(X))
IF X'=+X
QUIT
Begin DoDot:2
+8 SET A=$PIECE(BGPEXCT(X,1),U,1)
SET B=$PIECE(BGPEXCT(X,1),U,2)
SET C=$PIECE(BGPEXCT(X,1),U,3)
+9 SET D=$PIECE(BGPEXCT(X,2),U,1)
SET E=$PIECE(BGPEXCT(X,2),U,2)
SET F=$PIECE(BGPEXCT(X,2),U,3)
+10 SET G=$PIECE(BGPEXCT(X,3),U,1)
SET H=$PIECE(BGPEXCT(X,3),U,2)
SET I=$PIECE(BGPEXCT(X,3),U,3)
+11 IF $PIECE($PIECE(^BGPINDTC(BGPPC,0),U,4),".")="023"
SET Y=$PIECE(^BGPINDTC(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
+12 IF $PIECE($PIECE(^BGPINDTC(BGPPC,0),U,4),".",1,2)="014.A"
SET Y=$PIECE(^BGPINDTC(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(^BGPINDTC(BGPPC,0),U,4)="016.A.1"
SET Y=$PIECE(^BGPINDTC(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($GET(^BGPINDTC(BGPPC,19)),U,13)
SET Y=$PIECE(^BGPINDTC(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 SET Y=$PIECE(^BGPINDTC(BGPPC,0),U,14)
+16 SET $PIECE(BGPEI(X),U,$PIECE(^BGPINDTC(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)
+17 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(^BGPINDTC(BGPPC,12)),U,13)=""
QUIT
+3 NEW X
SET X=0
FOR
SET X=$ORDER(BGPSUL(X))
IF X'=+X
QUIT
Begin DoDot:2
+4 SET $PIECE(BGPEXCT(X,1),U,1)=$PIECE($GET(^BGPGPDCT(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:"")
+5 SET $PIECE(BGPEXCT(X,2),U,1)=$PIECE($GET(^BGPGPDPT(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:"")
+6 SET $PIECE(BGPEXCT(X,3),U,1)=$PIECE($GET(^BGPGPDBT(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
+7 SET X=0
FOR
SET X=$ORDER(BGPEXCT(X))
IF X'=+X
QUIT
Begin DoDot:2
+8 SET A=$PIECE(BGPEXCT(X,1),U,1)
SET B=$PIECE(BGPEXCT(X,1),U,2)
SET C=$PIECE(BGPEXCT(X,1),U,3)
+9 SET D=$PIECE(BGPEXCT(X,2),U,1)
SET E=$PIECE(BGPEXCT(X,2),U,2)
SET F=$PIECE(BGPEXCT(X,2),U,3)
+10 SET G=$PIECE(BGPEXCT(X,3),U,1)
SET H=$PIECE(BGPEXCT(X,3),U,2)
SET I=$PIECE(BGPEXCT(X,3),U,3)
+11 IF $PIECE($PIECE(^BGPINDTC(BGPPC,0),U,4),".")="023"
SET Y=$PIECE(^BGPINDTC(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
+12 IF $PIECE($PIECE(^BGPINDTC(BGPPC,0),U,4),".",1,2)="014.A"
SET Y=$PIECE(^BGPINDTC(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(^BGPINDTC(BGPPC,0),U,4)="016.A.1"
SET Y=$PIECE(^BGPINDTC(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($GET(^BGPINDTC(BGPPC,19)),U,13)
SET Y=$PIECE(^BGPINDTC(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 SET Y=$PIECE(^BGPINDTC(BGPPC,12),U,13)
+16 SET $PIECE(BGPEI2(X),U,$PIECE(^BGPINDTC(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)
+17 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
+18 IF $GET(BGPAREAA)
IF $GET(BGPEXCEL)
DO DEVEL1^BGP0DP1D
ONN1 ;
+1 DO ONM1^BGP0DP1D
+2 QUIT
SL(V) ;
+1 IF V=""
SET V=0
+2 QUIT $$STRIP^XLFSTR($JUSTIFY(V,5,1)," ")
SETEXA(T,N,P) ;EP
+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(^BGPGPDCT(X,N)),U,P)
+5 IF T=2
SET $PIECE(BGPEXCT(X,T),U,2)=$PIECE($GET(^BGPGPDPT(X,N)),U,P)
+6 IF T=3
SET $PIECE(BGPEXCT(X,T),U,2)=$PIECE($GET(^BGPGPDBT(X,N)),U,P)
End DoDot:1
+7 QUIT
V(T,R,N,P,ND) ;EP
+1 IF $GET(BGPAREAA)
GOTO VA
+2 NEW X
+3 IF T=1
SET X=$PIECE($GET(^BGPGPDCT(R,N)),U,P)
QUIT $SELECT(X]"":X,1:0)
+4 IF T=2
SET X=$PIECE($GET(^BGPGPDPT(R,N)),U,P)
QUIT $SELECT(X]"":X,1:0)
+5 IF T=3
SET X=$PIECE($GET(^BGPGPDBT(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(^BGPGPDCT(X,N)),U,P)
+3 IF T=2
SET C=C+$PIECE($GET(^BGPGPDPT(X,N)),U,P)
+4 IF T=3
SET C=C+$PIECE($GET(^BGPGPDBT(X,N)),U,P)
+5 IF $GET(BGPAREAA)
IF $PIECE($GET(^BGPINDTC(BGPPC,14)),U)
Begin DoDot:2
+6 IF T=1
SET $PIECE(BGPSDP(X,T),U,ND)=$PIECE($GET(^BGPGPDCT(X,N)),U,P)
+7 IF T=2
SET $PIECE(BGPSDP(X,T),U,ND)=$PIECE($GET(^BGPGPDPT(X,N)),U,P)
+8 IF T=3
SET $PIECE(BGPSDP(X,T),U,ND)=$PIECE($GET(^BGPGPDBT(X,N)),U,P)
End DoDot:2
+9 IF $GET(BGPAREAA)
IF $PIECE($GET(^BGPINDTC(BGPPC,15)),U)
Begin DoDot:2
+10 IF T=1
SET $PIECE(BGPSDPN(X,T),U,ND)=$PIECE($GET(^BGPGPDCT(X,N)),U,P)
+11 IF T=2
SET $PIECE(BGPSDPN(X,T),U,ND)=$PIECE($GET(^BGPGPDPT(X,N)),U,P)
+12 IF T=3
SET $PIECE(BGPSDPN(X,T),U,ND)=$PIECE($GET(^BGPGPDBT(X,N)),U,P)
End DoDot:2
+13 IF $GET(BGPAREAA)
IF $PIECE($GET(^BGPINDTC(BGPPC,19)),U)
Begin DoDot:2
+14 IF T=1
SET $PIECE(BGPSDPO(X,T),U,ND)=$PIECE($GET(^BGPGPDCT(X,N)),U,P)
+15 IF T=2
SET $PIECE(BGPSDPO(X,T),U,ND)=$PIECE($GET(^BGPGPDPT(X,N)),U,P)
+16 IF T=3
SET $PIECE(BGPSDPO(X,T),U,ND)=$PIECE($GET(^BGPGPDBT(X,N)),U,P)
End DoDot:2
+17 IF $GET(BGPAREAA)
IF $PIECE($GET(^BGPINDTC(BGPPC,22)),U)
Begin DoDot:2
+18 IF T=1
SET $PIECE(BGPSDPD(X,T),U,ND)=$PIECE($GET(^BGPGPDCT(X,N)),U,P)
+19 IF T=2
SET $PIECE(BGPSDPD(X,T),U,ND)=$PIECE($GET(^BGPGPDPT(X,N)),U,P)
+20 IF T=3
SET $PIECE(BGPSDPD(X,T),U,ND)=$PIECE($GET(^BGPGPDBT(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 ;
+1 NEW X,Y,T,D,N
+2 SET X=0
FOR
SET X=$ORDER(BGPSDP(X))
IF X'=+X
QUIT
Begin DoDot:1
+3 SET T=0
FOR
SET T=$ORDER(BGPSDP(X,T))
IF T'=+T
QUIT
Begin DoDot:2
+4 SET D=$PIECE(BGPSDP(X,T),U,1)
SET N=$PIECE(BGPSDP(X,T),U,2)
+5 SET $PIECE(BGPSDP(X,T),U,3)=$SELECT(D:((N/D)*100),1:"")
End DoDot:2
End DoDot:1
+6 SET X=0
FOR
SET X=$ORDER(BGPSDPN(X))
IF X'=+X
QUIT
Begin DoDot:1
+7 SET T=0
FOR
SET T=$ORDER(BGPSDPN(X,T))
IF T'=+T
QUIT
Begin DoDot:2
+8 SET D=$PIECE(BGPSDPN(X,T),U,1)
SET N=$PIECE(BGPSDPN(X,T),U,2)
+9 SET $PIECE(BGPSDPN(X,T),U,3)=$SELECT(D:((N/D)*100),1:"")
End DoDot:2
End DoDot:1
+10 SET X=0
FOR
SET X=$ORDER(BGPSDPO(X))
IF X'=+X
QUIT
Begin DoDot:1
+11 SET T=0
FOR
SET T=$ORDER(BGPSDPO(X,T))
IF T'=+T
QUIT
Begin DoDot:2
+12 SET D=$PIECE(BGPSDPO(X,T),U,1)
SET N=$PIECE(BGPSDPO(X,T),U,2)
+13 SET $PIECE(BGPSDPO(X,T),U,3)=$SELECT(D:((N/D)*100),1:"")
End DoDot:2
End DoDot:1
+14 SET X=0
FOR
SET X=$ORDER(BGPSDPD(X))
IF X'=+X
QUIT
Begin DoDot:1
+15 SET T=0
FOR
SET T=$ORDER(BGPSDPD(X,T))
IF T'=+T
QUIT
Begin DoDot:2
+16 SET D=$PIECE(BGPSDPD(X,T),U,1)
SET N=$PIECE(BGPSDPD(X,T),U,2)
+17 SET $PIECE(BGPSDPD(X,T),U,3)=$SELECT(D:((N/D)*100),1:"")
End DoDot:2
End DoDot:1
+18 QUIT
SB(X) ;EP
+1 NEW %
+2 XECUTE ^DD("FUNC",$ORDER(^DD("FUNC","B","STRIPBLANKS",0)),1)
+3 QUIT X
