Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BGP2EOP1

BGP2EOP1.m

Go to the documentation of this file. 
  1. BGP2EOP1 ; IHS/CMI/LAB - EO report print ;
  1.  ;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
  1.  ;
  1. IREG ;EP
  1.  I BGPPTYPE="P",$Y>(BGPIOSL-8) D HEADER^BGP2EOP Q:BGPQUIT
  1.  ;D W^BGP2EOH(^BGPEOMB(BGPIC,53,1,0),0,2,BGPPTYPE)
  1.  D H1^BGP2EOP
  1.  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
  1.  Q
  1.  ;
  1. PI ;EP
  1.  S BGPDENP=0
  1.  S BGPPC2=0 F  S BGPPC2=$O(^BGPEOMIB("AO",BGPPC1,BGPPC2)) Q:BGPPC2=""  S BGPPC=$O(^BGPEOMIB("AO",BGPPC1,BGPPC2,0)) D PI1
  1.  Q
  1.  ;
  1. PI1 ;EP
  1.  K BGPEXCT,BGPSDP,BGPSDPN,BGPSDPO ;SDPX
  1.  S BGPDF=$P(^BGPEOMIB(BGPPC,0),U,4)
  1.  ;get denominator value
  1.  S BGPNP=$P(^DD(90549.1,BGPDF,0),U,4),N=$P(BGPNP,";"),P=$P(BGPNP,";",2)
  1.  S BGPCYD=$$V(1,BGPRPT,N,P,1) I $G(BGPAREAA) D SETEXA(1,N,P) ;SPDX
  1.  S BGPPRD=$$V(2,BGPRPT,N,P,1) I $G(BGPAREAA) D SETEXA(2,N,P) ;SPDX
  1.  S BGPBLD=$$V(3,BGPRPT,N,P,1) I $G(BGPAREAA) D SETEXA(3,N,P) ;SPDX
  1.  ;write out denominator
  1.  I 'BGPDENP D
  1.  .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
  1.  .D W^BGP2EOH($P(^BGPEOMIB(BGPPC,0),U,9),0,2,BGPPTYPE)
  1.  .I $P(^BGPEOMIB(BGPPC,0),U,10)]"" D W^BGP2EOH($P(^BGPEOMIB(BGPPC,0),U,10),0,1,BGPPTYPE)
  1.  .I $P(^BGPEOMIB(BGPPC,0),U,11)]"" D W^BGP2EOH($P(^BGPEOMIB(BGPPC,0),U,11),0,1,BGPPTYPE)
  1.  .I BGPPTYPE="P" D
  1.  ..D W^BGP2EOH($$C(BGPCYD,0,8),0,0,BGPPTYPE,1,20)
  1.  ..D W^BGP2EOH($$C(BGPPRD,0,8),0,0,BGPPTYPE,1,35)
  1.  ..D W^BGP2EOH($$C(BGPBLD,0,8),0,0,BGPPTYPE,1,58)
  1.  ..D W^BGP2EOH("",0,1,BGPPTYPE)
  1.  .I BGPPTYPE="D" D
  1.  ..S Y=BGPCYD_"^^"_BGPPRD_"^^^"_BGPBLD D W^BGP2EOH(Y,0,0,BGPPTYPE,2),W^BGP2EOH(" ",0,1,BGPPTYPE)
  1.  .S BGPDENP=1
  1.  S BGPNF=$P(^BGPEOMIB(BGPPC,0),U,5)  ;numerator field
  1.  S BGPNP=$P(^DD(90549.1,BGPNF,0),U,4),N=$P(BGPNP,";"),P=$P(BGPNP,";",2)
  1.  D SETN
  1.  ;write header
  1.  D W^BGP2EOH($P(^BGPEOMIB(BGPPC,0),U,6),0,1,BGPPTYPE)
  1.  I $P(^BGPEOMIB(BGPPC,0),U,7)]"" D W^BGP2EOH($P(^BGPEOMIB(BGPPC,0),U,7),0,1,BGPPTYPE,1,1)
  1.  I $P(^BGPEOMIB(BGPPC,0),U,8)]"" D W^BGP2EOH($P(^BGPEOMIB(BGPPC,0),U,8),0,1,BGPPTYPE,1,1)
  1.  D H2^BGP2EOP
  1.  Q
  1.  ;
  1. SETN ;EP - set numerator fields
  1.  S BGPCYN=$$V(1,BGPRPT,N,P,2) ;SPDX
  1.  S BGPPRN=$$V(2,BGPRPT,N,P,2) ;SPDX
  1.  S BGPBLN=$$V(3,BGPRPT,N,P,2) ;SPDX
  1.  S BGPCYP=$S(BGPCYD:((BGPCYN/BGPCYD)*100),1:"")
  1.  S BGPPRP=$S(BGPPRD:((BGPPRN/BGPPRD)*100),1:"")
  1.  S BGPBLP=$S(BGPBLD:((BGPBLN/BGPBLD)*100),1:"")
  1.  I $G(BGPAREAA) D SDP
  1.  I $P($G(^BGPEOMIB(BGPPC,14)),U) D
  1.  .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
  1.  .I $G(BGPAREAA) D  ;SDPX
  1.  ..S X=0 F  S X=$O(BGPSDP(X)) Q:X'=+X  D  ;SDPX
  1.  ...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)
  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))
  1.  .I $G(BGPAREAA) D  ;SDPX
  1.  ..S X=0 F  S X=$O(BGPSDP(X)) Q:X'=+X  D  ;SDPX
  1.  ...S A=$P(^BGPSCAT($P(^BGPEOMIB(BGPPC,14),U,5),0),U,4)
  1.  ...S B=$P(^BGPEOMIB(BGPPC,14),U,6)
  1.  ...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))
  1.  ;
  1.  I BGPPTYPE="D",BGPROT="B" Q
  1. CRSEONT1 ;
  1.  I $G(BGPAREAA),$G(BGPEXCEL) D
  1.  .Q:$P(^BGPEOMIB(BGPPC,0),U,12)=""
  1.  .;set each numerator and percent,then set BGPEI
  1.  .NEW X S X=0 F  S X=$O(BGPSUL(X)) Q:X'=+X  D
  1.  ..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:"")
  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:"")
  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:"")
  1.  .S X=0 F  S X=$O(BGPEXCT(X)) Q:X'=+X  D
  1.  ..S A=$P(BGPEXCT(X,1),U,1),B=$P(BGPEXCT(X,1),U,2),C=$P(BGPEXCT(X,1),U,3)
  1.  ..S D=$P(BGPEXCT(X,2),U,1),E=$P(BGPEXCT(X,2),U,2),F=$P(BGPEXCT(X,2),U,3)
  1.  ..S G=$P(BGPEXCT(X,3),U,1),H=$P(BGPEXCT(X,3),U,2),I=$P(BGPEXCT(X,3),U,3)
  1.  ..S Y=$P(^BGPEOMIB(BGPPC,0),U,12)
  1.  ..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)
  1.  ..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)
  1.  Q
  1.  ;
  1. SL(V) ;
  1.  I V="" S V=0
  1.  Q $$STRIP^XLFSTR($J(V,5,1)," ")
  1.  ;
  1. SETEXA(T,N,P) ;EP - set denominator
  1.  Q:'$G(BGPEXCEL)
  1.  NEW X,Y,Z
  1.  S X=0 F  S X=$O(BGPSUL(X)) Q:X'=+X  D
  1.  .I T=1 S $P(BGPEXCT(X,T),U,2)=$P($G(^BGPEOCB(X,N)),U,P)
  1.  .I T=2 S $P(BGPEXCT(X,T),U,2)=$P($G(^BGPEOPB(X,N)),U,P)
  1.  .I T=3 S $P(BGPEXCT(X,T),U,2)=$P($G(^BGPEOBB(X,N)),U,P)
  1.  Q
  1.  ;
  1. V(T,R,N,P,ND) ;EP ;SPDX
  1.  I $G(BGPAREAA) G VA
  1.  NEW X
  1.  I T=1 S X=$P($G(^BGPEOCB(R,N)),U,P) Q $S(X]"":X,1:0)
  1.  I T=2 S X=$P($G(^BGPEOPB(R,N)),U,P) Q $S(X]"":X,1:0)
  1.  I T=3 S X=$P($G(^BGPEOBB(R,N)),U,P) Q $S(X]"":X,1:0)
  1.  Q ""
  1. VA ;
  1.  NEW X,V,C S X=0,C="" F  S X=$O(BGPSUL(X)) Q:X'=+X  D
  1.  .I T=1 S C=C+$P($G(^BGPEOCB(X,N)),U,P)
  1.  .I T=2 S C=C+$P($G(^BGPEOPB(X,N)),U,P)
  1.  .I T=3 S C=C+$P($G(^BGPEOBB(X,N)),U,P)
  1.  .I $G(BGPAREAA),$P($G(^BGPEOMIB(BGPPC,14)),U) D  ;SPDX
  1.  ..I T=1 S $P(BGPSDP(X,T),U,ND)=$P($G(^BGPEOCB(X,N)),U,P) ;SPDX
  1.  ..I T=2 S $P(BGPSDP(X,T),U,ND)=$P($G(^BGPEOPB(X,N)),U,P) ;SPDX
  1.  ..I T=3 S $P(BGPSDP(X,T),U,ND)=$P($G(^BGPEOBB(X,N)),U,P) ;SPDX
  1.  .I $G(BGPAREAA),$P($G(^BGPEOMIB(BGPPC,15)),U) D  ;SPDX
  1.  ..I T=1 S $P(BGPSDPN(X,T),U,ND)=$P($G(^BGPEOCB(X,N)),U,P) ;SPDX
  1.  ..I T=2 S $P(BGPSDPN(X,T),U,ND)=$P($G(^BGPEOPB(X,N)),U,P) ;SPDX
  1.  ..I T=3 S $P(BGPSDPN(X,T),U,ND)=$P($G(^BGPEOBB(X,N)),U,P) ;SPDX
  1.  .I $G(BGPAREAA),$P($G(^BGPEOMIB(BGPPC,19)),U) D  ;SPDX
  1.  ..I T=1 S $P(BGPSDPO(X,T),U,ND)=$P($G(^BGPEOCB(X,N)),U,P) ;SPDX
  1.  ..I T=2 S $P(BGPSDPO(X,T),U,ND)=$P($G(^BGPEOPB(X,N)),U,P) ;SPDX
  1.  ..I T=3 S $P(BGPSDPO(X,T),U,ND)=$P($G(^BGPEOBB(X,N)),U,P) ;SPDX
  1.  .Q
  1.  Q $S(C]"":C,1:0)
  1.  ;
  1. C(X,X2,X3) ;
  1.  D COMMA^%DTC
  1.  Q X
  1. SDP ;SDPX
  1.  ;loop thru each BGPSDP and set 3rd piece
  1.  NEW X,Y,T,D,N
  1.  S X=0 F  S X=$O(BGPSDP(X)) Q:X'=+X  D
  1.  .S T=0 F  S T=$O(BGPSDP(X,T)) Q:T'=+T  D
  1.  ..S D=$P(BGPSDP(X,T),U,1),N=$P(BGPSDP(X,T),U,2)
  1.  ..S $P(BGPSDP(X,T),U,3)=$S(D:((N/D)*100),1:"")
  1.  S X=0 F  S X=$O(BGPSDPN(X)) Q:X'=+X  D
  1.  .S T=0 F  S T=$O(BGPSDPN(X,T)) Q:T'=+T  D
  1.  ..S D=$P(BGPSDPN(X,T),U,1),N=$P(BGPSDPN(X,T),U,2)
  1.  ..S $P(BGPSDPN(X,T),U,3)=$S(D:((N/D)*100),1:"")
  1.  S X=0 F  S X=$O(BGPSDPO(X)) Q:X'=+X  D
  1.  .S T=0 F  S T=$O(BGPSDPO(X,T)) Q:T'=+T  D
  1.  ..S D=$P(BGPSDPO(X,T),U,1),N=$P(BGPSDPO(X,T),U,2)
  1.  ..S $P(BGPSDPO(X,T),U,3)=$S(D:((N/D)*100),1:"")
  1.  Q
  1.  ;
  1. SB(X) ;EP - Strip leading and trailing blanks from X.
  1.  NEW %
  1.  X ^DD("FUNC",$O(^DD("FUNC","B","STRIPBLANKS",0)),1)
  1.  Q X