BGP8DP1C ; IHS/CMI/LAB - print ind 1 21 Mar 2010 12:55 PM ;
;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
;
;
PI ;EP
S BGPDENP=0
S BGPPC2=0 F S BGPPC2=$O(^BGPINDRC("ABC",BGPPC1,BGPPC2)) Q:BGPPC2="" S BGPPC=$O(^BGPINDRC("ABC",BGPPC1,BGPPC2,0)) D PI1
Q
PI1 ;EP
K BGPEXCT,BGPSDP,BGPSDPN,BGPSDPO,BGPSDPD
Q:'$$CHECK^BGP8DP1E(BGPPC)
I $P(^BGPINDRC(BGPPC,0),U,4)="E-2.B.3" D:BGPPTYPE="D" W^BGP8DP("",0,1,BGPPTYPE) D PI1^BGP8DP2 Q
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 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)
I BGPRTYPE=1,$P(^BGPINDRC(BGPPC,0),U,4)="MS.A.9" S BGPDENP=0
I BGPRTYPE=1,$P(^BGPINDRC(BGPPC,0),U,4)="DM.2.1" S BGPDENP=0
I BGPRTYPE=1,$P(^BGPINDRC(BGPPC,0),U,4)="031-A.A.2" S BGPDENP=0
I BGPRTYPE=1,$P(^BGPINDRC(BGPPC,0),U,4)="E-2.B.8" S BGPDENP=0
I BGPRTYPE=7,$P(^BGPINDRC(BGPPC,0),U,4)="028.C.4" S BGPDENP=0
I BGPRTYPE=1,$P(^BGPINDRC(BGPPC,0),U,4)="E-2.A.1" S BGPDENP=0
I BGPRTYPE=9,$P(^BGPINDRC(BGPPC,0),U,4)="027.C.36" S BGPDENP=0
I BGPRTYPE=1,$P(^BGPINDRC(BGPPC,0),U,4)="026.C.5" S BGPDENP=0
I 'BGPDENP D
.I $P($G(^BGPINDRC(BGPPC,12)),U,14) Q
.I $P(^BGPINDRC(BGPPC,0),U,11),BGPRTYPE=1 I '$G(BGPSUMON) D HEADER^BGP8DPH Q:BGPQUIT D W^BGP8DP(^BGPINDR(BGPIC,53,1,0),0,2,BGPPTYPE) D:$D(^BGPINDR(BGPIC,53,2,0)) W^BGP8DP(^BGPINDR(BGPIC,53,2,0),0,1,BGPPTYPE) D H1^BGP8DPH
.I $P(^BGPINDRC(BGPPC,0),U,24),BGPRTYPE=4 I '$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
.I $P($G(^BGPINDRC(BGPPC,12)),U,15),BGPRTYPE=7 I '$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
.I $Y>(BGPIOSL-10),'$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
.I $G(BGPSEAT) W !!,$P(^DIBT(BGPSEAT,0),U)," Population"
.I '$G(BGPSUMON) D
..S X=$$LABEL^BGP8UTL1(BGPPC,BGPRTYPE,BGPPTYPE,$G(BGPINDG),"D")
..W:$G(BGPSEAT) ! W:'$G(BGPSEAT) !! W $P(X,U,1)
..F I=2:1 S Y=$P(X,U,I) Q:Y="" W !," ",Y
N1 .W:'$G(BGPSUMON) ?20,$$C(BGPCYD,0,8),?35,$$C(BGPPRD,0,8),?58,$$C(BGPBLD,0,8),!
.S BGPDENP=1
I $E($P(^BGPINDRC(BGPPC,0),U,4),1,2)="I." D
.S BGPDF=$P(^BGPINDRC(BGPPC,0),U,8)
.;get denom
.S BGPNP=$P(^DD(90560.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(^BGPINDRC(BGPPC,0),U,9)
S BGPNP=$P(^DD(90560.03,BGPNF,0),U,4),N=$P(BGPNP,";"),P=$P(BGPNP,";",2)
D SETN
I $P(^BGPINDRC(BGPPC,0),U,22) W:'$G(BGPSUMON) !
I $P($G(^BGPINDRC(BGPPC,12)),U,8),BGPRTYPE=4 I '$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
I $P($G(^BGPINDRC(BGPPC,21)),U,5),BGPRTYPE=1 I '$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
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
N D H2^BGP8DPH
Q
C18 ;
W:'$G(BGPSUMON) !,$P(^BGPINDRC(BGPPC,0),U,18)
Q
C21 ;
W:'$G(BGPSUMON) !,$P(^BGPINDRC(BGPPC,0),U,21)
Q
I1AGE ;EP
D I1AGE^BGP8DP11
Q
SETN ;EP
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:"")
SETN1 ;EP
NEW X
I $G(BGPAREAA) D SDP
I $P($G(^BGPINDRC(BGPPC,14)),U),'$G(BGPNOSUM) D
.S ^TMP($J,"SUMMARY",$P(^BGPSCAT($P(^BGPINDRC(BGPPC,14),U,5),0),U,2),$P(^BGPINDRC(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(^BGPINDRC(BGPPC,14),U,5),0),U,2),$P(^BGPINDRC(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(^BGPINDRC(BGPPC,14),U,5),0),U,2),$P(^BGPINDRC(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(^BGPINDRC(BGPPC,14),U,5),0),U,2)
...S B=$P(^BGPINDRC(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
I $P($G(^BGPINDRC(BGPPC,15)),U),'$G(BGPNOSUM) D
.S ^TMP($J,"SUMMARY NON",$P(^BGPSCAT($P(^BGPINDRC(BGPPC,15),U,5),0),U,2),$P(^BGPINDRC(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(^BGPINDRC(BGPPC,15),U,5),0),U,2),$P(^BGPINDRC(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(^BGPINDRC(BGPPC,15)),U),'$G(BGPNOSUM) D
.S ^TMP($J,"SUMMARYDEL NON",$P(^BGPSCAT($P(^BGPINDRC(BGPPC,15),U,5),0),U,2),$P(^BGPINDRC(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(^BGPINDRC(BGPPC,15),U,5),0),U,2)
...S B=$P(^BGPINDRC(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^BGP8DP1E
;OTHER
I $P($G(^BGPINDRC(BGPPC,19)),U),'$G(BGPNOSUM) D
.S ^TMP($J,"SUMMARY OTHER",$P(^BGPSCAT($P(^BGPINDRC(BGPPC,19),U,5),0),U,3),$P(^BGPINDRC(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(^BGPINDRC(BGPPC,19),U,5),0),U,3),$P(^BGPINDRC(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(^BGPINDRC(BGPPC,19)),U),'$G(BGPNOSUM) D
.S ^TMP($J,"SUMMARYDEL OTHER",$P(^BGPSCAT($P(^BGPINDRC(BGPPC,19),U,5),0),U,3),$P(^BGPINDRC(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(^BGPINDRC(BGPPC,19),U,5),0),U,3)
...S B=$P(^BGPINDRC(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 ;EP
NEW A,B,C,D,E,F,G,H,I,X,Y
I $G(BGPAREAA),$G(BGPEXCEL) D
.Q:$P(^BGPINDRC(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(^BGPGPDCR(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(^BGPGPDPR(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(^BGPGPDBR(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(^BGPINDRC(BGPPC,0),U,4),".")="023" S Y=$P(^BGPINDRC(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(^BGPINDRC(BGPPC,0),U,4),".",1,2)="014.A" S Y=$P(^BGPINDRC(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(^BGPINDRC(BGPPC,0),U,4)="016.A.1" S Y=$P(^BGPINDRC(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(^BGPINDRC(BGPPC,19)),U,13) S Y=$P(^BGPINDRC(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(^BGPINDRC(BGPPC,0),U,14)
..S $P(BGPEI(X),U,$P(^BGPINDRC(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(^BGPINDRC(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(^BGPGPDCR(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(^BGPGPDPR(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(^BGPGPDBR(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(^BGPINDRC(BGPPC,0),U,4),".")="023" S Y=$P(^BGPINDRC(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(^BGPINDRC(BGPPC,0),U,4),".",1,2)="014.A" S Y=$P(^BGPINDRC(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(^BGPINDRC(BGPPC,0),U,4)="016.A.1" S Y=$P(^BGPINDRC(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(^BGPINDRC(BGPPC,19)),U,13) S Y=$P(^BGPINDRC(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(^BGPINDRC(BGPPC,12),U,13)
..S $P(BGPEI2(X),U,$P(^BGPINDRC(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^BGP8DP1D
ONN1 ;
D ONM1^BGP8DP1D
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(^BGPGPDCR(X,N)),U,P)
.I T=2 S $P(BGPEXCT(X,T),U,2)=$P($G(^BGPGPDPR(X,N)),U,P)
.I T=3 S $P(BGPEXCT(X,T),U,2)=$P($G(^BGPGPDBR(X,N)),U,P)
Q
V(T,R,N,P,ND,DASH) ;EP
I $G(BGPAREAA) G VA
NEW X
I T=1 S X=$P($G(^BGPGPDCR(R,N)),U,P) Q $S(X]"":X,1:0)
I T=2 S X=$P($G(^BGPGPDPR(R,N)),U,P) Q $S(X]"":X,1:0)
I T=3 S X=$P($G(^BGPGPDBR(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(^BGPGPDCR(X,N)),U,P)
.I T=2 S C=C+$P($G(^BGPGPDPR(X,N)),U,P)
.I T=3 S C=C+$P($G(^BGPGPDBR(X,N)),U,P)
.Q:$G(DASH)
.I $G(BGPAREAA),$P($G(^BGPINDRC(BGPPC,14)),U) D
..I T=1 S $P(BGPSDP(X,T),U,ND)=$P($G(^BGPGPDCR(X,N)),U,P)
..I T=2 S $P(BGPSDP(X,T),U,ND)=$P($G(^BGPGPDPR(X,N)),U,P)
..I T=3 S $P(BGPSDP(X,T),U,ND)=$P($G(^BGPGPDBR(X,N)),U,P)
.I $G(BGPAREAA),$P($G(^BGPINDRC(BGPPC,15)),U) D
..I T=1 S $P(BGPSDPN(X,T),U,ND)=$P($G(^BGPGPDCR(X,N)),U,P)
..I T=2 S $P(BGPSDPN(X,T),U,ND)=$P($G(^BGPGPDPR(X,N)),U,P)
..I T=3 S $P(BGPSDPN(X,T),U,ND)=$P($G(^BGPGPDBR(X,N)),U,P)
.I $G(BGPAREAA),$P($G(^BGPINDRC(BGPPC,19)),U) D
..I T=1 S $P(BGPSDPO(X,T),U,ND)=$P($G(^BGPGPDCR(X,N)),U,P)
..I T=2 S $P(BGPSDPO(X,T),U,ND)=$P($G(^BGPGPDPR(X,N)),U,P)
..I T=3 S $P(BGPSDPO(X,T),U,ND)=$P($G(^BGPGPDBR(X,N)),U,P)
.I $G(BGPAREAA),$P($G(^BGPINDRC(BGPPC,22)),U) D
..I T=1 S $P(BGPSDPD(X,T),U,ND)=$P($G(^BGPGPDCR(X,N)),U,P)
..I T=2 S $P(BGPSDPD(X,T),U,ND)=$P($G(^BGPGPDPR(X,N)),U,P)
..I T=3 S $P(BGPSDPD(X,T),U,ND)=$P($G(^BGPGPDBR(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
BGP8DP1C ; IHS/CMI/LAB - print ind 1 21 Mar 2010 12:55 PM ;
+1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
+2 ;
+3 ;
PI ;EP
+1 SET BGPDENP=0
+2 SET BGPPC2=0
FOR
SET BGPPC2=$ORDER(^BGPINDRC("ABC",BGPPC1,BGPPC2))
IF BGPPC2=""
QUIT
SET BGPPC=$ORDER(^BGPINDRC("ABC",BGPPC1,BGPPC2,0))
DO PI1
+3 QUIT
PI1 ;EP
+1 KILL BGPEXCT,BGPSDP,BGPSDPN,BGPSDPO,BGPSDPD
+2 IF '$$CHECK^BGP8DP1E(BGPPC)
QUIT
+3 IF $PIECE(^BGPINDRC(BGPPC,0),U,4)="E-2.B.3"
IF BGPPTYPE="D"
DO W^BGP8DP("",0,1,BGPPTYPE)
DO PI1^BGP8DP2
QUIT
+4 SET BGPDF=$PIECE(^BGPINDRC(BGPPC,0),U,8)
+5 SET BGPNP=$PIECE(^DD(90560.03,BGPDF,0),U,4)
SET N=$PIECE(BGPNP,";")
SET P=$PIECE(BGPNP,";",2)
+6 SET BGPCYD=$$V(1,BGPRPT,N,P,1)
IF $GET(BGPAREAA)
DO SETEXA(1,N,P)
+7 SET BGPPRD=$$V(2,BGPRPT,N,P,1)
IF $GET(BGPAREAA)
DO SETEXA(2,N,P)
+8 SET BGPBLD=$$V(3,BGPRPT,N,P,1)
IF $GET(BGPAREAA)
DO SETEXA(3,N,P)
+9 IF BGPRTYPE=1
IF $PIECE(^BGPINDRC(BGPPC,0),U,4)="MS.A.9"
SET BGPDENP=0
+10 IF BGPRTYPE=1
IF $PIECE(^BGPINDRC(BGPPC,0),U,4)="DM.2.1"
SET BGPDENP=0
+11 IF BGPRTYPE=1
IF $PIECE(^BGPINDRC(BGPPC,0),U,4)="031-A.A.2"
SET BGPDENP=0
+12 IF BGPRTYPE=1
IF $PIECE(^BGPINDRC(BGPPC,0),U,4)="E-2.B.8"
SET BGPDENP=0
+13 IF BGPRTYPE=7
IF $PIECE(^BGPINDRC(BGPPC,0),U,4)="028.C.4"
SET BGPDENP=0
+14 IF BGPRTYPE=1
IF $PIECE(^BGPINDRC(BGPPC,0),U,4)="E-2.A.1"
SET BGPDENP=0
+15 IF BGPRTYPE=9
IF $PIECE(^BGPINDRC(BGPPC,0),U,4)="027.C.36"
SET BGPDENP=0
+16 IF BGPRTYPE=1
IF $PIECE(^BGPINDRC(BGPPC,0),U,4)="026.C.5"
SET BGPDENP=0
+17 IF 'BGPDENP
Begin DoDot:1
+18 IF $PIECE($GET(^BGPINDRC(BGPPC,12)),U,14)
QUIT
+19 IF $PIECE(^BGPINDRC(BGPPC,0),U,11)
IF BGPRTYPE=1
IF '$GET(BGPSUMON)
DO HEADER^BGP8DPH
IF BGPQUIT
QUIT
DO W^BGP8DP(^BGPINDR(BGPIC,53,1,0),0,2,BGPPTYPE)
IF $DATA(^BGPINDR(BGPIC,53,2,0))
DO W^BGP8DP(^BGPINDR(BGPIC,53,2,0),0,1,BGPPTYPE)
DO H1^BGP8DPH
+20 IF $PIECE(^BGPINDRC(BGPPC,0),U,24)
IF BGPRTYPE=4
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^BGP8DPH
+21 IF $PIECE($GET(^BGPINDRC(BGPPC,12)),U,15)
IF BGPRTYPE=7
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^BGP8DPH
+22 IF $Y>(BGPIOSL-10)
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^BGP8DPH
+23 IF $GET(BGPSEAT)
WRITE !!,$PIECE(^DIBT(BGPSEAT,0),U)," Population"
+24 IF '$GET(BGPSUMON)
Begin DoDot:2
+25 SET X=$$LABEL^BGP8UTL1(BGPPC,BGPRTYPE,BGPPTYPE,$GET(BGPINDG),"D")
+26 IF $GET(BGPSEAT)
WRITE !
IF '$GET(BGPSEAT)
WRITE !!
WRITE $PIECE(X,U,1)
+27 FOR I=2:1
SET Y=$PIECE(X,U,I)
IF Y=""
QUIT
WRITE !," ",Y
End DoDot:2
N1 IF '$GET(BGPSUMON)
WRITE ?20,$$C(BGPCYD,0,8),?35,$$C(BGPPRD,0,8),?58,$$C(BGPBLD,0,8),!
+1 SET BGPDENP=1
End DoDot:1
+2 IF $EXTRACT($PIECE(^BGPINDRC(BGPPC,0),U,4),1,2)="I."
Begin DoDot:1
+3 SET BGPDF=$PIECE(^BGPINDRC(BGPPC,0),U,8)
+4 ;get denom
+5 SET BGPNP=$PIECE(^DD(90560.03,BGPDF,0),U,4)
SET N=$PIECE(BGPNP,";")
SET P=$PIECE(BGPNP,";",2)
+6 SET BGPCYD=$$V(1,BGPRPT,N,P,1)
IF $GET(BGPAREAA)
DO SETEXA(1,N,P)
+7 SET BGPPRD=$$V(2,BGPRPT,N,P,1)
IF $GET(BGPAREAA)
DO SETEXA(2,N,P)
+8 SET BGPBLD=$$V(3,BGPRPT,N,P,1)
IF $GET(BGPAREAA)
DO SETEXA(3,N,P)
End DoDot:1
+9 SET BGPNF=$PIECE(^BGPINDRC(BGPPC,0),U,9)
+10 SET BGPNP=$PIECE(^DD(90560.03,BGPNF,0),U,4)
SET N=$PIECE(BGPNP,";")
SET P=$PIECE(BGPNP,";",2)
+11 DO SETN
+12 IF $PIECE(^BGPINDRC(BGPPC,0),U,22)
IF '$GET(BGPSUMON)
WRITE !
+13 IF $PIECE($GET(^BGPINDRC(BGPPC,12)),U,8)
IF BGPRTYPE=4
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^BGP8DPH
+14 IF $PIECE($GET(^BGPINDRC(BGPPC,21)),U,5)
IF BGPRTYPE=1
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^BGP8DPH
+15 IF '$GET(BGPSUMON)
Begin DoDot:1
+16 SET X=$$LABEL^BGP8UTL1(BGPPC,BGPRTYPE,BGPPTYPE,$GET(BGPINDG),"N")
+17 WRITE !,$PIECE(X,U,1)
+18 FOR I=2:1
SET Y=$PIECE(X,U,I)
IF Y=""
QUIT
WRITE !," ",Y
End DoDot:1
N DO H2^BGP8DPH
+1 QUIT
C18 ;
+1 IF '$GET(BGPSUMON)
WRITE !,$PIECE(^BGPINDRC(BGPPC,0),U,18)
+2 QUIT
C21 ;
+1 IF '$GET(BGPSUMON)
WRITE !,$PIECE(^BGPINDRC(BGPPC,0),U,21)
+2 QUIT
I1AGE ;EP
+1 DO I1AGE^BGP8DP11
+2 QUIT
SETN ;EP
+1 SET BGPCYN=$$V^BGP8DP1C(1,BGPRPT,N,P,2)
+2 SET BGPPRN=$$V^BGP8DP1C(2,BGPRPT,N,P,2)
+3 SET BGPBLN=$$V^BGP8DP1C(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:"")
SETN1 ;EP
+1 NEW X
+2 IF $GET(BGPAREAA)
DO SDP
+3 IF $PIECE($GET(^BGPINDRC(BGPPC,14)),U)
IF '$GET(BGPNOSUM)
Begin DoDot:1
+4 SET ^TMP($JOB,"SUMMARY",$PIECE(^BGPSCAT($PIECE(^BGPINDRC(BGPPC,14),U,5),0),U,2),$PIECE(^BGPINDRC(BGPPC,14),U,6),BGPPC)=BGPCYP_U_BGPPRP_U_BGPBLP
+5 IF $GET(BGPAREAA)
Begin DoDot:2
+6 SET X=0
FOR
SET X=$ORDER(BGPSDP(X))
IF X'=+X
QUIT
Begin DoDot:3
+7 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,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
+8 SET ^TMP($JOB,"SUMMARYDEL",$PIECE(^BGPSCAT($PIECE(^BGPINDRC(BGPPC,14),U,5),0),U,2),$PIECE(^BGPINDRC(BGPPC,14),U,6),BGPPC)=$$SB($JUSTIFY(BGPCYP,5,1))_U_$$SB($JUSTIFY(BGPPRP,5,1))_U_$$SB($JUSTIFY(BGPBLP,5,1))
+9 IF $GET(BGPAREAA)
Begin DoDot:2
+10 SET X=0
FOR
SET X=$ORDER(BGPSDP(X))
IF X'=+X
QUIT
Begin DoDot:3
+11 SET A=$PIECE(^BGPSCAT($PIECE(^BGPINDRC(BGPPC,14),U,5),0),U,2)
+12 SET B=$PIECE(^BGPINDRC(BGPPC,14),U,6)
+13 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
+14 ;NON
+15 IF $PIECE($GET(^BGPINDRC(BGPPC,15)),U)
IF '$GET(BGPNOSUM)
Begin DoDot:1
+16 SET ^TMP($JOB,"SUMMARY NON",$PIECE(^BGPSCAT($PIECE(^BGPINDRC(BGPPC,15),U,5),0),U,2),$PIECE(^BGPINDRC(BGPPC,15),U,6),BGPPC)=BGPCYP_U_BGPPRP_U_BGPBLP
+17 IF $GET(BGPAREAA)
Begin DoDot:2
+18 SET X=0
FOR
SET X=$ORDER(BGPSDPN(X))
IF X'=+X
QUIT
Begin DoDot:3
+19 SET ^TMP($JOB,"SUMMARY DETAIL PAGE NON",$PIECE(^BGPSCAT($PIECE(^BGPINDRC(BGPPC,15),U,5),0),U,2),$PIECE(^BGPINDRC(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
+20 IF $PIECE($GET(^BGPINDRC(BGPPC,15)),U)
IF '$GET(BGPNOSUM)
Begin DoDot:1
+21 SET ^TMP($JOB,"SUMMARYDEL NON",$PIECE(^BGPSCAT($PIECE(^BGPINDRC(BGPPC,15),U,5),0),U,2),$PIECE(^BGPINDRC(BGPPC,15),U,6),BGPPC)=$$SB($JUSTIFY(BGPCYP,5,1))_U_$$SB($JUSTIFY(BGPPRP,5,1))_U_$$SB($JUSTIFY(BGPBLP,5,1))
+22 IF $GET(BGPAREAA)
Begin DoDot:2
+23 SET X=0
FOR
SET X=$ORDER(BGPSDPN(X))
IF X'=+X
QUIT
Begin DoDot:3
+24 SET A=$PIECE(^BGPSCAT($PIECE(^BGPINDRC(BGPPC,15),U,5),0),U,2)
+25 SET B=$PIECE(^BGPINDRC(BGPPC,15),U,6)
+26 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
+27 DO SETDEV^BGP8DP1E
+28 ;OTHER
+29 IF $PIECE($GET(^BGPINDRC(BGPPC,19)),U)
IF '$GET(BGPNOSUM)
Begin DoDot:1
+30 SET ^TMP($JOB,"SUMMARY OTHER",$PIECE(^BGPSCAT($PIECE(^BGPINDRC(BGPPC,19),U,5),0),U,3),$PIECE(^BGPINDRC(BGPPC,19),U,6),BGPPC)=BGPCYP_U_BGPPRP_U_BGPBLP
+31 IF $GET(BGPAREAA)
Begin DoDot:2
+32 SET X=0
FOR
SET X=$ORDER(BGPSDPO(X))
IF X'=+X
QUIT
Begin DoDot:3
+33 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,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
+34 IF $PIECE($GET(^BGPINDRC(BGPPC,19)),U)
IF '$GET(BGPNOSUM)
Begin DoDot:1
+35 SET ^TMP($JOB,"SUMMARYDEL OTHER",$PIECE(^BGPSCAT($PIECE(^BGPINDRC(BGPPC,19),U,5),0),U,3),$PIECE(^BGPINDRC(BGPPC,19),U,6),BGPPC)=$$SB($JUSTIFY(BGPCYP,5,1))_U_$$SB($JUSTIFY(BGPPRP,5,1))_U_$$SB($JUSTIFY(BGPBLP,5,1))
+36 IF $GET(BGPAREAA)
Begin DoDot:2
+37 SET X=0
FOR
SET X=$ORDER(BGPSDPO(X))
IF X'=+X
QUIT
Begin DoDot:3
+38 SET A=$PIECE(^BGPSCAT($PIECE(^BGPINDRC(BGPPC,19),U,5),0),U,3)
+39 SET B=$PIECE(^BGPINDRC(BGPPC,19),U,6)
+40 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
+41 IF $GET(BGPIIDEL)
IF BGPROT="B"
QUIT
GPRANT1 ;EP
+1 NEW A,B,C,D,E,F,G,H,I,X,Y
+2 IF $GET(BGPAREAA)
IF $GET(BGPEXCEL)
Begin DoDot:1
+3 IF $PIECE(^BGPINDRC(BGPPC,0),U,14)=""
QUIT
+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(^BGPGPDCR(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(^BGPGPDPR(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(^BGPGPDBR(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(^BGPINDRC(BGPPC,0),U,4),".")="023"
SET Y=$PIECE(^BGPINDRC(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(^BGPINDRC(BGPPC,0),U,4),".",1,2)="014.A"
SET Y=$PIECE(^BGPINDRC(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(^BGPINDRC(BGPPC,0),U,4)="016.A.1"
SET Y=$PIECE(^BGPINDRC(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(^BGPINDRC(BGPPC,19)),U,13)
SET Y=$PIECE(^BGPINDRC(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(^BGPINDRC(BGPPC,0),U,14)
+17 SET $PIECE(BGPEI(X),U,$PIECE(^BGPINDRC(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(^BGPINDRC(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(^BGPGPDCR(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(^BGPGPDPR(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(^BGPGPDBR(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(^BGPINDRC(BGPPC,0),U,4),".")="023"
SET Y=$PIECE(^BGPINDRC(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(^BGPINDRC(BGPPC,0),U,4),".",1,2)="014.A"
SET Y=$PIECE(^BGPINDRC(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(^BGPINDRC(BGPPC,0),U,4)="016.A.1"
SET Y=$PIECE(^BGPINDRC(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(^BGPINDRC(BGPPC,19)),U,13)
SET Y=$PIECE(^BGPINDRC(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(^BGPINDRC(BGPPC,12),U,13)
+16 SET $PIECE(BGPEI2(X),U,$PIECE(^BGPINDRC(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 GPRANT3^BGP8DP1D
ONN1 ;
+1 DO ONM1^BGP8DP1D
+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(^BGPGPDCR(X,N)),U,P)
+5 IF T=2
SET $PIECE(BGPEXCT(X,T),U,2)=$PIECE($GET(^BGPGPDPR(X,N)),U,P)
+6 IF T=3
SET $PIECE(BGPEXCT(X,T),U,2)=$PIECE($GET(^BGPGPDBR(X,N)),U,P)
End DoDot:1
+7 QUIT
V(T,R,N,P,ND,DASH) ;EP
+1 IF $GET(BGPAREAA)
GOTO VA
+2 NEW X
+3 IF T=1
SET X=$PIECE($GET(^BGPGPDCR(R,N)),U,P)
QUIT $SELECT(X]"":X,1:0)
+4 IF T=2
SET X=$PIECE($GET(^BGPGPDPR(R,N)),U,P)
QUIT $SELECT(X]"":X,1:0)
+5 IF T=3
SET X=$PIECE($GET(^BGPGPDBR(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(^BGPGPDCR(X,N)),U,P)
+3 IF T=2
SET C=C+$PIECE($GET(^BGPGPDPR(X,N)),U,P)
+4 IF T=3
SET C=C+$PIECE($GET(^BGPGPDBR(X,N)),U,P)
+5 IF $GET(DASH)
QUIT
+6 IF $GET(BGPAREAA)
IF $PIECE($GET(^BGPINDRC(BGPPC,14)),U)
Begin DoDot:2
+7 IF T=1
SET $PIECE(BGPSDP(X,T),U,ND)=$PIECE($GET(^BGPGPDCR(X,N)),U,P)
+8 IF T=2
SET $PIECE(BGPSDP(X,T),U,ND)=$PIECE($GET(^BGPGPDPR(X,N)),U,P)
+9 IF T=3
SET $PIECE(BGPSDP(X,T),U,ND)=$PIECE($GET(^BGPGPDBR(X,N)),U,P)
End DoDot:2
+10 IF $GET(BGPAREAA)
IF $PIECE($GET(^BGPINDRC(BGPPC,15)),U)
Begin DoDot:2
+11 IF T=1
SET $PIECE(BGPSDPN(X,T),U,ND)=$PIECE($GET(^BGPGPDCR(X,N)),U,P)
+12 IF T=2
SET $PIECE(BGPSDPN(X,T),U,ND)=$PIECE($GET(^BGPGPDPR(X,N)),U,P)
+13 IF T=3
SET $PIECE(BGPSDPN(X,T),U,ND)=$PIECE($GET(^BGPGPDBR(X,N)),U,P)
End DoDot:2
+14 IF $GET(BGPAREAA)
IF $PIECE($GET(^BGPINDRC(BGPPC,19)),U)
Begin DoDot:2
+15 IF T=1
SET $PIECE(BGPSDPO(X,T),U,ND)=$PIECE($GET(^BGPGPDCR(X,N)),U,P)
+16 IF T=2
SET $PIECE(BGPSDPO(X,T),U,ND)=$PIECE($GET(^BGPGPDPR(X,N)),U,P)
+17 IF T=3
SET $PIECE(BGPSDPO(X,T),U,ND)=$PIECE($GET(^BGPGPDBR(X,N)),U,P)
End DoDot:2
+18 IF $GET(BGPAREAA)
IF $PIECE($GET(^BGPINDRC(BGPPC,22)),U)
Begin DoDot:2
+19 IF T=1
SET $PIECE(BGPSDPD(X,T),U,ND)=$PIECE($GET(^BGPGPDCR(X,N)),U,P)
+20 IF T=2
SET $PIECE(BGPSDPD(X,T),U,ND)=$PIECE($GET(^BGPGPDPR(X,N)),U,P)
+21 IF T=3
SET $PIECE(BGPSDPD(X,T),U,ND)=$PIECE($GET(^BGPGPDBR(X,N)),U,P)
End DoDot:2
+22 QUIT
End DoDot:1
+23 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
