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

BGPMUH06.m

Go to the documentation of this file. 
  1. BGPMUH06 ;IHS/MSC/MGH - MI measure NQF0438-STK-5 ;02-Mar-2011 16:05;MGH
  1.  ;;11.0;IHS CLINICAL REPORTING;**4**;JAN 06, 2011;Build 84
  1.  ;ED meaningful use hospital measured
  1. ENTRY ;PEP  Stroke Measure 5 - Antithrobtic therapy by end of 2nd day
  1.  N START,END,BGPIEN,DFN,BGPVST,BGPISDX,BGPHSDX,BGPAGEE,BGPIPROB,BGPHPROB,STROKE,EXC,NUM,BGPDIS
  1.  N BGPER,BGPADTMI,BDPDD,LKW,BGPADMIT,BGPDD,ADATE,SECOND
  1.  ;Start by finding all admissions during the reporting period
  1.  S START=BGPBDATE
  1.  S END=BGPEDATE_".2359"
  1.  F  S START=$O(^DGPM("B",START)) Q:START=""!(START>END)  D
  1.  .S BGPIEN="" F  S BGPIEN=$O(^DGPM("B",START,BGPIEN)) Q:BGPIEN=""  D
  1.  ..Q:$P($G(^DGPM(BGPIEN,0)),U,2)'=1    ;Only include admissions
  1.  ..S DFN=$P($G(^DGPM(BGPIEN,0)),U,3)
  1.  ..S BGPAGEE=$$AGE^AUPNPAT(DFN,BGPEDATE)
  1.  ..Q:DFN=""
  1.  ..S BGPACTUP=$$ACTUPAP^BGPMUEHD(DFN,BGPBDATE,BGPEDATE,BGPBEN)
  1.  ..I 'BGPACTUP,'$G(BGPXPXPX),'$G(BGPIISO) Q
  1.  ..S BGPVST=$P($G(^DGPM(BGPIEN,0)),U,27)  ;Get the visit
  1.  ..Q:BGPVST=""
  1.  ..S BGPDIS=$P($G(^DGPM(BGPIEN,0)),U,17)  ;Don't use if pt is still an inpt
  1.  ..Q:BGPDIS=""
  1.  ..S BGPADMIT=$P($G(^DGPM(BGPIEN,0)),U,1)  ;Admit date/time
  1.  ..S BGPDD=$P($G(^DGPM(BGPDIS,0)),U,1)     ;Discharge date/time
  1.  ..;Check for a diagnosis of stroke
  1.  ..S STROKE=0,EXC=0,NUM=0
  1.  ..S BGPISDX=$$VSTPOVA^BGPMUUT3(DFN,BGPVST,"BGPMU ISCHEMIC STROKE DX")
  1.  ..;S BGPIPROB=$$PLTAX^BGPMUUT1(DFN,"BGPMU ISCHEMIC STROKE DX","A")
  1.  ..;Pt must have both a POV of stoke and it must be an active problem
  1.  ..;I +BGPISDX&(+BGPIPROB) S STROKE=1
  1.  ..I +BGPISDX S STROKE=1
  1.  ..;Next check for exclusions
  1.  ..I +STROKE D
  1.  ...;See if there is an ER visit prior to admission
  1.  ...S BGPER=$$ER(DFN,BGPADMIT)
  1.  ...S EXC=$$EXCLUDE(DFN,BGPIEN,BGPVST,BGPDIS)
  1.  ...;If no exclusions see if they had antithrombolytics given in correct time frame
  1.  ...I EXC="" S NUM=$$NUMER(DFN,BGPADMIT,SECOND)
  1.  ...;Now add it all up
  1.  ...D TOTAL(BGPIEN)
  1.  Q
  1. TOTAL(BGPIEN) ;add up the totals
  1.  N PTCNT,EXCCT,DENCT,NUMCT,TOTALS,DATE,NOTCT
  1.  S TOTALS=$G(^TMP("BGPMU0438",$J,BGPMUTF,"TOT"))
  1.  S DENCT=+$G(^TMP("BGPMU0438",$J,BGPMUTF,"DEN"))
  1.  S NUMCT=+$G(^TMP("BGPMU0438",$J,BGPMUTF,"NUM"))
  1.  S EXCCT=+$G(^TMP("BGPMU0438",$J,BGPMUTF,"EXC"))
  1.  S NOTCT=+$G(^TMP("BGPMU0438",$J,BGPMUTF,"NOT"))
  1.  S PTCNT=TOTALS
  1.  S PTCNT=PTCNT+1
  1.  S DATE=$$DATE^BGPMUUTL($P($G(^DGPM(BGPIEN,0)),U,1))
  1.  S DENCT=DENCT+1 S ^TMP("BGPMU0438",$J,BGPMUTF,"DEN")=DENCT
  1.  I EXC'="" D
  1.  .S EXCCT=EXCCT+1 S ^TMP("BGPMU0438",$J,BGPMUTF,"EXC")=EXCCT
  1.  .I BGPMUTF="C" S ^TMP("BGPMU0438",$J,"PAT",BGPMUTF,"EXC",PTCNT)=DFN_U_DATE_U_$P(EXC,U,2)
  1.  I EXC="" D
  1.  .I +NUM=1 D
  1.  ..S NUMCT=NUMCT+1 S ^TMP("BGPMU0438",$J,BGPMUTF,"NUM")=NUMCT
  1.  ..S ^TMP("BGPMU0438",$J,"PAT",BGPMUTF,"NUM",PTCNT)=DFN_U_DATE_U_$P(NUM,U,3)_U_$P(NUM,U,2)
  1.  .I +NUM=0 D
  1.  ..S ^TMP("BGPMU0438",$J,"PAT",BGPMUTF,"NOT",PTCNT)=DFN_U_DATE_U_$P(NUM,U,3)_U_$P(NUM,U,2)
  1.  ..S NOTCT=NOTCT+1 S ^TMP("BGPMU0438",$J,BGPMUTF,"NOT")=NOTCT
  1.  S ^TMP("BGPMU0438",$J,BGPMUTF,"TOT")=PTCNT
  1.  S BGPICARE("MU.STK.0438.1",BGPMUTF,DFN)=1_U_+$G(NUM)_U_+EXC_U_DATE_";"_$P($G(NUM),U,3)_";"_$P(EXC,U,2)
  1.  Q
  1. EXCLUDE(DFN,BGPIEN,BGPVST,BGPDIS) ;See if there are exclusions
  1.  N REASON,BGPLOS,BGPHOS,BGPCLIN,BGPECI,DTYPE1,DTYPE2,BGPALL,BGPREF,BGPTPA
  1.  S REASON=""
  1.  I BGPAGEE<18 S REASON="1^AGE" Q REASON
  1.  ;Check for LOS
  1.  S BGPLOS=$$LOS^BGPMUH08(BGPIEN,BGPDIS)
  1.  I BGPLOS>120 S REASON="1^LOS" Q REASON
  1.  ;Check if LOS < 2 days
  1.  ;Find the end of hospital day 2
  1.  S ADATE=$P(BGPADMIT,".",1)
  1.  S SECOND=$$FMADD^XLFDT(ADATE,2),SECOND=SECOND_".2359"
  1.  I BGPDD<SECOND S EXC="1^LOS"            ;Length of stay too short
  1.  ;Check for palliative Care
  1.  S BGPHOS=$$HOSPICE(DFN,BGPVST,BGPADMIT)
  1.  I +BGPHOS S REASON=BGPHOS Q REASON
  1.  ;Check for clinical trial
  1.  S BGPCLIN=$$TRIAL^BGPMUH08(DFN,BGPVST)
  1.  I +BGPCLIN S REASON=BGPCLIN Q REASON
  1.  ;Check for elective carotid intervention procedure
  1.  S BGPECI=$$ELECTIVE^BGPMUH08(DFN,BGPVST,BGPIEN)
  1.  I +BGPECI S REASON=BGPECI Q REASON
  1.  ;Check for allergies to warfarin
  1.  S BGPALL=$$ALLER(DFN)
  1.  I +BGPALL S REASON=BGPALL Q REASON
  1.  ;Check for refusals
  1.  S BGPREF=$$REF(DFN,BGPVST,BGPDIS)
  1.  I +BGPREF S REASON=BGPREF Q REASON
  1.  ;Check if they had tPA
  1.  S BGPTPA=$$TPA(DFN,BGPADMIT,BGPDD)
  1.  I +BGPTPA S REASON=BGPTPA
  1.  Q REASON
  1. HOSPICE(DFN,BGPVST,BGPADMT) ;Find palliative care patients
  1.  N COMFORT,BGPTDX,BGPTPROB,BGPTCPT
  1.  S COMFORT=0
  1.  S BGPTDX=$$COMFORT^BGPMUUT3(DFN,BGPVST,"BGPMU TERMINAL",BGPADMIT,1)
  1.  I +BGPTDX S COMFORT=BGPTDX
  1.  S BGPTPROB=$$PLSTART^BGPMUUT3(DFN,"BGPMU TERMINAL","A",BGPADMIT)
  1.  I +BGPTPROB S COMFORT=BGPTPROB
  1.  S BGPTCPT=$$PALCPT^BGPMUUT3(DFN,BGPVST,"BGPMU PALLIATIVE CARE CPT",BGPADMIT)
  1.  I +BGPTCPT S COMFORT=BGPTCPT
  1.  Q COMFORT
  1. ALLER(DFN) ;Find if pt has allergies to warfarin
  1.  N AA,BB,X,Y,TEST
  1.  S (AA,TEST)=0
  1.  I '$D(^GMR(120.8,"B",DFN)) Q TEST
  1.  F  S AA=$O(^GMR(120.8,"B",DFN,AA)) Q:AA'>0!(TEST=1)  D
  1.  . I $P(^GMR(120.8,AA,0),"^",16)'=1 Q    ;Quit if not verified
  1.  . I $D(^GMR(120.8,AA,"ER")),$P(^GMR(120.8,AA,"ER"),"^",1)=1 Q
  1.  . S X=$P(^GMR(120.8,AA,0),"^",2) X ^%ZOSF("UPPERCASE")
  1.  . I (Y["COUMADIN")!(Y["WARFARIN") S TEST="1^"_Y
  1.  . S BB=0
  1.  . F  S BB=$O(^GMR(120.8,AA,3,"B",BB)) Q:BB'>0  D
  1.  . . I $P(^PS(50.605,BB,0),"^",1)="BL110" S TEST="1^"_Y
  1.  Q TEST
  1. REF(DFN,BGPVST,BGPDIS) ;Find refusals for this medication
  1.  N ENDDT,X1,X2,X,MED,BGPEVT,DISDT
  1.  S MED=0
  1.  S BGPEVT=$P($G(^AUPNVSIT(BGPVST,0)),U,1)
  1.  S DISDT=$P($G(^DGPM(BGPDIS,0)),U,1)
  1.  S ENDDT=$$FMADD^XLFDT(DISDT,+1)
  1.  S TAX="BGPMU ANTITHROMBOTIC NDCS"
  1.  S MED=$$MEDREF^BGPMUUT2(DFN,BGPEVT,ENDDT,TAX)
  1.  Q MED
  1. TPA(DFN,ADMIT,DIS) ;Check to see if had tpa
  1.  N TAX,MEDDTE,ENDDT,TPA,MEDIEN,STATUS,DRUG,BGPIDX,DISPENSE
  1.  S TPA=0
  1.  S MEDDTE=$$FMADD^XLFDT(ADMIT,-1)    ;Start time is 24hrs prior to admission
  1.  S TAX="BGPMU TPA NDC CODES"
  1.  S TPA=$$BCMA(DFN,MEDDTE,DIS,TAX)
  1.  I TPA=0 D    ;Check non-VA meds
  1.  .N N0,IEN,ST,ED,STATUS,BGPIDX,DC
  1.  .S IEN=0 F  S IEN=$O(^PS(55,DFN,"NVA",IEN)) Q:'+IEN!(+TPA)  D
  1.  ..S N0=$G(^PS(55,DFN,"NVA",IEN,0))
  1.  ..S DC=$P(N0,U,7),ST=$P(N0,U,9),ED=$P(N0,U,10)
  1.  ..S BGPIDX=$P(N0,U,2)
  1.  ..I ST="" S ST=ED
  1.  ..I ST>MEDDTE&(ST<DIS) S RESULT=$$NDC^BGPMUUT4(BGPIDX,TAX)
  1.  Q TPA
  1. ER(DFN,BGPADMIT,BGPVST) ;Find ER admit time since TPA is often given in the ER
  1.  N VST,IEN,FOUND,ERDTE,NEW
  1.  S FOUND=0,VST=0
  1.  S IEN="" F  S IEN=$O(^AMERVSIT("AC",DFN,IEN),-1) Q:IEN=""!(+FOUND)  D
  1.  .S ERDTE=$P($G(^AMERVSIT(IEN,0)),U,1)
  1.  .S NEW=$$FMADD^XLFDT(BGPADMIT,-1)
  1.  .I ERDTE>NEW&(ERDTE<BGPADMIT) S FOUND=1,VST=ERDTE
  1.  Q VST
  1. NUMER(DFN,ADMIT,SECOND) ;Find if pt in the numerator
  1.  N TAX,RESULT
  1.  S RESULT=0
  1.  S TAX="BGPMU ANTITHROMBOTIC NDCS"
  1.  S RESULT=$$BCMA(DFN,ADMIT,SECOND,TAX)
  1.  S:+RESULT $P(RESULT,U,3)=BGPDD
  1.  Q RESULT
  1. BCMA(DFN,MEDDTE,ENDDT,TAX) ;Check to see if pt is in the numerator
  1.  N MED,MEDIEN,STATUS,DRUG,DISPENSE
  1.  S MED=0
  1.  F  S MEDDTE=$O(^PSB(53.79,"AADT",DFN,MEDDTE)) Q:'+MEDDTE!(MEDDTE>ENDDT)!(+MED)  D
  1.  .S MEDIEN="" F  S MEDIEN=$O(^PSB(53.79,"AADT",DFN,MEDDTE,MEDIEN)) Q:'+MEDIEN!(+MED)  D
  1.  ..S STATUS=$P($G(^PSB(53.79,MEDIEN,0)),U,9)
  1.  ..I STATUS="G"!(STATUS="I")!(STATUS="C") D         ;Drug given
  1.  ...S DISPENSE=0 F  S DISPENSE=$O(^PSB(53.79,MEDIEN,.5,DISPENSE)) Q:'+DISPENSE!(+MED)  D
  1.  ....S DRUG=$G(^PSB(53.79,MEDIEN,.5,DISPENSE,0))
  1.  ....S DRUG=$P(DRUG,U,1)
  1.  ....S MED=$$NDC^BGPMUUT4(DRUG,TAX)
  1.  Q MED