BGP9D72 ; IHS/CMI/LAB - measure 31 ;
;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009
;
;
IHEDBBH ;EP
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
S BGPVALUE="" K BGPBETA
I BGPAGEB<36 S BGPSTOP=1 Q
I 'BGPACTUP S BGPSTOP=1 Q
S BGPAMI=$$AMIH(DFN,BGPBDATE,$$FMADD^XLFDT(BGPBDATE,(51*7)))
I '$P(BGPAMI,U) S BGPSTOP=1 Q ;no ami
I $$READM(DFN,$P(BGPAMI,U,4),$P(BGPAMI,U,2)) S BGPSTOP=1 Q
S BGPV=$P(BGPAMI,U,3)
S BGPBETAC=$$BETACONT(DFN,"",$S($P(BGPAMI,U,4)]"":$P(BGPAMI,U,4),1:$P(BGPAMI,U,2))) ;beta contraindications
I $P(BGPBETAC,U) S BGPSTOP=1 Q ;beta contraindication
S BGPBETAL=$$BETAALG1(DFN,$S($P(BGPAMI,U,4)]"":$P(BGPAMI,U,4),1:$P(BGPAMI,U,2))) ;beta allergy
I $P(BGPBETAL,U) S BGPSTOP=1 Q
I BGPACTCL S BGPD1=1
I BGPACTUP S BGPD2=1
S BGPBETA=$$BETA7(DFN,$$FMADD^XLFDT($P(BGPAMI,U,2),-60),$$FMADD^XLFDT($P(BGPAMI,U,4),7),$P(BGPAMI,U,4))
I $P(BGPBETA,U)=1 S BGPN1=1
S BGPVALUE=$S(BGPRTYPE=3:"",BGPD2:"UP",1:"")_$S(BGPD1:";AC",1:"")_"|||"_$S($P(BGPBETA,U):$P(BGPBETA,U,2)_" "_$P(BGPBETA,U,3),1:"")
K BGPAMI,BGPBETA,BGPBETAC,BGPBETAL
K ^TMP($J)
Q
IHEDPBH ;EP
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
K BGPBETA,BGPAMI,BGPV,BGPBETAC,BGPBETAL,BGPVALUE
I BGPAGEB<18 S BGPSTOP=1 Q
I 'BGPACTUP S BGPSTOP=1 Q
S BGPAMI=$$AMI(DFN,$$FMADD^XLFDT(BGPBDATE,-180),$$FMADD^XLFDT(BGPBDATE,180))
I '$P(BGPAMI,U) S BGPSTOP=1 Q ;no ami
S BGPBETAC=$$BETACONT(DFN,"",$S($P(BGPAMI,U,4)]"":$P(BGPAMI,U,4),1:$P(BGPAMI,U,2))) ;beta contraindications
I $P(BGPBETAC,U) S BGPSTOP=1 Q ;beta contraindication
S BGPBETAL=$$BETAALG1(DFN,$S($P(BGPAMI,U,4)]"":$P(BGPAMI,U,4),1:$P(BGPAMI,U,2))) ;beta allergy
I $P(BGPBETAL,U) S BGPSTOP=1 Q
I BGPACTCL S BGPD1=1
I BGPACTUP S BGPD2=1
S BGPBETA=$$BETA(DFN,$P(BGPAMI,U,2),$P(BGPAMI,U,4))
I $P(BGPBETA,U)=1 S BGPN1=1
S BGPVALUE=$S(BGPRTYPE=3:"",BGPD2:"UP")_$S(BGPD1:";AC",1:"")_"|||"_$S($P(BGPBETA,U):"YES, beta blocker 135+ "_$P(BGPBETA,U,2),1:"")
K BGPAMI,BGPBETA,BGPBETAC,BGPBETAL
K ^TMP($J)
Q
IHEDCHM ;EP
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
I BGPAGEB<18 S BGPSTOP=1 Q
I BGPAGEB>75 S BGPSTOP=1 Q
I 'BGPACTUP S BGPSTOP=1 Q
S BGPAMI=$$AMIO(DFN,BGPBDATE,BGPEDATE) I '$P(BGPAMI,U) S BGPSTOP=1 Q
I BGPACTUP S BGPD2=1
I BGPACTCL S BGPD1=1
I BGPRTYPE=3,'BGPD1 S BGPSTOP=1 Q
S BGPLDL=$$LDL^BGP9D2(DFN,BGPBDATE,BGPEDATE,$S(BGPRTYPE=3:1,1:""))
I $P(BGPLDL,U)=1 S BGPN1=1
I $P(BGPLDL,U,3)]"",BGPRTYPE'=3 D
.S V=$P(BGPLDL,U,3)
.I V["CPT" S:V["3048F" BGPN2=1 Q
.S V=+V
.I 'V Q
.I V]"",+V'>100 S BGPN2=1
.I +V>100,+V<131 S BGPN3=1
.I +V>130 S BGPN4=1
I $P(BGPLDL,U,3)]"",BGPRTYPE=3 D ;HEDIS ONLY
.S V=$P(BGPLDL,U,3)
.I V["CPT" S:V["3048F" BGPN2=1 Q
.S V=+V
.I 'V Q
.I V]"",+V<100 S BGPN2=1
S BGPXPNV=$P(BGPLDL,U,3)
S V=$S(BGPRTYPE=3:"",1:"UP")_$S(BGPD1:";AC",1:"")_";"_$P(BGPAMI,U,2)_"|||"
I $P(BGPLDL,U) S V=V_"LDL "_$$DATE^BGP9UTL($P(BGPLDL,U,2))_" "_$P(BGPLDL,U,3)
S BGPVALUE=V
K V,BGPAMI,BGPLDL,D
K ^TMP($J)
Q
CHOL(P,BDATE,EDATE) ;
K BGPG
S (Q,R,S,M,N,O,B,D,E,L,G)=""
S R=$O(^ATXLAB("B","DM AUDIT CHOLESTEROL TAX",0))
S N=$O(^ATXAX("B","BGP TOTAL CHOLESTEROL LOINC",0))
S B=9999999-BDATE,E=9999999-EDATE S D=E-1 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(D>B)!(G]"") D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(G]"") D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(G]"") D
...Q:'$D(^AUPNVLAB(X,0))
...I R,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(R,21,"B",$P(^AUPNVLAB(X,0),U))) S G=(9999999-D)_"^CHOL"_"^"_$P(^AUPNVLAB(X,0),U,4) Q
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...I $$LOINC(J,N) S G=(9999999-D)_"^CHOL LOINC"_"^"_$P(^AUPNVLAB(X,0),U,4) Q
...Q
I G]"" Q G
S E=+$$CODEN^ICPTCOD(82465),%=$$CPTI^BGP9DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)_"^CPT 82465"
S E=+$$CODEN^ICPTCOD(82465),%=$$TRANI^BGP9DU(P,BDATE,EDATE,E) I %]"" Q $P(%,U,2)_"^TRAN 82465"
Q ""
LOINC(A,B) ;
NEW %
S %=$P($G(^LAB(95.3,A,9999999)),U,2)
I %]"",$D(^ATXAX(B,21,"B",%)) Q 1
S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)
I $D(^ATXAX(B,21,"B",%)) Q 1
Q ""
AMIO(P,BDATE,EDATE) ;
NEW BGPG
K BGPG
S Y="BGPG("
S X=P_"^LAST DX [BGP AMI DXS (HEDIS);DURING "_$$FMADD^XLFDT(BDATE,-365)_"-"_$$FMADD^XLFDT(BDATE,-60) S E=$$START1^APCLDF(X,Y)
I $D(BGPG(1)) Q 1_U_"AMI DX" ;has a dx
;check for procedure in BGP CABG PROCS
S BGPG=$$LASTPRC^BGP9UTL1(P,"BGP CABG PROCS",$$FMADD^XLFDT(BDATE,-365),$$FMADD^XLFDT(BDATE,-60))
I $P(BGPG,U) Q 1_U_"CABG PROC"
;now check cpts
S BGPG=$$CPT^BGP9DU(P,$$FMADD^XLFDT(BDATE,-365),$$FMADD^XLFDT(BDATE,-60),$O(^ATXAX("B","BGP CABG CPTS",0)),6)
I $P(BGPG,U) Q 1_U_"CABG CPT"
S BGPG=$$TRAN^BGP9DU(P,$$FMADD^XLFDT(BDATE,-365),$$FMADD^XLFDT(BDATE,-60),$O(^ATXAX("B","BGP CABG CPTS",0)),6)
I $P(BGPG,U) Q 1_U_"CABG TRAN"
;check for procedure in BGP PTCA PROCS
S BGPG=$$LASTPRC^BGP9UTL1(P,"BGP PTCA PROCS",$$FMADD^XLFDT(BDATE,-365),$$FMADD^XLFDT(BDATE,-60))
I $P(BGPG,U) Q 1_U_"PTCA PROC"
;now check cpts
S BGPG=$$CPT^BGP9DU(P,$$FMADD^XLFDT(BDATE,-365),$$FMADD^XLFDT(BDATE,-60),$O(^ATXAX("B","BGP PTCA CPTS",0)),6)
I $P(BGPG,U) Q 1_U_"PTCA CPT"
S BGPG=$$TRAN^BGP9DU(P,$$FMADD^XLFDT(BDATE,-365),$$FMADD^XLFDT(BDATE,-60),$O(^ATXAX("B","BGP PTCA CPTS",0)),6)
I $P(BGPG,U) Q 1_U_"PTCA TRAN"
;now check IVD dxs
S BGPG(1)=$$LASTDX^BGP9UTL1(P,"BGP IVD DXS",BDATE,EDATE)
S BGPG(2)=$$LASTDX^BGP9UTL1(P,"BGP IVD DXS",$$FMADD^XLFDT(BDATE,-365),BDATE)
I $P(BGPG(1),U),$P(BGPG(2),U) Q 1_U_"IVD DXS"
Q ""
AMI(P,BDATE,EDATE) ;
;look for any H with AMI discharge dx
K ^TMP($J,"A"),G
S A="^TMP($J,""A"",",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
I '$D(^TMP($J,"A",1)) Q 0 ;no HOSP
S T=$O(^ATXAX("B","BGP AMI DXS (HEDIS)",0))
S (BGPX,G,M,D,E)=0 F S BGPX=$O(^TMP($J,"A",BGPX)) Q:BGPX'=+BGPX S V=$P(^TMP($J,"A",BGPX),U,5) D
.Q:'$D(^AUPNVSIT(V,0))
.Q:'$P(^AUPNVSIT(V,0),U,9)
.Q:$P(^AUPNVSIT(V,0),U,11)
.;Q:$P(^AUPNVSIT(V,0),U,6)'=DUZ(2)
.Q:"AOSH"'[$P(^AUPNVSIT(V,0),U,7)
.S H=0
.I $P(^AUPNVSIT(V,0),U,7)="H" S H=$O(^AUPNVINP("AD",V,0)) D Q:'B
..S B=0
..I 'H Q
..Q:$$AMA(H) ;ama
..Q:$$TRANS(H) ;transferred
..Q:$$EXPIRED(H) ;died
..S B=1
.S (D,Y)=0 F S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(D) I $D(^AUPNVPOV(Y,0)) S %=$P(^AUPNVPOV(Y,0),U) I $$ICD^ATXCHK(%,T,9) S D=1
.I D S G=G+1,G($P($P(^AUPNVSIT(V,0),U),"."))=V ;got one visit
I 'G Q G
S D=$O(G(0)),V=G(D),H=$O(^AUPNVINP("AD",V,0))
Q 1_U_$O(G(0))_U_V_U_$S(H:$P($P(^AUPNVINP(H,0),U),"."),1:"")_U_H
;
AMIH(P,BDATE,EDATE) ;
;look for any H with AMI discharge dx
K ^TMP($J,"A"),G
S A="^TMP($J,""A"",",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
I '$D(^TMP($J,"A",1)) Q 0 ;no HOSP
S T=$O(^ATXAX("B","BGP AMI IND 30",0))
S (BGPX,G,M,D,E)=0 F S BGPX=$O(^TMP($J,"A",BGPX)) Q:BGPX'=+BGPX S V=$P(^TMP($J,"A",BGPX),U,5) D
.Q:'$D(^AUPNVSIT(V,0))
.Q:'$P(^AUPNVSIT(V,0),U,9)
.Q:$P(^AUPNVSIT(V,0),U,11)
.;Q:$P(^AUPNVSIT(V,0),U,6)'=DUZ(2)
.Q:$P(^AUPNVSIT(V,0),U,7)'="H"
.S H=0
.S H=$O(^AUPNVINP("AD",V,0)) D Q:'B
..S B=0
..I 'H Q
..Q:$P($P(^AUPNVINP(H,0),U),".")>EDATE
..Q:$$AMA(H) ;ama
..Q:$$TRANS(H) ;transferred
..Q:$$EXPIRED(H) ;died
..S B=1
.S (D,Y)=0 F S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(D) I $D(^AUPNVPOV(Y,0)) S %=$P(^AUPNVPOV(Y,0),U) I $$ICD^ATXCHK(%,T,9) S D=1
.I D S G=G+1,G($P($P(^AUPNVSIT(V,0),U),"."))=V ;got one visit
I 'G Q G
S D=$O(G(0)),V=G(D),H=$O(^AUPNVINP("AD",V,0))
Q 1_U_$O(G(0))_U_V_U_$S(H:$P($P(^AUPNVINP(H,0),U),"."),1:"")_U_H
READM(P,D,PV) ;EP
S ED=$$FMADD^XLFDT(D,7),G=0
S X=0,V=0 F S X=$O(^AUPNVSIT("AAH",P,X)) Q:X'=+X D
.S V=0 F S V=$O(^AUPNVSIT("AAH",P,X,V)) Q:V'=+V D
..Q:PV=V
..S E=$P($P($G(^AUPNVSIT(V,0)),U),".")
..Q:E<D
..Q:E>ED
..S G=1
Q G
BETACONT(P,BDATE,EDATE) ;EP BETA BLOCKER CONTRAINDICATION
I $G(BDATE)="" S BDATE=$$DOB^AUPNPAT(P)
K BGPG,BGPD
S Y="BGPG("
S X=P_"^ALL DX [BGP ASTHMA DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
S (X,G)=0 F S X=$O(BGPG(X)) Q:X'=+X S BGPD($P(BGPG(X),U))=""
S (X,G)=0 F S X=$O(BGPD(X)) Q:X'=+X S G=G+1
I G>1 Q 1_U_"2 dx asthma contra" ;has 2 dx of asthma so contraindication
S BGPG=$$LASTDX^BGP9UTL1(P,"BGP HYPOTENSION DXS",$$DOB^AUPNPAT(P),EDATE)
I $P(BGPG,U)=1 Q 1_U_"hypotension dx contra" ;has hypotension dx
S BGPG=$$LASTDX^BGP9UTL1(P,"BGP CMS 2/3 HEART BLOCK DXS",$$DOB^AUPNPAT(P),EDATE)
I $P(BGPG,U)=1 Q 1_U_"heart blk contra" ;has heart block dx
K BGPG,BGPD
S Y="BGPG("
S X=P_"^ALL DX [BGP COPD DXS BB CONT;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
S (X,G)=0 F S X=$O(BGPG(X)) Q:X'=+X S BGPD($P(BGPG(X),U))=""
S (X,G)=0 F S X=$O(BGPD(X)) Q:X'=+X S G=G+1
I G>1 Q 1_U_"copd dx contra"
Q 0
AMA(H) ;EP
S X=$P(^AUPNVINP(H,0),U,6)
I X="" Q 0
S X=$P($G(^DG(405.1,X,"IHS")),U,1)
I X=3 Q 1
Q 0
EXPIRED(H) ;EP
S X=$P(^AUPNVINP(H,0),U,6)
I X="" Q 0
S X=$P($G(^DG(405.1,X,"IHS")),U,1)
I X=4!(X=5)!(X=6)!(X=7) Q 1
Q 0
DSCH(H) ;
Q $P($P(^AUPNVINP(H,0),U),".")
TRANS(H) ;EP
S X=$P(^AUPNVINP(H,0),U,6)
I X="" Q 0
S X=$P($G(^DG(405.1,X,"IHS")),U,1)
I X=2 Q 1
Q 0
BETA(P,BGPADMD,BGPDD) ;EP
;get all beta blockers
I BGPADMD="" Q ""
K ^TMP($J,"MEDS")
S BGPC1=0 K BGPZ
I $G(BGPDD)="" S BGPDD=BGPADMD
S (G,N,Y,X,T,T1,T2,M,K,S,C,K,R)=""
S Y="^TMP($J,""MEDS"",",X=P_"^ALL MED;DURING "_$$FMTE^XLFDT(BGPADMD)_"-"_$$FMTE^XLFDT($$FMADD^XLFDT(BGPDD,180)) S E=$$START1^APCLDF(X,Y)
S T=$O(^ATXAX("B","BGP HEDIS BETA BLOCKER MEDS",0))
S T1=$O(^ATXAX("B","BGP HEDIS BETA BLOCKER NDC",0))
S X=0 F S X=$O(^TMP($J,"MEDS",X)) Q:X'=+X S Y=+$P(^TMP($J,"MEDS",X),U,4) D
.Q:'$D(^AUPNVMED(Y,0))
.S G=0
.S D=$P(^AUPNVMED(Y,0),U)
.I T,$D(^ATXAX(T,21,"B",D)) S G=1 G BETA1
.S C=$P($G(^PSDRUG(D,0)),U,2)
.S N=$P($G(^PSDRUG(D,2)),U,4)
.I N]"",T1,$D(^ATXAX(T1,21,"B",N)) S G=1
.Q:'G
BETA1 .;
.S J=$P(^AUPNVMED(Y,0),U,8)
.S V=$P(^AUPNVMED(Y,0),U,3)
.Q:'V
.Q:'$D(^AUPNVSIT(V,0))
.;S IS DAYS SUPPLY, J IS DATE DISCONTINUED
.I J]"" S S=$$FMDIFF^XLFDT(J,$P($P(^AUPNVSIT(V,0),U),"."))
.I J="" S S=$P(^AUPNVMED(Y,0),U,7)
.S K=S+K ;TOTAL DAYS SUPPLY
.I R]"" S R=R_";"
.S R=R_$$DATE^BGP9UTL($P($P(^AUPNVSIT(V,0),U),"."))_"("_S_")"
I K>134 Q 1_U_" total days beta blocker: "_K
BETAADM ;now add in any before admission
K ^TMP($J,"MEDS")
S Y="^TMP($J,""MEDS"",",X=P_"^LAST 30 MED;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT($$FMADD^XLFDT(BGPADMD,-1)) S E=$$START1^APCLDF(X,Y)
S X=0 F S X=$O(^TMP($J,"MEDS",X)) Q:X'=+X S Y=+$P(^TMP($J,"MEDS",X),U,4) D
.Q:'$D(^AUPNVMED(Y,0))
.S G=0
.S D=$P(^AUPNVMED(Y,0),U)
.I T,$D(^ATXAX(T,21,"B",D)) S G=1 G BETA2
.S C=$P($G(^PSDRUG(D,0)),U,2)
.I C]"",T2,$D(^ATXAX(T2,21,"B",C)) S G=1 G BETA2
.S N=$P($G(^PSDRUG(D,2)),U,4)
.I N]"",T1,$D(^ATXAX(T1,21,"B",N)) S G=1
.Q:'G
BETA2 .;
.S J=$P(^AUPNVMED(Y,0),U,8)
.S V=$P(^AUPNVMED(Y,0),U,3)
.Q:'V
.Q:'$D(^AUPNVSIT(V,0))
.;S IS DAYS SUPPLY, J IS DATE DISCONTINUED
.Q:J]"" ;don't use if discontinued
.S D=$$FMDIFF^XLFDT(BGPDD,$P($P(^AUPNVSIT(V,0),U),".")) ;difference between dsch date and date prescribed
.S S=$P(^AUPNVMED(Y,0),U,7)
.S S=S-D ;subtract the number of days used
.S:S<0 S=0
.S K=S+K ;TOTAL DAYS SUPPLY
.I R]"" S R=R_";"
.S R=R_$$DATE^BGP9UTL($P($P(^AUPNVSIT(V,0),U),"."))_"("_S_")"
I K>134 Q 1_U_" total days beta blocker: "_K
Q 0_U_R_" total days beta blocker: "_K
BETA7(P,BDATE,EDATE,BGPDD) ;
;see if there ACTIVE PRESCRIPTION of beta blockers in time window
K ^TMP($J,"MEDS")
S BGPG=0
S Y="^TMP($J,""MEDS"",",X=P_"^ALL MED;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
S T=$O(^ATXAX("B","BGP HEDIS BETA BLOCKER MEDS",0))
S T1=$O(^ATXAX("B","BGP HEDIS BETA BLOCKER NDC",0))
;S T2=$O(^ATXAX("B","BGP HEDIS BETA BLOCKER CLASS",0))
S X=0 F S X=$O(^TMP($J,"MEDS",X)) Q:X'=+X!(BGPG) S Y=+$P(^TMP($J,"MEDS",X),U,4) D
.Q:'$D(^AUPNVMED(Y,0))
.S G=0
.S D=$P(^AUPNVMED(Y,0),U)
.I T,$D(^ATXAX(T,21,"B",D)) S G=1 G BETA8
.S C=$P($G(^PSDRUG(D,0)),U,2)
.;I C]"",T2,$D(^ATXAX(T2,21,"B",C)) S G=1 G BETA8
.S N=$P($G(^PSDRUG(D,2)),U,4)
.I N]"",T1,$D(^ATXAX(T1,21,"B",N)) S G=1
.Q:'G ;NOT A BETA BLOCKER
BETA8 .;
.S J=$P(^AUPNVMED(Y,0),U,8)
.S V=$P(^AUPNVMED(Y,0),U,3)
.Q:'V
.Q:'$D(^AUPNVSIT(V,0))
.;S IS DAYS SUPPLY, J IS DATE DISCONTINUED
.I J]"" Q:J<EDATE ;discontinued W/IN 7 days of discharge date
.S S=$P(^AUPNVMED(Y,0),U,7)
.S Z=$$FMDIFF^XLFDT(EDATE,$P($P(^AUPNVSIT(V,0),U),"."))
.I S>Z S BGPG=1_U_$$DATE^BGP9UTL($P($P(^AUPNVSIT(V,0),U),"."))_U_$P(^PSDRUG(D,0),U)
.Q
Q BGPG
BETAALG1(P,BGPD) ;EP - does patient have an Beta Blocker allergy
;get all povs with 995.0-995.3 with ecode of e935.3 up to discharge date
S BGPC=0
BETAPOV ;
K BGPG,BGPY S Y="BGPG(",X=P_"^ALL DX [BGP ASA ALLERGY 995.0-995.3;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(BGPD) S E=$$START1^APCLDF(X,Y)
S X=0 F S X=$O(BGPG(X)) Q:X'=+X S Y=+$P(BGPG(X),U,4) D
.S N=$$VAL^XBDIQ1(9000010.07,Y,.04) S N=$$UP^XLFSTR(N)
.I N["BETA BLOCK"!(N["BBLOCK")!(N["B BLOCK") S BGPC=BGPC+1,BGPY(BGPC)="POV: "_$$DATE^BGP9UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_"] "_N
.S Z=$P(^AUPNVPOV(Y,0),U,9) I Z]"",$P($$ICDDX^ICDCODE(Z),U,2)="E942.0" S BGPC=BGPC+1,BGPY(BGPC)="POV: "_$$DATE^BGP9UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + E942.0] "_N
.Q
I BGPC>0 Q 1_U_BGPY(BGPC)
K BGPG S BGPC=0 S Y="BGPG(",X=P_"^ALL DX V14.8;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(DFN))_"-"_$$FMTE^XLFDT(BGPD) S E=$$START1^APCLDF(X,Y)
S X=0 F S X=$O(BGPG(X)) Q:X'=+X S Y=+$P(BGPG(X),U,4) D
.S N=$$VAL^XBDIQ1(9000010.07,Y,.04),N=$$UP^XLFSTR(N)
.I N["BETA BLOCK"!(N["BBLOCK")!(N["B BLOCK") S BGPC=BGPC+1,BGPY(BGPC)="POV: "_$$DATE^BGP9UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_"] "_N
I BGPC>0 Q 1_U_BGPY(BGPC)
;now check problem list for these codes
S BGPC=0
S T="",T=$O(^ATXAX("B","BGP ASA ALLERGY 995.0-995.3",0))
S X=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X D
.S I=$P($G(^AUPNPROB(X,0)),U),Y=$P($$ICDDX^ICDCODE(I),U,2)
.S N=$$VAL^XBDIQ1(9000011,X,.05),N=$$UP^XLFSTR(N)
.Q:$P(^AUPNPROB(X,0),U,8)>BGPD
.I Y="V14.8"!($$ICD^ATXCHK(I,T,9)),N["BETA BLOCK"!(N["BBLOCK")!(N["B BLOCK") S BGPC=BGPC+1,BGPY(BGPC)="PROBLEM LIST: "_$$DATE^BGP9UTL($P(^AUPNPROB(X,0),U,8))_" ["_Y_"] "_N
.Q
I BGPC>0 Q 1_U_BGPY(BGPC)
;now check allergy tracking
S BGPC=0
S X=0 F S X=$O(^GMR(120.8,"B",P,X)) Q:X'=+X D
.Q:$P($P($G(^GMR(120.8,X,0)),U,4),".")>BGPD ;entered after end date
.S N=$P($G(^GMR(120.8,X,0)),U,2),N=$$UP^XLFSTR(N)
.I N["BETA BLOCK" S BGPC=BGPC+1,BGPY(BGPC)="ALLERGY TRACKING: "_$$DATE^BGP9UTL($P(^GMR(120.8,X,0),U,4))_" "_N
I BGPC>0 Q 1_U_BGPY(BGPC)
Q 0
BGP9D72 ; IHS/CMI/LAB - measure 31 ;
+1 ;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009
+2 ;
+3 ;
IHEDBBH ;EP
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
+2 SET BGPVALUE=""
KILL BGPBETA
+3 IF BGPAGEB<36
SET BGPSTOP=1
QUIT
+4 IF 'BGPACTUP
SET BGPSTOP=1
QUIT
+5 SET BGPAMI=$$AMIH(DFN,BGPBDATE,$$FMADD^XLFDT(BGPBDATE,(51*7)))
+6 ;no ami
IF '$PIECE(BGPAMI,U)
SET BGPSTOP=1
QUIT
+7 IF $$READM(DFN,$PIECE(BGPAMI,U,4),$PIECE(BGPAMI,U,2))
SET BGPSTOP=1
QUIT
+8 SET BGPV=$PIECE(BGPAMI,U,3)
+9 ;beta contraindications
SET BGPBETAC=$$BETACONT(DFN,"",$SELECT($PIECE(BGPAMI,U,4)]"":$PIECE(BGPAMI,U,4),1:$PIECE(BGPAMI,U,2)))
+10 ;beta contraindication
IF $PIECE(BGPBETAC,U)
SET BGPSTOP=1
QUIT
+11 ;beta allergy
SET BGPBETAL=$$BETAALG1(DFN,$SELECT($PIECE(BGPAMI,U,4)]"":$PIECE(BGPAMI,U,4),1:$PIECE(BGPAMI,U,2)))
+12 IF $PIECE(BGPBETAL,U)
SET BGPSTOP=1
QUIT
+13 IF BGPACTCL
SET BGPD1=1
+14 IF BGPACTUP
SET BGPD2=1
+15 SET BGPBETA=$$BETA7(DFN,$$FMADD^XLFDT($PIECE(BGPAMI,U,2),-60),$$FMADD^XLFDT($PIECE(BGPAMI,U,4),7),$PIECE(BGPAMI,U,4))
+16 IF $PIECE(BGPBETA,U)=1
SET BGPN1=1
+17 SET BGPVALUE=$SELECT(BGPRTYPE=3:"",BGPD2:"UP",1:"")_$SELECT(BGPD1:";AC",1:"")_"|||"_$SELECT($PIECE(BGPBETA,U):$PIECE(BGPBETA,U,2)_" "_$PIECE(BGPBETA,U,3),1:"")
+18 KILL BGPAMI,BGPBETA,BGPBETAC,BGPBETAL
+19 KILL ^TMP($JOB)
+20 QUIT
IHEDPBH ;EP
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
+2 KILL BGPBETA,BGPAMI,BGPV,BGPBETAC,BGPBETAL,BGPVALUE
+3 IF BGPAGEB<18
SET BGPSTOP=1
QUIT
+4 IF 'BGPACTUP
SET BGPSTOP=1
QUIT
+5 SET BGPAMI=$$AMI(DFN,$$FMADD^XLFDT(BGPBDATE,-180),$$FMADD^XLFDT(BGPBDATE,180))
+6 ;no ami
IF '$PIECE(BGPAMI,U)
SET BGPSTOP=1
QUIT
+7 ;beta contraindications
SET BGPBETAC=$$BETACONT(DFN,"",$SELECT($PIECE(BGPAMI,U,4)]"":$PIECE(BGPAMI,U,4),1:$PIECE(BGPAMI,U,2)))
+8 ;beta contraindication
IF $PIECE(BGPBETAC,U)
SET BGPSTOP=1
QUIT
+9 ;beta allergy
SET BGPBETAL=$$BETAALG1(DFN,$SELECT($PIECE(BGPAMI,U,4)]"":$PIECE(BGPAMI,U,4),1:$PIECE(BGPAMI,U,2)))
+10 IF $PIECE(BGPBETAL,U)
SET BGPSTOP=1
QUIT
+11 IF BGPACTCL
SET BGPD1=1
+12 IF BGPACTUP
SET BGPD2=1
+13 SET BGPBETA=$$BETA(DFN,$PIECE(BGPAMI,U,2),$PIECE(BGPAMI,U,4))
+14 IF $PIECE(BGPBETA,U)=1
SET BGPN1=1
+15 SET BGPVALUE=$SELECT(BGPRTYPE=3:"",BGPD2:"UP")_$SELECT(BGPD1:";AC",1:"")_"|||"_$SELECT($PIECE(BGPBETA,U):"YES, beta blocker 135+ "_$PIECE(BGPBETA,U,2),1:"")
+16 KILL BGPAMI,BGPBETA,BGPBETAC,BGPBETAL
+17 KILL ^TMP($JOB)
+18 QUIT
IHEDCHM ;EP
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
+2 IF BGPAGEB<18
SET BGPSTOP=1
QUIT
+3 IF BGPAGEB>75
SET BGPSTOP=1
QUIT
+4 IF 'BGPACTUP
SET BGPSTOP=1
QUIT
+5 SET BGPAMI=$$AMIO(DFN,BGPBDATE,BGPEDATE)
IF '$PIECE(BGPAMI,U)
SET BGPSTOP=1
QUIT
+6 IF BGPACTUP
SET BGPD2=1
+7 IF BGPACTCL
SET BGPD1=1
+8 IF BGPRTYPE=3
IF 'BGPD1
SET BGPSTOP=1
QUIT
+9 SET BGPLDL=$$LDL^BGP9D2(DFN,BGPBDATE,BGPEDATE,$SELECT(BGPRTYPE=3:1,1:""))
+10 IF $PIECE(BGPLDL,U)=1
SET BGPN1=1
+11 IF $PIECE(BGPLDL,U,3)]""
IF BGPRTYPE'=3
Begin DoDot:1
+12 SET V=$PIECE(BGPLDL,U,3)
+13 IF V["CPT"
IF V["3048F"
SET BGPN2=1
QUIT
+14 SET V=+V
+15 IF 'V
QUIT
+16 IF V]""
IF +V'>100
SET BGPN2=1
+17 IF +V>100
IF +V<131
SET BGPN3=1
+18 IF +V>130
SET BGPN4=1
End DoDot:1
+19 ;HEDIS ONLY
IF $PIECE(BGPLDL,U,3)]""
IF BGPRTYPE=3
Begin DoDot:1
+20 SET V=$PIECE(BGPLDL,U,3)
+21 IF V["CPT"
IF V["3048F"
SET BGPN2=1
QUIT
+22 SET V=+V
+23 IF 'V
QUIT
+24 IF V]""
IF +V<100
SET BGPN2=1
End DoDot:1
+25 SET BGPXPNV=$PIECE(BGPLDL,U,3)
+26 SET V=$SELECT(BGPRTYPE=3:"",1:"UP")_$SELECT(BGPD1:";AC",1:"")_";"_$PIECE(BGPAMI,U,2)_"|||"
+27 IF $PIECE(BGPLDL,U)
SET V=V_"LDL "_$$DATE^BGP9UTL($PIECE(BGPLDL,U,2))_" "_$PIECE(BGPLDL,U,3)
+28 SET BGPVALUE=V
+29 KILL V,BGPAMI,BGPLDL,D
+30 KILL ^TMP($JOB)
+31 QUIT
CHOL(P,BDATE,EDATE) ;
+1 KILL BGPG
+2 SET (Q,R,S,M,N,O,B,D,E,L,G)=""
+3 SET R=$ORDER(^ATXLAB("B","DM AUDIT CHOLESTEROL TAX",0))
+4 SET N=$ORDER(^ATXAX("B","BGP TOTAL CHOLESTEROL LOINC",0))
+5 SET B=9999999-BDATE
SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(D>B)!(G]"")
QUIT
Begin DoDot:1
+6 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!(G]"")
QUIT
Begin DoDot:2
+7 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:3
+8 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+9 IF R
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(R,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET G=(9999999-D)_"^CHOL"_"^"_$PIECE(^AUPNVLAB(X,0),U,4)
QUIT
+10 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+11 IF $$LOINC(J,N)
SET G=(9999999-D)_"^CHOL LOINC"_"^"_$PIECE(^AUPNVLAB(X,0),U,4)
QUIT
+12 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+13 IF G]""
QUIT G
+14 SET E=+$$CODEN^ICPTCOD(82465)
SET %=$$CPTI^BGP9DU(P,BDATE,EDATE,E)
IF %]""
QUIT $PIECE(%,U,2)_"^CPT 82465"
+15 SET E=+$$CODEN^ICPTCOD(82465)
SET %=$$TRANI^BGP9DU(P,BDATE,EDATE,E)
IF %]""
QUIT $PIECE(%,U,2)_"^TRAN 82465"
+16 QUIT ""
LOINC(A,B) ;
+1 NEW %
+2 SET %=$PIECE($GET(^LAB(95.3,A,9999999)),U,2)
+3 IF %]""
IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+4 SET %=$PIECE($GET(^LAB(95.3,A,0)),U)_"-"_$PIECE($GET(^LAB(95.3,A,0)),U,15)
+5 IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+6 QUIT ""
AMIO(P,BDATE,EDATE) ;
+1 NEW BGPG
+2 KILL BGPG
+3 SET Y="BGPG("
+4 SET X=P_"^LAST DX [BGP AMI DXS (HEDIS);DURING "_$$FMADD^XLFDT(BDATE,-365)_"-"_$$FMADD^XLFDT(BDATE,-60)
SET E=$$START1^APCLDF(X,Y)
+5 ;has a dx
IF $DATA(BGPG(1))
QUIT 1_U_"AMI DX"
+6 ;check for procedure in BGP CABG PROCS
+7 SET BGPG=$$LASTPRC^BGP9UTL1(P,"BGP CABG PROCS",$$FMADD^XLFDT(BDATE,-365),$$FMADD^XLFDT(BDATE,-60))
+8 IF $PIECE(BGPG,U)
QUIT 1_U_"CABG PROC"
+9 ;now check cpts
+10 SET BGPG=$$CPT^BGP9DU(P,$$FMADD^XLFDT(BDATE,-365),$$FMADD^XLFDT(BDATE,-60),$ORDER(^ATXAX("B","BGP CABG CPTS",0)),6)
+11 IF $PIECE(BGPG,U)
QUIT 1_U_"CABG CPT"
+12 SET BGPG=$$TRAN^BGP9DU(P,$$FMADD^XLFDT(BDATE,-365),$$FMADD^XLFDT(BDATE,-60),$ORDER(^ATXAX("B","BGP CABG CPTS",0)),6)
+13 IF $PIECE(BGPG,U)
QUIT 1_U_"CABG TRAN"
+14 ;check for procedure in BGP PTCA PROCS
+15 SET BGPG=$$LASTPRC^BGP9UTL1(P,"BGP PTCA PROCS",$$FMADD^XLFDT(BDATE,-365),$$FMADD^XLFDT(BDATE,-60))
+16 IF $PIECE(BGPG,U)
QUIT 1_U_"PTCA PROC"
+17 ;now check cpts
+18 SET BGPG=$$CPT^BGP9DU(P,$$FMADD^XLFDT(BDATE,-365),$$FMADD^XLFDT(BDATE,-60),$ORDER(^ATXAX("B","BGP PTCA CPTS",0)),6)
+19 IF $PIECE(BGPG,U)
QUIT 1_U_"PTCA CPT"
+20 SET BGPG=$$TRAN^BGP9DU(P,$$FMADD^XLFDT(BDATE,-365),$$FMADD^XLFDT(BDATE,-60),$ORDER(^ATXAX("B","BGP PTCA CPTS",0)),6)
+21 IF $PIECE(BGPG,U)
QUIT 1_U_"PTCA TRAN"
+22 ;now check IVD dxs
+23 SET BGPG(1)=$$LASTDX^BGP9UTL1(P,"BGP IVD DXS",BDATE,EDATE)
+24 SET BGPG(2)=$$LASTDX^BGP9UTL1(P,"BGP IVD DXS",$$FMADD^XLFDT(BDATE,-365),BDATE)
+25 IF $PIECE(BGPG(1),U)
IF $PIECE(BGPG(2),U)
QUIT 1_U_"IVD DXS"
+26 QUIT ""
AMI(P,BDATE,EDATE) ;
+1 ;look for any H with AMI discharge dx
+2 KILL ^TMP($JOB,"A"),G
+3 SET A="^TMP($J,""A"","
SET B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(B,A)
+4 ;no HOSP
IF '$DATA(^TMP($JOB,"A",1))
QUIT 0
+5 SET T=$ORDER(^ATXAX("B","BGP AMI DXS (HEDIS)",0))
+6 SET (BGPX,G,M,D,E)=0
FOR
SET BGPX=$ORDER(^TMP($JOB,"A",BGPX))
IF BGPX'=+BGPX
QUIT
SET V=$PIECE(^TMP($JOB,"A",BGPX),U,5)
Begin DoDot:1
+7 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+8 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+9 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+10 ;Q:$P(^AUPNVSIT(V,0),U,6)'=DUZ(2)
+11 IF "AOSH"'[$PIECE(^AUPNVSIT(V,0),U,7)
QUIT
+12 SET H=0
+13 IF $PIECE(^AUPNVSIT(V,0),U,7)="H"
SET H=$ORDER(^AUPNVINP("AD",V,0))
Begin DoDot:2
+14 SET B=0
+15 IF 'H
QUIT
+16 ;ama
IF $$AMA(H)
QUIT
+17 ;transferred
IF $$TRANS(H)
QUIT
+18 ;died
IF $$EXPIRED(H)
QUIT
+19 SET B=1
End DoDot:2
IF 'B
QUIT
+20 SET (D,Y)=0
FOR
SET Y=$ORDER(^AUPNVPOV("AD",V,Y))
IF Y'=+Y!(D)
QUIT
IF $DATA(^AUPNVPOV(Y,0))
SET %=$PIECE(^AUPNVPOV(Y,0),U)
IF $$ICD^ATXCHK(%,T,9)
SET D=1
+21 ;got one visit
IF D
SET G=G+1
SET G($PIECE($PIECE(^AUPNVSIT(V,0),U),"."))=V
End DoDot:1
+22 IF 'G
QUIT G
+23 SET D=$ORDER(G(0))
SET V=G(D)
SET H=$ORDER(^AUPNVINP("AD",V,0))
+24 QUIT 1_U_$ORDER(G(0))_U_V_U_$SELECT(H:$PIECE($PIECE(^AUPNVINP(H,0),U),"."),1:"")_U_H
+25 ;
AMIH(P,BDATE,EDATE) ;
+1 ;look for any H with AMI discharge dx
+2 KILL ^TMP($JOB,"A"),G
+3 SET A="^TMP($J,""A"","
SET B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(B,A)
+4 ;no HOSP
IF '$DATA(^TMP($JOB,"A",1))
QUIT 0
+5 SET T=$ORDER(^ATXAX("B","BGP AMI IND 30",0))
+6 SET (BGPX,G,M,D,E)=0
FOR
SET BGPX=$ORDER(^TMP($JOB,"A",BGPX))
IF BGPX'=+BGPX
QUIT
SET V=$PIECE(^TMP($JOB,"A",BGPX),U,5)
Begin DoDot:1
+7 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+8 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+9 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+10 ;Q:$P(^AUPNVSIT(V,0),U,6)'=DUZ(2)
+11 IF $PIECE(^AUPNVSIT(V,0),U,7)'="H"
QUIT
+12 SET H=0
+13 SET H=$ORDER(^AUPNVINP("AD",V,0))
Begin DoDot:2
+14 SET B=0
+15 IF 'H
QUIT
+16 IF $PIECE($PIECE(^AUPNVINP(H,0),U),".")>EDATE
QUIT
+17 ;ama
IF $$AMA(H)
QUIT
+18 ;transferred
IF $$TRANS(H)
QUIT
+19 ;died
IF $$EXPIRED(H)
QUIT
+20 SET B=1
End DoDot:2
IF 'B
QUIT
+21 SET (D,Y)=0
FOR
SET Y=$ORDER(^AUPNVPOV("AD",V,Y))
IF Y'=+Y!(D)
QUIT
IF $DATA(^AUPNVPOV(Y,0))
SET %=$PIECE(^AUPNVPOV(Y,0),U)
IF $$ICD^ATXCHK(%,T,9)
SET D=1
+22 ;got one visit
IF D
SET G=G+1
SET G($PIECE($PIECE(^AUPNVSIT(V,0),U),"."))=V
End DoDot:1
+23 IF 'G
QUIT G
+24 SET D=$ORDER(G(0))
SET V=G(D)
SET H=$ORDER(^AUPNVINP("AD",V,0))
+25 QUIT 1_U_$ORDER(G(0))_U_V_U_$SELECT(H:$PIECE($PIECE(^AUPNVINP(H,0),U),"."),1:"")_U_H
READM(P,D,PV) ;EP
+1 SET ED=$$FMADD^XLFDT(D,7)
SET G=0
+2 SET X=0
SET V=0
FOR
SET X=$ORDER(^AUPNVSIT("AAH",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+3 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AAH",P,X,V))
IF V'=+V
QUIT
Begin DoDot:2
+4 IF PV=V
QUIT
+5 SET E=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+6 IF E<D
QUIT
+7 IF E>ED
QUIT
+8 SET G=1
End DoDot:2
End DoDot:1
+9 QUIT G
BETACONT(P,BDATE,EDATE) ;EP BETA BLOCKER CONTRAINDICATION
+1 IF $GET(BDATE)=""
SET BDATE=$$DOB^AUPNPAT(P)
+2 KILL BGPG,BGPD
+3 SET Y="BGPG("
+4 SET X=P_"^ALL DX [BGP ASTHMA DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+5 SET (X,G)=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET BGPD($PIECE(BGPG(X),U))=""
+6 SET (X,G)=0
FOR
SET X=$ORDER(BGPD(X))
IF X'=+X
QUIT
SET G=G+1
+7 ;has 2 dx of asthma so contraindication
IF G>1
QUIT 1_U_"2 dx asthma contra"
+8 SET BGPG=$$LASTDX^BGP9UTL1(P,"BGP HYPOTENSION DXS",$$DOB^AUPNPAT(P),EDATE)
+9 ;has hypotension dx
IF $PIECE(BGPG,U)=1
QUIT 1_U_"hypotension dx contra"
+10 SET BGPG=$$LASTDX^BGP9UTL1(P,"BGP CMS 2/3 HEART BLOCK DXS",$$DOB^AUPNPAT(P),EDATE)
+11 ;has heart block dx
IF $PIECE(BGPG,U)=1
QUIT 1_U_"heart blk contra"
+12 KILL BGPG,BGPD
+13 SET Y="BGPG("
+14 SET X=P_"^ALL DX [BGP COPD DXS BB CONT;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+15 SET (X,G)=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET BGPD($PIECE(BGPG(X),U))=""
+16 SET (X,G)=0
FOR
SET X=$ORDER(BGPD(X))
IF X'=+X
QUIT
SET G=G+1
+17 IF G>1
QUIT 1_U_"copd dx contra"
+18 QUIT 0
AMA(H) ;EP
+1 SET X=$PIECE(^AUPNVINP(H,0),U,6)
+2 IF X=""
QUIT 0
+3 SET X=$PIECE($GET(^DG(405.1,X,"IHS")),U,1)
+4 IF X=3
QUIT 1
+5 QUIT 0
EXPIRED(H) ;EP
+1 SET X=$PIECE(^AUPNVINP(H,0),U,6)
+2 IF X=""
QUIT 0
+3 SET X=$PIECE($GET(^DG(405.1,X,"IHS")),U,1)
+4 IF X=4!(X=5)!(X=6)!(X=7)
QUIT 1
+5 QUIT 0
DSCH(H) ;
+1 QUIT $PIECE($PIECE(^AUPNVINP(H,0),U),".")
TRANS(H) ;EP
+1 SET X=$PIECE(^AUPNVINP(H,0),U,6)
+2 IF X=""
QUIT 0
+3 SET X=$PIECE($GET(^DG(405.1,X,"IHS")),U,1)
+4 IF X=2
QUIT 1
+5 QUIT 0
BETA(P,BGPADMD,BGPDD) ;EP
+1 ;get all beta blockers
+2 IF BGPADMD=""
QUIT ""
+3 KILL ^TMP($JOB,"MEDS")
+4 SET BGPC1=0
KILL BGPZ
+5 IF $GET(BGPDD)=""
SET BGPDD=BGPADMD
+6 SET (G,N,Y,X,T,T1,T2,M,K,S,C,K,R)=""
+7 SET Y="^TMP($J,""MEDS"","
SET X=P_"^ALL MED;DURING "_$$FMTE^XLFDT(BGPADMD)_"-"_$$FMTE^XLFDT($$FMADD^XLFDT(BGPDD,180))
SET E=$$START1^APCLDF(X,Y)
+8 SET T=$ORDER(^ATXAX("B","BGP HEDIS BETA BLOCKER MEDS",0))
+9 SET T1=$ORDER(^ATXAX("B","BGP HEDIS BETA BLOCKER NDC",0))
+10 SET X=0
FOR
SET X=$ORDER(^TMP($JOB,"MEDS",X))
IF X'=+X
QUIT
SET Y=+$PIECE(^TMP($JOB,"MEDS",X),U,4)
Begin DoDot:1
+11 IF '$DATA(^AUPNVMED(Y,0))
QUIT
+12 SET G=0
+13 SET D=$PIECE(^AUPNVMED(Y,0),U)
+14 IF T
IF $DATA(^ATXAX(T,21,"B",D))
SET G=1
GOTO BETA1
+15 SET C=$PIECE($GET(^PSDRUG(D,0)),U,2)
+16 SET N=$PIECE($GET(^PSDRUG(D,2)),U,4)
+17 IF N]""
IF T1
IF $DATA(^ATXAX(T1,21,"B",N))
SET G=1
+18 IF 'G
QUIT
BETA1 ;
+1 SET J=$PIECE(^AUPNVMED(Y,0),U,8)
+2 SET V=$PIECE(^AUPNVMED(Y,0),U,3)
+3 IF 'V
QUIT
+4 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+5 ;S IS DAYS SUPPLY, J IS DATE DISCONTINUED
+6 IF J]""
SET S=$$FMDIFF^XLFDT(J,$PIECE($PIECE(^AUPNVSIT(V,0),U),"."))
+7 IF J=""
SET S=$PIECE(^AUPNVMED(Y,0),U,7)
+8 ;TOTAL DAYS SUPPLY
SET K=S+K
+9 IF R]""
SET R=R_";"
+10 SET R=R_$$DATE^BGP9UTL($PIECE($PIECE(^AUPNVSIT(V,0),U),"."))_"("_S_")"
End DoDot:1
+11 IF K>134
QUIT 1_U_" total days beta blocker: "_K
BETAADM ;now add in any before admission
+1 KILL ^TMP($JOB,"MEDS")
+2 SET Y="^TMP($J,""MEDS"","
SET X=P_"^LAST 30 MED;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT($$FMADD^XLFDT(BGPADMD,-1))
SET E=$$START1^APCLDF(X,Y)
+3 SET X=0
FOR
SET X=$ORDER(^TMP($JOB,"MEDS",X))
IF X'=+X
QUIT
SET Y=+$PIECE(^TMP($JOB,"MEDS",X),U,4)
Begin DoDot:1
+4 IF '$DATA(^AUPNVMED(Y,0))
QUIT
+5 SET G=0
+6 SET D=$PIECE(^AUPNVMED(Y,0),U)
+7 IF T
IF $DATA(^ATXAX(T,21,"B",D))
SET G=1
GOTO BETA2
+8 SET C=$PIECE($GET(^PSDRUG(D,0)),U,2)
+9 IF C]""
IF T2
IF $DATA(^ATXAX(T2,21,"B",C))
SET G=1
GOTO BETA2
+10 SET N=$PIECE($GET(^PSDRUG(D,2)),U,4)
+11 IF N]""
IF T1
IF $DATA(^ATXAX(T1,21,"B",N))
SET G=1
+12 IF 'G
QUIT
BETA2 ;
+1 SET J=$PIECE(^AUPNVMED(Y,0),U,8)
+2 SET V=$PIECE(^AUPNVMED(Y,0),U,3)
+3 IF 'V
QUIT
+4 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+5 ;S IS DAYS SUPPLY, J IS DATE DISCONTINUED
+6 ;don't use if discontinued
IF J]""
QUIT
+7 ;difference between dsch date and date prescribed
SET D=$$FMDIFF^XLFDT(BGPDD,$PIECE($PIECE(^AUPNVSIT(V,0),U),"."))
+8 SET S=$PIECE(^AUPNVMED(Y,0),U,7)
+9 ;subtract the number of days used
SET S=S-D
+10 IF S<0
SET S=0
+11 ;TOTAL DAYS SUPPLY
SET K=S+K
+12 IF R]""
SET R=R_";"
+13 SET R=R_$$DATE^BGP9UTL($PIECE($PIECE(^AUPNVSIT(V,0),U),"."))_"("_S_")"
End DoDot:1
+14 IF K>134
QUIT 1_U_" total days beta blocker: "_K
+15 QUIT 0_U_R_" total days beta blocker: "_K
BETA7(P,BDATE,EDATE,BGPDD) ;
+1 ;see if there ACTIVE PRESCRIPTION of beta blockers in time window
+2 KILL ^TMP($JOB,"MEDS")
+3 SET BGPG=0
+4 SET Y="^TMP($J,""MEDS"","
SET X=P_"^ALL MED;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+5 SET T=$ORDER(^ATXAX("B","BGP HEDIS BETA BLOCKER MEDS",0))
+6 SET T1=$ORDER(^ATXAX("B","BGP HEDIS BETA BLOCKER NDC",0))
+7 ;S T2=$O(^ATXAX("B","BGP HEDIS BETA BLOCKER CLASS",0))
+8 SET X=0
FOR
SET X=$ORDER(^TMP($JOB,"MEDS",X))
IF X'=+X!(BGPG)
QUIT
SET Y=+$PIECE(^TMP($JOB,"MEDS",X),U,4)
Begin DoDot:1
+9 IF '$DATA(^AUPNVMED(Y,0))
QUIT
+10 SET G=0
+11 SET D=$PIECE(^AUPNVMED(Y,0),U)
+12 IF T
IF $DATA(^ATXAX(T,21,"B",D))
SET G=1
GOTO BETA8
+13 SET C=$PIECE($GET(^PSDRUG(D,0)),U,2)
+14 ;I C]"",T2,$D(^ATXAX(T2,21,"B",C)) S G=1 G BETA8
+15 SET N=$PIECE($GET(^PSDRUG(D,2)),U,4)
+16 IF N]""
IF T1
IF $DATA(^ATXAX(T1,21,"B",N))
SET G=1
+17 ;NOT A BETA BLOCKER
IF 'G
QUIT
BETA8 ;
+1 SET J=$PIECE(^AUPNVMED(Y,0),U,8)
+2 SET V=$PIECE(^AUPNVMED(Y,0),U,3)
+3 IF 'V
QUIT
+4 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+5 ;S IS DAYS SUPPLY, J IS DATE DISCONTINUED
+6 ;discontinued W/IN 7 days of discharge date
IF J]""
IF J<EDATE
QUIT
+7 SET S=$PIECE(^AUPNVMED(Y,0),U,7)
+8 SET Z=$$FMDIFF^XLFDT(EDATE,$PIECE($PIECE(^AUPNVSIT(V,0),U),"."))
+9 IF S>Z
SET BGPG=1_U_$$DATE^BGP9UTL($PIECE($PIECE(^AUPNVSIT(V,0),U),"."))_U_$PIECE(^PSDRUG(D,0),U)
+10 QUIT
End DoDot:1
+11 QUIT BGPG
BETAALG1(P,BGPD) ;EP - does patient have an Beta Blocker allergy
+1 ;get all povs with 995.0-995.3 with ecode of e935.3 up to discharge date
+2 SET BGPC=0
BETAPOV ;
+1 KILL BGPG,BGPY
SET Y="BGPG("
SET X=P_"^ALL DX [BGP ASA ALLERGY 995.0-995.3;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(BGPD)
SET E=$$START1^APCLDF(X,Y)
+2 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BGPG(X),U,4)
Begin DoDot:1
+3 SET N=$$VAL^XBDIQ1(9000010.07,Y,.04)
SET N=$$UP^XLFSTR(N)
+4 IF N["BETA BLOCK"!(N["BBLOCK")!(N["B BLOCK")
SET BGPC=BGPC+1
SET BGPY(BGPC)="POV: "_$$DATE^BGP9UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_"] "_N
+5 SET Z=$PIECE(^AUPNVPOV(Y,0),U,9)
IF Z]""
IF $PIECE($$ICDDX^ICDCODE(Z),U,2)="E942.0"
SET BGPC=BGPC+1
SET BGPY(BGPC)="POV: "_$$DATE^BGP9UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_" + E942.0] "_N
+6 QUIT
End DoDot:1
+7 IF BGPC>0
QUIT 1_U_BGPY(BGPC)
+8 KILL BGPG
SET BGPC=0
SET Y="BGPG("
SET X=P_"^ALL DX V14.8;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(DFN))_"-"_$$FMTE^XLFDT(BGPD)
SET E=$$START1^APCLDF(X,Y)
+9 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BGPG(X),U,4)
Begin DoDot:1
+10 SET N=$$VAL^XBDIQ1(9000010.07,Y,.04)
SET N=$$UP^XLFSTR(N)
+11 IF N["BETA BLOCK"!(N["BBLOCK")!(N["B BLOCK")
SET BGPC=BGPC+1
SET BGPY(BGPC)="POV: "_$$DATE^BGP9UTL($PIECE(BGPG(X),U))_" ["_$PIECE(BGPG(X),U,2)_"] "_N
End DoDot:1
+12 IF BGPC>0
QUIT 1_U_BGPY(BGPC)
+13 ;now check problem list for these codes
+14 SET BGPC=0
+15 SET T=""
SET T=$ORDER(^ATXAX("B","BGP ASA ALLERGY 995.0-995.3",0))
+16 SET X=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+17 SET I=$PIECE($GET(^AUPNPROB(X,0)),U)
SET Y=$PIECE($$ICDDX^ICDCODE(I),U,2)
+18 SET N=$$VAL^XBDIQ1(9000011,X,.05)
SET N=$$UP^XLFSTR(N)
+19 IF $PIECE(^AUPNPROB(X,0),U,8)>BGPD
QUIT
+20 IF Y="V14.8"!($$ICD^ATXCHK(I,T,9))
IF N["BETA BLOCK"!(N["BBLOCK")!(N["B BLOCK")
SET BGPC=BGPC+1
SET BGPY(BGPC)="PROBLEM LIST: "_$$DATE^BGP9UTL($PIECE(^AUPNPROB(X,0),U,8))_" ["_Y_"] "_N
+21 QUIT
End DoDot:1
+22 IF BGPC>0
QUIT 1_U_BGPY(BGPC)
+23 ;now check allergy tracking
+24 SET BGPC=0
+25 SET X=0
FOR
SET X=$ORDER(^GMR(120.8,"B",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+26 ;entered after end date
IF $PIECE($PIECE($GET(^GMR(120.8,X,0)),U,4),".")>BGPD
QUIT
+27 SET N=$PIECE($GET(^GMR(120.8,X,0)),U,2)
SET N=$$UP^XLFSTR(N)
+28 IF N["BETA BLOCK"
SET BGPC=BGPC+1
SET BGPY(BGPC)="ALLERGY TRACKING: "_$$DATE^BGP9UTL($PIECE(^GMR(120.8,X,0),U,4))_" "_N
End DoDot:1
+29 IF BGPC>0
QUIT 1_U_BGPY(BGPC)
+30 QUIT 0
