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

BGP3D5A.m

Go to the documentation of this file.
  1. BGP3D5A ; IHS/CMI/LAB - measure calc ;
  1. ;;13.0;IHS CLINICAL REPORTING;;NOV 20, 2012;Build 81
  1. ;
  1. ALDX(P,BDATE,EDATE) ;EP
  1. NEW BGPLAL,BGPG,X,Y,E,BGPC,BGPP,D,G
  1. S BGPLAL=""
  1. I $G(P)="" Q ""
  1. K BGPG
  1. S Y="BGPG("
  1. S X=P_"^LAST DX [BGP ALCOHOL DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
  1. I $D(BGPG(1)) S BGPLAL=1_U_"POV "_$P(BGPG(1),U,2)_U_$$DATE^BGP3UTL($P(BGPG(1),U))_U_$P(BGPG(1),U)
  1. S BGPC=""
  1. ;go through BH record file and find up to 1 visits in date range
  1. S E=9999999-BDATE,D=9999999-EDATE-1_".99" F S D=$O(^AMHREC("AE",P,D)) Q:D'=+D!($P(D,".")>E)!(BGPC) S V=0 F S V=$O(^AMHREC("AE",P,D,V)) Q:V'=+V!(BGPC) D
  1. .S X=0 F S X=$O(^AMHRPRO("AD",V,X)) Q:X'=+X!(BGPC) S BGPP=$P($G(^AMHRPRO(X,0)),U) D
  1. ..Q:'BGPP
  1. ..S BGPP=$P($G(^AMHPROB(BGPP,0)),U)
  1. ..I BGPP=10 S BGPC=1_U_"BH POV 10"_U_$$DATE^BGP3UTL((9999999-D))_U_(9999999-D) Q
  1. ..I BGPP=27 S BGPC=1_U_"BH POV 27"_U_$$DATE^BGP3UTL((9999999-D))_U_(9999999-D) Q
  1. ..I BGPP=29 S BGPC=1_U_"BH POV 29"_U_$$DATE^BGP3UTL((9999999-D))_U_(9999999-D) Q
  1. ..I $E(BGPP,1,3)=303 S BGPC=1_U_"BH POV "_BGPP_U_$$DATE^BGP3UTL((9999999-D))_U_(9999999-D) Q
  1. ..I $E(BGPP,1,5)=305.0 S BGPC=1_U_"BH POV "_BGPP_U_$$DATE^BGP3UTL((9999999-D))_U_(9999999-D) Q
  1. ..I $E(BGPP,1,3)=291 S BGPC=1_U_"BH POV "_BGPP_U_$$DATE^BGP3UTL((9999999-D))_U_(9999999-D) Q
  1. ..I $E(BGPP,1,5)=357.5 S BGPC=1_U_"BH POV "_BGPP_U_$$DATE^BGP3UTL((9999999-D))_U_(9999999-D) Q
  1. ..Q
  1. I $P(BGPLAL,U,4)<$P(BGPC,U,4) S BGPLAL=BGPC
  1. ;now check pcc and bh problem lists
  1. S T=$O(^ATXAX("B","BGP ALCOHOL DXS",0))
  1. S (X,G)=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G) D
  1. .Q:$P(^AUPNPROB(X,0),U,12)'="A"
  1. .Q:$P(^AUPNPROB(X,0),U,3)>EDATE
  1. .Q:$P(^AUPNPROB(X,0),U,3)<BDATE
  1. .S Y=$P(^AUPNPROB(X,0),U)
  1. .Q:'$$ICD^ATXCHK(Y,T,9)
  1. .S D=$P(^AUPNPROB(X,0),U,3)
  1. .S G=1_U_"PROB LIST "_$P($$ICDDX^ICDCODE(Y),U,2)_U_$$DATE^BGP3UTL((D))_U_(D)
  1. .Q
  1. I $P(BGPLAL,U,4)<$P(G,U,4) S BGPLAL=G
  1. S (X,G)=0 F S X=$O(^AMHPPROB("AC",P,X)) Q:X'=+X!(G) D
  1. .Q:$P(^AMHPPROB(X,0),U,12)'="A"
  1. .Q:$P(^AMHPPROB(X,0),U,3)>EDATE
  1. .Q:$P(^AMHPPROB(X,0),U,3)<BDATE
  1. .S Y=$P(^AMHPPROB(X,0),U)
  1. .S Y=$P($G(^AMHPROB(Y,0)),U)
  1. .I $E(Y,1,3)="303" S G=1_U_"BH PROB LIST "_Y_U_$$DATE^BGP3UTL($P(^AMHPPROB(X,0),U,3))_U_$P(^AMHPPROB(X,0),U,3) Q
  1. .I $E(Y,1,5)="305.0" S G=1_U_"BH PROB LIST "_Y_U_$$DATE^BGP3UTL($P(^AMHPPROB(X,0),U,3))_U_$P(^AMHPPROB(X,0),U,3) Q
  1. .I $E(Y,1,3)=291 S G=1_U_"BH PROB LIST "_Y_U_$$DATE^BGP3UTL($P(^AMHPPROB(X,0),U,3))_U_$P(^AMHPPROB(X,0),U,3) Q
  1. .I $E(Y,1,5)=357.5 S G=1_U_"BH PROB LIST "_Y_U_$$DATE^BGP3UTL($P(^AMHPPROB(X,0),U,3))_U_$P(^AMHPPROB(X,0),U,3) Q
  1. .I Y=10 S G=1_U_"BH PROB LIST "_Y_U_$$DATE^BGP3UTL($P(^AMHPPROB(X,0),U,3))_U_$P(^AMHPPROB(X,0),U,3) Q
  1. .I Y=27 S G=1_U_"BH PROB LIST "_Y_U_$$DATE^BGP3UTL($P(^AMHPPROB(X,0),U,3))_U_$P(^AMHPPROB(X,0),U,3) Q
  1. .I Y=29 S G=1_U_"BH PROB LIST "_Y_U_$$DATE^BGP3UTL($P(^AMHPPROB(X,0),U,3))_U_$P(^AMHPPROB(X,0),U,3) Q
  1. .Q
  1. I $P(BGPLAL,U,4)<$P(G,U,4) S BGPLAL=G
  1. Q BGPLAL