BGPMUH04.m

BGPMUH04 ; IHS/MSC/MGH - MI measure NQF0436-STK-3 ;02-Mar-2011 16:05;MGH

 ;;11.0;IHS CLINICAL REPORTING;**4**;JAN 06, 2011;Build 84

 ;ED meaningful use hospital measured

ENTRY ;PEP  Stroke Measure 3- Stroke anticoagulation therapy

 N START,END,BGPIEN,DFN,BGPVST,BGPISDX,BGPHSDX,BGPAGEE,BGPIPROB,BGPHPROB,STROKE,FIB,EXC,NUM,BGPDIS

 N BGPFIBDX,BGPFIBPB,BGPFIBCP,BGPFIBPR

 N BGPDT,BGPDSTR,BGPNSTR,BGPVCNT

 ; BGPTDT=visit date; BGPDSTR='not in numerator' string; BGPNSTR='in numerater' string

 S (BGPDT,BGPDSTR,BGPNSTR)=""

 S BGPVCNT=0

 ;Start by finding all admissions during the reporting period

 S START=BGPBDATE

 S END=BGPEDATE_".2359"

 F  S START=$O(^DGPM("B",START)) Q:START=""!(START>END)  D

 .S BGPIEN="" F  S BGPIEN=$O(^DGPM("B",START,BGPIEN)) Q:BGPIEN=""  D

 ..Q:$P($G(^DGPM(BGPIEN,0)),U,2)'=1    ;Only include admissions

 ..S DFN=$P($G(^DGPM(BGPIEN,0)),U,3)

 ..Q:DFN=""

 ..S BGPACTUP=$$ACTUPAP^BGPMUEHD(DFN,BGPBDATE,BGPEDATE,BGPBEN)

 ..I 'BGPACTUP,'$G(BGPXPXPX),'$G(BGPIISO) Q

 ..S BGPVST=$P($G(^DGPM(BGPIEN,0)),U,27)  ;Get the visit

 ..Q:BGPVST=""

 ..S BGPADM=$P($$GET1^DIQ(9000010,BGPVST_",",.01,"I"),".",1) ;get admin date

 ..S BGPAGEE=$$AGE^AUPNPAT(DFN,BGPADM)

 ..S BGPDIS=$P($G(^DGPM(BGPIEN,0)),U,17)  ;Don't use if pt is still an inpt

 ..Q:BGPDIS=""

 ..;Check for a diagnosis of stroke

 ..S STROKE=0,EXC=0,NUM=0

 ..S BGPISDX=$$VSTPOVA^BGPMUUT3(DFN,BGPVST,"BGPMU ISCHEMIC STROKE DX")

 ..;S BGPIPROB=$$PLTAX^BGPMUUT1(DFN,"BGPMU ISCHEMIC STROKE DX","A")

 ..;Pt must have both a POV of stoke and it must be an active problem

 ..;I +BGPISDX&(+BGPIPROB) S STROKE=1

 ..I +BGPISDX S STROKE=1

 ..Q:'STROKE

 ..;Check next for atrial fibrillation since pt must have both

 ..S FIB=0

 ..I +STROKE D

 ...S BGPFIBDX=$$VSTPOV^BGPMUUT3(DFN,BGPVST,"BGPMU ATRIAL FIB DX")

 ...I +BGPFIBDX S FIB=BGPFIBDX

 ...S BGPFIBPB=$$PLTAX^BGPMUUT1(DFN,"BGPMU ATRIAL FIB DX")

 ...I +BGPFIBPB S FIB=BGPFIBPB

 ...S BGPFIBCP=$$VSTCPT^BGPMUUT1(DFN,BGPVST,"BGPMU ATRIAL FIB CPT")

 ...I +BGPFIBCP S FIB=BGPFIBCP

 ...S BGPFIBPR=$$VSTICD0^BGPMUUT3(DFN,BGPVST,"BGPMU ATRIAL FIB ICD0")

 ...I +BGPFIBPR S FIB=BGPFIBPR

 ...;Next check for exclusions

 ...I +FIB D

 ....S EXC=$$EXCLUDE(DFN,BGPIEN,BGPVST,BGPDIS)

 ....;If no exclusions see if they had the drug ordered

 ....I EXC="" D

 .....S (BGPNSTR,BGPDSTR)=""

 .....S BGPDT=$P($P($G(^AUPNVSIT(BGPVST,0)),U,1),".",1)

 .....;see if they had the drug ordered

 .....S NUM=$$NUMER(DFN,BGPDIS)

 .....I NUM'=0 S BGPNSTR=BGPDT_":"_$P(NUM,U,3)

 .....I NUM=0 S BGPDSTR=BGPDT

 ....;Now add it all up

 ....D TOTAL(BGPIEN)

 Q

