BGP2EOP1 ; IHS/CMI/LAB - EO report print ;
;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
;
IREG ;EP
I BGPPTYPE="P",$Y>(BGPIOSL-8) D HEADER^BGP2EOP Q:BGPQUIT
;D W^BGP2EOH(^BGPEOMB(BGPIC,53,1,0),0,2,BGPPTYPE)
D H1^BGP2EOP
S BGPORDP=$P(^BGPEOMB(BGPIC,0),U,6) F BGPORDP1=1:1:$P(^BGPEOMB(BGPIC,0),U,4) S BGPPC1=BGPORDP_"."_BGPORDP1 Q:BGPQUIT D PI
Q
;
PI ;EP
S BGPDENP=0
S BGPPC2=0 F S BGPPC2=$O(^BGPEOMIB("AO",BGPPC1,BGPPC2)) Q:BGPPC2="" S BGPPC=$O(^BGPEOMIB("AO",BGPPC1,BGPPC2,0)) D PI1
Q
;
PI1 ;EP
K BGPEXCT,BGPSDP,BGPSDPN,BGPSDPO ;SDPX
S BGPDF=$P(^BGPEOMIB(BGPPC,0),U,4)
;get denominator value
S BGPNP=$P(^DD(90549.1,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) ;SPDX
S BGPPRD=$$V(2,BGPRPT,N,P,1) I $G(BGPAREAA) D SETEXA(2,N,P) ;SPDX
S BGPBLD=$$V(3,BGPRPT,N,P,1) I $G(BGPAREAA) D SETEXA(3,N,P) ;SPDX
;write out denominator
I 'BGPDENP D
.I BGPPTYPE="P",$Y>(BGPIOSL-10) D HEADER^BGP2EOP Q:BGPQUIT D W^BGP2EOH(^BGPEOMB(BGPIC,53,1,0),0,2,BGPPTYPE) D:$D(^BGPEOMB(BGPIC,53,2,0)) W^BGP2EOH(^BGPEOMB(BGPIC,53,2,0),0,1,BGPPTYPE) D H1^BGP2EOP
.D W^BGP2EOH($P(^BGPEOMIB(BGPPC,0),U,9),0,2,BGPPTYPE)
.I $P(^BGPEOMIB(BGPPC,0),U,10)]"" D W^BGP2EOH($P(^BGPEOMIB(BGPPC,0),U,10),0,1,BGPPTYPE)
.I $P(^BGPEOMIB(BGPPC,0),U,11)]"" D W^BGP2EOH($P(^BGPEOMIB(BGPPC,0),U,11),0,1,BGPPTYPE)
.I BGPPTYPE="P" D
..D W^BGP2EOH($$C(BGPCYD,0,8),0,0,BGPPTYPE,1,20)
..D W^BGP2EOH($$C(BGPPRD,0,8),0,0,BGPPTYPE,1,35)
..D W^BGP2EOH($$C(BGPBLD,0,8),0,0,BGPPTYPE,1,58)
..D W^BGP2EOH("",0,1,BGPPTYPE)
.I BGPPTYPE="D" D
..S Y=BGPCYD_"^^"_BGPPRD_"^^^"_BGPBLD D W^BGP2EOH(Y,0,0,BGPPTYPE,2),W^BGP2EOH(" ",0,1,BGPPTYPE)
.S BGPDENP=1
S BGPNF=$P(^BGPEOMIB(BGPPC,0),U,5) ;numerator field
S BGPNP=$P(^DD(90549.1,BGPNF,0),U,4),N=$P(BGPNP,";"),P=$P(BGPNP,";",2)
D SETN
;write header
D W^BGP2EOH($P(^BGPEOMIB(BGPPC,0),U,6),0,1,BGPPTYPE)
I $P(^BGPEOMIB(BGPPC,0),U,7)]"" D W^BGP2EOH($P(^BGPEOMIB(BGPPC,0),U,7),0,1,BGPPTYPE,1,1)
I $P(^BGPEOMIB(BGPPC,0),U,8)]"" D W^BGP2EOH($P(^BGPEOMIB(BGPPC,0),U,8),0,1,BGPPTYPE,1,1)
D H2^BGP2EOP
Q
;
SETN ;EP - set numerator fields
S BGPCYN=$$V(1,BGPRPT,N,P,2) ;SPDX
S BGPPRN=$$V(2,BGPRPT,N,P,2) ;SPDX
S BGPBLN=$$V(3,BGPRPT,N,P,2) ;SPDX
S BGPCYP=$S(BGPCYD:((BGPCYN/BGPCYD)*100),1:"")
S BGPPRP=$S(BGPPRD:((BGPPRN/BGPPRD)*100),1:"")
S BGPBLP=$S(BGPBLD:((BGPBLN/BGPBLD)*100),1:"")
I $G(BGPAREAA) D SDP
I $P($G(^BGPEOMIB(BGPPC,14)),U) D
.S ^TMP($J,"SUMMARY",$P(^BGPSCAT($P(^BGPEOMIB(BGPPC,14),U,5),0),U,4),$P(^BGPEOMIB(BGPPC,14),U,6),BGPPC)=BGPCYP_U_BGPPRP_U_BGPBLP
.I $G(BGPAREAA) D ;SDPX
..S X=0 F S X=$O(BGPSDP(X)) Q:X'=+X D ;SDPX
...S ^TMP($J,"SUMMARY DETAIL PAGE",$P(^BGPSCAT($P(^BGPEOMIB(BGPPC,14),U,5),0),U,4),$P(^BGPEOMIB(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(^BGPEOMIB(BGPPC,14),U,5),0),U,4),$P(^BGPEOMIB(BGPPC,14),U,6),BGPPC)=$$SB($J(BGPCYP,5,1))_U_$$SB($J(BGPPRP,5,1))_U_$$SB($J(BGPBLP,5,1))
.I $G(BGPAREAA) D ;SDPX
..S X=0 F S X=$O(BGPSDP(X)) Q:X'=+X D ;SDPX
...S A=$P(^BGPSCAT($P(^BGPEOMIB(BGPPC,14),U,5),0),U,4)
...S B=$P(^BGPEOMIB(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))
;
I BGPPTYPE="D",BGPROT="B" Q
CRSEONT1 ;
I $G(BGPAREAA),$G(BGPEXCEL) D
.Q:$P(^BGPEOMIB(BGPPC,0),U,12)=""
.;set each numerator and percent,then set BGPEI
.NEW X S X=0 F S X=$O(BGPSUL(X)) Q:X'=+X D
..S $P(BGPEXCT(X,1),U,1)=$P($G(^BGPEOCB(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(^BGPEOPB(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(^BGPEOBB(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)
..S Y=$P(^BGPEOMIB(BGPPC,0),U,12)
..S $P(BGPEI(X),U,$P(^BGPEOMIB(BGPPC,0),U,12))=$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)
Q
;
SL(V) ;
I V="" S V=0
Q $$STRIP^XLFSTR($J(V,5,1)," ")
;
SETEXA(T,N,P) ;EP - set denominator
Q:'$G(BGPEXCEL)
NEW X,Y,Z
S X=0 F S X=$O(BGPSUL(X)) Q:X'=+X D
.I T=1 S $P(BGPEXCT(X,T),U,2)=$P($G(^BGPEOCB(X,N)),U,P)
.I T=2 S $P(BGPEXCT(X,T),U,2)=$P($G(^BGPEOPB(X,N)),U,P)
.I T=3 S $P(BGPEXCT(X,T),U,2)=$P($G(^BGPEOBB(X,N)),U,P)
Q
;
V(T,R,N,P,ND) ;EP ;SPDX
I $G(BGPAREAA) G VA
NEW X
I T=1 S X=$P($G(^BGPEOCB(R,N)),U,P) Q $S(X]"":X,1:0)
I T=2 S X=$P($G(^BGPEOPB(R,N)),U,P) Q $S(X]"":X,1:0)
I T=3 S X=$P($G(^BGPEOBB(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(^BGPEOCB(X,N)),U,P)
.I T=2 S C=C+$P($G(^BGPEOPB(X,N)),U,P)
.I T=3 S C=C+$P($G(^BGPEOBB(X,N)),U,P)
.I $G(BGPAREAA),$P($G(^BGPEOMIB(BGPPC,14)),U) D ;SPDX
..I T=1 S $P(BGPSDP(X,T),U,ND)=$P($G(^BGPEOCB(X,N)),U,P) ;SPDX
..I T=2 S $P(BGPSDP(X,T),U,ND)=$P($G(^BGPEOPB(X,N)),U,P) ;SPDX
..I T=3 S $P(BGPSDP(X,T),U,ND)=$P($G(^BGPEOBB(X,N)),U,P) ;SPDX
.I $G(BGPAREAA),$P($G(^BGPEOMIB(BGPPC,15)),U) D ;SPDX
..I T=1 S $P(BGPSDPN(X,T),U,ND)=$P($G(^BGPEOCB(X,N)),U,P) ;SPDX
..I T=2 S $P(BGPSDPN(X,T),U,ND)=$P($G(^BGPEOPB(X,N)),U,P) ;SPDX
..I T=3 S $P(BGPSDPN(X,T),U,ND)=$P($G(^BGPEOBB(X,N)),U,P) ;SPDX
.I $G(BGPAREAA),$P($G(^BGPEOMIB(BGPPC,19)),U) D ;SPDX
..I T=1 S $P(BGPSDPO(X,T),U,ND)=$P($G(^BGPEOCB(X,N)),U,P) ;SPDX
..I T=2 S $P(BGPSDPO(X,T),U,ND)=$P($G(^BGPEOPB(X,N)),U,P) ;SPDX
..I T=3 S $P(BGPSDPO(X,T),U,ND)=$P($G(^BGPEOBB(X,N)),U,P) ;SPDX
.Q
Q $S(C]"":C,1:0)
;
C(X,X2,X3) ;
D COMMA^%DTC
Q X
SDP ;SDPX
;loop thru each BGPSDP and set 3rd piece
NEW X,Y,T,D,N
S X=0 F S X=$O(BGPSDP(X)) Q:X'=+X D
.S T=0 F S T=$O(BGPSDP(X,T)) Q:T'=+T D
..S D=$P(BGPSDP(X,T),U,1),N=$P(BGPSDP(X,T),U,2)
..S $P(BGPSDP(X,T),U,3)=$S(D:((N/D)*100),1:"")
S X=0 F S X=$O(BGPSDPN(X)) Q:X'=+X D
.S T=0 F S T=$O(BGPSDPN(X,T)) Q:T'=+T D
..S D=$P(BGPSDPN(X,T),U,1),N=$P(BGPSDPN(X,T),U,2)
..S $P(BGPSDPN(X,T),U,3)=$S(D:((N/D)*100),1:"")
S X=0 F S X=$O(BGPSDPO(X)) Q:X'=+X D
.S T=0 F S T=$O(BGPSDPO(X,T)) Q:T'=+T D
..S D=$P(BGPSDPO(X,T),U,1),N=$P(BGPSDPO(X,T),U,2)
..S $P(BGPSDPO(X,T),U,3)=$S(D:((N/D)*100),1:"")
Q
;
SB(X) ;EP - Strip leading and trailing blanks from X.
NEW %
X ^DD("FUNC",$O(^DD("FUNC","B","STRIPBLANKS",0)),1)
Q X
BGP2EOP1 ; IHS/CMI/LAB - EO report print ;
+1 ;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
+2 ;
IREG ;EP
+1 IF BGPPTYPE="P"
IF $Y>(BGPIOSL-8)
DO HEADER^BGP2EOP
IF BGPQUIT
QUIT
+2 ;D W^BGP2EOH(^BGPEOMB(BGPIC,53,1,0),0,2,BGPPTYPE)
+3 DO H1^BGP2EOP
+4 SET BGPORDP=$PIECE(^BGPEOMB(BGPIC,0),U,6)
FOR BGPORDP1=1:1:$PIECE(^BGPEOMB(BGPIC,0),U,4)
SET BGPPC1=BGPORDP_"."_BGPORDP1
IF BGPQUIT
QUIT
DO PI
+5 QUIT
+6 ;
PI ;EP
+1 SET BGPDENP=0
+2 SET BGPPC2=0
FOR
SET BGPPC2=$ORDER(^BGPEOMIB("AO",BGPPC1,BGPPC2))
IF BGPPC2=""
QUIT
SET BGPPC=$ORDER(^BGPEOMIB("AO",BGPPC1,BGPPC2,0))
DO PI1
+3 QUIT
+4 ;
PI1 ;EP
+1 ;SDPX
KILL BGPEXCT,BGPSDP,BGPSDPN,BGPSDPO
+2 SET BGPDF=$PIECE(^BGPEOMIB(BGPPC,0),U,4)
+3 ;get denominator value
+4 SET BGPNP=$PIECE(^DD(90549.1,BGPDF,0),U,4)
SET N=$PIECE(BGPNP,";")
SET P=$PIECE(BGPNP,";",2)
+5 ;SPDX
SET BGPCYD=$$V(1,BGPRPT,N,P,1)
IF $GET(BGPAREAA)
DO SETEXA(1,N,P)
+6 ;SPDX
SET BGPPRD=$$V(2,BGPRPT,N,P,1)
IF $GET(BGPAREAA)
DO SETEXA(2,N,P)
+7 ;SPDX
SET BGPBLD=$$V(3,BGPRPT,N,P,1)
IF $GET(BGPAREAA)
DO SETEXA(3,N,P)
+8 ;write out denominator
+9 IF 'BGPDENP
Begin DoDot:1
+10 IF BGPPTYPE="P"
IF $Y>(BGPIOSL-10)
DO HEADER^BGP2EOP
IF BGPQUIT
QUIT
DO W^BGP2EOH(^BGPEOMB(BGPIC,53,1,0),0,2,BGPPTYPE)
IF $DATA(^BGPEOMB(BGPIC,53,2,0))
DO W^BGP2EOH(^BGPEOMB(BGPIC,53,2,0),0,1,BGPPTYPE)
DO H1^BGP2EOP
+11 DO W^BGP2EOH($PIECE(^BGPEOMIB(BGPPC,0),U,9),0,2,BGPPTYPE)
+12 IF $PIECE(^BGPEOMIB(BGPPC,0),U,10)]""
DO W^BGP2EOH($PIECE(^BGPEOMIB(BGPPC,0),U,10),0,1,BGPPTYPE)
+13 IF $PIECE(^BGPEOMIB(BGPPC,0),U,11)]""
DO W^BGP2EOH($PIECE(^BGPEOMIB(BGPPC,0),U,11),0,1,BGPPTYPE)
+14 IF BGPPTYPE="P"
Begin DoDot:2
+15 DO W^BGP2EOH($$C(BGPCYD,0,8),0,0,BGPPTYPE,1,20)
+16 DO W^BGP2EOH($$C(BGPPRD,0,8),0,0,BGPPTYPE,1,35)
+17 DO W^BGP2EOH($$C(BGPBLD,0,8),0,0,BGPPTYPE,1,58)
+18 DO W^BGP2EOH("",0,1,BGPPTYPE)
End DoDot:2
+19 IF BGPPTYPE="D"
Begin DoDot:2
+20 SET Y=BGPCYD_"^^"_BGPPRD_"^^^"_BGPBLD
DO W^BGP2EOH(Y,0,0,BGPPTYPE,2)
DO W^BGP2EOH(" ",0,1,BGPPTYPE)
End DoDot:2
+21 SET BGPDENP=1
End DoDot:1
+22 ;numerator field
SET BGPNF=$PIECE(^BGPEOMIB(BGPPC,0),U,5)
+23 SET BGPNP=$PIECE(^DD(90549.1,BGPNF,0),U,4)
SET N=$PIECE(BGPNP,";")
SET P=$PIECE(BGPNP,";",2)
+24 DO SETN
+25 ;write header
+26 DO W^BGP2EOH($PIECE(^BGPEOMIB(BGPPC,0),U,6),0,1,BGPPTYPE)
+27 IF $PIECE(^BGPEOMIB(BGPPC,0),U,7)]""
DO W^BGP2EOH($PIECE(^BGPEOMIB(BGPPC,0),U,7),0,1,BGPPTYPE,1,1)
+28 IF $PIECE(^BGPEOMIB(BGPPC,0),U,8)]""
DO W^BGP2EOH($PIECE(^BGPEOMIB(BGPPC,0),U,8),0,1,BGPPTYPE,1,1)
+29 DO H2^BGP2EOP
+30 QUIT
+31 ;
SETN ;EP - set numerator fields
+1 ;SPDX
SET BGPCYN=$$V(1,BGPRPT,N,P,2)
+2 ;SPDX
SET BGPPRN=$$V(2,BGPRPT,N,P,2)
+3 ;SPDX
SET BGPBLN=$$V(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 IF $PIECE($GET(^BGPEOMIB(BGPPC,14)),U)
Begin DoDot:1
+9 SET ^TMP($JOB,"SUMMARY",$PIECE(^BGPSCAT($PIECE(^BGPEOMIB(BGPPC,14),U,5),0),U,4),$PIECE(^BGPEOMIB(BGPPC,14),U,6),BGPPC)=BGPCYP_U_BGPPRP_U_BGPBLP
+10 ;SDPX
IF $GET(BGPAREAA)
Begin DoDot:2
+11 ;SDPX
SET X=0
FOR
SET X=$ORDER(BGPSDP(X))
IF X'=+X
QUIT
Begin DoDot:3
+12 SET ^TMP($JOB,"SUMMARY DETAIL PAGE",$PIECE(^BGPSCAT($PIECE(^BGPEOMIB(BGPPC,14),U,5),0),U,4),$PIECE(^BGPEOMIB(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
+13 SET ^TMP($JOB,"SUMMARYDEL",$PIECE(^BGPSCAT($PIECE(^BGPEOMIB(BGPPC,14),U,5),0),U,4),$PIECE(^BGPEOMIB(BGPPC,14),U,6),BGPPC)=$$SB($JUSTIFY(BGPCYP,5,1))_U_$$SB($JUSTIFY(BGPPRP,5,1))_U_$$SB($JUSTIFY(BGPBLP,5,1))
+14 ;SDPX
IF $GET(BGPAREAA)
Begin DoDot:2
+15 ;SDPX
SET X=0
FOR
SET X=$ORDER(BGPSDP(X))
IF X'=+X
QUIT
Begin DoDot:3
+16 SET A=$PIECE(^BGPSCAT($PIECE(^BGPEOMIB(BGPPC,14),U,5),0),U,4)
+17 SET B=$PIECE(^BGPEOMIB(BGPPC,14),U,6)
+18 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($JUSTIF
Y(BGPCYP,5,1))
End DoDot:3
End DoDot:2
End DoDot:1
+19 ;
+20 IF BGPPTYPE="D"
IF BGPROT="B"
QUIT
CRSEONT1 ;
+1 IF $GET(BGPAREAA)
IF $GET(BGPEXCEL)
Begin DoDot:1
+2 IF $PIECE(^BGPEOMIB(BGPPC,0),U,12)=""
QUIT
+3 ;set each numerator and percent,then set BGPEI
+4 NEW X
SET X=0
FOR
SET X=$ORDER(BGPSUL(X))
IF X'=+X
QUIT
Begin DoDot:2
+5 SET $PIECE(BGPEXCT(X,1),U,1)=$PIECE($GET(^BGPEOCB(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(^BGPEOPB(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(^BGPEOBB(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 SET Y=$PIECE(^BGPEOMIB(BGPPC,0),U,12)
+13 SET $PIECE(BGPEI(X),U,$PIECE(^BGPEOMIB(BGPPC,0),U,12))=$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)
+14 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
+15 QUIT
+16 ;
SL(V) ;
+1 IF V=""
SET V=0
+2 QUIT $$STRIP^XLFSTR($JUSTIFY(V,5,1)," ")
+3 ;
SETEXA(T,N,P) ;EP - set denominator
+1 IF '$GET(BGPEXCEL)
QUIT
+2 NEW X,Y,Z
+3 SET X=0
FOR
SET X=$ORDER(BGPSUL(X))
IF X'=+X
QUIT
Begin DoDot:1
+4 IF T=1
SET $PIECE(BGPEXCT(X,T),U,2)=$PIECE($GET(^BGPEOCB(X,N)),U,P)
+5 IF T=2
SET $PIECE(BGPEXCT(X,T),U,2)=$PIECE($GET(^BGPEOPB(X,N)),U,P)
+6 IF T=3
SET $PIECE(BGPEXCT(X,T),U,2)=$PIECE($GET(^BGPEOBB(X,N)),U,P)
End DoDot:1
+7 QUIT
+8 ;
V(T,R,N,P,ND) ;EP ;SPDX
+1 IF $GET(BGPAREAA)
GOTO VA
+2 NEW X
+3 IF T=1
SET X=$PIECE($GET(^BGPEOCB(R,N)),U,P)
QUIT $SELECT(X]"":X,1:0)
+4 IF T=2
SET X=$PIECE($GET(^BGPEOPB(R,N)),U,P)
QUIT $SELECT(X]"":X,1:0)
+5 IF T=3
SET X=$PIECE($GET(^BGPEOBB(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(^BGPEOCB(X,N)),U,P)
+3 IF T=2
SET C=C+$PIECE($GET(^BGPEOPB(X,N)),U,P)
+4 IF T=3
SET C=C+$PIECE($GET(^BGPEOBB(X,N)),U,P)
+5 ;SPDX
IF $GET(BGPAREAA)
IF $PIECE($GET(^BGPEOMIB(BGPPC,14)),U)
Begin DoDot:2
+6 ;SPDX
IF T=1
SET $PIECE(BGPSDP(X,T),U,ND)=$PIECE($GET(^BGPEOCB(X,N)),U,P)
+7 ;SPDX
IF T=2
SET $PIECE(BGPSDP(X,T),U,ND)=$PIECE($GET(^BGPEOPB(X,N)),U,P)
+8 ;SPDX
IF T=3
SET $PIECE(BGPSDP(X,T),U,ND)=$PIECE($GET(^BGPEOBB(X,N)),U,P)
End DoDot:2
+9 ;SPDX
IF $GET(BGPAREAA)
IF $PIECE($GET(^BGPEOMIB(BGPPC,15)),U)
Begin DoDot:2
+10 ;SPDX
IF T=1
SET $PIECE(BGPSDPN(X,T),U,ND)=$PIECE($GET(^BGPEOCB(X,N)),U,P)
+11 ;SPDX
IF T=2
SET $PIECE(BGPSDPN(X,T),U,ND)=$PIECE($GET(^BGPEOPB(X,N)),U,P)
+12 ;SPDX
IF T=3
SET $PIECE(BGPSDPN(X,T),U,ND)=$PIECE($GET(^BGPEOBB(X,N)),U,P)
End DoDot:2
+13 ;SPDX
IF $GET(BGPAREAA)
IF $PIECE($GET(^BGPEOMIB(BGPPC,19)),U)
Begin DoDot:2
+14 ;SPDX
IF T=1
SET $PIECE(BGPSDPO(X,T),U,ND)=$PIECE($GET(^BGPEOCB(X,N)),U,P)
+15 ;SPDX
IF T=2
SET $PIECE(BGPSDPO(X,T),U,ND)=$PIECE($GET(^BGPEOPB(X,N)),U,P)
+16 ;SPDX
IF T=3
SET $PIECE(BGPSDPO(X,T),U,ND)=$PIECE($GET(^BGPEOBB(X,N)),U,P)
End DoDot:2
+17 QUIT
End DoDot:1
+18 QUIT $SELECT(C]"":C,1:0)
+19 ;
C(X,X2,X3) ;
+1 DO COMMA^%DTC
+2 QUIT X
SDP ;SDPX
+1 ;loop thru each BGPSDP and set 3rd piece
+2 NEW X,Y,T,D,N
+3 SET X=0
FOR
SET X=$ORDER(BGPSDP(X))
IF X'=+X
QUIT
Begin DoDot:1
+4 SET T=0
FOR
SET T=$ORDER(BGPSDP(X,T))
IF T'=+T
QUIT
Begin DoDot:2
+5 SET D=$PIECE(BGPSDP(X,T),U,1)
SET N=$PIECE(BGPSDP(X,T),U,2)
+6 SET $PIECE(BGPSDP(X,T),U,3)=$SELECT(D:((N/D)*100),1:"")
End DoDot:2
End DoDot:1
+7 SET X=0
FOR
SET X=$ORDER(BGPSDPN(X))
IF X'=+X
QUIT
Begin DoDot:1
+8 SET T=0
FOR
SET T=$ORDER(BGPSDPN(X,T))
IF T'=+T
QUIT
Begin DoDot:2
+9 SET D=$PIECE(BGPSDPN(X,T),U,1)
SET N=$PIECE(BGPSDPN(X,T),U,2)
+10 SET $PIECE(BGPSDPN(X,T),U,3)=$SELECT(D:((N/D)*100),1:"")
End DoDot:2
End DoDot:1
+11 SET X=0
FOR
SET X=$ORDER(BGPSDPO(X))
IF X'=+X
QUIT
Begin DoDot:1
+12 SET T=0
FOR
SET T=$ORDER(BGPSDPO(X,T))
IF T'=+T
QUIT
Begin DoDot:2
+13 SET D=$PIECE(BGPSDPO(X,T),U,1)
SET N=$PIECE(BGPSDPO(X,T),U,2)
+14 SET $PIECE(BGPSDPO(X,T),U,3)=$SELECT(D:((N/D)*100),1:"")
End DoDot:2
End DoDot:1
+15 QUIT
+16 ;
SB(X) ;EP - Strip leading and trailing blanks from X.
+1 NEW %
+2 XECUTE ^DD("FUNC",$ORDER(^DD("FUNC","B","STRIPBLANKS",0)),1)
+3 QUIT X
