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

BGP7C13.m

Go to the documentation of this file.
  1. BGP7C13 ; IHS/CMI/LAB - calc CMS measures 26 Sep 2004 11:28 AM ;
  1. ;;17.1;IHS CLINICAL REPORTING;;MAY 10, 2017;Build 29
  1. ;
  1. ARBALG1 ;EP does patient have an ARB allergy
  1. ;get all povs with 995.0-995.3 with ecode of e935.3 up to discharge date
  1. NEW ED,BD,BGPG,X,Y,Z,N
  1. ;BGPD is discharge date
  1. S:$G(BGPC)="" BGPC=0 ;cmi/maw 3/19/2010 this was commented out for some reason so it was undef in the next sub routine
  1. S ED=$$FMADD^XLFDT(BGPD,-365)
  1. ARBPOV ;
  1. K BGPG 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)
  1. S X=0 F S X=$O(BGPG(X)) Q:X'=+X S Y=+$P(BGPG(X),U,4) D
  1. .S N=$$VAL^XBDIQ1(9000010.07,Y,.04) S N=$$UP^XLFSTR(N)
  1. .I N["ARB"!(N["ANGIOTENSIN RECEPTOR BLOCKER") S BGPC=BGPC+1,BGPY(BGPC)=$$DATE^BGP7UTL($P(BGPG(X),U))_" ADR POV "_$P(BGPG(X),U,2) Q
  1. .S T=$O(^ATXAX("B","BGP ADV EFF ANTIHYPERTEN ARB",0))
  1. .S Z=$P(^AUPNVPOV(Y,0),U,9) I Z]"",$$ICD^BGP7UTL2(Z,T,9) S G=1_U_"POV: "_$$DATE^BGP7UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^BGP7UTL2(Z),U,2)_"] "_N Q
  1. .S Z=$P(^AUPNVPOV(Y,0),U,18) I Z]"",$$ICD^BGP7UTL2(Z,T,9) S G=1_U_"POV: "_$$DATE^BGP7UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^BGP7UTL2(Z),U,2)_"] "_N Q
  1. .S Z=$P(^AUPNVPOV(Y,0),U,19) I Z]"",$$ICD^BGP7UTL2(Z,T,9) S G=1_U_"POV: "_$$DATE^BGP7UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + "_$P($$ICDDX^BGP7UTL2(Z),U,2)_"] "_N Q
  1. .Q
  1. K BGPG S Y="BGPG(",X=P_"^ALL DX [BGP HX DRUG ALLERGY NEC;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(DFN))_"-"_$$FMTE^XLFDT(BGPD) S E=$$START1^APCLDF(X,Y)
  1. S X=0 F S X=$O(BGPG(X)) Q:X'=+X S Y=+$P(BGPG(X),U,4) D
  1. .S N=$$VAL^XBDIQ1(9000010.07,Y,.04),N=$$UP^XLFSTR(N)
  1. .I N["ARB"!(N["ANGIOTENSIN RECEPTOR BLOCKER") S BGPC=BGPC+1,BGPY(BGPC)=$$DATE^BGP7UTL($P(BGPG(X),U))_" ADR POV "_$P(BGPG(X),U,2)
  1. ;now check problem list for these codes
  1. S T="",T=$O(^ATXAX("B","BGP ASA ALLERGY 995.0-995.3",0))
  1. S X=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X D
  1. .S I=$P($G(^AUPNPROB(X,0)),U),Y=$P($$ICDDX^BGP7UTL2(I),U,2)
  1. .S N=$$VAL^XBDIQ1(9000011,X,.05),N=$$UP^XLFSTR(N)
  1. .Q:$P(^AUPNPROB(X,0),U,8)>BGPD ;added after discharge date
  1. .I $P(^AUPNPROB(X,0),U,13)]"",$P(^AUPNPROB(X,0),U,13)>EDATE Q ;doo
  1. .Q:$P(^AUPNPROB(X,0),U,12)="D"
  1. .;Q:$P(^AUPNPROB(X,0),U,12)="I"
  1. .I $$ICD^BGP7UTL2(I,$O(^ATXAX("B","BGP HX DRUG ALLERGY NEC",0)),9)!($$ICD^BGP7UTL2(I,T,9)),N["ARB"!(N["ANGIOTENSIN RECEPTOR BLOCKER") S BGPC=BGPC+1,BGPY(BGPC)=$$DATE^BGP7UTL($P(^AUPNPROB(X,0),U,8))_" ADR PROBLEM LIST "_Y_" "_N Q
  1. .S S=$$VAL^XBDIQ1(9000011,X,80001)
  1. .I S]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP ADR ARB",S)) S BGPC=BGPC+1,BGPY(BGPC)=$$DATE^BGP7UTL($P(^AUPNPROB(X,0),U,8))_" ADR PROBLEM LIST "_S_" "_N Q
  1. .Q
  1. ;now check allergy tracking
  1. S X=0 F S X=$O(^GMR(120.8,"B",P,X)) Q:X'=+X D
  1. .Q:$P($P($G(^GMR(120.8,X,0)),U,4),".")>BGPD ;entered after discharge date
  1. .S N=$P($G(^GMR(120.8,X,0)),U,2),N=$$UP^XLFSTR(N)
  1. .I N["ARB"!(N["ANGIOTENSIN RECEPTOR BLOCKER") S BGPC=BGPC+1,BGPY(BGPC)=$$DATE^BGP7UTL($P(^GMR(120.8,X,0),U,4))_" ADR ALLERGY TRACKING"
  1. Q
  1. ARBCON1 ;EP does patient have an ARB allergy
  1. ;nmi in refusal file for ARB
  1. S T=$O(^ATXAX("B","BGP CMS ARB MEDS",0))
  1. S Z=$$FMADD^XLFDT(BGPDDT,-365)
  1. S X=0 F S X=$O(^AUPNPREF("AA",P,50,X)) Q:X'=+X D
  1. .Q:'$D(^ATXAX(T,21,"B",X)) ;not an ARB
  1. .S D=0 F S D=$O(^AUPNPREF("AA",P,50,X,D)) Q:D'=+D D
  1. ..S Y=9999999-D I Y<Z Q ;documented more than 1 year before discharge
  1. ..I Y>BGPDDT Q ;documented after discharge
  1. ..S N=0 F S N=$O(^AUPNPREF("AA",P,50,X,D,N)) Q:N'=+N D
  1. ...Q:$P($G(^AUPNPREF(N,0)),U,7)'="N"
  1. ...S BGPC=BGPC+1,BGPY(BGPC)="NMI ARB: "_$$VAL^XBDIQ1(9000022,N,.04)_" "_$$DATE^BGP7UTL($P(^AUPNPREF(N,0),U,3))_" "_$$VAL^XBDIQ1(9000022,X,1101)
  1. ..Q
  1. .Q
  1. Q:BGPIND'=2
  1. S X=$$CPTI^BGP7DU(P,BGPD,BGPDDT,+$$CODEN^ICPTCOD("G8029"))
  1. I X S BGPC=BGPC+1,BGPY(BGPC)="CPT code G8029: "_$$DATE^BGP7UTL($P(X,U,2))
  1. S X=$$TRANI^BGP7DU(P,BGPD,BGPDDT,+$$CODEN^ICPTCOD("G8029"))
  1. I X S BGPC=BGPC+1,BGPY(BGPC)="Tran Code G8029: "_$$DATE^BGP7UTL($P(X,U,2))
  1. Q
  1. ARBRX1 ;EP
  1. ;get last aspirin rx before date of adm
  1. NEW BGPG,BGPC,X,Y,Z,E,BD,ED
  1. S BGPC=0
  1. S ED=$$FMADD^XLFDT(BGPA,-1)
  1. S BD=$$FMADD^XLFDT(BGPA,-365)
  1. D GETMEDS^BGP7CU(P,BD,ED,"BGP CMS ARB MEDS","BGP CMS ARB MEDS NDC","BGP CMS ARB MEDS CLASS")
  1. I BGPIND=2 D
  1. .S X=$$CPTI^BGP7DU(P,BD,ED,+$$CODEN^ICPTCOD("G8027"))
  1. .I X S BGPC=BGPC+1,BGPY(BGPC)="CPT code G8027: "_$$DATE^BGP7UTL($P(X,U,2))
  1. .S X=$$TRANI^BGP7DU(P,BD,ED,+$$CODEN^ICPTCOD("G8027"))
  1. .I X S BGPC=BGPC+1,BGPY(BGPC)="Tran Code G8027: "_$$DATE^BGP7UTL($P(X,U,2))
  1. S BD=BGPA
  1. S ED=$$FMADD^XLFDT(BGPD,30)
  1. D GETMEDS^BGP7CU(P,BD,ED,"BGP CMS ARB MEDS","BGP CMS ARB MEDS NDC","BGP CMS ARB MEDS CLASS")
  1. I BGPIND=2 D
  1. .S X=$$CPTI^BGP7DU(P,BD,ED,+$$CODEN^ICPTCOD("G8027"))
  1. .I X S BGPC=BGPC+1,BGPY(BGPC)="CPT code G8027: "_$$DATE^BGP7UTL($P(X,U,2))
  1. .S X=$$TRANI^BGP7DU(P,BD,ED,+$$CODEN^ICPTCOD("G8027"))
  1. .I X S BGPC=BGPC+1,BGPY(BGPC)="Tran Code G8027: "_$$DATE^BGP7UTL($P(X,U,2))
  1. K BGPG
  1. Q
  1. DSCH(H) ;
  1. Q $P($P(^AUPNVINP(H,0),U),".")
  1. ACEICON1(P,BGPD,BGPDDT,BGPV,BGPY) ;EP have an ACEI allergy
  1. NEW ED,BD,BGPG,BGPC,X,Y,Z,N,E
  1. S BGPC=0 K BGPY
  1. S BD=$$FMADD^XLFDT(BGPD,-365)
  1. K BGPG S Y="BGPG(",X=P_"^LAST DX [BGP CMS AORTIC STENOSIS DXS;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(BGPDDT) S E=$$START1^APCLDF(X,Y)
  1. I $D(BGPG(1)) S BGPC=BGPC+1,BGPY(BGPC)="POV: "_$$DATE^BGP7UTL($P(BGPG(1),U))_" ["_$P(BGPG(1),U,2)_"] "_$$VAL^XBDIQ1(9000010.07,+$P(BGPG(1),U,4),.04)
  1. ;
  1. ;nmi in refusal file for ACEI
  1. S T=$O(^ATXAX("B","BGP CMS ACEI MEDS",0))
  1. S Z=$$FMADD^XLFDT(BGPDDT,-365)
  1. S X=0 F S X=$O(^AUPNPREF("AA",P,50,X)) Q:X'=+X D
  1. .Q:'$D(^ATXAX(T,21,"B",X)) ;not an ACEI
  1. .S D=0 F S D=$O(^AUPNPREF("AA",P,50,X,D)) Q:D'=+D D
  1. ..S Y=9999999-D I Y<Z Q ;documented more than 1 year before disc
  1. ..I Y>BGPDDT Q ;documented after discharge
  1. ..S N=0 F S N=$O(^AUPNPREF("AA",P,50,X,D,N)) Q:N'=+N D
  1. ...Q:$P($G(^AUPNPREF(N,0)),U,7)'="N"
  1. ...S BGPC=BGPC+1,BGPY(BGPC)="NMI ACEI: "_$$VAL^XBDIQ1(9000022,N,.04)_" "_$$DATE^BGP7UTL($P(^AUPNPREF(N,0),U,3))_" "_$$VAL^XBDIQ1(9000022,X,1101)
  1. ..Q
  1. .Q
  1. D ARBCON1
  1. Q