TOTAL(BGPIEN) ;add up the totals

 N PTCNT,EXCCT,DENCT,NUMCT,TOTALS,DATE,NOTCT

 S TOTALS=$G(^TMP("BGPMU0436",$J,BGPMUTF,"TOT"))

 S DENCT=+$G(^TMP("BGPMU0436",$J,BGPMUTF,"DEN"))

 S NUMCT=+$G(^TMP("BGPMU0436",$J,BGPMUTF,"NUM"))

 S EXCCT=+$G(^TMP("BGPMU0436",$J,BGPMUTF,"EXC"))

 S NOTCT=+$G(^TMP("BGPMU0436",$J,BGPMUTF,"NOT"))

 S PTCNT=TOTALS

 S PTCNT=PTCNT+1

 S DATE=$$DATE^BGPMUUTL($P($G(^DGPM(BGPIEN,0)),U,1))

 S DENCT=DENCT+1 S ^TMP("BGPMU0436",$J,BGPMUTF,"DEN")=DENCT

 I EXC'="" D

 .S EXCCT=EXCCT+1 S ^TMP("BGPMU0436",$J,BGPMUTF,"EXC")=EXCCT

 .I BGPMUTF="C" S ^TMP("BGPMU0436",$J,"PAT",BGPMUTF,"EXC",PTCNT)=DFN_U_DATE_U_$P(EXC,U,2)

 I EXC="" D

 .I +NUM D

 ..S NUMCT=NUMCT+1 S ^TMP("BGPMU0436",$J,BGPMUTF,"NUM")=NUMCT

 ..S BGPNSTR1=$P($G(^TMP("BGPMU0436",$J,"PAT",BGPMUTF,"NUM",PTCNT)),U,2)

 ..S ^TMP("BGPMU0436",$J,"PAT",BGPMUTF,"NUM",PTCNT)=DFN_U_DATE_U_$P(NUM,U,3)_U_$P(NUM,U,2)

 .I +NUM=0 D

 ..S NOTCT=NOTCT+1 S ^TMP("BGPMU0436",$J,BGPMUTF,"NOT")=NOTCT

 ..S BGPDSTR1=$P($G(^TMP("BGPMU0436",$J,"PAT",BGPMUTF,"NOT",PTCNT)),U,2)

 ..S ^TMP("BGPMU0436",$J,"PAT",BGPMUTF,"NOT",PTCNT)=DFN_U_DATE_U_$P(NUM,U,3)_U_$P(NUM,U,2)

 S ^TMP("BGPMU0436",$J,BGPMUTF,"TOT")=PTCNT

 S BGPICARE("MU.STK.0436.1",BGPMUTF,DFN)=1_U_+$G(NUM)_U_+EXC_U_DATE_";"_$P($G(NUM),U,3)_";"_$P(EXC,U,2)

 Q

