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

BGPMUD03.m

Go to the documentation of this file. 
  1. BGPMUD03 ; IHS/MSC/SAT - MU measure NQF0081 ;03-Aug-2011 16:14;DU
  1.  ;;11.1;IHS CLINICAL REPORTING SYSTEM;**1**;JUN 27, 2011;Build 106
  1.  ;code to collect meaningful use report Heart Failure w/ ACE Inhibitor or ARB
  1.  ;NQF0081
  1.  ;Print Output: HF^BGPMUP2
  1.  ;Delimited Output: HF^BGPMUDD2
  1. ENTRY ;EP
  1.  ; expects:
  1.  ;  DFN      = patient code from VA PATIENT file
  1.  ;  BGPBDATE = begin date of report
  1.  ;  BGPEDATE = end date of report
  1.  ;  BGPPROV  = provider code from NEW PERSON file
  1.  ;  BGPMUTF  = timeframe variable - "C"=current year; "P"=previous year; "B"=baseline year
  1.  N BGP4,BGPSEX,EXCEPT,PREG,RET
  1.  N BGPBIRTH,BGPDEN,BGPNUM,BGPDT,BGPAGEE,END,FIRST,IEN,START,VIEN
  1.  N BGPEXC,BGPNOT
  1.  ; BGPLED  = latest encounter date
  1.  ; BGPEMF = EM code(s) found
  1.  ; BGPC = display value of encounters
  1.  N BGPLED,BGPEMF,BGPC
  1.  ; BGP*C = <COUNT> U CODE : DATE ; ...
  1.  N BGPIC,BGPNC,BGPOC
  1.  S BGPDEN=0
  1.  S BGPEXC=0
  1.  S BGPNUM=0
  1.  S BGPNOT=0
  1.  S BGPSEX=$$SEX^AUPNPAT(DFN)
  1.  ;
  1.  ;Pts must be 18 and older
  1.  S BGPAGEE=$$AGE^AUPNPAT(DFN,BGPEDATE)
  1.  ;No need to check further on children
  1.  Q:BGPAGEE<18
  1.  ; check for encounters with the provider
  1.  S (BGPEMF,BGPIC,BGPNC,BGPOC)=0
  1.  S BGPLED=9999999
  1.  S BGPC=""
  1.  S START=9999999-BGPBDATE,END=9999999-BGPEDATE
  1.  S FIRST=END-0.1 F  S FIRST=$O(^AUPNVSIT("AA",DFN,FIRST)) Q:FIRST=""!($P(FIRST,".",1)>START)  D  Q:BGPC'=""
  1.  .S VIEN=0 F  S VIEN=$O(^AUPNVSIT("AA",DFN,FIRST,VIEN)) Q:'+VIEN  D  Q:BGPC'=""
  1.  ..S BGPDT=$P($P($G(^AUPNVSIT(VIEN,0)),U,1),".",1)
  1.  ..;Check provider, determine if there are visits with E&M codes
  1.  ..I $$PRV^BGPMUUT1(VIEN,BGPPROV) D
  1.  ...S X=+$$VSTCPT^BGPMUUT1(DFN,VIEN,"BGPMU ENC INPATIENT DISCH CPT")
  1.  ...I +X D
  1.  ....S BGPIC=(+$P(BGPIC,U,1)+1)_U_$S(+BGPIC:$P(BGPIC,U,2)_";",1:"")_"EN:"_$$DATE^BGPMUUTL(BGPDT)
  1.  ....S BGPLED=$S(BGPLED<$P(X,U,3):BGPLED,1:BGPLED)
  1.  ....S:+BGPIC>0 BGPC=$P(BGPIC,U,2)
  1.  ....;S BGPEND=$S(BGPEND'="":BGPEND_";",1:"")_"EN:"_$$DATE^BGPMUUTL($P(X,U,3))
  1.  ...Q:BGPC'=""
  1.  ...S X=+$$VSTCPT^BGPMUUT1(DFN,VIEN,"BGPMU ENC OUTPATIENT CPT")
  1.  ...I +X D
  1.  ....S BGPOC=(+$P(BGPOC,U,1)+1)_U_$S(+BGPOC:$P(BGPOC,U,2)_";",1:"")_"EN:"_$$DATE^BGPMUUTL(BGPDT)
  1.  ....S BGPLED=$S(BGPLED<$P(X,U,3):BGPLED,1:BGPLED)
  1.  ....S:+BGPOC>1 BGPC=$P(BGPOC,U,2)
  1.  ....;S BGPEND=$S(BGPEND'="":BGPEND_";",1:"")_"EN:"_$$DATE^BGPMUUTL($P(X,U,3))
  1.  ...Q:BGPC'=""
  1.  ...S X=+$$VSTCPT^BGPMUUT1(DFN,VIEN,"BGPMU ENC NURSING FAC CPT")
  1.  ...I +X D
  1.  ....S BGPNC=(+$P(BGPNC,U,1)+1)_U_$S(+BGPNC:$P(BGPNC,U,2)_";",1:"")_"EN:"_$$DATE^BGPMUUTL(BGPDT)
  1.  ....S BGPLED=$S(BGPLED<$P(X,U,3):BGPLED,1:BGPLED)
  1.  ....S:+BGPNC>1 BGPC=$P(BGPNC,U,2)
  1.  ....;S BGPEND=$S(BGPEND'="":BGPEND_";",1:"")_"EN:"_$$DATE^BGPMUUTL($P(X,U,3))
  1.  Q:BGPC=""
  1.  ;
  1.  ;Does patient have Heart Failure as an active diagnosis
  1.  ; check POV
  1.  S BGPBIRTH=$P(^DPT(DFN,0),U,3)
  1.  I BGPBIRTH="" S BGPBIRTH=$$FMADD^XLFDT(BGPBDATE,-730)  ;if no dob, use 2 years prior to report period
  1.  S BGPHF=$$LASTDX^BGPMUUT2(DFN,BGPBIRTH,BGPLED,"BGPMU HEART FAILURE DX")
  1.  ; check problem list
  1.  S:'+BGPHF BGPHF=$$PLTAX^BGPMUUT1(DFN,"BGPMU HEART FAILURE DX","C")  ; "C" for active (current) only
  1.  ;quit if not active in problem list
  1.  Q:'+BGPHF
  1.  ; check for ejection fraction result of < 40%
  1.  S BGP4=0
  1.  S BGP4=$$DEN1(DFN,BGPBIRTH,BGPLED)
  1.  Q:'+BGP4
  1.  ;if we got here, patient is in the denominator
  1.  S BGPDEN=1_U_"HF:"_$$DATE^BGPMUUTL($P(BGPHF,U,3))_";"_"LVEF:"_$$DATE^BGPMUUTL($P(BGP4,U,3))_";"_BGPC
  1.  ;
  1.  ;check if patient is in numerator
  1.  ;determine if patient has medications that are ACE Inhibitor or ARB
  1.  S BGPNUM=$$NUM(DFN,BGPBDATE,BGPEDATE)
  1.  I +BGPNUM S BGPNUM=1_U_"M:MED "_$$DATE^BGPMUUTL($P(BGPNUM,U,2))
  1.  E  D
  1.  .S BGPNOT=1_U_"NM:"
  1.  .S BGPEXC=$$EXCLUDE(DFN)
  1.  ;
  1.  D TOTAL(DFN)
  1.  ;cleanup
  1.  K BGP4,BGPSEX,EXCEPT,PREG,RET
  1.  K BGPBIRTH,BGPDEN,BGPNUM,BGPDT,BGPAGEE,END,FIRST,IEN,START,VIEN
  1.  K BGPEXC,BGPNOT
  1.  K BGPLED,BGPEMF,BGPC
  1.  K BGPIC,BGPNC,BGPOC
  1.  Q
  1. TOTAL(DFN) ;See where this patient ends up
  1.  N PTCNT,EXCCT,DENCT,NOT1CT,NUMCT,TOTALS
  1.  S TOTALS=$G(^TMP("BGPMU0081",$J,BGPMUTF,"TOT"))
  1.  S EXCCT=+$G(^TMP("BGPMU0081",$J,BGPMUTF,"EXC"))
  1.  S DENCT=+$G(^TMP("BGPMU0081",$J,BGPMUTF,"DEN"))
  1.  S NUMCT=+$G(^TMP("BGPMU0081",$J,BGPMUTF,"NUM"))
  1.  S NOT1CT=+$G(^TMP("BGPMU0081",$J,BGPMUTF,"NOT"))
  1.  S PTCNT=TOTALS
  1.  S PTCNT=PTCNT+1
  1.  ;denominator
  1.  S DENCT=DENCT+1
  1.  S ^TMP("BGPMU0081",$J,BGPMUTF,"DEN")=DENCT
  1.  S ^TMP("BGPMU0081",$J,"PAT",BGPMUTF,"DEN",PTCNT)=DFN
  1.  ;If excluded
  1.  I +BGPEXC D
  1.  .S EXCCT=EXCCT+1 S ^TMP("BGPMU0081",$J,BGPMUTF,"EXC")=EXCCT
  1.  .I BGPMUTF="C" S ^TMP("BGPMU0081",$J,"PAT",BGPMUTF,"EXC",PTCNT)=DFN_U_$P(BGPDEN,U,2)
  1.  E  D
  1.  .I +BGPNUM D   ;numerator
  1.  ..S NUMCT=NUMCT+1 S ^TMP("BGPMU0081",$J,BGPMUTF,"NUM")=NUMCT
  1.  ..S ^TMP("BGPMU0081",$J,"PAT",BGPMUTF,"NUM",PTCNT)=DFN_U_$P(BGPDEN,U,2)_U_$P(BGPNUM,U,2)
  1.  .I +BGPNOT D
  1.  ..S NOT1CT=NOT1CT+1 S ^TMP("BGPMU0081",$J,BGPMUTF,"NOT")=NOT1CT
  1.  ..S ^TMP("BGPMU0081",$J,"PAT",BGPMUTF,"NOT",PTCNT)=DFN_U_$P(BGPDEN,U,2)_U_$P(BGPNOT,U,2)
  1.  S ^TMP("BGPMU0081",$J,BGPMUTF,"TOT")=PTCNT
  1.  Q
  1. NUM(DFN,BGPBDATE,BGPEDATE) ;Look for ACE/ARB PRESCRIPTION
  1.  N FOUND,ACERX
  1.  S FOUND=0
  1.  S ACERX=$$FIND^BGPMUUT8(DFN,"BGPMU ACE ARBS NDCS",BGPBDATE,"",BGPEDATE)
  1.  Q:'ACERX FOUND
  1.  S FOUND=1_U_$P(ACERX,U,3)
  1.  Q FOUND
  1.  ;
  1. EXCLUDE(DFN) ;check for exclusions
  1.  S EXCEPT=0
  1.  ;check for allergy or intolerance to ACE Inhibitors or ARBs (CV800 or CV805)
  1.  S BGPACE=$O(^PS(50.605,"B","CV800",""))
  1.  S BGPARB=$O(^PS(50.605,"B","CV805",""))
  1.  S BGPPA="" F  S BGPPA=$O(^GMR(120.8,"B",DFN,BGPPA)) Q:BGPPA=""  D
  1.  .S BGPDA=0 F  S BGPDA=$O(^GMR(120.8,BGPPA,3,BGPDA)) Q:BGPDA'>0  D
  1.  ..S BGPDC=$P($G(^GMR(120.8,BGPPA,3,BGPDA,0)),U,1)
  1.  ..S:BGPDC=BGPACE EXCEPT=1_U_"ACE INHIBITORS"
  1.  ..S:BGPDC=BGPARB EXCEPT=1_U_"ANGIOTENSIN II INHIBITOR"
  1.  Q:+EXCEPT EXCEPT
  1.  ; Pregnant
  1.  S PREG=0
  1.  I BGPSEX="F" S PREG=$$LASTDX^BGPMUUT2(DFN,BGPBIRTH,BGPEDATE,"BGPMU PREGNANCY ALL ICD")
  1.  I +PREG=1 S EXCEPT=1_U_$P(PREG,U,2)_U_$P(PREG,U,3)
  1.  Q:+EXCEPT EXCEPT
  1.  S PREG=$$PLTAX^BGPMUUT1(DFN,"BGPMU PREGNANCY ALL ICD","C")
  1.  I +PREG=1 S EXCEPT=1_U_$P(PREG,U,2)_U_$P(PREG,U,3)
  1.  Q:+EXCEPT EXCEPT
  1.  ; All other exclusions:
  1.  ;   Deficiencies of Circulating Enzymes
  1.  ;   Disease of Aortic and Mitral Valves
  1.  ;   Disease Non-Rheumatic Mitral (Valve)
  1.  ;   Chronic Kidney Disease with and without Hypertension
  1.  ;   Hypertensive Renal Disease with Renal Failure
  1.  ;   Atherosclerosis of Renal Artery
  1.  ;   Renal Failure and ESRD
  1.  ;   Acute Renal Failure
  1.  ;   Atresia and Stenosis of Aorta
  1.  S RET=0
  1.  S RET=$$LASTDX^BGPMUUT2(DFN,BGPBIRTH,BGPEDATE,"BGPMU HF0081 EXCLUSION DX")
  1.  I +RET=1 S EXCEPT=1_U_$P(RET,U,2)_U_$P(RET,U,3)
  1.  Q:+EXCEPT EXCEPT
  1.  S RET=$$PLTAX^BGPMUUT1(DFN,"BGPMU HF0081 EXCLUSION DX","C")
  1.  I +RET=1 S EXCEPT=1_U_$P(RET,U,2)_U_$P(RET,U,3)
  1.  Q:+EXCEPT EXCEPT
  1.  ;Check for refusal of ACE or ARB med
  1.  S MED=$$MEDREF^BGPMUUT2(DFN,BGPBIRTH,BGPLED_".2359","BGPMU ACE ARBS NDCS")
  1.  I +MED S EXCEPT=MED
  1.  Q EXCEPT
  1.  ;
  1. DEN1(DFN,BGPBDATE,BGPLED) ; Find the latest CARDIAC EJECTION FRACTION (CEF) measurement
  1.  N CEF,FOUND,IEN,INV,MTYPE,RESULT,RDATE
  1.  S (CEF,FOUND)=0
  1.  ;S CEF=+$$CPT^BGPMUUT1(DFN,BGPBDATE,BGPLED,"BGPMU LVEF UNDER 40% CPT")
  1.  ;Q:CEF CEF
  1.  ;S MTYP="" S MTYP=$O(^AUTTMSR("B","HT",MTYP))  ;ZSAT: for testing; delete this line, keep next line
  1.  S MTYP="" S MTYP=$O(^AUTTMSR("B","CEF",MTYP))
  1.  Q:MTYP="" 0
  1.  S INV=0 F  S INV=$O(^AUPNVMSR("AA",DFN,MTYP,INV)) Q:'+INV!(+FOUND)  D
  1.  .S RDATE=9999999-INV
  1.  .I RDATE>BGPBDATE&(RDATE<BGPLED) D
  1.  ..S IEN=0 F  S IEN=$O(^AUPNVMSR("AA",DFN,MTYP,INV,IEN)) Q:IEN=""!(+FOUND)  D
  1.  ...S FOUND=1
  1.  ...S RESULT=$P($G(^AUPNVMSR(IEN,0)),U,4)
  1.  ...;I RESULT<80 S CEF=1_U_U_RDATE   ;ZSAT: testing; delete this line; keep next line
  1.  ...I RESULT<40 S CEF=1_U_U_RDATE
  1.  Q CEF
  1.  ;
  1. TEST ;debug target
  1.  ;S U="^"
  1.  ;S DUZ=1
  1.  ;S DT=3110310
  1.  ;S DFN=184
  1.  ;S DFN=158
  1.  ;S BGPBDATE=3100101
  1.  ;S BGPEDATE=3110401
  1.  ;S BGPPROV=2
  1.  ;S BGPMUTF="C"
  1.  ;D ENTRY
  1.  Q