- BGP8DP1G ; IHS/CMI/LAB - print ind 1 ;
- ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
- SL(V) ;
- I V="" S V=0
- Q $$STRIP^XLFSTR($J(V,5,1)," ")
- ;
- GPRANT5 ;
- DEVEL3 ;EP
- I $G(BGPAREAA),$G(BGPEXCEL) D
- .Q:$P($G(^BGPINDRC(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(^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,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(^BGPINDRC(BGPPC,0),U,4),".",1,2)="014.A" S Y=$P(^BGPINDRC(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(^BGPINDRC(BGPPC,0),U,4)="016.A.1" S Y=$P(^BGPINDRC(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(^BGPINDRC(BGPPC,19)),U,13) S Y=$P(^BGPINDRC(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(^BGPINDRC(BGPPC,21),U,8)
- ..S $P(BGPEIDV3(X),U,$P(^BGPINDRC(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)
- DEVEL4 ;EP
- I $G(BGPAREAA),$G(BGPEXCEL) D
- .Q:$P($G(^BGPINDRC(BGPPC,21)),U,11)=""
- .;set each numerator and percent,then set BGPEIDV4
- .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,21),U,11),$P(BGPEIDV4(X),U,Y)=$S(B:B,1:0),$P(BGPEIDV4(X),U,(Y+3))=$S(E:E,1:0),$P(BGPEIDV4(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,21),U,11),$P(BGPEIDV4(X),U,Y)=$S(B:B,1:0),$P(BGPEIDV4(X),U,(Y+3))=$S(E:E,1:0),$P(BGPEIDV4(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,21),U,11),$P(BGPEIDV4(X),U,Y)=$S(B:B,1:0),$P(BGPEIDV4(X),U,(Y+3))=$S(E:E,1:0),$P(BGPEIDV4(X),U,(Y+6))=$S(H:H,1:0) Q
- ..I $P($G(^BGPINDRC(BGPPC,19)),U,13) S Y=$P(^BGPINDRC(BGPPC,21),U,11),$P(BGPEIDV4(X),U,Y)=$S(B:B,1:0),$P(BGPEIDV4(X),U,(Y+3))=$S(E:E,1:0),$P(BGPEIDV4(X),U,(Y+6))=$S(H:H,1:0) Q
- ..S Y=$P(^BGPINDRC(BGPPC,21),U,11)
- ..S $P(BGPEIDV4(X),U,$P(^BGPINDRC(BGPPC,21),U,11))=$S(A:A,1:0),$P(BGPEIDV4(X),U,(Y+1))=$S(B:B,1:0),$P(BGPEIDV4(X),U,(Y+2))=$$SL(C)
- ..S $P(BGPEIDV4(X),U,(Y+3))=$S(D:D,1:0),$P(BGPEIDV4(X),U,(Y+4))=$S(E:E,1:0),$P(BGPEIDV4(X),U,(Y+5))=$$SL(F),$P(BGPEIDV4(X),U,(Y+6))=$S(G:G,1:0),$P(BGPEIDV4(X),U,(Y+7))=$S(H:H,1:0),$P(BGPEIDV4(X),U,(Y+8))=$$SL(I)
- Q
- BGP8DP1G ; IHS/CMI/LAB - print ind 1 ;
- +1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
- SL(V) ;
- +1 IF V=""
- SET V=0
- +2 QUIT $$STRIP^XLFSTR($JUSTIFY(V,5,1)," ")
- +3 ;
- GPRANT5 ;
- DEVEL3 ;EP
- +1 IF $GET(BGPAREAA)
- IF $GET(BGPEXCEL)
- Begin DoDot:1
- +2 IF $PIECE($GET(^BGPINDRC(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(^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,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(^BGPINDRC(BGPPC,0),U,4),".",1,2)="014.A"
- SET Y=$PIECE(^BGPINDRC(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(^BGPINDRC(BGPPC,0),U,4)="016.A.1"
- SET Y=$PIECE(^BGPINDRC(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(^BGPINDRC(BGPPC,19)),U,13)
- SET Y=$PIECE(^BGPINDRC(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(^BGPINDRC(BGPPC,21),U,8)
- +17 SET $PIECE(BGPEIDV3(X),U,$PIECE(^BGPINDRC(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
- DEVEL4 ;EP
- +1 IF $GET(BGPAREAA)
- IF $GET(BGPEXCEL)
- Begin DoDot:1
- +2 IF $PIECE($GET(^BGPINDRC(BGPPC,21)),U,11)=""
- QUIT
- +3 ;set each numerator and percent,then set BGPEIDV4
- +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,21),U,11)
- SET $PIECE(BGPEIDV4(X),U,Y)=$SELECT(B:B,1:0)
- SET $PIECE(BGPEIDV4(X),U,(Y+3))=$SELECT(E:E,1:0)
- SET $PIECE(BGPEIDV4(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,21),U,11)
- SET $PIECE(BGPEIDV4(X),U,Y)=$SELECT(B:B,1:0)
- SET $PIECE(BGPEIDV4(X),U,(Y+3))=$SELECT(E:E,1:0)
- SET $PIECE(BGPEIDV4(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,21),U,11)
- SET $PIECE(BGPEIDV4(X),U,Y)=$SELECT(B:B,1:0)
- SET $PIECE(BGPEIDV4(X),U,(Y+3))=$SELECT(E:E,1:0)
- SET $PIECE(BGPEIDV4(X),U,(Y+6))=$SELECT(H:H,1:0)
- QUIT
- +15 IF $PIECE($GET(^BGPINDRC(BGPPC,19)),U,13)
- SET Y=$PIECE(^BGPINDRC(BGPPC,21),U,11)
- SET $PIECE(BGPEIDV4(X),U,Y)=$SELECT(B:B,1:0)
- SET $PIECE(BGPEIDV4(X),U,(Y+3))=$SELECT(E:E,1:0)
- SET $PIECE(BGPEIDV4(X),U,(Y+6))=$SELECT(H:H,1:0)
- QUIT
- +16 SET Y=$PIECE(^BGPINDRC(BGPPC,21),U,11)
- +17 SET $PIECE(BGPEIDV4(X),U,$PIECE(^BGPINDRC(BGPPC,21),U,11))=$SELECT(A:A,1:0)
- SET $PIECE(BGPEIDV4(X),U,(Y+1))=$SELECT(B:B,1:0)
- SET $PIECE(BGPEIDV4(X),U,(Y+2))=$$SL(C)
- +18 SET $PIECE(BGPEIDV4(X),U,(Y+3))=$SELECT(D:D,1:0)
- SET $PIECE(BGPEIDV4(X),U,(Y+4))=$SELECT(E:E,1:0)
- SET $PIECE(BGPEIDV4(X),U,(Y+5))=$$SL(F)
- SET $PIECE(BGPEIDV4(X),U,(Y+6))=$SELECT(G:G,1:0)
- SET $PIECE(BGPEIDV4(X),U,(Y+7))=$SELECT(H:H,1:0)
- SET $PIECE(BGPEIDV4(X),U,(Y+8))=$$SL(I)
- End DoDot:2
- End DoDot:1
- +19 QUIT