EXCLUDE(DFN,BGPIEN,BGPVST,BGPDIS) ;See if there are exclusions

 N ANTICOAG,REASON,BGPLOS,BGPHOS,BGPCLIN,BGPECI,DTYPE1,DTYPE2,BGPALL,BGPREF

 S REASON=""

 I BGPAGEE<18 S REASON="1^AGE" Q REASON

 ;Check for LOS

 S BGPLOS=$$LOS^BGPMUH08(BGPIEN,BGPDIS)

 I BGPLOS>120 S REASON="1^LOS" Q REASON

 ;Check for discharge reasons

 S DTYPE2=$P($G(^DGPM(BGPDIS,"IHS")),U,7)

 I (DTYPE2="2")!(DTYPE2="3")!(DTYPE2="4")!(DTYPE2="5")!(DTYPE2="7")!(DTYPE2="43")!(DTYPE2="50")!(DTYPE2="51") S REASON="1^"_DTYPE2 Q REASON

 ;Check for expired

 S DTYPE2=$P($G(^DGPM(BGPDIS,"IHS")),U,7)

 I (DTYPE2="20")!(DTYPE2="40")!(DTYPE2="41")!(DTYPE2="42") S REASON="1^"_DTYPE2 Q REASON

 ;Check for hospice care

 S BGPHOS=$$HOSPICE^BGPMUH08(DFN,BGPVST)

 I +BGPHOS S REASON=BGPHOS Q REASON

 ;Check for clinical trial

 S BGPCLIN=$$TRIAL^BGPMUH08(DFN,BGPVST)

 I +BGPCLIN S REASON=BGPCLIN Q REASON

 ;Check for elective carotid intervention procedure

 S BGPECI=$$ELECTIVE^BGPMUH08(DFN,BGPVST,BGPIEN)

 I +BGPECI S REASON=BGPECI Q REASON

 ;Check for allergies to warfarin

 S BGPALL=$$ALLER^BGPMUH04(DFN)

 I +BGPALL S REASON=BGPALL Q REASON

 ;Check for Anticoagulation CPT codes within past 180 days of discharge

 S BGPDISDT=$P($P($G(^DGPM(BGPDIS,0)),U,1),".",1)

 S ANTICOAG=$$CPT^BGPMUUT1(DFN,$$FMADD^XLFDT(BGPDISDT,-180),BGPDISDT,"BGPMU WARFARIN THERAPY CPT")  ;(DFN,BDATE,EDATE,TAX)

 I +ANTICOAG S REASON=ANTICOAG Q REASON

 ;Check for refusals

 S BGPREF=$$REF(DFN,BGPVST,BGPDIS)

 I +BGPREF S REASON=BGPREF

 Q REASON

