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
