BUDCRP6R ; IHS/CMI/LAB - UDS REPORT PROCESSOR ;
;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
;
BMI(P,BDATE,EDATE,AGE) ;EP
NEW HDATE,BUDCMIH,W,H,X,WD
S BUDCMIH="",WD=""
I AGE>18,AGE<51 D Q WD
.S HDATE=$$FMADD^XLFDT(BDATE,-(5*365)),HDATE=$$FMTE^XLFDT(HDATE)
.;S BDATE=$$FMADD^XLFDT(BDATE,-(5*365))
.S BDATE=$$FMTE^XLFDT(BDATE),EDATE=$$FMTE^XLFDT(EDATE)
.S W=$$WT(P,BDATE,EDATE)
.S WD=$P(W,U,2)
.S W=$P(W,U,1) I W=""!(W="?") Q
.;S HDATE=$$FMTE^XLFDT($$FMADD^XLFDT($P(^DPT(P,0),U,3),(19*365)))
.;S HDATE=BDATE
.S H=$$HT(P,HDATE,EDATE) I H="" Q
.S W=W*.45359,H=(H*.0254),H=(H*H),BUDCMIH=(W/H)
I AGE>50 D Q WD
.S HDATE=$$FMADD^XLFDT(BDATE,-(2*365)),HDATE=$$FMTE^XLFDT(HDATE)
.S BDATE=$$FMTE^XLFDT(BDATE),EDATE=$$FMTE^XLFDT(EDATE)
.S W=$$WT(P,BDATE,EDATE)
.S WD=$P(W,U,2)
.S W=$P(W,U,1) I W=""!(W="?") Q
.;S HDATE=$$FMTE^XLFDT($$FMADD^XLFDT($P(^DPT(P,0),U,3),(19*365)))
.S HDATE=BDATE
.S H=$$HT(P,HDATE,EDATE) I H="" Q
.S W=W*.45359,H=(H*.0254),H=(H*H),BUDCMIH=(W/H)
I AGE<19 D Q WD
.S X=$$HTWTSD(P,BDATE,EDATE)
.I '$P(X,"^") Q
.I '$P(X,"^",2) Q
.S W=$P(X,"^"),H=$P(X,"^",2),WD=$P(X,U,3)
.S W=W*.45359,H=(H*.0254),H=(H*H),BUDCMIH=(W/H)
.Q
Q ""
HT(P,BDATE,EDATE) ;EP
I 'P Q ""
NEW %,BUDARRY,H,E
S %=P_"^LAST MEAS HT;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(%,"BUDARRY(") S H=$P($G(BUDARRY(1)),U,2)
I H="" Q H
I H["?" Q ""
S H=$J(H,2,0)
Q H
WT(P,BDATE,EDATE) ;EP
I 'P Q ""
NEW %,E,BUDLW,X,BUDLN,BUDL,BUDLD,BUDLZ,BUDLX,ICD,BUDLWD
K BUDL S BUDLW="",BUDLWD="" S BUDLX=P_"^LAST 24 MEAS WT;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(BUDLX,"BUDL(")
S BUDLN=0 F S BUDLN=$O(BUDL(BUDLN)) Q:BUDLN'=+BUDLN!(BUDLW]"") D
.S BUDLZ=$P(BUDL(BUDLN),U,5)
.I '$D(^AUPNVPOV("AD",BUDLZ)) S BUDLW=$P(BUDL(BUDLN),U,2) Q
. S BUDLD=0 F S BUDLD=$O(^AUPNVPOV("AD",BUDLZ,BUDLD)) Q:'BUDLD!(BUDLW]"") D
.. S D=$P(BUDL(BUDLN),U)
.. S ICD=$P(^AUPNVPOV(BUDLD,0),U,1) ;$P($$ICDDX^ICDEX($P(^AUPNVPOV(BUDLD,0),U),D),U,2) D
.. I $$ICD^ATXCHK(ICD,$O(^ATXAX("B","BGP PREGNANCY DIAGNOSES 2",0)),9) Q
.. S BUDLW=$P(BUDL(BUDLN),U,2),BUDLWD=$P(BUDL(BUDLN),U,1)
..Q
Q BUDLW_U_BUDLWD
HTWTSD(P,BDATE,EDATE) ;get last ht / wt on same day
I '$G(P) Q ""
KILL BUDLWTS,BUDLHTS,%,X,BUDLWTS1,BUDLHTS1,Y
;get all hts during time frame
S %=P_"^ALL MEAS HT;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(%,"BUDLHTS(")
S Y=0 F S Y=$O(BUDLHTS(Y)) Q:Y'=+Y I $P(BUDLHTS(Y),U,2)="?"!($P(BUDLHTS(Y),U,2)="") K BUDLHTS(Y)
;set the array up by date
K BUDLHTS1 S X=0 F S X=$O(BUDLHTS(X)) Q:X'=+X S BUDLHTS1($P(BUDLHTS(X),U))=X
;get all wts during time frame
S %=P_"^ALL MEAS WT;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(%,"BUDLWTS(")
S Y=0 F S Y=$O(BUDLWTS(Y)) Q:Y'=+Y I $P(BUDLWTS(Y),U,2)="?"!($P(BUDLWTS(Y),U,2)="") K BUDLWTS(Y)
;set the array up by date
K BUDLWTS1 S X=0 F S X=$O(BUDLWTS(X)) Q:X'=+X S BUDLWTS1($P(BUDLWTS(X),U))=X
S BUDLCHT="",X=9999999 F S X=$O(BUDLWTS1(X),-1) Q:X=""!(BUDLCHT]"") I $D(BUDLHTS1(X)) S BUDLCHT=$P(BUDLWTS(BUDLWTS1(X)),U,2)_U_$P(BUDLHTS(BUDLHTS1(X)),U,2)_U_X
Q BUDLCHT
G ;EP
NEW BUDGOT
S BUDGOT=""
S BUDDOB=$P(^DPT(DFN,0),U,3)
S BUDX18RB=($E(BUDBD,1,3)-18)_"1231"
Q:BUDDOB>BUDX18RB
Q:BUDMEDV<1
S BUDX18TH=$E(BUDDOB,1,3)+18_$E(BUDDOB,4,7)
I '$$VBBD^BUDCRP6V(DFN,$$FMADD^XLFDT(BUDX18TH,1),BUDED) Q
S X=$$GETV^BUDCRP6U(DFN,BUDDOB,BUDED,BUDSITE)
Q:X<2
K BUDTOBS,BUDTOBD
S BUDTOBDD=$E(BUDBD,1,3)-1_$E(BUDBD,4,7)
S BUDB24M=$$VD^APCLV(BUDLASTV),BUDB24M=$E(BUDB24M,1,3)-2_$E(BUDB24M,4,7)
S BUDTOBS=$$TOBACCO(DFN,BUDB24M,$$VD^APCLV(BUDLASTV)) ;SCREENED IN 24 MONTHS PRIOR TO OR ON LAST VISIT
;I BUDTOBS]"",$P(BUDTOBS,U,3)'<BUDTOBDD S BUDSECG1("ABM")=$G(BUDSECG1("ABM"))+1,BUDGOT=1
S BUDUSER=$$TOBACCO^BUDCRP6U(DFN,BUDB24M,BUDED)
S BUDCESS=""
I BUDTOBS]"",BUDUSER="" S BUDGOT=1
I BUDTOBS]"",BUDUSER]"" S BUDCESS=$$TOBCESS^BUDCRP6U(DFN,BUDB24M,BUDED) I BUDCESS]"" S BUDGOT=1
I BUDGOT S BUDSECG1("ABM")=$G(BUDSECG1("ABM"))+1
S1 ;put the rest in demoninator
S BUDSECG1("PTS")=$G(BUDSECG1("PTS"))+1 D
.I $G(BUDTUA2L) D
..I 'BUDGOT S ^XTMP("BUDCRP6B",BUDJ,BUDH,"TUA2",BUDAGE,$P(^DPT(DFN,0),U),BUDCOM,DFN)=BUDTOBS_"|"_$S(BUDUSER]"":$P(BUDUSER,U,1)_" "_$$DATE^BUDCUTL1($P(BUDUSER,U,2))_"|"_$P(BUDCESS,U,1)_" "_$$DATE^BUDCUTL1($P(BUDCESS,U,3)),1:"")
.I $G(BUDTUA1L) D
..I BUDGOT S ^XTMP("BUDCRP6B",BUDJ,BUDH,"TUA1",BUDAGE,$P(^DPT(DFN,0),U),BUDCOM,DFN)=BUDTOBS_"|"_$S(BUDUSER]"":$P(BUDUSER,U,1)_" "_$$DATE^BUDCUTL1($P(BUDUSER,U,2))_"|"_$P(BUDCESS,U,1)_" "_$$DATE^BUDCUTL1($P(BUDCESS,U,3)),1:"")
Q
;
TOBACCO(P,BDATE,EDATE) ;
;TOBACCO SCREENING IN DATE RANGE?
NEW BUDTOB,BUDX,BUDPV,BUDLAST
K BUDLAST
D TOBACCO1
I BUDTOB]"" S BUDLAST($P(BUDTOB,U,3))=BUDTOB
;PATIENT ED
S BUDTOB=$$TOBPED(P,BDATE,EDATE)
I BUDTOB]"" S X=$P(BUDTOB,U,3),BUDLAST(X)=BUDTOB
;V10.0 ICD10
K BUDG S %=P_"^ALL DX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
S T=$O(^BUDCTSSC("B","TOBACCO SCREEN DXS",0))
S X=0,G="" F S X=$O(BUDG(X)) Q:X'=+X D
.S Y=+$P(BUDG(X),U,4)
.S Y=$P($G(^AUPNVPOV(Y,0)),U,1)
.I $D(^BUDCTSSC("AD",Y,T)) S BUDLAST($P(BUDG(X),U,1))=$P(BUDG(X),U,2)_U_$$FMTE^XLFDT($P(BUDG(X),U,1))_U_$P(BUDG(X),U,1)
;I G]"" Q G
;S BUDPV=$$LASTDX^BUDCUTL1(P,"BUD TOBACCO SCREEN DXS",BDATE,EDATE)
;I BUDPV S BUDLAST($P(BUDPV,U,3))=$P(BUDPV,U,2)_U_$$FMTE^XLFDT($P(BUDPV,U,3))_U_$P(BUDPV,U,3) ; Q BUDTOB
S BUDCPT=$$CPT^BUDCUTL1(P,BDATE,EDATE,$O(^ATXAX("B","BUD TOBACCO SCREEN CPTS",0)),7)
I BUDCPT]"" S BUDLAST($P(BUDCPT,U,3))=BUDCPT ;S BUDTOB=BUDCPT Q BUDTOB
I '$D(BUDLAST) Q ""
S BUDX=0 F S BUDX=$O(BUDLAST(BUDX)) Q:BUDX'=+BUDX S BUDTOB=BUDX
Q BUDLAST(BUDTOB)
TOBACCO1 ;
K BUDTOB
S BUDTOB=$$LASTHF(P,"TOBACCO (SMOKING)",BDATE,EDATE) K O,D,H
I BUDTOB]"" S BUDLAST($P(BUDTOB,U,3))=BUDTOB
S BUDTOB=$$LASTHF(P,"TOBACCO (SMOKELESS - CHEWING/DIP)",BDATE,EDATE) K O,D,H
I BUDTOB]"",'$D(BUDLAST($P(BUDTOB,U,3))) S BUDLAST($P(BUDTOB,U,3))=BUDTOB
;S BUDTOB=$$LASTHF(P,"TOBACCO (EXPOSURE)",BDATE,EDATE) K O,D,H
;I BUDTOB]"" S BUDLAST($P(BUDTOB,U,3))=BUDTOB
;S BUDTOB=$$LASTHF(P,"TOBACCO",BDATE,EDATE) K O,D,H
;I BUDTOB]"" S BUDLAST($P(BUDTOB,U,3))=BUDTOB
Q
;
LASTHF(P,C,BDATE,EDATE) ;EP
S C=$O(^AUTTHF("B",C,0))
I '$G(C) Q ""
S (H,D)=0 K O
F S H=$O(^AUTTHF("AC",C,H)) Q:'+H D
.Q:'$D(^AUPNVHF("AA",P,H))
.S D="" F S D=$O(^AUPNVHF("AA",P,H,D)) Q:D'=+D D
..Q:(9999999-D)>EDATE
..Q:(9999999-D)<BDATE
..S O(D)=$O(^AUPNVHF("AA",P,H,D,""))
.Q
S D=$O(O(0))
I D="" Q D
Q $$VAL^XBDIQ1(9000010.23,O(D),.01)_"^"_$$FMTE^XLFDT(9999999-D)_"^"_(9999999-D)
;
TOBPED(P,BDATE,EDATE) ;EP
NEW Y,X,E,D,T,%,BUDG,BUDPED,SN
K BUDPED
S Y="BUDG("
S X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I '$D(BUDG) Q ""
S SN=$O(^BGPSNOMM("B","TOBACCO SCREEN PATIENT ED",0))
S (X,D)=0,%="",T="" F S X=$O(BUDG(X)) Q:X'=+X D
.S T=$P(^AUPNVPED(+$P(BUDG(X),U,4),0),U)
.Q:'T
.Q:'$D(^AUTTEDT(T,0))
.S T=$P(^AUTTEDT(T,0),U,2)
.I $P(T,"-")="TO" S BUDPED($P(BUDG(X),U))=T_U_$$FMTE^XLFDT($P(BUDG(X),U))_U_$P(BUDG(X),U) Q
.I $P(T,"-",2)="TO" S BUDPED($P(BUDG(X),U))=T_U_$$FMTE^XLFDT($P(BUDG(X),U))_U_$P(BUDG(X),U) Q
.I $P(T,"-",2)="SHS" S BUDPED($P(BUDG(X),U))=T_U_$$FMTE^XLFDT($P(BUDG(X),U))_U_$P(BUDG(X),U) Q
.I $P(T,"-")="305.1" S BUDPED($P(BUDG(X),U))=T_U_$$FMTE^XLFDT($P(BUDG(X),U))_U_$P(BUDG(X),U) Q
.I $P(T,"-")="649.00" S BUDPED($P(BUDG(X),U))=T_U_$$FMTE^XLFDT($P(BUDG(X),U))_U_$P(BUDG(X),U) Q
.I $P(T,"-")="649.01" S BUDPED($P(BUDG(X),U))=T_U_$$FMTE^XLFDT($P(BUDG(X),U))_U_$P(BUDG(X),U) Q
.I $P(T,"-")="649.02" S BUDPED($P(BUDG(X),U))=T_U_$$FMTE^XLFDT($P(BUDG(X),U))_U_$P(BUDG(X),U) Q
.I $P(T,"-")="649.03" S BUDPED($P(BUDG(X),U))=T_U_$$FMTE^XLFDT($P(BUDG(X),U))_U_$P(BUDG(X),U) Q
.I $P(T,"-")="649.04" S BUDPED($P(BUDG(X),U))=T_U_$$FMTE^XLFDT($P(BUDG(X),U))_U_$P(BUDG(X),U) Q
.I $P(T,"-")="V15.82" S BUDPED($P(BUDG(X),U))=T_U_$$FMTE^XLFDT($P(BUDG(X),U))_U_$P(BUDG(X),U) Q
.I $P(T,"-")="1034F" S BUDPED($P(BUDG(X),U))=T_U_$$FMTE^XLFDT($P(BUDG(X),U))_U_$P(BUDG(X),U) Q
.I $P(T,"-")="1035F" S BUDPED($P(BUDG(X),U))=T_U_$$FMTE^XLFDT($P(BUDG(X),U))_U_$P(BUDG(X),U) Q
.I $P(T,"-")="1036F" S BUDPED($P(BUDG(X),U))=T_U_$$FMTE^XLFDT($P(BUDG(X),U))_U_$P(BUDG(X),U) Q
.I $P(T,"-")="1000F" S BUDPED($P(BUDG(X),U))=T_U_$$FMTE^XLFDT($P(BUDG(X),U))_U_$P(BUDG(X),U) Q
.I $E($P(T,"-"),1,3)="F17" S BUDPED($P(BUDG(X),U))=T_U_$$FMTE^XLFDT($P(BUDG(X),U))_U_$P(BUDG(X),U) Q
.I $E($P(T,"-"),1,6)="O99.33" S BUDPED($P(BUDG(X),U))=T_U_$$FMTE^XLFDT($P(BUDG(X),U))_U_$P(BUDG(X),U) Q
.I SN,$P(T,"-")]"",$D(^BGPSNOMM(SN,11,"B",$P(T,"-"))) S BUDPED($P(BUDG(X),U))=T_U_$$FMTE^XLFDT($P(BUDG(X),U))_U_$P(BUDG(X),U) Q
I '$D(BUDPED) Q ""
S X=0 F S X=$O(BUDPED(X)) Q:X'=+X S %=X
Q BUDPED(%)
CAD2HD ;EP
D S(),S(),S()
D S("***** CONFIDENTIAL PATIENT INFORMATION, COVERED BY THE PRIVACY ACT *****")
D S($P(^VA(200,DUZ,0),U,2)_" "_$$FMTE^XLFDT(DT))
D S("*** RPMS Uniform Data System (UDS) ***")
D S("Patient List for Table 6B, Section I")
D S("Coronary Artery Disease: Lipid Therapy")
D S($P(^DIC(4,BUDSITE,0),U))
S X="Reporting Period: "_$$FMTE^XLFDT(BUDBD)_" to "_$$FMTE^XLFDT(BUDED) D S(X)
S X="Population: "_$S($G(BUDCEN)=1:"Indian/Alaskan Native (Classification 01)",$G(BUDCEN)=2:"Not Indian Alaskan/Native (Not Classification 01)",$G(BUDCEN)=3:"All (both Indian/Alaskan Natives and Non 01)",1:"") D S(X)
D S()
D S("This report provides a list of all patients 18 years of age and older")
D S("with an active diagnosis of Coronary Artery Disease (CAD) including ")
D S("myocardial infarction (MI) or have had cardiac surgery and whose last ")
D S("LDL was greater than or equal to 130 or last recorded LDL is greater than")
D S("1yr from last visit in the report year who were not prescribed a ")
D S("lipid-lowering therapy medication or has no documented evidence of use by")
D S("patient of lipid lowering medication during the report period or has an ")
D S("allergy or adverse reaction to lipid-lowering therapy medications, had at")
D S("least two medical visits ever, and had a medical visit during the report")
D S("period.")
D S("Age is calculated as of December 31.")
D S("PATIENT NAME^HRN^COMMUNITY^SEX^AGE^Date of DX^DX or Svc CD^Medication^LDL")
I BUDROT="P",'BUDX2ALG W "CAD Patients with LDL >=130 w/o Lipid Lowering Medication",!
I BUDROT="P",BUDX2ALG W "CAD Patients w/LDL =>130 and an ALG or ADV Reaction to Lipid Lowering Medication"
I BUDROT="D",'BUDX2ALG D S("CAD Patients with LDL >=130 w/o Lipid Lowering Medication")
I BUDROT="D",BUDX2ALG D S("CAD Patients w/LDL =>130 and an ALG or ADV Reaction to Lipid Lowering Medication")
Q
S(V) ;
S BUDDECNT=BUDDECNT+1
S ^TMP($J,"BUDDEL",BUDDECNT)=$G(V)
Q
;------
BUDCRP6R ; IHS/CMI/LAB - UDS REPORT PROCESSOR ;
+1 ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
+2 ;
BMI(P,BDATE,EDATE,AGE) ;EP
+1 NEW HDATE,BUDCMIH,W,H,X,WD
+2 SET BUDCMIH=""
SET WD=""
+3 IF AGE>18
IF AGE<51
Begin DoDot:1
+4 SET HDATE=$$FMADD^XLFDT(BDATE,-(5*365))
SET HDATE=$$FMTE^XLFDT(HDATE)
+5 ;S BDATE=$$FMADD^XLFDT(BDATE,-(5*365))
+6 SET BDATE=$$FMTE^XLFDT(BDATE)
SET EDATE=$$FMTE^XLFDT(EDATE)
+7 SET W=$$WT(P,BDATE,EDATE)
+8 SET WD=$PIECE(W,U,2)
+9 SET W=$PIECE(W,U,1)
IF W=""!(W="?")
QUIT
+10 ;S HDATE=$$FMTE^XLFDT($$FMADD^XLFDT($P(^DPT(P,0),U,3),(19*365)))
+11 ;S HDATE=BDATE
+12 SET H=$$HT(P,HDATE,EDATE)
IF H=""
QUIT
+13 SET W=W*.45359
SET H=(H*.0254)
SET H=(H*H)
SET BUDCMIH=(W/H)
End DoDot:1
QUIT WD
+14 IF AGE>50
Begin DoDot:1
+15 SET HDATE=$$FMADD^XLFDT(BDATE,-(2*365))
SET HDATE=$$FMTE^XLFDT(HDATE)
+16 SET BDATE=$$FMTE^XLFDT(BDATE)
SET EDATE=$$FMTE^XLFDT(EDATE)
+17 SET W=$$WT(P,BDATE,EDATE)
+18 SET WD=$PIECE(W,U,2)
+19 SET W=$PIECE(W,U,1)
IF W=""!(W="?")
QUIT
+20 ;S HDATE=$$FMTE^XLFDT($$FMADD^XLFDT($P(^DPT(P,0),U,3),(19*365)))
+21 SET HDATE=BDATE
+22 SET H=$$HT(P,HDATE,EDATE)
IF H=""
QUIT
+23 SET W=W*.45359
SET H=(H*.0254)
SET H=(H*H)
SET BUDCMIH=(W/H)
End DoDot:1
QUIT WD
+24 IF AGE<19
Begin DoDot:1
+25 SET X=$$HTWTSD(P,BDATE,EDATE)
+26 IF '$PIECE(X,"^")
QUIT
+27 IF '$PIECE(X,"^",2)
QUIT
+28 SET W=$PIECE(X,"^")
SET H=$PIECE(X,"^",2)
SET WD=$PIECE(X,U,3)
+29 SET W=W*.45359
SET H=(H*.0254)
SET H=(H*H)
SET BUDCMIH=(W/H)
+30 QUIT
End DoDot:1
QUIT WD
+31 QUIT ""
HT(P,BDATE,EDATE) ;EP
+1 IF 'P
QUIT ""
+2 NEW %,BUDARRY,H,E
+3 SET %=P_"^LAST MEAS HT;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDARRY(")
SET H=$PIECE($GET(BUDARRY(1)),U,2)
+4 IF H=""
QUIT H
+5 IF H["?"
QUIT ""
+6 SET H=$JUSTIFY(H,2,0)
+7 QUIT H
WT(P,BDATE,EDATE) ;EP
+1 IF 'P
QUIT ""
+2 NEW %,E,BUDLW,X,BUDLN,BUDL,BUDLD,BUDLZ,BUDLX,ICD,BUDLWD
+3 KILL BUDL
SET BUDLW=""
SET BUDLWD=""
SET BUDLX=P_"^LAST 24 MEAS WT;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(BUDLX,"BUDL(")
+4 SET BUDLN=0
FOR
SET BUDLN=$ORDER(BUDL(BUDLN))
IF BUDLN'=+BUDLN!(BUDLW]"")
QUIT
Begin DoDot:1
+5 SET BUDLZ=$PIECE(BUDL(BUDLN),U,5)
+6 IF '$DATA(^AUPNVPOV("AD",BUDLZ))
SET BUDLW=$PIECE(BUDL(BUDLN),U,2)
QUIT
+7 SET BUDLD=0
FOR
SET BUDLD=$ORDER(^AUPNVPOV("AD",BUDLZ,BUDLD))
IF 'BUDLD!(BUDLW]"")
QUIT
Begin DoDot:2
+8 SET D=$PIECE(BUDL(BUDLN),U)
+9 ;$P($$ICDDX^ICDEX($P(^AUPNVPOV(BUDLD,0),U),D),U,2) D
SET ICD=$PIECE(^AUPNVPOV(BUDLD,0),U,1)
+10 IF $$ICD^ATXCHK(ICD,$ORDER(^ATXAX("B","BGP PREGNANCY DIAGNOSES 2",0)),9)
QUIT
+11 SET BUDLW=$PIECE(BUDL(BUDLN),U,2)
SET BUDLWD=$PIECE(BUDL(BUDLN),U,1)
+12 QUIT
End DoDot:2
End DoDot:1
+13 QUIT BUDLW_U_BUDLWD
HTWTSD(P,BDATE,EDATE) ;get last ht / wt on same day
+1 IF '$GET(P)
QUIT ""
+2 KILL BUDLWTS,BUDLHTS,%,X,BUDLWTS1,BUDLHTS1,Y
+3 ;get all hts during time frame
+4 SET %=P_"^ALL MEAS HT;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDLHTS(")
+5 SET Y=0
FOR
SET Y=$ORDER(BUDLHTS(Y))
IF Y'=+Y
QUIT
IF $PIECE(BUDLHTS(Y),U,2)="?"!($PIECE(BUDLHTS(Y),U,2)="")
KILL BUDLHTS(Y)
+6 ;set the array up by date
+7 KILL BUDLHTS1
SET X=0
FOR
SET X=$ORDER(BUDLHTS(X))
IF X'=+X
QUIT
SET BUDLHTS1($PIECE(BUDLHTS(X),U))=X
+8 ;get all wts during time frame
+9 SET %=P_"^ALL MEAS WT;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDLWTS(")
+10 SET Y=0
FOR
SET Y=$ORDER(BUDLWTS(Y))
IF Y'=+Y
QUIT
IF $PIECE(BUDLWTS(Y),U,2)="?"!($PIECE(BUDLWTS(Y),U,2)="")
KILL BUDLWTS(Y)
+11 ;set the array up by date
+12 KILL BUDLWTS1
SET X=0
FOR
SET X=$ORDER(BUDLWTS(X))
IF X'=+X
QUIT
SET BUDLWTS1($PIECE(BUDLWTS(X),U))=X
+13 SET BUDLCHT=""
SET X=9999999
FOR
SET X=$ORDER(BUDLWTS1(X),-1)
IF X=""!(BUDLCHT]"")
QUIT
IF $DATA(BUDLHTS1(X))
SET BUDLCHT=$PIECE(BUDLWTS(BUDLWTS1(X)),U,2)_U_$PIECE(BUDLHTS(BUDLHTS1(X)),U,2)_U_X
+14 QUIT BUDLCHT
G ;EP
+1 NEW BUDGOT
+2 SET BUDGOT=""
+3 SET BUDDOB=$PIECE(^DPT(DFN,0),U,3)
+4 SET BUDX18RB=($EXTRACT(BUDBD,1,3)-18)_"1231"
+5 IF BUDDOB>BUDX18RB
QUIT
+6 IF BUDMEDV<1
QUIT
+7 SET BUDX18TH=$EXTRACT(BUDDOB,1,3)+18_$EXTRACT(BUDDOB,4,7)
+8 IF '$$VBBD^BUDCRP6V(DFN,$$FMADD^XLFDT(BUDX18TH,1),BUDED)
QUIT
+9 SET X=$$GETV^BUDCRP6U(DFN,BUDDOB,BUDED,BUDSITE)
+10 IF X<2
QUIT
+11 KILL BUDTOBS,BUDTOBD
+12 SET BUDTOBDD=$EXTRACT(BUDBD,1,3)-1_$EXTRACT(BUDBD,4,7)
+13 SET BUDB24M=$$VD^APCLV(BUDLASTV)
SET BUDB24M=$EXTRACT(BUDB24M,1,3)-2_$EXTRACT(BUDB24M,4,7)
+14 ;SCREENED IN 24 MONTHS PRIOR TO OR ON LAST VISIT
SET BUDTOBS=$$TOBACCO(DFN,BUDB24M,$$VD^APCLV(BUDLASTV))
+15 ;I BUDTOBS]"",$P(BUDTOBS,U,3)'<BUDTOBDD S BUDSECG1("ABM")=$G(BUDSECG1("ABM"))+1,BUDGOT=1
+16 SET BUDUSER=$$TOBACCO^BUDCRP6U(DFN,BUDB24M,BUDED)
+17 SET BUDCESS=""
+18 IF BUDTOBS]""
IF BUDUSER=""
SET BUDGOT=1
+19 IF BUDTOBS]""
IF BUDUSER]""
SET BUDCESS=$$TOBCESS^BUDCRP6U(DFN,BUDB24M,BUDED)
IF BUDCESS]""
SET BUDGOT=1
+20 IF BUDGOT
SET BUDSECG1("ABM")=$GET(BUDSECG1("ABM"))+1
S1 ;put the rest in demoninator
+1 SET BUDSECG1("PTS")=$GET(BUDSECG1("PTS"))+1
Begin DoDot:1
+2 IF $GET(BUDTUA2L)
Begin DoDot:2
+3 IF 'BUDGOT
SET ^XTMP("BUDCRP6B",BUDJ,BUDH,"TUA2",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCOM,DFN)=BUDTOBS_"|"_$SELECT(BUDUSER]"":$PIECE(BUDUSER,U,1)_" "_$$DATE^BUDCUTL1($PIECE(BUDUSER,U,2))_"|"_$PIECE(BUDCESS,U,1)_" "_$$DATE^BUDCUTL1($PIECE(BUDCES
S,U,3)),1:"")
End DoDot:2
+4 IF $GET(BUDTUA1L)
Begin DoDot:2
+5 IF BUDGOT
SET ^XTMP("BUDCRP6B",BUDJ,BUDH,"TUA1",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCOM,DFN)=BUDTOBS_"|"_$SELECT(BUDUSER]"":$PIECE(BUDUSER,U,1)_" "_$$DATE^BUDCUTL1($PIECE(BUDUSER,U,2))_"|"_$PIECE(BUDCESS,U,1)_" "_$$DATE^BUDCUTL1($PIECE(BUDCES
S,U,3)),1:"")
End DoDot:2
End DoDot:1
+6 QUIT
+7 ;
TOBACCO(P,BDATE,EDATE) ;
+1 ;TOBACCO SCREENING IN DATE RANGE?
+2 NEW BUDTOB,BUDX,BUDPV,BUDLAST
+3 KILL BUDLAST
+4 DO TOBACCO1
+5 IF BUDTOB]""
SET BUDLAST($PIECE(BUDTOB,U,3))=BUDTOB
+6 ;PATIENT ED
+7 SET BUDTOB=$$TOBPED(P,BDATE,EDATE)
+8 IF BUDTOB]""
SET X=$PIECE(BUDTOB,U,3)
SET BUDLAST(X)=BUDTOB
+9 ;V10.0 ICD10
+10 KILL BUDG
SET %=P_"^ALL DX;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+11 SET T=$ORDER(^BUDCTSSC("B","TOBACCO SCREEN DXS",0))
+12 SET X=0
SET G=""
FOR
SET X=$ORDER(BUDG(X))
IF X'=+X
QUIT
Begin DoDot:1
+13 SET Y=+$PIECE(BUDG(X),U,4)
+14 SET Y=$PIECE($GET(^AUPNVPOV(Y,0)),U,1)
+15 IF $DATA(^BUDCTSSC("AD",Y,T))
SET BUDLAST($PIECE(BUDG(X),U,1))=$PIECE(BUDG(X),U,2)_U_$$FMTE^XLFDT($PIECE(BUDG(X),U,1))_U_$PIECE(BUDG(X),U,1)
End DoDot:1
+16 ;I G]"" Q G
+17 ;S BUDPV=$$LASTDX^BUDCUTL1(P,"BUD TOBACCO SCREEN DXS",BDATE,EDATE)
+18 ;I BUDPV S BUDLAST($P(BUDPV,U,3))=$P(BUDPV,U,2)_U_$$FMTE^XLFDT($P(BUDPV,U,3))_U_$P(BUDPV,U,3) ; Q BUDTOB
+19 SET BUDCPT=$$CPT^BUDCUTL1(P,BDATE,EDATE,$ORDER(^ATXAX("B","BUD TOBACCO SCREEN CPTS",0)),7)
+20 ;S BUDTOB=BUDCPT Q BUDTOB
IF BUDCPT]""
SET BUDLAST($PIECE(BUDCPT,U,3))=BUDCPT
+21 IF '$DATA(BUDLAST)
QUIT ""
+22 SET BUDX=0
FOR
SET BUDX=$ORDER(BUDLAST(BUDX))
IF BUDX'=+BUDX
QUIT
SET BUDTOB=BUDX
+23 QUIT BUDLAST(BUDTOB)
TOBACCO1 ;
+1 KILL BUDTOB
+2 SET BUDTOB=$$LASTHF(P,"TOBACCO (SMOKING)",BDATE,EDATE)
KILL O,D,H
+3 IF BUDTOB]""
SET BUDLAST($PIECE(BUDTOB,U,3))=BUDTOB
+4 SET BUDTOB=$$LASTHF(P,"TOBACCO (SMOKELESS - CHEWING/DIP)",BDATE,EDATE)
KILL O,D,H
+5 IF BUDTOB]""
IF '$DATA(BUDLAST($PIECE(BUDTOB,U,3)))
SET BUDLAST($PIECE(BUDTOB,U,3))=BUDTOB
+6 ;S BUDTOB=$$LASTHF(P,"TOBACCO (EXPOSURE)",BDATE,EDATE) K O,D,H
+7 ;I BUDTOB]"" S BUDLAST($P(BUDTOB,U,3))=BUDTOB
+8 ;S BUDTOB=$$LASTHF(P,"TOBACCO",BDATE,EDATE) K O,D,H
+9 ;I BUDTOB]"" S BUDLAST($P(BUDTOB,U,3))=BUDTOB
+10 QUIT
+11 ;
LASTHF(P,C,BDATE,EDATE) ;EP
+1 SET C=$ORDER(^AUTTHF("B",C,0))
+2 IF '$GET(C)
QUIT ""
+3 SET (H,D)=0
KILL O
+4 FOR
SET H=$ORDER(^AUTTHF("AC",C,H))
IF '+H
QUIT
Begin DoDot:1
+5 IF '$DATA(^AUPNVHF("AA",P,H))
QUIT
+6 SET D=""
FOR
SET D=$ORDER(^AUPNVHF("AA",P,H,D))
IF D'=+D
QUIT
Begin DoDot:2
+7 IF (9999999-D)>EDATE
QUIT
+8 IF (9999999-D)<BDATE
QUIT
+9 SET O(D)=$ORDER(^AUPNVHF("AA",P,H,D,""))
End DoDot:2
+10 QUIT
End DoDot:1
+11 SET D=$ORDER(O(0))
+12 IF D=""
QUIT D
+13 QUIT $$VAL^XBDIQ1(9000010.23,O(D),.01)_"^"_$$FMTE^XLFDT(9999999-D)_"^"_(9999999-D)
+14 ;
TOBPED(P,BDATE,EDATE) ;EP
+1 NEW Y,X,E,D,T,%,BUDG,BUDPED,SN
+2 KILL BUDPED
+3 SET Y="BUDG("
+4 SET X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+5 IF '$DATA(BUDG)
QUIT ""
+6 SET SN=$ORDER(^BGPSNOMM("B","TOBACCO SCREEN PATIENT ED",0))
+7 SET (X,D)=0
SET %=""
SET T=""
FOR
SET X=$ORDER(BUDG(X))
IF X'=+X
QUIT
Begin DoDot:1
+8 SET T=$PIECE(^AUPNVPED(+$PIECE(BUDG(X),U,4),0),U)
+9 IF 'T
QUIT
+10 IF '$DATA(^AUTTEDT(T,0))
QUIT
+11 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+12 IF $PIECE(T,"-")="TO"
SET BUDPED($PIECE(BUDG(X),U))=T_U_$$FMTE^XLFDT($PIECE(BUDG(X),U))_U_$PIECE(BUDG(X),U)
QUIT
+13 IF $PIECE(T,"-",2)="TO"
SET BUDPED($PIECE(BUDG(X),U))=T_U_$$FMTE^XLFDT($PIECE(BUDG(X),U))_U_$PIECE(BUDG(X),U)
QUIT
+14 IF $PIECE(T,"-",2)="SHS"
SET BUDPED($PIECE(BUDG(X),U))=T_U_$$FMTE^XLFDT($PIECE(BUDG(X),U))_U_$PIECE(BUDG(X),U)
QUIT
+15 IF $PIECE(T,"-")="305.1"
SET BUDPED($PIECE(BUDG(X),U))=T_U_$$FMTE^XLFDT($PIECE(BUDG(X),U))_U_$PIECE(BUDG(X),U)
QUIT
+16 IF $PIECE(T,"-")="649.00"
SET BUDPED($PIECE(BUDG(X),U))=T_U_$$FMTE^XLFDT($PIECE(BUDG(X),U))_U_$PIECE(BUDG(X),U)
QUIT
+17 IF $PIECE(T,"-")="649.01"
SET BUDPED($PIECE(BUDG(X),U))=T_U_$$FMTE^XLFDT($PIECE(BUDG(X),U))_U_$PIECE(BUDG(X),U)
QUIT
+18 IF $PIECE(T,"-")="649.02"
SET BUDPED($PIECE(BUDG(X),U))=T_U_$$FMTE^XLFDT($PIECE(BUDG(X),U))_U_$PIECE(BUDG(X),U)
QUIT
+19 IF $PIECE(T,"-")="649.03"
SET BUDPED($PIECE(BUDG(X),U))=T_U_$$FMTE^XLFDT($PIECE(BUDG(X),U))_U_$PIECE(BUDG(X),U)
QUIT
+20 IF $PIECE(T,"-")="649.04"
SET BUDPED($PIECE(BUDG(X),U))=T_U_$$FMTE^XLFDT($PIECE(BUDG(X),U))_U_$PIECE(BUDG(X),U)
QUIT
+21 IF $PIECE(T,"-")="V15.82"
SET BUDPED($PIECE(BUDG(X),U))=T_U_$$FMTE^XLFDT($PIECE(BUDG(X),U))_U_$PIECE(BUDG(X),U)
QUIT
+22 IF $PIECE(T,"-")="1034F"
SET BUDPED($PIECE(BUDG(X),U))=T_U_$$FMTE^XLFDT($PIECE(BUDG(X),U))_U_$PIECE(BUDG(X),U)
QUIT
+23 IF $PIECE(T,"-")="1035F"
SET BUDPED($PIECE(BUDG(X),U))=T_U_$$FMTE^XLFDT($PIECE(BUDG(X),U))_U_$PIECE(BUDG(X),U)
QUIT
+24 IF $PIECE(T,"-")="1036F"
SET BUDPED($PIECE(BUDG(X),U))=T_U_$$FMTE^XLFDT($PIECE(BUDG(X),U))_U_$PIECE(BUDG(X),U)
QUIT
+25 IF $PIECE(T,"-")="1000F"
SET BUDPED($PIECE(BUDG(X),U))=T_U_$$FMTE^XLFDT($PIECE(BUDG(X),U))_U_$PIECE(BUDG(X),U)
QUIT
+26 IF $EXTRACT($PIECE(T,"-"),1,3)="F17"
SET BUDPED($PIECE(BUDG(X),U))=T_U_$$FMTE^XLFDT($PIECE(BUDG(X),U))_U_$PIECE(BUDG(X),U)
QUIT
+27 IF $EXTRACT($PIECE(T,"-"),1,6)="O99.33"
SET BUDPED($PIECE(BUDG(X),U))=T_U_$$FMTE^XLFDT($PIECE(BUDG(X),U))_U_$PIECE(BUDG(X),U)
QUIT
+28 IF SN
IF $PIECE(T,"-")]""
IF $DATA(^BGPSNOMM(SN,11,"B",$PIECE(T,"-")))
SET BUDPED($PIECE(BUDG(X),U))=T_U_$$FMTE^XLFDT($PIECE(BUDG(X),U))_U_$PIECE(BUDG(X),U)
QUIT
End DoDot:1
+29 IF '$DATA(BUDPED)
QUIT ""
+30 SET X=0
FOR
SET X=$ORDER(BUDPED(X))
IF X'=+X
QUIT
SET %=X
+31 QUIT BUDPED(%)
CAD2HD ;EP
+1 DO S()
DO S()
DO S()
+2 DO S("***** CONFIDENTIAL PATIENT INFORMATION, COVERED BY THE PRIVACY ACT *****")
+3 DO S($PIECE(^VA(200,DUZ,0),U,2)_" "_$$FMTE^XLFDT(DT))
+4 DO S("*** RPMS Uniform Data System (UDS) ***")
+5 DO S("Patient List for Table 6B, Section I")
+6 DO S("Coronary Artery Disease: Lipid Therapy")
+7 DO S($PIECE(^DIC(4,BUDSITE,0),U))
+8 SET X="Reporting Period: "_$$FMTE^XLFDT(BUDBD)_" to "_$$FMTE^XLFDT(BUDED)
DO S(X)
+9 SET X="Population: "_$SELECT($GET(BUDCEN)=1:"Indian/Alaskan Native (Classification 01)",$GET(BUDCEN)=2:"Not Indian Alaskan/Native (Not Classification 01)",$GET(BUDCEN)=3:"All (both Indian/Alaskan Natives and Non 01)",1:"")
DO S(X)
+10 DO S()
+11 DO S("This report provides a list of all patients 18 years of age and older")
+12 DO S("with an active diagnosis of Coronary Artery Disease (CAD) including ")
+13 DO S("myocardial infarction (MI) or have had cardiac surgery and whose last ")
+14 DO S("LDL was greater than or equal to 130 or last recorded LDL is greater than")
+15 DO S("1yr from last visit in the report year who were not prescribed a ")
+16 DO S("lipid-lowering therapy medication or has no documented evidence of use by")
+17 DO S("patient of lipid lowering medication during the report period or has an ")
+18 DO S("allergy or adverse reaction to lipid-lowering therapy medications, had at")
+19 DO S("least two medical visits ever, and had a medical visit during the report")
+20 DO S("period.")
+21 DO S("Age is calculated as of December 31.")
+22 DO S("PATIENT NAME^HRN^COMMUNITY^SEX^AGE^Date of DX^DX or Svc CD^Medication^LDL")
+23 IF BUDROT="P"
IF 'BUDX2ALG
WRITE "CAD Patients with LDL >=130 w/o Lipid Lowering Medication",!
+24 IF BUDROT="P"
IF BUDX2ALG
WRITE "CAD Patients w/LDL =>130 and an ALG or ADV Reaction to Lipid Lowering Medication"
+25 IF BUDROT="D"
IF 'BUDX2ALG
DO S("CAD Patients with LDL >=130 w/o Lipid Lowering Medication")
+26 IF BUDROT="D"
IF BUDX2ALG
DO S("CAD Patients w/LDL =>130 and an ALG or ADV Reaction to Lipid Lowering Medication")
+27 QUIT
S(V) ;
+1 SET BUDDECNT=BUDDECNT+1
+2 SET ^TMP($JOB,"BUDDEL",BUDDECNT)=$GET(V)
+3 QUIT
+4 ;------
