BGPMUH07.m

BGPMUH07 ; IHS/MSC/MGH - MU measure NQF0439-STK-6 ;02-Mar-2011 16:18;DU

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

 ;meaningful use hospital measure STROKE-6 - High Cholest w/ Statin Rx

 ;

ENTRY ;PEP  Stroke Measure 6 - High Cholest w/ Statin RxHigh Cholest w/ Statin Rx

 N START,END,BGPIEN,DFN,BGPVST,BGPISDX,BGPAGEE,BGPBIRTH,BGPIPROB,STROKE,EXC,NUM,BGPDIS,BGPCHOL,BGPLIPID

 N BGPADM

 ;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)

 ..S BGPBIRTH=$$DOB^AUPNPAT(DFN)

 ..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 BGPDIS=$P($G(^DGPM(BGPIEN,0)),U,17)  ;Don't use if pt is still an inpt

 ..Q:BGPDIS=""

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

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

 ..;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

 ..;Pt must have high cholest OR (not measured) OR (on a lipid lowering drug prior to arrival)

 ..S BGPCHOL=$$CHOLEST(DFN,BGPIEN,BGPVST)  ; returns 0 for normal, 1^<value>, or 2 for not measured

 ..S BGPLIPID=$$LIPIDRX(DFN,BGPVST)

 ..;quit if normal cholest AND not on a lipid lowering agent

 ..I 'BGPCHOL,'BGPLIPID Q

 ..;Next check for exclusions

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

 ..;If no exclusions see if they have high cholesterol and an Rx for statin

 ..I '+EXC S NUM=$$NUMER(DFN,BGPVST,BGPIEN,BGPDIS)

 ..;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("BGPMU0439",$J,BGPMUTF,"TOT"))

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

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

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

 S NOTCT=+$G(^TMP("BGPMU0439",$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("BGPMU0439",$J,BGPMUTF,"DEN")=DENCT

 I +EXC D

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

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

 I '+EXC D

 .I +NUM=1 D

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

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

 .I +NUM=0 D

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

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

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

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

 Q

CHOLEST(DFN,BGPIEN,BGPVST) ; RETURNS 0^value^dt for normal, 1^value^date if high or a 2 if cholesterol not measured

 ;search for LDL-c measurement in LAB data

 ;  from 30-days prior to the admission date through the

 ;  first 48 hours of the encounter

 N LDLSDATE,LDLEDATE,ADMDATE,BGPLDL,LIEN,LABVAL,%,LDLFOUND

 S %=2

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

 S LDLSDATE=$$FMADD^XLFDT(ADMDATE,-30),LDLEDATE=$$FMADD^XLFDT(ADMDATE,2)

 S BGPLDL=$$LOINC^BGPMUUT2(DFN,LDLSDATE,LDLEDATE,"BGPMU LDL LOINC")

 I +BGPLDL D

 .S LIEN=$P(BGPLDL,U,2)

 .S LABVAL=$P($G(^AUPNVLAB(LIEN,0)),U,4)

 .I LABVAL>=100 D

 ..S %=1_U_LABVAL_U_$P(BGPLDL,U,1) Q

 .I LABVAL<100 D

 ..S %=0_U_LABVAL_U_$P(BGPLDL,U,1)

 Q %

LIPIDRX(DFN,BGPVST) ;

 Q $$FIND^BGPMUUT4(DFN,"BGPMU LIPID LOWERING NDCS",$P($G(^DGPM(BGPIEN,0)),U,1),"OP")

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

 N REASON,BGPLOS,BGPHOS,BGPCLIN,BGPECI,BGPATH,DTYPE1,DTYPE1C,DTYPE2,DTYPE2C,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 hospice care

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

 I +BGPHOS S REASON=BGPHOS Q REASON

 ;Check for clinical trials

 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 no evidence of Atherosclerosis

 S BGPATH=$$ATHERO(DFN,BGPVST,BGPIEN,BGPBIRTH)

 I 'BGPATH S REASON="1^No Atherosclerosis" Q REASON

 ;

 ; ajf ; Getting specific discharge reasons

 ;Check for discharge reasons

 S DTYPE1=$P($G(^DGPM(BGPDIS,0)),U,4)

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

 ;I DTYPE1'=12 S REASON="1^"_DTYPE1

 ;I DTYPE2'=1 S REASON="1^"_DTYPE2

 I DTYPE1 S DTYPE1C=$$MOVE(DTYPE1) I +DTYPE1C S REASON=DTYPE1C Q REASON

 I DTYPE2 S DTYPE2C=$$PSTAT(DTYPE2) I +DTYPE2C S REASON=DTYPE2C Q REASON

 ;

 ;Check for allergies to statins

 S BGPALL=$$ALLER(DFN)

 I +BGPALL S REASON=BGPALL 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 statins

 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["LIST DRUG")!(Y["NAMES HERE???") S TEST="1^"_Y  ; <----- NEEDS ATTENTION

 . 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)="CV350" S TEST="1^"_Y

 Q TEST

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

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

 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 STATIN NDCS"

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

 Q MED

ATHERO(DFN,BGPVST,BGPIEN,BGPBIRTH) ;Find evidence of atherosclerosis

 N BGPF,BGPF1,BGPF2,BGPI,BGPADX,BGPAPROB,BGPCS,BGPTMP

 S BGPF=0 ;DX pair found

 F BGPI=1:1 Q:+BGPF  S BGPCS=$T(ATHEROT+BGPI) Q:$P(BGPCS,";;",2)=""  D

 .S BGPF1=$$LASTDXI^BGPMUUT2(DFN,$P(BGPCS,";;",2),BGPBIRTH,BGPEDATE)

 .S BGPF2=$$LASTDXI^BGPMUUT2(DFN,$P(BGPCS,";;",3),BGPBIRTH,BGPEDATE)

 .S BGPF=(+BGPF1)&(+BGPF2)

 I +BGPF Q BGPF1

 S BGPADX=$$LASTDX^BGPMUUT2(DFN,BGPBIRTH,BGPEDATE,"BGPMU ATHEROSCLEROSIS DX")

 I +BGPADX Q BGPADX

 S BGPAPROB=$$PLTAX^BGPMUUT1(DFN,"BGPMU ATHEROSCLEROSIS DX","C")

 Q BGPAPROB

ATHEROT ;;

 ;;250.70;;443.81

 ;;250.80;;443.9

 ;;250.81;;443.89

 ;;414.06;;996.83

 ;;434.91;;784.51

 ;;414.00;;997.1

 ;

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

 N %,DISCHKDT,EDATE

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

 S %=0

 S DISCHKDT=$$FMADD^XLFDT(EDATE,1),$P(DISCHKDT,".",2)="0001"

 S %=$$FIND^BGPMUUT4(DFN,"BGPMU STATIN NDCS",DISCHKDT,"OP")

 S:+% $P(%,U,3)=EDATE

 Q %

 ;

MOVE(IEN) ;Check to see if movement is part of exclusions

 ; Transfer status from Facility Movement Type 405.1

 ; 2,3,13,14

 I IEN=2!IEN=3!IEN=13!IEN=14 Q "1^TRANSFER"

 ;Death -

 ; 15,16,17,18

 I IEN=15!IEN=16!IEN=17!IEN=18 Q "1^DEATH"

 Q 0

 ;

PSTAT(IEN) ;Check to see if patient status code is part of exclusions

 ; Transfer status from Patient Status Code 99999.04

 I IEN>19,IEN<30 Q "1^DEATH"

 I IEN=40!IEN=41!IEN=42 Q "1^DEATH"

 ;

 ;Discharged/Transferred to a Hospice

 I IEN=50!IEN=51 Q "1^HOSPICE"

 ;

 ;Transferred to Federal HealthCARE Facility

 I IEN=3!IEN=4!IEN=62!IEN=63!IEN=63 Q "1^FH TRANSFER"

 ;

 Q 0

BGPMUH07  ; IHS/MSC/MGH - MU measure NQF0439-STK-6 ;02-Mar-2011 16:18;DU

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

 +2       ;meaningful use hospital measure STROKE-6 - High Cholest w/ Statin Rx

 +3       ;

ENTRY     ;PEP  Stroke Measure 6 - High Cholest w/ Statin RxHigh Cholest w/ Statin Rx

 +1        NEW START,END,BGPIEN,DFN,BGPVST,BGPISDX,BGPAGEE,BGPBIRTH,BGPIPROB,STROKE,EXC,NUM,BGPDIS,BGPCHOL,BGPLIPID

 +2        NEW BGPADM

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

 +4        SET START=BGPBDATE

 +5        SET END=BGPEDATE_".2359"

 +6        FOR 

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

               IF START=""!(START>END)

                   QUIT 

               Begin DoDot:1

 +7                SET BGPIEN=""

                   FOR 

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

                       IF BGPIEN=""

                           QUIT 

                       Begin DoDot:2

 +8       ;Only include admissions

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

                               QUIT 

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

 +10                       SET BGPBIRTH=$$DOB^AUPNPAT(DFN)

 +11                       IF DFN=""

                               QUIT 

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

 +13                       IF 'BGPACTUP

                               IF '$GET(BGPXPXPX)

                                   IF '$GET(BGPIISO)

                                       QUIT 

 +14      ;Get the visit

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

 +15                       IF BGPVST=""

                               QUIT 

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

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

 +17                       IF BGPDIS=""

                               QUIT 

 +18      ;get admin date

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

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

 +20      ;Check for a diagnosis of stroke

 +21                       SET STROKE=0

                           SET EXC=0

                           SET NUM=0

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

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

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

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

 +26                       IF +BGPISDX

                               SET STROKE=1

 +27                       IF 'STROKE

                               QUIT 

 +28      ;Pt must have high cholest OR (not measured) OR (on a lipid lowering drug prior to arrival)

 +29      ; returns 0 for normal, 1^<value>, or 2 for not measured

                           SET BGPCHOL=$$CHOLEST(DFN,BGPIEN,BGPVST)

 +30                       SET BGPLIPID=$$LIPIDRX(DFN,BGPVST)

 +31      ;quit if normal cholest AND not on a lipid lowering agent

 +32                       IF 'BGPCHOL

                               IF 'BGPLIPID

                                   QUIT 

 +33      ;Next check for exclusions

 +34                       SET EXC=$$EXCLUDE(DFN,BGPIEN,BGPVST,BGPBIRTH)

 +35      ;If no exclusions see if they have high cholesterol and an Rx for statin

 +36                       IF '+EXC

                               SET NUM=$$NUMER(DFN,BGPVST,BGPIEN,BGPDIS)

 +37      ;Now add it all up

 +38                       DO TOTAL(BGPIEN)

                       End DoDot:2

               End DoDot:1

 +39       QUIT 

TOTAL(BGPIEN) ;add up the totals

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

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

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

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

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

 +6        SET NOTCT=+$GET(^TMP("BGPMU0439",$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("BGPMU0439",$JOB,BGPMUTF,"DEN")=DENCT

 +11       IF +EXC

               Begin DoDot:1

 +12               SET EXCCT=EXCCT+1

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

 +13               IF BGPMUTF="C"

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

               End DoDot:1

 +14       IF '+EXC

               Begin DoDot:1

 +15               IF +NUM=1

                       Begin DoDot:2

 +16                       SET NUMCT=NUMCT+1

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

 +17                       SET ^TMP("BGPMU0439",$JOB,"PAT",BGPMUTF,"NUM",PTCNT)=DFN_U_DATE_U_$PIECE(NUM,U,3)_U_$PIECE(NUM,U,2)_U_$PIECE(BGPCHOL,U,2)_U_$PIECE(BGPLIPID,U,2)

                       End DoDot:2

 +18               IF +NUM=0

                       Begin DoDot:2

 +19                       SET NOTCT=NOTCT+1

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

 +20                       SET ^TMP("BGPMU0439",$JOB,"PAT",BGPMUTF,"NOT",PTCNT)=DFN_U_DATE_U_$PIECE(NUM,U,3)_U_$PIECE(NUM,U,2)_U_$PIECE(BGPCHOL,U,2)_U_$PIECE(BGPLIPID,U,2)

                       End DoDot:2

               End DoDot:1

 +21       SET ^TMP("BGPMU0439",$JOB,BGPMUTF,"TOT")=PTCNT

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

 +23       QUIT 

CHOLEST(DFN,BGPIEN,BGPVST) ; RETURNS 0^value^dt for normal, 1^value^date if high or a 2 if cholesterol not measured

 +1       ;search for LDL-c measurement in LAB data

 +2       ;  from 30-days prior to the admission date through the

 +3       ;  first 48 hours of the encounter

 +4        NEW LDLSDATE,LDLEDATE,ADMDATE,BGPLDL,LIEN,LABVAL,%,LDLFOUND

 +5        SET %=2

 +6        SET ADMDATE=$PIECE($GET(^DGPM(BGPIEN,0)),U,1)

 +7        SET LDLSDATE=$$FMADD^XLFDT(ADMDATE,-30)

           SET LDLEDATE=$$FMADD^XLFDT(ADMDATE,2)

 +8        SET BGPLDL=$$LOINC^BGPMUUT2(DFN,LDLSDATE,LDLEDATE,"BGPMU LDL LOINC")

 +9        IF +BGPLDL

               Begin DoDot:1

 +10               SET LIEN=$PIECE(BGPLDL,U,2)

 +11               SET LABVAL=$PIECE($GET(^AUPNVLAB(LIEN,0)),U,4)

 +12               IF LABVAL>=100

                       Begin DoDot:2

 +13                       SET %=1_U_LABVAL_U_$PIECE(BGPLDL,U,1)

                           QUIT 

                       End DoDot:2

 +14               IF LABVAL<100

                       Begin DoDot:2

 +15                       SET %=0_U_LABVAL_U_$PIECE(BGPLDL,U,1)

                       End DoDot:2

               End DoDot:1

 +16       QUIT %

LIPIDRX(DFN,BGPVST) ;

 +1        QUIT $$FIND^BGPMUUT4(DFN,"BGPMU LIPID LOWERING NDCS",$PIECE($GET(^DGPM(BGPIEN,0)),U,1),"OP")

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

 +1        NEW REASON,BGPLOS,BGPHOS,BGPCLIN,BGPECI,BGPATH,DTYPE1,DTYPE1C,DTYPE2,DTYPE2C,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 hospice care

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

 +9        IF +BGPHOS

               SET REASON=BGPHOS

               QUIT REASON

 +10      ;Check for clinical trials

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

 +12       IF +BGPCLIN

               SET REASON=BGPCLIN

               QUIT REASON

 +13      ;Check for elective carotid intervention procedure

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

 +15       IF +BGPECI

               SET REASON=BGPECI

               QUIT REASON

 +16      ;Check for no evidence of Atherosclerosis

 +17       SET BGPATH=$$ATHERO(DFN,BGPVST,BGPIEN,BGPBIRTH)

 +18       IF 'BGPATH

               SET REASON="1^No Atherosclerosis"

               QUIT REASON

 +19      ;

 +20      ; ajf ; Getting specific discharge reasons

 +21      ;Check for discharge reasons

 +22       SET DTYPE1=$PIECE($GET(^DGPM(BGPDIS,0)),U,4)

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

 +24      ;I DTYPE1'=12 S REASON="1^"_DTYPE1

 +25      ;I DTYPE2'=1 S REASON="1^"_DTYPE2

 +26       IF DTYPE1

               SET DTYPE1C=$$MOVE(DTYPE1)

               IF +DTYPE1C

                   SET REASON=DTYPE1C

                   QUIT REASON

 +27       IF DTYPE2

               SET DTYPE2C=$$PSTAT(DTYPE2)

               IF +DTYPE2C

                   SET REASON=DTYPE2C

                   QUIT REASON

 +28      ;

 +29      ;Check for allergies to statins

 +30       SET BGPALL=$$ALLER(DFN)

 +31       IF +BGPALL

               SET REASON=BGPALL

               QUIT REASON

 +32      ;Check for refusals

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

 +34       IF +BGPREF

               SET REASON=BGPREF

 +35       QUIT REASON

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

 +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       ; <----- NEEDS ATTENTION

                   IF (Y["LIST DRUG")!(Y["NAMES HERE???")

                       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)="CV350"

                               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,TAX

 +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 STATIN NDCS"

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

 +8        QUIT MED

ATHERO(DFN,BGPVST,BGPIEN,BGPBIRTH) ;Find evidence of atherosclerosis

 +1        NEW BGPF,BGPF1,BGPF2,BGPI,BGPADX,BGPAPROB,BGPCS,BGPTMP

 +2       ;DX pair found

           SET BGPF=0

 +3        FOR BGPI=1:1

               IF +BGPF

                   QUIT 

               SET BGPCS=$TEXT(ATHEROT+BGPI)

               IF $PIECE(BGPCS,";;",2)=""

                   QUIT 

               Begin DoDot:1

 +4                SET BGPF1=$$LASTDXI^BGPMUUT2(DFN,$PIECE(BGPCS,";;",2),BGPBIRTH,BGPEDATE)

 +5                SET BGPF2=$$LASTDXI^BGPMUUT2(DFN,$PIECE(BGPCS,";;",3),BGPBIRTH,BGPEDATE)

 +6                SET BGPF=(+BGPF1)&(+BGPF2)

               End DoDot:1

 +7        IF +BGPF

               QUIT BGPF1

 +8        SET BGPADX=$$LASTDX^BGPMUUT2(DFN,BGPBIRTH,BGPEDATE,"BGPMU ATHEROSCLEROSIS DX")

 +9        IF +BGPADX

               QUIT BGPADX

 +10       SET BGPAPROB=$$PLTAX^BGPMUUT1(DFN,"BGPMU ATHEROSCLEROSIS DX","C")

 +11       QUIT BGPAPROB

ATHEROT   ;;

 +1       ;;250.70;;443.81

 +2       ;;250.80;;443.9

 +3       ;;250.81;;443.89

 +4       ;;414.06;;996.83

 +5       ;;434.91;;784.51

 +6       ;;414.00;;997.1

 +7       ;

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

 +1        NEW %,DISCHKDT,EDATE

 +2        SET EDATE=$PIECE($GET(^DGPM(BGPDIS,0)),U,1)

 +3        SET %=0

 +4        SET DISCHKDT=$$FMADD^XLFDT(EDATE,1)

           SET $PIECE(DISCHKDT,".",2)="0001"

 +5        SET %=$$FIND^BGPMUUT4(DFN,"BGPMU STATIN NDCS",DISCHKDT,"OP")

 +6        IF +%

               SET $PIECE(%,U,3)=EDATE

 +7        QUIT %

 +8       ;

MOVE(IEN) ;Check to see if movement is part of exclusions

 +1       ; Transfer status from Facility Movement Type 405.1

 +2       ; 2,3,13,14

 +3        IF IEN=2!IEN=3!IEN=13!IEN=14

               QUIT "1^TRANSFER"

 +4       ;Death -

 +5       ; 15,16,17,18

 +6        IF IEN=15!IEN=16!IEN=17!IEN=18

               QUIT "1^DEATH"

 +7        QUIT 0

 +8       ;

PSTAT(IEN) ;Check to see if patient status code is part of exclusions

 +1       ; Transfer status from Patient Status Code 99999.04

 +2        IF IEN>19

               IF IEN<30

                   QUIT "1^DEATH"

 +3        IF IEN=40!IEN=41!IEN=42

               QUIT "1^DEATH"

 +4       ;

 +5       ;Discharged/Transferred to a Hospice

 +6        IF IEN=50!IEN=51

               QUIT "1^HOSPICE"

 +7       ;

 +8       ;Transferred to Federal HealthCARE Facility

 +9        IF IEN=3!IEN=4!IEN=62!IEN=63!IEN=63

               QUIT "1^FH TRANSFER"

 +10      ;

 +11       QUIT 0