BGP3DP1D ; IHS/CMI/LAB - print ind 1 ;
;;13.0;IHS CLINICAL REPORTING;;NOV 20, 2012;Build 81
ONM1 ;EP
I $G(BGPAREAA),$G(BGPEXCEL) D
.Q:$P(^BGPINDHC(BGPPC,0),U,6)=""
.;set each numerator and percent,then set BGPONN1
.NEW X S X=0 F S X=$O(BGPSUL(X)) Q:X'=+X D
..S $P(BGPEXCT(X,1),U,1)=$P($G(^BGPGPDCH(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(^BGPGPDPH(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(^BGPGPDBH(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(^BGPINDHC(BGPPC,0),U,4),".")="023" S Y=$P(^BGPINDHC(BGPPC,0),U,6),$P(BGPONN1(X),U,Y)=$S(B:B,1:0),$P(BGPONN1(X),U,(Y+3))=$S(E:E,1:0),$P(BGPONN1(X),U,(Y+6))=$S(H:H,1:0) Q
..I $P($P(^BGPINDHC(BGPPC,0),U,4),".",1,2)="014.A" S Y=$P(^BGPINDHC(BGPPC,0),U,6),$P(BGPONN1(X),U,Y)=$S(B:B,1:0),$P(BGPONN1(X),U,(Y+3))=$S(E:E,1:0),$P(BGPONN1(X),U,(Y+6))=$S(H:H,1:0) Q
..I $P(^BGPINDHC(BGPPC,0),U,4)="016.A.1" S Y=$P(^BGPINDHC(BGPPC,0),U,6),$P(BGPONN1(X),U,Y)=$S(B:B,1:0),$P(BGPONN1(X),U,(Y+3))=$S(E:E,1:0),$P(BGPONN1(X),U,(Y+6))=$S(H:H,1:0) Q
..I $P($G(^BGPINDHC(BGPPC,19)),U,13) S Y=$P(^BGPINDHC(BGPPC,0),U,6),$P(BGPONN1(X),U,Y)=$S(B:B,1:0),$P(BGPONN1(X),U,(Y+3))=$S(E:E,1:0),$P(BGPONN1(X),U,(Y+6))=$S(H:H,1:0) Q
..S Y=$P(^BGPINDHC(BGPPC,0),U,6)
..S $P(BGPONN1(X),U,$P(^BGPINDHC(BGPPC,0),U,6))=$S(A:A,1:0),$P(BGPONN1(X),U,(Y+1))=$S(B:B,1:0),$P(BGPONN1(X),U,(Y+2))=$$SL(C)
..S $P(BGPONN1(X),U,(Y+3))=$S(D:D,1:0),$P(BGPONN1(X),U,(Y+4))=$S(E:E,1:0),$P(BGPONN1(X),U,(Y+5))=$$SL(F),$P(BGPONN1(X),U,(Y+6))=$S(G:G,1:0),$P(BGPONN1(X),U,(Y+7))=$S(H:H,1:0),$P(BGPONN1(X),U,(Y+8))=$$SL(I)
ONN2 ;
I $G(BGPAREAA),$G(BGPEXCEL) D
.Q:$P(^BGPINDHC(BGPPC,0),U,7)=""
.;set each numerator and percent,then set BGPONN2
.NEW X S X=0 F S X=$O(BGPSUL(X)) Q:X'=+X D
..S $P(BGPEXCT(X,1),U,1)=$P($G(^BGPGPDCH(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(^BGPGPDPH(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(^BGPGPDBH(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(^BGPINDHC(BGPPC,0),U,4),".")="023" S Y=$P(^BGPINDHC(BGPPC,0),U,7),$P(BGPONN2(X),U,Y)=$S(B:B,1:0),$P(BGPONN2(X),U,(Y+3))=$S(E:E,1:0),$P(BGPONN2(X),U,(Y+6))=$S(H:H,1:0) Q
..I $P($P(^BGPINDHC(BGPPC,0),U,4),".",1,2)="014.A" S Y=$P(^BGPINDHC(BGPPC,0),U,7),$P(BGPONN2(X),U,Y)=$S(B:B,1:0),$P(BGPONN2(X),U,(Y+3))=$S(E:E,1:0),$P(BGPONN2(X),U,(Y+6))=$S(H:H,1:0) Q
..I $P(^BGPINDHC(BGPPC,0),U,4)="016.A.1" S Y=$P(^BGPINDHC(BGPPC,0),U,7),$P(BGPONN2(X),U,Y)=$S(B:B,1:0),$P(BGPONN2(X),U,(Y+3))=$S(E:E,1:0),$P(BGPONN2(X),U,(Y+6))=$S(H:H,1:0) Q
..I $P(^BGPINDHC(BGPPC,0),U,4)="STI.AA.1A" S Y=$P(^BGPINDHC(BGPPC,0),U,7),$P(BGPONN2(X),U,Y)=$S(B:B,1:0),$P(BGPONN2(X),U,(Y+3))=$S(E:E,1:0),$P(BGPONN2(X),U,(Y+6))=$S(H:H,1:0) Q
..I $P(^BGPINDHC(BGPPC,0),U,4)="STI.AB.4A" S Y=$P(^BGPINDHC(BGPPC,0),U,7),$P(BGPONN2(X),U,Y)=$S(B:B,1:0),$P(BGPONN2(X),U,(Y+3))=$S(E:E,1:0),$P(BGPONN2(X),U,(Y+6))=$S(H:H,1:0) Q
..I $P($G(^BGPINDHC(BGPPC,19)),U,13) S Y=$P(^BGPINDHC(BGPPC,0),U,7),$P(BGPONN2(X),U,Y)=$S(B:B,1:0),$P(BGPONN2(X),U,(Y+3))=$S(E:E,1:0),$P(BGPONN2(X),U,(Y+6))=$S(H:H,1:0) Q
..S Y=$P(^BGPINDHC(BGPPC,0),U,7)
..S $P(BGPONN2(X),U,$P(^BGPINDHC(BGPPC,0),U,7))=$S(A:A,1:0),$P(BGPONN2(X),U,(Y+1))=$S(B:B,1:0),$P(BGPONN2(X),U,(Y+2))=$$SL(C)
..S $P(BGPONN2(X),U,(Y+3))=$S(D:D,1:0),$P(BGPONN2(X),U,(Y+4))=$S(E:E,1:0),$P(BGPONN2(X),U,(Y+5))=$$SL(F),$P(BGPONN2(X),U,(Y+6))=$S(G:G,1:0),$P(BGPONN2(X),U,(Y+7))=$S(H:H,1:0),$P(BGPONN2(X),U,(Y+8))=$$SL(I)
ONN3 ;
I $G(BGPAREAA),$G(BGPEXCEL) D
.Q:$P($G(^BGPINDHC(BGPPC,21)),U,7)=""
.;set each numerator and percent,then set BGPONN3
.NEW X S X=0 F S X=$O(BGPSUL(X)) Q:X'=+X D
..S $P(BGPEXCT(X,1),U,1)=$P($G(^BGPGPDCH(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(^BGPGPDPH(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(^BGPGPDBH(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(^BGPINDHC(BGPPC,0),U,4),".")="023" S Y=$P(^BGPINDHC(BGPPC,21),U,7),$P(BGPONN3(X),U,Y)=$S(B:B,1:0),$P(BGPONN3(X),U,(Y+3))=$S(E:E,1:0),$P(BGPONN3(X),U,(Y+6))=$S(H:H,1:0) Q
..I $P($P(^BGPINDHC(BGPPC,0),U,4),".",1,2)="014.A" S Y=$P(^BGPINDHC(BGPPC,21),U,7),$P(BGPONN3(X),U,Y)=$S(B:B,1:0),$P(BGPONN3(X),U,(Y+3))=$S(E:E,1:0),$P(BGPONN3(X),U,(Y+6))=$S(H:H,1:0) Q
..I $P(^BGPINDHC(BGPPC,0),U,4)="016.A.1" S Y=$P(^BGPINDHC(BGPPC,21),U,7),$P(BGPONN3(X),U,Y)=$S(B:B,1:0),$P(BGPONN3(X),U,(Y+3))=$S(E:E,1:0),$P(BGPONN3(X),U,(Y+6))=$S(H:H,1:0) Q
..I $P(^BGPINDHC(BGPPC,0),U,4)="STI.AA.1A" S Y=$P(^BGPINDHC(BGPPC,21),U,7),$P(BGPONN3(X),U,Y)=$S(B:B,1:0),$P(BGPONN3(X),U,(Y+3))=$S(E:E,1:0),$P(BGPONN3(X),U,(Y+6))=$S(H:H,1:0) Q
..I $P(^BGPINDHC(BGPPC,0),U,4)="STI.AB.4A" S Y=$P(^BGPINDHC(BGPPC,21),U,7),$P(BGPONN3(X),U,Y)=$S(B:B,1:0),$P(BGPONN3(X),U,(Y+3))=$S(E:E,1:0),$P(BGPONN3(X),U,(Y+6))=$S(H:H,1:0) Q
..I $P($G(^BGPINDHC(BGPPC,19)),U,13) S Y=$P(^BGPINDHC(BGPPC,21),U,7),$P(BGPONN3(X),U,Y)=$S(B:B,1:0),$P(BGPONN3(X),U,(Y+3))=$S(E:E,1:0),$P(BGPONN3(X),U,(Y+6))=$S(H:H,1:0) Q
..S Y=$P(^BGPINDHC(BGPPC,21),U,7)
..S $P(BGPONN3(X),U,$P(^BGPINDHC(BGPPC,21),U,7))=$S(A:A,1:0),$P(BGPONN3(X),U,(Y+1))=$S(B:B,1:0),$P(BGPONN3(X),U,(Y+2))=$$SL(C)
..S $P(BGPONN3(X),U,(Y+3))=$S(D:D,1:0),$P(BGPONN3(X),U,(Y+4))=$S(E:E,1:0),$P(BGPONN3(X),U,(Y+5))=$$SL(F),$P(BGPONN3(X),U,(Y+6))=$S(G:G,1:0),$P(BGPONN3(X),U,(Y+7))=$S(H:H,1:0),$P(BGPONN3(X),U,(Y+8))=$$SL(I)
D ONN4^BGP3DP1F
Q
SL(V) ;
I V="" S V=0
Q $$STRIP^XLFSTR($J(V,5,1)," ")
;
GPRANT3 ;EP
I $G(BGPAREAA),$G(BGPEXCEL) D
.Q:$P($G(^BGPINDHC(BGPPC,11)),U,3)=""
.;set each numerator and percent,then set BGPEI3
.NEW X S X=0 F S X=$O(BGPSUL(X)) Q:X'=+X D
..S $P(BGPEXCT(X,1),U,1)=$P($G(^BGPGPDCH(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(^BGPGPDPH(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(^BGPGPDBH(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(^BGPINDHC(BGPPC,0),U,4),".")="023" S Y=$P(^BGPINDHC(BGPPC,11),U,3),$P(BGPEI3(X),U,Y)=$S(B:B,1:0),$P(BGPEI3(X),U,(Y+3))=$S(E:E,1:0),$P(BGPEI3(X),U,(Y+6))=$S(H:H,1:0) Q
..I $P($P(^BGPINDHC(BGPPC,0),U,4),".")="014" S Y=$P(^BGPINDHC(BGPPC,11),U,3),$P(BGPEI3(X),U,Y)=$S(B:B,1:0),$P(BGPEI3(X),U,(Y+3))=$S(E:E,1:0),$P(BGPEI3(X),U,(Y+6))=$S(H:H,1:0) Q
..I $P($P(^BGPINDHC(BGPPC,0),U,4),".")="016" S Y=$P(^BGPINDHC(BGPPC,11),U,3),$P(BGPEI3(X),U,Y)=$S(B:B,1:0),$P(BGPEI3(X),U,(Y+3))=$S(E:E,1:0),$P(BGPEI3(X),U,(Y+6))=$S(H:H,1:0) Q
..I $P($G(^BGPINDHC(BGPPC,19)),U,13) S Y=$P(^BGPINDHC(BGPPC,11),U,3),$P(BGPEI3(X),U,Y)=$S(B:B,1:0),$P(BGPEI3(X),U,(Y+3))=$S(E:E,1:0),$P(BGPEI3(X),U,(Y+6))=$S(H:H,1:0) Q
..S Y=$P(^BGPINDHC(BGPPC,11),U,3)
..S $P(BGPEI3(X),U,$P(^BGPINDHC(BGPPC,11),U,3))=$S(A:A,1:0),$P(BGPEI3(X),U,(Y+1))=$S(B:B,1:0),$P(BGPEI3(X),U,(Y+2))=$$SL(C)
..S $P(BGPEI3(X),U,(Y+3))=$S(D:D,1:0),$P(BGPEI3(X),U,(Y+4))=$S(E:E,1:0),$P(BGPEI3(X),U,(Y+5))=$$SL(F),$P(BGPEI3(X),U,(Y+6))=$S(G:G,1:0),$P(BGPEI3(X),U,(Y+7))=$S(H:H,1:0),$P(BGPEI3(X),U,(Y+8))=$$SL(I)
DEVEL1 ;EP
I $G(BGPAREAA),$G(BGPEXCEL) D
.Q:$P($G(^BGPINDHC(BGPPC,21)),U,3)=""
.;set each numerator and percent,then set BGPEIDV1
.NEW X S X=0 F S X=$O(BGPSUL(X)) Q:X'=+X D
..S $P(BGPEXCT(X,1),U,1)=$P($G(^BGPGPDCH(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(^BGPGPDPH(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(^BGPGPDBH(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(^BGPINDHC(BGPPC,0),U,4),".")="023" S Y=$P(^BGPINDHC(BGPPC,21),U,3),$P(BGPEIDV1(X),U,Y)=$S(B:B,1:0),$P(BGPEIDV1(X),U,(Y+3))=$S(E:E,1:0),$P(BGPEIDV1(X),U,(Y+6))=$S(H:H,1:0) Q
..I $P($P(^BGPINDHC(BGPPC,0),U,4),".",1,2)="014.A" S Y=$P(^BGPINDHC(BGPPC,21),U,3),$P(BGPEIDV1(X),U,Y)=$S(B:B,1:0),$P(BGPEIDV1(X),U,(Y+3))=$S(E:E,1:0),$P(BGPEIDV1(X),U,(Y+6))=$S(H:H,1:0) Q
..I $P(^BGPINDHC(BGPPC,0),U,4)="016.A.1" S Y=$P(^BGPINDHC(BGPPC,21),U,3),$P(BGPEIDV1(X),U,Y)=$S(B:B,1:0),$P(BGPEIDV1(X),U,(Y+3))=$S(E:E,1:0),$P(BGPEIDV1(X),U,(Y+6))=$S(H:H,1:0) Q
..I $P($G(^BGPINDHC(BGPPC,19)),U,13) S Y=$P(^BGPINDHC(BGPPC,21),U,3),$P(BGPEIDV1(X),U,Y)=$S(B:B,1:0),$P(BGPEIDV1(X),U,(Y+3))=$S(E:E,1:0),$P(BGPEIDV1(X),U,(Y+6))=$S(H:H,1:0) Q
..S Y=$P(^BGPINDHC(BGPPC,21),U,3)
..S $P(BGPEIDV1(X),U,$P(^BGPINDHC(BGPPC,21),U,3))=$S(A:A,1:0),$P(BGPEIDV1(X),U,(Y+1))=$S(B:B,1:0),$P(BGPEIDV1(X),U,(Y+2))=$$SL(C)
..S $P(BGPEIDV1(X),U,(Y+3))=$S(D:D,1:0),$P(BGPEIDV1(X),U,(Y+4))=$S(E:E,1:0),$P(BGPEIDV1(X),U,(Y+5))=$$SL(F),$P(BGPEIDV1(X),U,(Y+6))=$S(G:G,1:0),$P(BGPEIDV1(X),U,(Y+7))=$S(H:H,1:0),$P(BGPEIDV1(X),U,(Y+8))=$$SL(I)
DEVEL2 ;
I $G(BGPAREAA),$G(BGPEXCEL) D
.Q:$P($G(^BGPINDHC(BGPPC,21)),U,4)=""
.;set each numerator and percent,then set BGPEIDV2
.NEW X S X=0 F S X=$O(BGPSUL(X)) Q:X'=+X D
..S $P(BGPEXCT(X,1),U,1)=$P($G(^BGPGPDCH(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(^BGPGPDPH(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(^BGPGPDBH(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(^BGPINDHC(BGPPC,0),U,4),".")="023" S Y=$P(^BGPINDHC(BGPPC,21),U,4),$P(BGPEIDV2(X),U,Y)=$S(B:B,1:0),$P(BGPEIDV2(X),U,(Y+3))=$S(E:E,1:0),$P(BGPEIDV2(X),U,(Y+6))=$S(H:H,1:0) Q
..I $P($P(^BGPINDHC(BGPPC,0),U,4),".",1,2)="014.A" S Y=$P(^BGPINDHC(BGPPC,21),U,4),$P(BGPEIDV2(X),U,Y)=$S(B:B,1:0),$P(BGPEIDV2(X),U,(Y+3))=$S(E:E,1:0),$P(BGPEIDV2(X),U,(Y+6))=$S(H:H,1:0) Q
..I $P(^BGPINDHC(BGPPC,0),U,4)="016.A.1" S Y=$P(^BGPINDHC(BGPPC,21),U,4),$P(BGPEIDV2(X),U,Y)=$S(B:B,1:0),$P(BGPEIDV2(X),U,(Y+3))=$S(E:E,1:0),$P(BGPEIDV2(X),U,(Y+6))=$S(H:H,1:0) Q
..I $P($G(^BGPINDHC(BGPPC,19)),U,13) S Y=$P(^BGPINDHC(BGPPC,21),U,4),$P(BGPEIDV2(X),U,Y)=$S(B:B,1:0),$P(BGPEIDV2(X),U,(Y+3))=$S(E:E,1:0),$P(BGPEIDV2(X),U,(Y+6))=$S(H:H,1:0) Q
..S Y=$P(^BGPINDHC(BGPPC,21),U,4)
..S $P(BGPEIDV2(X),U,$P(^BGPINDHC(BGPPC,21),U,4))=$S(A:A,1:0),$P(BGPEIDV2(X),U,(Y+1))=$S(B:B,1:0),$P(BGPEIDV2(X),U,(Y+2))=$$SL(C)
..S $P(BGPEIDV2(X),U,(Y+3))=$S(D:D,1:0),$P(BGPEIDV2(X),U,(Y+4))=$S(E:E,1:0),$P(BGPEIDV2(X),U,(Y+5))=$$SL(F),$P(BGPEIDV2(X),U,(Y+6))=$S(G:G,1:0),$P(BGPEIDV2(X),U,(Y+7))=$S(H:H,1:0),$P(BGPEIDV2(X),U,(Y+8))=$$SL(I)
DEVEL3 ;
I $G(BGPAREAA),$G(BGPEXCEL) D
.Q:$P($G(^BGPINDHC(BGPPC,21)),U,8)=""
.;set each numerator and percent,then set BGPEIDV3
.NEW X S X=0 F S X=$O(BGPSUL(X)) Q:X'=+X D
..S $P(BGPEXCT(X,1),U,1)=$P($G(^BGPGPDCH(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(^BGPGPDPH(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(^BGPGPDBH(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(^BGPINDHC(BGPPC,0),U,4),".")="023" S Y=$P(^BGPINDHC(BGPPC,21),U,8),$P(BGPEIDV3(X),U,Y)=$S(B:B,1:0),$P(BGPEIDV3(X),U,(Y+3))=$S(E:E,1:0),$P(BGPEIDV3(X),U,(Y+6))=$S(H:H,1:0) Q
..I $P($P(^BGPINDHC(BGPPC,0),U,4),".",1,2)="014.A" S Y=$P(^BGPINDHC(BGPPC,21),U,8),$P(BGPEIDV3(X),U,Y)=$S(B:B,1:0),$P(BGPEIDV3(X),U,(Y+3))=$S(E:E,1:0),$P(BGPEIDV3(X),U,(Y+6))=$S(H:H,1:0) Q
..I $P(^BGPINDHC(BGPPC,0),U,4)="016.A.1" S Y=$P(^BGPINDHC(BGPPC,21),U,8),$P(BGPEIDV3(X),U,Y)=$S(B:B,1:0),$P(BGPEIDV3(X),U,(Y+3))=$S(E:E,1:0),$P(BGPEIDV3(X),U,(Y+6))=$S(H:H,1:0) Q
..I $P($G(^BGPINDHC(BGPPC,19)),U,13) S Y=$P(^BGPINDHC(BGPPC,21),U,8),$P(BGPEIDV3(X),U,Y)=$S(B:B,1:0),$P(BGPEIDV3(X),U,(Y+3))=$S(E:E,1:0),$P(BGPEIDV3(X),U,(Y+6))=$S(H:H,1:0) Q
..S Y=$P(^BGPINDHC(BGPPC,21),U,8)
..S $P(BGPEIDV3(X),U,$P(^BGPINDHC(BGPPC,21),U,8))=$S(A:A,1:0),$P(BGPEIDV3(X),U,(Y+1))=$S(B:B,1:0),$P(BGPEIDV3(X),U,(Y+2))=$$SL(C)
..S $P(BGPEIDV3(X),U,(Y+3))=$S(D:D,1:0),$P(BGPEIDV3(X),U,(Y+4))=$S(E:E,1:0),$P(BGPEIDV3(X),U,(Y+5))=$$SL(F),$P(BGPEIDV3(X),U,(Y+6))=$S(G:G,1:0),$P(BGPEIDV3(X),U,(Y+7))=$S(H:H,1:0),$P(BGPEIDV3(X),U,(Y+8))=$$SL(I)
Q
BGP3DP1D ; IHS/CMI/LAB - print ind 1 ;
+1 ;;13.0;IHS CLINICAL REPORTING;;NOV 20, 2012;Build 81
ONM1 ;EP
+1 IF $GET(BGPAREAA)
IF $GET(BGPEXCEL)
Begin DoDot:1
+2 IF $PIECE(^BGPINDHC(BGPPC,0),U,6)=""
QUIT
+3 ;set each numerator and percent,then set BGPONN1
+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(^BGPGPDCH(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(^BGPGPDPH(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(^BGPGPDBH(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(^BGPINDHC(BGPPC,0),U,4),".")="023"
SET Y=$PIECE(^BGPINDHC(BGPPC,0),U,6)
SET $PIECE(BGPONN1(X),U,Y)=$SELECT(B:B,1:0)
SET $PIECE(BGPONN1(X),U,(Y+3))=$SELECT(E:E,1:0)
SET $PIECE(BGPONN1(X),U,(Y+6))=$SELECT(H:H,1:0)
QUIT
+13 IF $PIECE($PIECE(^BGPINDHC(BGPPC,0),U,4),".",1,2)="014.A"
SET Y=$PIECE(^BGPINDHC(BGPPC,0),U,6)
SET $PIECE(BGPONN1(X),U,Y)=$SELECT(B:B,1:0)
SET $PIECE(BGPONN1(X),U,(Y+3))=$SELECT(E:E,1:0)
SET $PIECE(BGPONN1(X),U,(Y+6))=$SELECT(H:H,1:0)
QUIT
+14 IF $PIECE(^BGPINDHC(BGPPC,0),U,4)="016.A.1"
SET Y=$PIECE(^BGPINDHC(BGPPC,0),U,6)
SET $PIECE(BGPONN1(X),U,Y)=$SELECT(B:B,1:0)
SET $PIECE(BGPONN1(X),U,(Y+3))=$SELECT(E:E,1:0)
SET $PIECE(BGPONN1(X),U,(Y+6))=$SELECT(H:H,1:0)
QUIT
+15 IF $PIECE($GET(^BGPINDHC(BGPPC,19)),U,13)
SET Y=$PIECE(^BGPINDHC(BGPPC,0),U,6)
SET $PIECE(BGPONN1(X),U,Y)=$SELECT(B:B,1:0)
SET $PIECE(BGPONN1(X),U,(Y+3))=$SELECT(E:E,1:0)
SET $PIECE(BGPONN1(X),U,(Y+6))=$SELECT(H:H,1:0)
QUIT
+16 SET Y=$PIECE(^BGPINDHC(BGPPC,0),U,6)
+17 SET $PIECE(BGPONN1(X),U,$PIECE(^BGPINDHC(BGPPC,0),U,6))=$SELECT(A:A,1:0)
SET $PIECE(BGPONN1(X),U,(Y+1))=$SELECT(B:B,1:0)
SET $PIECE(BGPONN1(X),U,(Y+2))=$$SL(C)
+18 SET $PIECE(BGPONN1(X),U,(Y+3))=$SELECT(D:D,1:0)
SET $PIECE(BGPONN1(X),U,(Y+4))=$SELECT(E:E,1:0)
SET $PIECE(BGPONN1(X),U,(Y+5))=$$SL(F)
SET $PIECE(BGPONN1(X),U,(Y+6))=$SELECT(G:G,1:0)
SET $PIECE(BGPONN1(X),U,(Y+7))=$SELECT(H:H,1:0)
SET $PIECE(BGPONN1(X),U,(Y+8))=$$SL(I)
End DoDot:2
End DoDot:1
ONN2 ;
+1 IF $GET(BGPAREAA)
IF $GET(BGPEXCEL)
Begin DoDot:1
+2 IF $PIECE(^BGPINDHC(BGPPC,0),U,7)=""
QUIT
+3 ;set each numerator and percent,then set BGPONN2
+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(^BGPGPDCH(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(^BGPGPDPH(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(^BGPGPDBH(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(^BGPINDHC(BGPPC,0),U,4),".")="023"
SET Y=$PIECE(^BGPINDHC(BGPPC,0),U,7)
SET $PIECE(BGPONN2(X),U,Y)=$SELECT(B:B,1:0)
SET $PIECE(BGPONN2(X),U,(Y+3))=$SELECT(E:E,1:0)
SET $PIECE(BGPONN2(X),U,(Y+6))=$SELECT(H:H,1:0)
QUIT
+13 IF $PIECE($PIECE(^BGPINDHC(BGPPC,0),U,4),".",1,2)="014.A"
SET Y=$PIECE(^BGPINDHC(BGPPC,0),U,7)
SET $PIECE(BGPONN2(X),U,Y)=$SELECT(B:B,1:0)
SET $PIECE(BGPONN2(X),U,(Y+3))=$SELECT(E:E,1:0)
SET $PIECE(BGPONN2(X),U,(Y+6))=$SELECT(H:H,1:0)
QUIT
+14 IF $PIECE(^BGPINDHC(BGPPC,0),U,4)="016.A.1"
SET Y=$PIECE(^BGPINDHC(BGPPC,0),U,7)
SET $PIECE(BGPONN2(X),U,Y)=$SELECT(B:B,1:0)
SET $PIECE(BGPONN2(X),U,(Y+3))=$SELECT(E:E,1:0)
SET $PIECE(BGPONN2(X),U,(Y+6))=$SELECT(H:H,1:0)
QUIT
+15 IF $PIECE(^BGPINDHC(BGPPC,0),U,4)="STI.AA.1A"
SET Y=$PIECE(^BGPINDHC(BGPPC,0),U,7)
SET $PIECE(BGPONN2(X),U,Y)=$SELECT(B:B,1:0)
SET $PIECE(BGPONN2(X),U,(Y+3))=$SELECT(E:E,1:0)
SET $PIECE(BGPONN2(X),U,(Y+6))=$SELECT(H:H,1:0)
QUIT
+16 IF $PIECE(^BGPINDHC(BGPPC,0),U,4)="STI.AB.4A"
SET Y=$PIECE(^BGPINDHC(BGPPC,0),U,7)
SET $PIECE(BGPONN2(X),U,Y)=$SELECT(B:B,1:0)
SET $PIECE(BGPONN2(X),U,(Y+3))=$SELECT(E:E,1:0)
SET $PIECE(BGPONN2(X),U,(Y+6))=$SELECT(H:H,1:0)
QUIT
+17 IF $PIECE($GET(^BGPINDHC(BGPPC,19)),U,13)
SET Y=$PIECE(^BGPINDHC(BGPPC,0),U,7)
SET $PIECE(BGPONN2(X),U,Y)=$SELECT(B:B,1:0)
SET $PIECE(BGPONN2(X),U,(Y+3))=$SELECT(E:E,1:0)
SET $PIECE(BGPONN2(X),U,(Y+6))=$SELECT(H:H,1:0)
QUIT
+18 SET Y=$PIECE(^BGPINDHC(BGPPC,0),U,7)
+19 SET $PIECE(BGPONN2(X),U,$PIECE(^BGPINDHC(BGPPC,0),U,7))=$SELECT(A:A,1:0)
SET $PIECE(BGPONN2(X),U,(Y+1))=$SELECT(B:B,1:0)
SET $PIECE(BGPONN2(X),U,(Y+2))=$$SL(C)
+20 SET $PIECE(BGPONN2(X),U,(Y+3))=$SELECT(D:D,1:0)
SET $PIECE(BGPONN2(X),U,(Y+4))=$SELECT(E:E,1:0)
SET $PIECE(BGPONN2(X),U,(Y+5))=$$SL(F)
SET $PIECE(BGPONN2(X),U,(Y+6))=$SELECT(G:G,1:0)
SET $PIECE(BGPONN2(X),U,(Y+7))=$SELECT(H:H,1:0)
SET $PIECE(BGPONN2(X),U,(Y+8))=$$SL(I)
End DoDot:2
End DoDot:1
ONN3 ;
+1 IF $GET(BGPAREAA)
IF $GET(BGPEXCEL)
Begin DoDot:1
+2 IF $PIECE($GET(^BGPINDHC(BGPPC,21)),U,7)=""
QUIT
+3 ;set each numerator and percent,then set BGPONN3
+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(^BGPGPDCH(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(^BGPGPDPH(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(^BGPGPDBH(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(^BGPINDHC(BGPPC,0),U,4),".")="023"
SET Y=$PIECE(^BGPINDHC(BGPPC,21),U,7)
SET $PIECE(BGPONN3(X),U,Y)=$SELECT(B:B,1:0)
SET $PIECE(BGPONN3(X),U,(Y+3))=$SELECT(E:E,1:0)
SET $PIECE(BGPONN3(X),U,(Y+6))=$SELECT(H:H,1:0)
QUIT
+13 IF $PIECE($PIECE(^BGPINDHC(BGPPC,0),U,4),".",1,2)="014.A"
SET Y=$PIECE(^BGPINDHC(BGPPC,21),U,7)
SET $PIECE(BGPONN3(X),U,Y)=$SELECT(B:B,1:0)
SET $PIECE(BGPONN3(X),U,(Y+3))=$SELECT(E:E,1:0)
SET $PIECE(BGPONN3(X),U,(Y+6))=$SELECT(H:H,1:0)
QUIT
+14 IF $PIECE(^BGPINDHC(BGPPC,0),U,4)="016.A.1"
SET Y=$PIECE(^BGPINDHC(BGPPC,21),U,7)
SET $PIECE(BGPONN3(X),U,Y)=$SELECT(B:B,1:0)
SET $PIECE(BGPONN3(X),U,(Y+3))=$SELECT(E:E,1:0)
SET $PIECE(BGPONN3(X),U,(Y+6))=$SELECT(H:H,1:0)
QUIT
+15 IF $PIECE(^BGPINDHC(BGPPC,0),U,4)="STI.AA.1A"
SET Y=$PIECE(^BGPINDHC(BGPPC,21),U,7)
SET $PIECE(BGPONN3(X),U,Y)=$SELECT(B:B,1:0)
SET $PIECE(BGPONN3(X),U,(Y+3))=$SELECT(E:E,1:0)
SET $PIECE(BGPONN3(X),U,(Y+6))=$SELECT(H:H,1:0)
QUIT
+16 IF $PIECE(^BGPINDHC(BGPPC,0),U,4)="STI.AB.4A"
SET Y=$PIECE(^BGPINDHC(BGPPC,21),U,7)
SET $PIECE(BGPONN3(X),U,Y)=$SELECT(B:B,1:0)
SET $PIECE(BGPONN3(X),U,(Y+3))=$SELECT(E:E,1:0)
SET $PIECE(BGPONN3(X),U,(Y+6))=$SELECT(H:H,1:0)
QUIT
+17 IF $PIECE($GET(^BGPINDHC(BGPPC,19)),U,13)
SET Y=$PIECE(^BGPINDHC(BGPPC,21),U,7)
SET $PIECE(BGPONN3(X),U,Y)=$SELECT(B:B,1:0)
SET $PIECE(BGPONN3(X),U,(Y+3))=$SELECT(E:E,1:0)
SET $PIECE(BGPONN3(X),U,(Y+6))=$SELECT(H:H,1:0)
QUIT
+18 SET Y=$PIECE(^BGPINDHC(BGPPC,21),U,7)
+19 SET $PIECE(BGPONN3(X),U,$PIECE(^BGPINDHC(BGPPC,21),U,7))=$SELECT(A:A,1:0)
SET $PIECE(BGPONN3(X),U,(Y+1))=$SELECT(B:B,1:0)
SET $PIECE(BGPONN3(X),U,(Y+2))=$$SL(C)
+20 SET $PIECE(BGPONN3(X),U,(Y+3))=$SELECT(D:D,1:0)
SET $PIECE(BGPONN3(X),U,(Y+4))=$SELECT(E:E,1:0)
SET $PIECE(BGPONN3(X),U,(Y+5))=$$SL(F)
SET $PIECE(BGPONN3(X),U,(Y+6))=$SELECT(G:G,1:0)
SET $PIECE(BGPONN3(X),U,(Y+7))=$SELECT(H:H,1:0)
SET $PIECE(BGPONN3(X),U,(Y+8))=$$SL(I)
End DoDot:2
End DoDot:1
+21 DO ONN4^BGP3DP1F
+22 QUIT
SL(V) ;
+1 IF V=""
SET V=0
+2 QUIT $$STRIP^XLFSTR($JUSTIFY(V,5,1)," ")
+3 ;
GPRANT3 ;EP
+1 IF $GET(BGPAREAA)
IF $GET(BGPEXCEL)
Begin DoDot:1
+2 IF $PIECE($GET(^BGPINDHC(BGPPC,11)),U,3)=""
QUIT
+3 ;set each numerator and percent,then set BGPEI3
+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(^BGPGPDCH(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(^BGPGPDPH(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(^BGPGPDBH(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(^BGPINDHC(BGPPC,0),U,4),".")="023"
SET Y=$PIECE(^BGPINDHC(BGPPC,11),U,3)
SET $PIECE(BGPEI3(X),U,Y)=$SELECT(B:B,1:0)
SET $PIECE(BGPEI3(X),U,(Y+3))=$SELECT(E:E,1:0)
SET $PIECE(BGPEI3(X),U,(Y+6))=$SELECT(H:H,1:0)
QUIT
+13 IF $PIECE($PIECE(^BGPINDHC(BGPPC,0),U,4),".")="014"
SET Y=$PIECE(^BGPINDHC(BGPPC,11),U,3)
SET $PIECE(BGPEI3(X),U,Y)=$SELECT(B:B,1:0)
SET $PIECE(BGPEI3(X),U,(Y+3))=$SELECT(E:E,1:0)
SET $PIECE(BGPEI3(X),U,(Y+6))=$SELECT(H:H,1:0)
QUIT
+14 IF $PIECE($PIECE(^BGPINDHC(BGPPC,0),U,4),".")="016"
SET Y=$PIECE(^BGPINDHC(BGPPC,11),U,3)
SET $PIECE(BGPEI3(X),U,Y)=$SELECT(B:B,1:0)
SET $PIECE(BGPEI3(X),U,(Y+3))=$SELECT(E:E,1:0)
SET $PIECE(BGPEI3(X),U,(Y+6))=$SELECT(H:H,1:0)
QUIT
+15 IF $PIECE($GET(^BGPINDHC(BGPPC,19)),U,13)
SET Y=$PIECE(^BGPINDHC(BGPPC,11),U,3)
SET $PIECE(BGPEI3(X),U,Y)=$SELECT(B:B,1:0)
SET $PIECE(BGPEI3(X),U,(Y+3))=$SELECT(E:E,1:0)
SET $PIECE(BGPEI3(X),U,(Y+6))=$SELECT(H:H,1:0)
QUIT
+16 SET Y=$PIECE(^BGPINDHC(BGPPC,11),U,3)
+17 SET $PIECE(BGPEI3(X),U,$PIECE(^BGPINDHC(BGPPC,11),U,3))=$SELECT(A:A,1:0)
SET $PIECE(BGPEI3(X),U,(Y+1))=$SELECT(B:B,1:0)
SET $PIECE(BGPEI3(X),U,(Y+2))=$$SL(C)
+18 SET $PIECE(BGPEI3(X),U,(Y+3))=$SELECT(D:D,1:0)
SET $PIECE(BGPEI3(X),U,(Y+4))=$SELECT(E:E,1:0)
SET $PIECE(BGPEI3(X),U,(Y+5))=$$SL(F)
SET $PIECE(BGPEI3(X),U,(Y+6))=$SELECT(G:G,1:0)
SET $PIECE(BGPEI3(X),U,(Y+7))=$SELECT(H:H,1:0)
SET $PIECE(BGPEI3(X),U,(Y+8))=$$SL(I)
End DoDot:2
End DoDot:1
DEVEL1 ;EP
+1 IF $GET(BGPAREAA)
IF $GET(BGPEXCEL)
Begin DoDot:1
+2 IF $PIECE($GET(^BGPINDHC(BGPPC,21)),U,3)=""
QUIT
+3 ;set each numerator and percent,then set BGPEIDV1
+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(^BGPGPDCH(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(^BGPGPDPH(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(^BGPGPDBH(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(^BGPINDHC(BGPPC,0),U,4),".")="023"
SET Y=$PIECE(^BGPINDHC(BGPPC,21),U,3)
SET $PIECE(BGPEIDV1(X),U,Y)=$SELECT(B:B,1:0)
SET $PIECE(BGPEIDV1(X),U,(Y+3))=$SELECT(E:E,1:0)
SET $PIECE(BGPEIDV1(X),U,(Y+6))=$SELECT(H:H,1:0)
QUIT
+13 IF $PIECE($PIECE(^BGPINDHC(BGPPC,0),U,4),".",1,2)="014.A"
SET Y=$PIECE(^BGPINDHC(BGPPC,21),U,3)
SET $PIECE(BGPEIDV1(X),U,Y)=$SELECT(B:B,1:0)
SET $PIECE(BGPEIDV1(X),U,(Y+3))=$SELECT(E:E,1:0)
SET $PIECE(BGPEIDV1(X),U,(Y+6))=$SELECT(H:H,1:0)
QUIT
+14 IF $PIECE(^BGPINDHC(BGPPC,0),U,4)="016.A.1"
SET Y=$PIECE(^BGPINDHC(BGPPC,21),U,3)
SET $PIECE(BGPEIDV1(X),U,Y)=$SELECT(B:B,1:0)
SET $PIECE(BGPEIDV1(X),U,(Y+3))=$SELECT(E:E,1:0)
SET $PIECE(BGPEIDV1(X),U,(Y+6))=$SELECT(H:H,1:0)
QUIT
+15 IF $PIECE($GET(^BGPINDHC(BGPPC,19)),U,13)
SET Y=$PIECE(^BGPINDHC(BGPPC,21),U,3)
SET $PIECE(BGPEIDV1(X),U,Y)=$SELECT(B:B,1:0)
SET $PIECE(BGPEIDV1(X),U,(Y+3))=$SELECT(E:E,1:0)
SET $PIECE(BGPEIDV1(X),U,(Y+6))=$SELECT(H:H,1:0)
QUIT
+16 SET Y=$PIECE(^BGPINDHC(BGPPC,21),U,3)
+17 SET $PIECE(BGPEIDV1(X),U,$PIECE(^BGPINDHC(BGPPC,21),U,3))=$SELECT(A:A,1:0)
SET $PIECE(BGPEIDV1(X),U,(Y+1))=$SELECT(B:B,1:0)
SET $PIECE(BGPEIDV1(X),U,(Y+2))=$$SL(C)
+18 SET $PIECE(BGPEIDV1(X),U,(Y+3))=$SELECT(D:D,1:0)
SET $PIECE(BGPEIDV1(X),U,(Y+4))=$SELECT(E:E,1:0)
SET $PIECE(BGPEIDV1(X),U,(Y+5))=$$SL(F)
SET $PIECE(BGPEIDV1(X),U,(Y+6))=$SELECT(G:G,1:0)
SET $PIECE(BGPEIDV1(X),U,(Y+7))=$SELECT(H:H,1:0)
SET $PIECE(BGPEIDV1(X),U,(Y+8))=$$SL(I)
End DoDot:2
End DoDot:1
DEVEL2 ;
+1 IF $GET(BGPAREAA)
IF $GET(BGPEXCEL)
Begin DoDot:1
+2 IF $PIECE($GET(^BGPINDHC(BGPPC,21)),U,4)=""
QUIT
+3 ;set each numerator and percent,then set BGPEIDV2
+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(^BGPGPDCH(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(^BGPGPDPH(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(^BGPGPDBH(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(^BGPINDHC(BGPPC,0),U,4),".")="023"
SET Y=$PIECE(^BGPINDHC(BGPPC,21),U,4)
SET $PIECE(BGPEIDV2(X),U,Y)=$SELECT(B:B,1:0)
SET $PIECE(BGPEIDV2(X),U,(Y+3))=$SELECT(E:E,1:0)
SET $PIECE(BGPEIDV2(X),U,(Y+6))=$SELECT(H:H,1:0)
QUIT
+13 IF $PIECE($PIECE(^BGPINDHC(BGPPC,0),U,4),".",1,2)="014.A"
SET Y=$PIECE(^BGPINDHC(BGPPC,21),U,4)
SET $PIECE(BGPEIDV2(X),U,Y)=$SELECT(B:B,1:0)
SET $PIECE(BGPEIDV2(X),U,(Y+3))=$SELECT(E:E,1:0)
SET $PIECE(BGPEIDV2(X),U,(Y+6))=$SELECT(H:H,1:0)
QUIT
+14 IF $PIECE(^BGPINDHC(BGPPC,0),U,4)="016.A.1"
SET Y=$PIECE(^BGPINDHC(BGPPC,21),U,4)
SET $PIECE(BGPEIDV2(X),U,Y)=$SELECT(B:B,1:0)
SET $PIECE(BGPEIDV2(X),U,(Y+3))=$SELECT(E:E,1:0)
SET $PIECE(BGPEIDV2(X),U,(Y+6))=$SELECT(H:H,1:0)
QUIT
+15 IF $PIECE($GET(^BGPINDHC(BGPPC,19)),U,13)
SET Y=$PIECE(^BGPINDHC(BGPPC,21),U,4)
SET $PIECE(BGPEIDV2(X),U,Y)=$SELECT(B:B,1:0)
SET $PIECE(BGPEIDV2(X),U,(Y+3))=$SELECT(E:E,1:0)
SET $PIECE(BGPEIDV2(X),U,(Y+6))=$SELECT(H:H,1:0)
QUIT
+16 SET Y=$PIECE(^BGPINDHC(BGPPC,21),U,4)
+17 SET $PIECE(BGPEIDV2(X),U,$PIECE(^BGPINDHC(BGPPC,21),U,4))=$SELECT(A:A,1:0)
SET $PIECE(BGPEIDV2(X),U,(Y+1))=$SELECT(B:B,1:0)
SET $PIECE(BGPEIDV2(X),U,(Y+2))=$$SL(C)
+18 SET $PIECE(BGPEIDV2(X),U,(Y+3))=$SELECT(D:D,1:0)
SET $PIECE(BGPEIDV2(X),U,(Y+4))=$SELECT(E:E,1:0)
SET $PIECE(BGPEIDV2(X),U,(Y+5))=$$SL(F)
SET $PIECE(BGPEIDV2(X),U,(Y+6))=$SELECT(G:G,1:0)
SET $PIECE(BGPEIDV2(X),U,(Y+7))=$SELECT(H:H,1:0)
SET $PIECE(BGPEIDV2(X),U,(Y+8))=$$SL(I)
End DoDot:2
End DoDot:1
DEVEL3 ;
+1 IF $GET(BGPAREAA)
IF $GET(BGPEXCEL)
Begin DoDot:1
+2 IF $PIECE($GET(^BGPINDHC(BGPPC,21)),U,8)=""
QUIT
+3 ;set each numerator and percent,then set BGPEIDV3
+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(^BGPGPDCH(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(^BGPGPDPH(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(^BGPGPDBH(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(^BGPINDHC(BGPPC,0),U,4),".")="023"
SET Y=$PIECE(^BGPINDHC(BGPPC,21),U,8)
SET $PIECE(BGPEIDV3(X),U,Y)=$SELECT(B:B,1:0)
SET $PIECE(BGPEIDV3(X),U,(Y+3))=$SELECT(E:E,1:0)
SET $PIECE(BGPEIDV3(X),U,(Y+6))=$SELECT(H:H,1:0)
QUIT
+13 IF $PIECE($PIECE(^BGPINDHC(BGPPC,0),U,4),".",1,2)="014.A"
SET Y=$PIECE(^BGPINDHC(BGPPC,21),U,8)
SET $PIECE(BGPEIDV3(X),U,Y)=$SELECT(B:B,1:0)
SET $PIECE(BGPEIDV3(X),U,(Y+3))=$SELECT(E:E,1:0)
SET $PIECE(BGPEIDV3(X),U,(Y+6))=$SELECT(H:H,1:0)
QUIT
+14 IF $PIECE(^BGPINDHC(BGPPC,0),U,4)="016.A.1"
SET Y=$PIECE(^BGPINDHC(BGPPC,21),U,8)
SET $PIECE(BGPEIDV3(X),U,Y)=$SELECT(B:B,1:0)
SET $PIECE(BGPEIDV3(X),U,(Y+3))=$SELECT(E:E,1:0)
SET $PIECE(BGPEIDV3(X),U,(Y+6))=$SELECT(H:H,1:0)
QUIT
+15 IF $PIECE($GET(^BGPINDHC(BGPPC,19)),U,13)
SET Y=$PIECE(^BGPINDHC(BGPPC,21),U,8)
SET $PIECE(BGPEIDV3(X),U,Y)=$SELECT(B:B,1:0)
SET $PIECE(BGPEIDV3(X),U,(Y+3))=$SELECT(E:E,1:0)
SET $PIECE(BGPEIDV3(X),U,(Y+6))=$SELECT(H:H,1:0)
QUIT
+16 SET Y=$PIECE(^BGPINDHC(BGPPC,21),U,8)
+17 SET $PIECE(BGPEIDV3(X),U,$PIECE(^BGPINDHC(BGPPC,21),U,8))=$SELECT(A:A,1:0)
SET $PIECE(BGPEIDV3(X),U,(Y+1))=$SELECT(B:B,1:0)
SET $PIECE(BGPEIDV3(X),U,(Y+2))=$$SL(C)
+18 SET $PIECE(BGPEIDV3(X),U,(Y+3))=$SELECT(D:D,1:0)
SET $PIECE(BGPEIDV3(X),U,(Y+4))=$SELECT(E:E,1:0)
SET $PIECE(BGPEIDV3(X),U,(Y+5))=$$SL(F)
SET $PIECE(BGPEIDV3(X),U,(Y+6))=$SELECT(G:G,1:0)
SET $PIECE(BGPEIDV3(X),U,(Y+7))=$SELECT(H:H,1:0)
SET $PIECE(BGPEIDV3(X),U,(Y+8))=$$SL(I)
End DoDot:2
End DoDot:1
+19 QUIT