ALLER(DFN) ;Find if pt has allergies to warfarin

 N AA,BB,X,Y,TEST

 S (AA,TEST)=0

 I '$D(^GMR(120.8,"B",DFN)) Q TEST

 F  S AA=$O(^GMR(120.8,"B",DFN,AA)) Q:AA'>0!(TEST=1)  D

 . I $P(^GMR(120.8,AA,0),"^",16)'=1 Q    ;Quit if not verified

 . I $D(^GMR(120.8,AA,"ER")),$P(^GMR(120.8,AA,"ER"),"^",1)=1 Q          ;

 . S X=$P(^GMR(120.8,AA,0),"^",2) X ^%ZOSF("UPPERCASE")

 . I (Y["COUMADIN")!(Y["WARFARIN") S TEST="1^"_Y

 . S BB=0

 . F  S BB=$O(^GMR(120.8,AA,3,"B",BB)) Q:BB'>0  D

 . . I $P(^PS(50.605,BB,0),"^",1)="BL110" S TEST="1^"_Y

 Q TEST

REF(DFN,BGPVST,BGPDIS) ;Find refuals for this medication

 N ENDDT,X1,X2,X,MED,BGPEVT,DISDT

 S MED=0

 S BGPEVT=$P($G(^AUPNVSIT(BGPVST,0)),U,1)

 S DISDT=$P($G(^DGPM(BGPDIS,0)),U,1)

 S ENDDT=$$FMADD^XLFDT(DISDT,+1)

 S TAX="BGPMU ANTICOAG NDCS"

 S MED=$$MEDREF^BGPMUUT2(DFN,BGPEVT,ENDDT,TAX)

 Q MED

NUMER(DFN,BGPDIS) ;Check to see if pt is in the numerator

 N DRUG,TAX,MEDTYPE,DDATE

 S MEDTYPE="OP",TAX="BGPMU ANTICOAG NDCS"

 S DDATE=$P($G(^DGPM(BGPDIS,0)),U,1)

 S DRUG=$$FIND^BGPMUUT4(DFN,TAX,DDATE,MEDTYPE)     ; DRUG = 1_U_NDC

 Q DRUG_U_DDATE

BGPMUH04  ; IHS/MSC/MGH - MI measure NQF0436-STK-3 ;02-Mar-2011 16:05;MGH

 +1       ;;11.0;IHS CLINICAL REPORTING;**4**;JAN 06, 2011;Build 84

 +2       ;ED meaningful use hospital measured

ENTRY     ;PEP  Stroke Measure 3- Stroke anticoagulation therapy

 +1        NEW START,END,BGPIEN,DFN,BGPVST,BGPISDX,BGPHSDX,BGPAGEE,BGPIPROB,BGPHPROB,STROKE,FIB,EXC,NUM,BGPDIS

 +2        NEW BGPFIBDX,BGPFIBPB,BGPFIBCP,BGPFIBPR

 +3        NEW BGPDT,BGPDSTR,BGPNSTR,BGPVCNT

 +4       ; BGPTDT=visit date; BGPDSTR='not in numerator' string; BGPNSTR='in numerater' string

 +5        SET (BGPDT,BGPDSTR,BGPNSTR)=""

 +6        SET BGPVCNT=0

 +7       ;Start by finding all admissions during the reporting period

 +8        SET START=BGPBDATE

 +9        SET END=BGPEDATE_".2359"

 +10       FOR 

               SET START=$ORDER(^DGPM("B",START))

               IF START=""!(START>END)

                   QUIT 

               Begin DoDot:1

 +11               SET BGPIEN=""

                   FOR 

                       SET BGPIEN=$ORDER(^DGPM("B",START,BGPIEN))

                       IF BGPIEN=""

                           QUIT 

                       Begin DoDot:2

 +12      ;Only include admissions

                           IF $PIECE($GET(^DGPM(BGPIEN,0)),U,2)'=1

                               QUIT 

 +13                       SET DFN=$PIECE($GET(^DGPM(BGPIEN,0)),U,3)

 +14                       IF DFN=""

                               QUIT 

 +15                       SET BGPACTUP=$$ACTUPAP^BGPMUEHD(DFN,BGPBDATE,BGPEDATE,BGPBEN)

 +16                       IF 'BGPACTUP

                               IF '$GET(BGPXPXPX)

                                   IF '$GET(BGPIISO)

                                       QUIT 

 +17      ;Get the visit

                           SET BGPVST=$PIECE($GET(^DGPM(BGPIEN,0)),U,27)

 +18                       IF BGPVST=""

                               QUIT 

 +19      ;get admin date

                           SET BGPADM=$PIECE($$GET1^DIQ(9000010,BGPVST_",",.01,"I"),".",1)

 +20                       SET BGPAGEE=$$AGE^AUPNPAT(DFN,BGPADM)

 +21      ;Don't use if pt is still an inpt

                           SET BGPDIS=$PIECE($GET(^DGPM(BGPIEN,0)),U,17)

 +22                       IF BGPDIS=""

                               QUIT 

 +23      ;Check for a diagnosis of stroke

 +24                       SET STROKE=0

                           SET EXC=0

                           SET NUM=0

 +25                       SET BGPISDX=$$VSTPOVA^BGPMUUT3(DFN,BGPVST,"BGPMU ISCHEMIC STROKE DX")

 +26      ;S BGPIPROB=$$PLTAX^BGPMUUT1(DFN,"BGPMU ISCHEMIC STROKE DX","A")

 +27      ;Pt must have both a POV of stoke and it must be an active problem

 +28      ;I +BGPISDX&(+BGPIPROB) S STROKE=1

 +29                       IF +BGPISDX

                               SET STROKE=1

 +30                       IF 'STROKE

                               QUIT 

 +31      ;Check next for atrial fibrillation since pt must have both

 +32                       SET FIB=0

 +33                       IF +STROKE

                               Begin DoDot:3

 +34                               SET BGPFIBDX=$$VSTPOV^BGPMUUT3(DFN,BGPVST,"BGPMU ATRIAL FIB DX")

 +35                               IF +BGPFIBDX

                                       SET FIB=BGPFIBDX

 +36                               SET BGPFIBPB=$$PLTAX^BGPMUUT1(DFN,"BGPMU ATRIAL FIB DX")

 +37                               IF +BGPFIBPB

                                       SET FIB=BGPFIBPB

 +38                               SET BGPFIBCP=$$VSTCPT^BGPMUUT1(DFN,BGPVST,"BGPMU ATRIAL FIB CPT")

 +39                               IF +BGPFIBCP

                                       SET FIB=BGPFIBCP

 +40                               SET BGPFIBPR=$$VSTICD0^BGPMUUT3(DFN,BGPVST,"BGPMU ATRIAL FIB ICD0")

 +41                               IF +BGPFIBPR

                                       SET FIB=BGPFIBPR

 +42      ;Next check for exclusions

 +43                               IF +FIB

                                       Begin DoDot:4

 +44                                       SET EXC=$$EXCLUDE(DFN,BGPIEN,BGPVST,BGPDIS)

 +45      ;If no exclusions see if they had the drug ordered

 +46                                       IF EXC=""

                                               Begin DoDot:5

 +47                                               SET (BGPNSTR,BGPDSTR)=""

 +48                                               SET BGPDT=$PIECE($PIECE($GET(^AUPNVSIT(BGPVST,0)),U,1),".",1)

 +49      ;see if they had the drug ordered

 +50                                               SET NUM=$$NUMER(DFN,BGPDIS)

 +51                                               IF NUM'=0

                                                       SET BGPNSTR=BGPDT_":"_$PIECE(NUM,U,3)

 +52                                               IF NUM=0

                                                       SET BGPDSTR=BGPDT

                                               End DoDot:5

 +53      ;Now add it all up

 +54                                       DO TOTAL(BGPIEN)

                                       End DoDot:4

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +55       QUIT 

TOTAL(BGPIEN) ;add up the totals

 +1        NEW PTCNT,EXCCT,DENCT,NUMCT,TOTALS,DATE,NOTCT

 +2        SET TOTALS=$GET(^TMP("BGPMU0436",$JOB,BGPMUTF,"TOT"))

 +3        SET DENCT=+$GET(^TMP("BGPMU0436",$JOB,BGPMUTF,"DEN"))

 +4        SET NUMCT=+$GET(^TMP("BGPMU0436",$JOB,BGPMUTF,"NUM"))

 +5        SET EXCCT=+$GET(^TMP("BGPMU0436",$JOB,BGPMUTF,"EXC"))

 +6        SET NOTCT=+$GET(^TMP("BGPMU0436",$JOB,BGPMUTF,"NOT"))

 +7        SET PTCNT=TOTALS

 +8        SET PTCNT=PTCNT+1

 +9        SET DATE=$$DATE^BGPMUUTL($PIECE($GET(^DGPM(BGPIEN,0)),U,1))

 +10       SET DENCT=DENCT+1

           SET ^TMP("BGPMU0436",$JOB,BGPMUTF,"DEN")=DENCT

 +11       IF EXC'=""

               Begin DoDot:1

 +12               SET EXCCT=EXCCT+1

                   SET ^TMP("BGPMU0436",$JOB,BGPMUTF,"EXC")=EXCCT

 +13               IF BGPMUTF="C"

                       SET ^TMP("BGPMU0436",$JOB,"PAT",BGPMUTF,"EXC",PTCNT)=DFN_U_DATE_U_$PIECE(EXC,U,2)

               End DoDot:1

 +14       IF EXC=""

               Begin DoDot:1

 +15               IF +NUM

                       Begin DoDot:2

 +16                       SET NUMCT=NUMCT+1

                           SET ^TMP("BGPMU0436",$JOB,BGPMUTF,"NUM")=NUMCT

 +17                       SET BGPNSTR1=$PIECE($GET(^TMP("BGPMU0436",$JOB,"PAT",BGPMUTF,"NUM",PTCNT)),U,2)

 +18                       SET ^TMP("BGPMU0436",$JOB,"PAT",BGPMUTF,"NUM",PTCNT)=DFN_U_DATE_U_$PIECE(NUM,U,3)_U_$PIECE(NUM,U,2)

                       End DoDot:2

 +19               IF +NUM=0

                       Begin DoDot:2

 +20                       SET NOTCT=NOTCT+1

                           SET ^TMP("BGPMU0436",$JOB,BGPMUTF,"NOT")=NOTCT

 +21                       SET BGPDSTR1=$PIECE($GET(^TMP("BGPMU0436",$JOB,"PAT",BGPMUTF,"NOT",PTCNT)),U,2)

 +22                       SET ^TMP("BGPMU0436",$JOB,"PAT",BGPMUTF,"NOT",PTCNT)=DFN_U_DATE_U_$PIECE(NUM,U,3)_U_$PIECE(NUM,U,2)

                       End DoDot:2

               End DoDot:1

 +23       SET ^TMP("BGPMU0436",$JOB,BGPMUTF,"TOT")=PTCNT

 +24       SET BGPICARE("MU.STK.0436.1",BGPMUTF,DFN)=1_U_+$GET(NUM)_U_+EXC_U_DATE_";"_$PIECE($GET(NUM),U,3)_";"_$PIECE(EXC,U,2)

 +25       QUIT 

EXCLUDE(DFN,BGPIEN,BGPVST,BGPDIS) ;See if there are exclusions

 +1        NEW ANTICOAG,REASON,BGPLOS,BGPHOS,BGPCLIN,BGPECI,DTYPE1,DTYPE2,BGPALL,BGPREF

 +2        SET REASON=""

 +3        IF BGPAGEE<18

               SET REASON="1^AGE"

               QUIT REASON

 +4       ;Check for LOS

 +5        SET BGPLOS=$$LOS^BGPMUH08(BGPIEN,BGPDIS)

 +6        IF BGPLOS>120

               SET REASON="1^LOS"

               QUIT REASON

 +7       ;Check for discharge reasons

 +8        SET DTYPE2=$PIECE($GET(^DGPM(BGPDIS,"IHS")),U,7)

 +9        IF (DTYPE2="2")!(DTYPE2="3")!(DTYPE2="4")!(DTYPE2="5")!(DTYPE2="7")!(DTYPE2="43")!(DTYPE2="50")!(DTYPE2="51")

               SET REASON="1^"_DTYPE2

               QUIT REASON

 +10      ;Check for expired

 +11       SET DTYPE2=$PIECE($GET(^DGPM(BGPDIS,"IHS")),U,7)

 +12       IF (DTYPE2="20")!(DTYPE2="40")!(DTYPE2="41")!(DTYPE2="42")

               SET REASON="1^"_DTYPE2

               QUIT REASON

 +13      ;Check for hospice care

 +14       SET BGPHOS=$$HOSPICE^BGPMUH08(DFN,BGPVST)

 +15       IF +BGPHOS

               SET REASON=BGPHOS

               QUIT REASON

 +16      ;Check for clinical trial

 +17       SET BGPCLIN=$$TRIAL^BGPMUH08(DFN,BGPVST)

 +18       IF +BGPCLIN

               SET REASON=BGPCLIN

               QUIT REASON

 +19      ;Check for elective carotid intervention procedure

 +20       SET BGPECI=$$ELECTIVE^BGPMUH08(DFN,BGPVST,BGPIEN)

 +21       IF +BGPECI

               SET REASON=BGPECI

               QUIT REASON

 +22      ;Check for allergies to warfarin

 +23       SET BGPALL=$$ALLER^BGPMUH04(DFN)

 +24       IF +BGPALL

               SET REASON=BGPALL

               QUIT REASON

 +25      ;Check for Anticoagulation CPT codes within past 180 days of discharge

 +26       SET BGPDISDT=$PIECE($PIECE($GET(^DGPM(BGPDIS,0)),U,1),".",1)

 +27      ;(DFN,BDATE,EDATE,TAX)

           SET ANTICOAG=$$CPT^BGPMUUT1(DFN,$$FMADD^XLFDT(BGPDISDT,-180),BGPDISDT,"BGPMU WARFARIN THERAPY CPT")

 +28       IF +ANTICOAG

               SET REASON=ANTICOAG

               QUIT REASON

 +29      ;Check for refusals

 +30       SET BGPREF=$$REF(DFN,BGPVST,BGPDIS)

 +31       IF +BGPREF

               SET REASON=BGPREF

 +32       QUIT REASON

ALLER(DFN) ;Find if pt has allergies to warfarin

 +1        NEW AA,BB,X,Y,TEST

 +2        SET (AA,TEST)=0

 +3        IF '$DATA(^GMR(120.8,"B",DFN))

               QUIT TEST

 +4        FOR 

               SET AA=$ORDER(^GMR(120.8,"B",DFN,AA))

               IF AA'>0!(TEST=1)

                   QUIT 

               Begin DoDot:1

 +5       ;Quit if not verified

                   IF $PIECE(^GMR(120.8,AA,0),"^",16)'=1

                       QUIT 

 +6       ;

                   IF $DATA(^GMR(120.8,AA,"ER"))

                       IF $PIECE(^GMR(120.8,AA,"ER"),"^",1)=1

                           QUIT 

 +7                SET X=$PIECE(^GMR(120.8,AA,0),"^",2)

                   XECUTE ^%ZOSF("UPPERCASE")

 +8                IF (Y["COUMADIN")!(Y["WARFARIN")

                       SET TEST="1^"_Y

 +9                SET BB=0

 +10               FOR 

                       SET BB=$ORDER(^GMR(120.8,AA,3,"B",BB))

                       IF BB'>0

                           QUIT 

                       Begin DoDot:2

 +11                       IF $PIECE(^PS(50.605,BB,0),"^",1)="BL110"

                               SET TEST="1^"_Y

                       End DoDot:2

               End DoDot:1

 +12       QUIT TEST

REF(DFN,BGPVST,BGPDIS) ;Find refuals for this medication

 +1        NEW ENDDT,X1,X2,X,MED,BGPEVT,DISDT

 +2        SET MED=0

 +3        SET BGPEVT=$PIECE($GET(^AUPNVSIT(BGPVST,0)),U,1)

 +4        SET DISDT=$PIECE($GET(^DGPM(BGPDIS,0)),U,1)

 +5        SET ENDDT=$$FMADD^XLFDT(DISDT,+1)

 +6        SET TAX="BGPMU ANTICOAG NDCS"

 +7        SET MED=$$MEDREF^BGPMUUT2(DFN,BGPEVT,ENDDT,TAX)

 +8        QUIT MED

NUMER(DFN,BGPDIS) ;Check to see if pt is in the numerator

 +1        NEW DRUG,TAX,MEDTYPE,DDATE

 +2        SET MEDTYPE="OP"

           SET TAX="BGPMU ANTICOAG NDCS"

 +3        SET DDATE=$PIECE($GET(^DGPM(BGPDIS,0)),U,1)

 +4       ; DRUG = 1_U_NDC

           SET DRUG=$$FIND^BGPMUUT4(DFN,TAX,DDATE,MEDTYPE)

 +5        QUIT DRUG_U_DDATE