BGP2D22 ; IHS/CMI/LAB - measure I2 ;
;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
;
I2 ;EP
K BGPN1,BGPN2,BGPN3,BGPN4,BGPVALUE,BGPLHGB,BGPN5,BGPN6,BGPN7,BGPN8,BGPD7
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8)=0
S BGPD1=0,BGPD7=1 ;D7 FOOT DENOM
I 'BGPDMD2 S BGPSTOP=1 Q
I BGPDMD2 S BGPD1=1
I 'BGPDM1 S BGPSTOP=1 Q
I 'BGPD1 S BGPSTOP=1 Q
S BGPLHGB=$$HGBA1C^BGP2D2(DFN,BGPBDATE,BGPEDATE)
S BGPN1=$P(BGPLHGB,U)
S BGPVALUE=""
I BGPN1 S BGPVALUE=BGPVALUE_"A1c: "_$$DATE^BGP2UTL($P(BGPLHGB,U,3))_" "_$P(BGPLHGB,U,4)
K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,J,K,G,I,L,T,BGPG
22 ;BPS to set numr 2
S BGPV=""
S BGPBP=$$MEANBP^BGP2D2(DFN,BGPBDATE,BGPEDATE)
I BGPBP="" S BGPBP=$$BPCPT(DFN,BGPBDATE,BGPEDATE) I BGPBP]"" S BGPN2=1 D G BPS
.S BGPN7=$P(BGPBP,U),BGPV=$S(BGPN7:"BP: <130/80: BP: ",BGPN2:"BP: ",1:"")_$P(BGPBP,U,2)
I BGPBP="" G BPS
S BGPN2=1
S S=$P(BGPBP," ",1)
S DS=$P(S,"/",2),S=$P(S,"/",1)
I S<130&(DS<80) S BGPN7=1,BGPV="BP: <130/80: BP: "_S_"/"_DS I 1
E S BGPV="BP: "_S_"/"_DS
BPS ;
I BGPV]"" S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"")_BGPV
;
23 ;
S BGPLDL=$$LDL^BGP2D2(DFN,BGP365,BGPEDATE,1)
S BGPN3=$P(BGPLDL,U)
I BGPN3 S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"")_"LDL: "_$$DATE^BGP2UTL($P(BGPLDL,U,2))_" "_$P(BGPLDL,U,3)
K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,BGPLDL,BGPHDL,BGPTRI,BGPLP
24 ;micro or pos urine & GFR
S BGPGFR=$$GFR^BGP2D211(DFN,BGP365,BGPEDATE)
S BGPESRD=$$ESRD^BGP2D211(DFN,$P(^DPT(DFN,0),U,3),BGPEDATE)
S BGPQUP=$$QUANTUP^BGP2D211(DFN,BGPBDATE,BGPEDATE)
I $P(BGPESRD,U) S BGPN4=1
I BGPGFR&(BGPQUP) S BGPN4=1
I BGPN4 D
.I BGPESRD S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"")_$S(BGPESRD]"":"ESRD: "_$$DATE^BGP2UTL($P(BGPESRD,U,3))_" "_$P(BGPESRD,U,2),1:"") Q
.S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"")_"GFR: "_$$DATE^BGP2UTL($P(BGPGFR,U,2))
.S BGPVALUE=BGPVALUE_" & QUANT UP: "_$$DATE^BGP2UTL($P(BGPQUP,U,3))_" "_$P(BGPQUP,U,2)
K BGPX,BGPC
25 ;
S BGPEYE=$$EYE^BGP2D21(DFN,BGP365,BGPEDATE,1)
S A=0 I $P(BGPEYE,U)=1 S A=1
S B=0 I $P(BGPEYE,U)=2 S B=1
S C=0 I $P(BGPEYE,U)=3 S C=1
S BGPN5=0 I A!(B)!(C) S BGPN5=1
I BGPN5 S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"")_"EYE: "_$$DATE^BGP2UTL($P(BGPEYE,U,2))_" "_$P(BGPEYE,U,3)
K BGPG
K ^TMP($J,"A")
26 ;FOOT EXAM
S X=$$AMP^BGP2D27(DFN,BGPEDATE) I X S BGPD7=0,BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"")_"FOOT AMPUTATION" G ALL ;if had amputation don't put in d7 denom
S BGPFOOT=$$FOOT(DFN,BGPBDATE,BGPEDATE,1)
S BGPN8=$P(BGPFOOT,U)
I BGPN8 S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"")_"FOOT EXAM: "_$$DATE^BGP2UTL($P(BGPFOOT,U,2))_" "_$P(BGPFOOT,U,3)
ALL I BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,$S(BGPD7:BGPN8,1:1) S BGPN6=1
S BGPVALUE="AD|||"_BGPVALUE I BGPN6 S BGPVALUE=$P(BGPVALUE,"|||")_"|||*ALL* "_$P(BGPVALUE,"|||",2)
K BGPBP,BGPLDL,BGPEYE,BGPUP,BGPLHGB,BGPG,BGPX,BGPC,BGPGFR,BGPFOOT
K ^TMP($J,"A")
Q
IOMW ;EP
S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7)=0
I BGPAGEB<67 S BGPSTOP=1 Q
I $P(^DPT(DFN,0),U,2)'="F" S BGPSTOP=1 Q
S BGPFRAC=$$FRACTURE^BGP2EL3(DFN,$$FMADD^XLFDT(BGPBDATE,-182),$$FMADD^XLFDT(BGPBDATE,182))
I '$P(BGPFRAC,U) S BGPSTOP=1 Q
I BGPACTCL S BGPD1=1
I BGPACTUP S BGPD2=1
S BGPISD=$P(BGPFRAC,U,2),BGPISV=$P(BGPFRAC,U,3),BGPISV=$P(BGPFRAC,U,4)
S BGPBMD=""
I $P(BGPFRAC,U,3)="H" S BGPBMD=$$TXBMD^BGP2EL4(DFN,$P($P(^AUPNVSIT(BGPISV,0),U),"."),$$DSCHDATE^APCLV(BGPISV,"I"),1)
I $P(BGPFRAC,U,3)'="H" S BGPBMD=$$TXBMD^BGP2EL4(DFN,BGPISD,$$FMADD^XLFDT(BGPISD,182))
I $P(BGPBMD,U) S BGPN1=1
S BGPVALUE=$S(BGPRTYPE=3:"AC",BGPD1:"UP,AC",1:"UP")
S Y=""
F X=5,6,7 S V=$P(BGPFRAC,U,X) I V]"" S:Y]"" Y=Y_";" S Y=Y_V
S BGPVALUE=BGPVALUE_" FX: "_$$DATE^BGP2UTL($P(BGPFRAC,U,2))_" "_Y_"|||"_$S($P(BGPBMD,U,2)]"":"TX: "_$P(BGPBMD,U,2),1:"")
K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T,FBD,FED
Q
IAS ;EP
S (BGPN1,BGPN2,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8)=0
I BGPAGEB<5 S BGPSTOP=1 Q
I BGPAGEB>56 S BGPSTOP=1 Q
I $$EMP(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE) S BGPSTOP=1 Q
I $$COPD(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE) S BGPSTOP=1 Q
S (BGPASTH1,BGPASTH2)=$$ASSEV(DFN,BGPEDATE)
I BGPASTH1="" S BGPASTH1=$$PERASTH(DFN,$$FMADD^XLFDT(BGPBDATE,-365),BGPBDATE)
I BGPASTH2="" S BGPASTH2=$$PERASTH(DFN,BGPBDATE,BGPEDATE)
I 'BGPASTH1!('BGPASTH2) K ^TMP($J,"A") S BGPSTOP=1 Q ;not asthma in both time periods
K ^TMP($J,"A")
I BGPACTCL S BGPD1=1
I BGPACTUP S BGPD2=1
I BGPACTCL,BGPAGEB>4,BGPAGEB<10 S BGPD3=1
I BGPACTCL,BGPAGEB>9,BGPAGEB<18 S BGPD4=1
I BGPACTCL,BGPAGEB>17,BGPAGEB<57 S BGPD5=1
I BGPACTUP,BGPAGEB>4,BGPAGEB<10 S BGPD6=1
I BGPACTUP,BGPAGEB>9,BGPAGEB<18 S BGPD7=1
I BGPACTUP,BGPAGEB>17,BGPAGEB<57 S BGPD8=1
S BGPVALUE=$$ASTHTHER(DFN,BGPBDATE,BGPEDATE)
I $P(BGPVALUE,U)=1 S BGPN1=1
S BGPVALUE=$S(BGPRTYPE=3:"",BGPD2:"UP",1:"")_$S(BGPD1:",AC",1:"")_","_$P(BGPASTH1,U,2)_","_$S(BGPASTH1'=BGPASTH2:$P(BGPASTH2,U,2),1:"")_"|||"_$S($P(BGPVALUE,U,1):"NUM: "_$P(BGPVALUE,U,3)_", "_$P(BGPVALUE,U,2),1:"")
K ^TMP($J,"A")
Q
IL ;EP
S (BGPN1,BGPN2,BGPN3,BGPD1,BGPD2)=0
I BGPAGEB<18 S BGPSTOP=1 Q
I BGPACTCL S BGPD1=1
I BGPACTUP S BGPD2=1
I '(BGPD1+BGPD2) S BGPSTOP=1 Q
S X=$$CREAT(DFN,BGP365,BGPEDATE) I 'X S BGPSTOP=1 Q ;no serum creatinine test
S BGPGFR=$$GFRV(DFN,BGP365,BGPEDATE)
I $P(BGPGFR,U) D
.S BGPN1=1
.S V=$P(BGPGFR,U,2)
.I V]"" D
..I V[">" S BGPN3=1 Q
..I V["<" S BGPN2=1 Q
.S V=+V I V,V<60 S BGPN2=1 Q
.I V S BGPN3=1
.Q
S BGPVALUE=$S(BGPD2:"UP",1:"")_$S(BGPD1:",AC",1:"")_"|||"
I $P(BGPGFR,U) S BGPVALUE=BGPVALUE_$$DATE^BGP2UTL($P(BGPGFR,U,3))_" GFR: "_$P(BGPGFR,U,2)
K BGPGFR
Q
CREAT(P,BDATE,EDATE) ;EP
K BGPC
S BGPC=0
S T=$O(^ATXAX("B","BGP CREATININE CPTS",0))
I T D I X Q 1
.S X=$$CPT^BGP2DU(P,BDATE,EDATE,T,1) I X]"" Q
.S X=$$TRAN^BGP2DU(P,BDATE,EDATE,T,1)
;now get all loinc/taxonomy tests
S T=$O(^ATXAX("B","BGP CREATININE LOINC CODES",0))
S BGPLT=$O(^ATXLAB("B","DM AUDIT CREATININE TAX",0))
S B=9999999-BDATE,E=9999999-EDATE S D=E-1 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(D>B)!(BGPC) D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(BGPC) D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(BGPC) D
...Q:'$D(^AUPNVLAB(X,0))
...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC=1_U_(9999999-D)
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,T)
...S BGPC=1_U_(9999999-D)
...Q
Q BGPC
GFRV(P,BDATE,EDATE) ;
S BGPC=""
S T=$O(^LAB(60,"B","ESTIMATED GFR",0))
S T1=$O(^ATXLAB("B","BGP GPRA ESTIMATED GFR TAX",0))
S B=9999999-BDATE,E=9999999-EDATE S D=E-1 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(D>B)!(BGPC]"") D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(BGPC]"") D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(BGPC]"") D
...Q:'$D(^AUPNVLAB(X,0))
...I T,$P(^AUPNVLAB(X,0),U)=T S BGPC=1_U_$P(^AUPNVLAB(X,0),U,4)_U_(9999999-D) Q
...I T1,$D(^ATXLAB(T1,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC=1_U_$P(^AUPNVLAB(X,0),U,4)_U_(9999999-D) Q
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...S %=$P($G(^LAB(95.3,J,9999999)),U,2)
...I %="33914-3" S BGPC=1_U_$P(^AUPNVLAB(X,0),U,4)_U_(9999999-D) Q
...S J=$P($G(^LAB(95.3,J,0)),U)_"-"_$P($G(^LAB(95.3,J,0)),U,15)
...I J="33914-3" S BGPC=1_U_$P(^AUPNVLAB(X,0),U,4)_U_(9999999-D) Q
...Q
Q BGPC
LOINC(A,B) ;
NEW %
S %=$P($G(^LAB(95.3,A,9999999)),U,2)
I %]"",$D(^ATXAX(B,21,"B",%)) Q 1
S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)
I $D(^ATXAX(B,21,"B",%)) Q 1
Q ""
EMP(P,BDATE,EDATE) ;EP
K BGPG
S Y="BGPG("
S X=P_"^LAST DX [BGP EMPHYSEMA DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(BGPG(1)) Q 1
Q 0
COPD(P,BDATE,EDATE) ;EP
K BGPG
S Y="BGPG("
S X=P_"^LAST DX [BGP COPD DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(BGPG(1)) Q 1
Q 0
PERASTH(P,BDATE,EDATE) ;EP
;item 1 - one visit to er w/493 OR hosp
K ^TMP($J,"A")
S A="^TMP($J,""A"",",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
I '$D(^TMP($J,"A",1)) Q 0
S T=$O(^ATXAX("B","BGP ASTHMA DXS",0))
S (X,G)=0 F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(G) S V=$P(^TMP($J,"A",X),U,5) D
.Q:'$D(^AUPNVSIT(V,0))
.Q:'$P(^AUPNVSIT(V,0),U,9)
.Q:$P(^AUPNVSIT(V,0),U,11)
.S K=0
.I $P(^AUPNVSIT(V,0),U,7)="H" S K=1
.I $$CLINIC^APCLV(V,"C")=30 S K=1
.Q:'K
.Q:"V"[$P(^AUPNVSIT(V,0),U,3)
.S Y=$$PRIMPOV^APCLV(V,"I")
.Q:'$$ICD^ATXCHK(Y,T,9)
.S G=1_U_$$DATE^BGP2UTL($P($P(^AUPNVSIT(V,0),U),".")) ;got one
;
I G Q 1_U_"DX ON HOSP/OR ER ON "_$P(G,U,2) ;had prim dx on 30 or H so meets denom
PER3 ;
;meds
S BGPT=$O(^ATXAX("B","BGP ASTHMA DXS",0))
S T=$O(^ATXAX("B","BGP HEDIS ASTHMA MEDS",0))
S T3=$O(^ATXAX("B","BGP HEDIS ASTHMA NDC",0))
S T1=$O(^ATXAX("B","BGP HEDIS ASTHMA INHALED MEDS",0))
S T4=$O(^ATXAX("B","BGP HEDIS ASTHMA INHALED NDC",0))
S T2=$O(^ATXAX("B","BGP HEDIS ASTHMA LEUK MEDS",0))
S T5=$O(^ATXAX("B","BGP HEDIS ASTHMA LEUK NDC",0))
S (X,G,M,D,E)=0 F S X=$O(^TMP($J,"A",X)) Q:X'=+X S V=$P(^TMP($J,"A",X),U,5) D
.Q:'$D(^AUPNVSIT(V,0))
.Q:'$P(^AUPNVSIT(V,0),U,9)
.Q:$P(^AUPNVSIT(V,0),U,11)
.Q:"AOS"'[$P(^AUPNVSIT(V,0),U,7)
.S (D,Y)=0 F S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(D) I $D(^AUPNVPOV(Y,0)) S %=$P(^AUPNVPOV(Y,0),U) I $$ICD^ATXCHK(%,BGPT,9) S D=1
.I D S G=G+1 ;got one visit
.S Y=0 F S Y=$O(^AUPNVMED("AD",V,Y)) Q:Y'=+Y D
..S S=0
..Q:'$D(^AUPNVMED(Y,0))
..Q:$$UP^XLFSTR($P($G(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"
..S Z=$P($G(^AUPNVMED(Y,0)),U) ;get drug ien
..I $D(^ATXAX(T1,21,"B",Z))!($$NDC(Z,T4)),$P(^AUPNVMED(Y,0),U,8)="" S M=M+1 Q ;it is an inhaled steroid that wasn't d/c'ed so 1 dispensing event
..I $D(^ATXAX(T,21,"B",Z))!($$NDC(Z,T3)) D
...Q:$$LEUK(Z,T2,T5) ;don't count if it is a leukotriene
...S J=$P(^AUPNVMED(Y,0),U,8)
...I J]"" S S=$$FMDIFF^XLFDT(J,$P($P(^AUPNVSIT(V,0),U),"."))
...I J="" S S=$P(^AUPNVMED(Y,0),U,7)
...;S K=S/30,M=M+K
...S K=S\30 S:K<1 K=1 S M=M+K
..I $D(^ATXAX(T2,21,"B",Z))!($$NDC(Z,T5)) D Q
...S J=$P(^AUPNVMED(Y,0),U,8)
...I J]"" S S=$$FMDIFF^XLFDT(J,$P($P(^AUPNVSIT(V,0),U),"."))
...I J="" S S=$P(^AUPNVMED(Y,0),U,7)
...S K=S\30 S:K<1 K=1 S M=M+K,E=E+K
I G>3,M>1 Q 1_U_"4 POVS AND 2 MEDS"
I M>3,E<M Q 1_U_"4 meds" ;had 4 meds, not all were leuko
I M>3,E=M,G>0 Q 1_U_"LEUKOTRIENE AND 1 DX" ;had all leuk and 1 dx
Q ""
;
ASSEV(P,EDATE) ;EP - NOW CHECK ASTHMA PACKAGE SEV
;find problem list active for asthma with 2, 3 or 4 in 15th piece
NEW S,A,B,T,X,G,V,Y
S G=""
S T=$O(^ATXAX("B","BGP ASTHMA DXS",0))
S X=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G) D
.Q:$P(^AUPNPROB(X,0),U,8)>EDATE ;if added to pl after end
.S Y=$P(^AUPNPROB(X,0),U)
.Q:$P(^AUPNPROB(X,0),U,12)'="A"
.Q:'$$ICD^ATXCHK(Y,T,9)
.Q:$P(^AUPNPROB(X,0),U,15)=""
.Q:$P(^AUPNPROB(X,0),U,15)<2
.S G=1_U_"Severity >1 on PL for "_$P(^ICD9(Y,0),U)
.Q
I G Q G
S D=9999999-EDATE-1,G=""
S D=$O(^AUPNVAST("AS",P,D)) I D]"" D
.S I="" F S I=$O(^AUPNVAST("AS",P,D,I)) Q:I'=+I D
..S S=^AUPNVAST("AS",P,D,I)
..I S>1 S G="1^Severity "_S_" in V Asthma "_$$DATE^BGP2UTL((9999999-D))
Q G
;
NDC(A,B) ;
;a is drug ien
;b is taxonomy ien
S BGPNDC=$P($G(^PSDRUG(A,2)),U,4)
I BGPNDC]"",B,$D(^ATXAX(B,21,"B",BGPNDC)) Q 1
Q 0
LEUK(A,B,C) ;
;a drug ien
;b tax ien
;c tax ien for ndc
I $D(^ATXAX(B,21,"B",A)) Q 1
I $$NDC(A,C) Q 1
Q ""
ASTHTHER(P,BDATE,EDATE) ;EP
;get number of asthma medication events
K BGPMEDS1
D GETMEDS^BGP2UTL2(P,BDATE,EDATE,,,,,.BGPMEDS1)
I '$D(BGPMEDS1) Q ""
S T=$O(^ATXAX("B","BGP HEDIS PRIMARY ASTHMA MEDS",0))
S T3=$O(^ATXAX("B","BGP HEDIS PRIMARY ASTHMA NDC",0))
S (X,G,M,E)=0,D="" F S X=$O(BGPMEDS1(X)) Q:X'=+X!(D]"") S V=$P(BGPMEDS1(X),U,5),Y=+$P(BGPMEDS1(X),U,4) D
.Q:'$D(^AUPNVSIT(V,0))
.Q:'$D(^AUPNVMED(Y,0))
.Q:$$UP^XLFSTR($P($G(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"
.S Z=$P($G(^AUPNVMED(Y,0)),U) ;get drug ien
.I $D(^ATXAX(T,21,"B",Z))!($$NDC(Z,T3)),$P(^AUPNVMED(Y,0),U,8)="" S D=1_U_$P(^PSDRUG(Z,0),U)_U_$$DATE^BGP2UTL($P($P(^AUPNVSIT(V,0),U),".")) Q
Q D
NEW BGPG,%,E,A,Y,X,R,G
S REFUSAL=$G(REFUSAL) ;if =1 then don't look for Refusal
K BGPG S %=P_"^LAST EXAM DIABETIC FOOT EXAM;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q "1^"_$P(BGPG(1),U)_"^Diab Foot Ex"
K ^TMP($J,"A")
S A="^TMP($J,""A"","
S %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,A)
S X=0,Y=0 F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(Y) S R=$$CLINIC^APCLV($P(^TMP($J,"A",X),U,5),"C") I R=65,'$$DNKA^BGP2D21($P(^TMP($J,"A",X),U,5)) S Y=1,D=$P(^TMP($J,"A",X),U)
I Y Q 1_"^"_D_"^Cl "_R
S (X,Y)=0,D="" F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(Y) S R=$$PRIMPROV^APCLV($P(^TMP($J,"A",X),U,5),"D") I (R=33!(R=84)!(R=25)),'$$DNKA^BGP2D21($P(^TMP($J,"A",X),U,5)) S Y=1,D=$P(^TMP($J,"A",X),U)
I Y Q "1^"_D_"^Prv "_R
;now check for Refusal
S G=$$CPTI^BGP2DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("2028F"))
I G Q G_"^CPT: 2028F"
I $G(REFUSAL) Q ""
S G=$$REFUSAL^BGP2UTL1(P,9999999.15,$O(^AUTTEXAM("B","DIABETIC FOOT EXAM, COMPLETE",0)),BDATE,EDATE)
I $P(G,U)=1 Q "1^"_$P(G,U,2)_"^Refused"
Q ""
BPCPT(P,BDATE,EDATE,GDEV) ;EP
NEW S,D,C,E,BGPG,X,Y,G,T,M,A,Z,L
K BGPG S Y="BGPG(",X=P_"^ALL VISIT;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,Y)
;go through and get all cpt codes in the 2 taxonomies and table by date using the lowest value on that day, skip ER visits
S X=0,G="" F S X=$O(BGPG(X)) Q:X'=+X D
.S V=$P(BGPG(X),U,5) ;visit ien
.Q:'$D(^AUPNVSIT(V,0))
.Q:$$CLINIC^APCLV(V,"C")=30 ;clinic ER
.I $G(GDEV) Q:$$GDEV^BGP2D2(V)
.S E=0 F S E=$O(^AUPNVCPT("AD",V,E)) Q:E'=+E D
..S C=$P($G(^AUPNVCPT(E,0)),U)
..I 'C Q
..S D=$P($P(^AUPNVSIT(V,0),U),"."),D=(9999999-D)_"."_$P(D,".",2)
..I $$ICD^ATXCHK(C,$O(^ATXAX("B","BGP SYSTOLIC BP CPTS",0)),1) D
...S Y=$P($$CPT^ICPTCOD(C),U,2)
...S:'$D(S(D)) S(D)=Y,A(D)=Y_U_"S"
...I +S(D)>+Y S S(D)=Y
..I $$ICD^ATXCHK(C,$O(^ATXAX("B","BGP DIASTOLIC BP CPTS",0)),1) D
...S Y=$P($$CPT^ICPTCOD(C),U,2)
...S:'$D(T(D)) T(D)=Y,A(D)=Y_U_"T"
...I +T(D)>+Y S T(D)=Y
..I $$ICD^ATXCHK(C,$O(^ATXAX("B","BGP BP MEASURED CPT",0)),1) D
...S Y=$P($$CPT^ICPTCOD(C),U,2)
...S:'$D(M(D)) M(D)=Y,A(D)=Y_U_"M"
.S E=0 F S E=$O(^AUPNVPOV("AD",V,E)) Q:E'=+E D
..S Y=$$VAL^XBDIQ1(9000010.07,E,.01)
..I Y="" Q
..Q:'$$ICD^ATXCHK($$VALI^XBDIQ1(9000010.07,E,.01),$O(^ATXAX("B","BGP HYPERTENSION SCREEN DXS",0)),9)
..S D=$P($P(^AUPNVSIT(V,0),U),"."),D=(9999999-D)_"."_$P(D,".",2)
..S:'$D(M(D)) M(D)=Y,A(D)=Y_U_"M"
I '$D(S),'$D(T),'$D(M) Q "" ;
S L=$O(A(0)),Z=$P(A(L),U,2) I Z="M" Q 0_U_$P(A(L),U,1)
S S=$O(S(0)) I S S S=S(S)
S D=$O(T(0)) I D S D=T(D)
I S=""!(D="") Q 0_U_S_"/"_D
I S="3074F",D="3078F" Q 1_U_S_"/"_D
Q 0_U_S_"/"_D
BGP2D22 ; IHS/CMI/LAB - measure I2 ;
+1 ;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
+2 ;
I2 ;EP
+1 KILL BGPN1,BGPN2,BGPN3,BGPN4,BGPVALUE,BGPLHGB,BGPN5,BGPN6,BGPN7,BGPN8,BGPD7
+2 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8)=0
+3 ;D7 FOOT DENOM
SET BGPD1=0
SET BGPD7=1
+4 IF 'BGPDMD2
SET BGPSTOP=1
QUIT
+5 IF BGPDMD2
SET BGPD1=1
+6 IF 'BGPDM1
SET BGPSTOP=1
QUIT
+7 IF 'BGPD1
SET BGPSTOP=1
QUIT
+8 SET BGPLHGB=$$HGBA1C^BGP2D2(DFN,BGPBDATE,BGPEDATE)
+9 SET BGPN1=$PIECE(BGPLHGB,U)
+10 SET BGPVALUE=""
+11 IF BGPN1
SET BGPVALUE=BGPVALUE_"A1c: "_$$DATE^BGP2UTL($PIECE(BGPLHGB,U,3))_" "_$PIECE(BGPLHGB,U,4)
+12 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,J,K,G,I,L,T,BGPG
22 ;BPS to set numr 2
+1 SET BGPV=""
+2 SET BGPBP=$$MEANBP^BGP2D2(DFN,BGPBDATE,BGPEDATE)
+3 IF BGPBP=""
SET BGPBP=$$BPCPT(DFN,BGPBDATE,BGPEDATE)
IF BGPBP]""
SET BGPN2=1
Begin DoDot:1
+4 SET BGPN7=$PIECE(BGPBP,U)
SET BGPV=$SELECT(BGPN7:"BP: <130/80: BP: ",BGPN2:"BP: ",1:"")_$PIECE(BGPBP,U,2)
End DoDot:1
GOTO BPS
+5 IF BGPBP=""
GOTO BPS
+6 SET BGPN2=1
+7 SET S=$PIECE(BGPBP," ",1)
+8 SET DS=$PIECE(S,"/",2)
SET S=$PIECE(S,"/",1)
+9 IF S<130&(DS<80)
SET BGPN7=1
SET BGPV="BP: <130/80: BP: "_S_"/"_DS
IF 1
+10 IF '$TEST
SET BGPV="BP: "_S_"/"_DS
BPS ;
+1 IF BGPV]""
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")_BGPV
+2 ;
23 ;
+1 SET BGPLDL=$$LDL^BGP2D2(DFN,BGP365,BGPEDATE,1)
+2 SET BGPN3=$PIECE(BGPLDL,U)
+3 IF BGPN3
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")_"LDL: "_$$DATE^BGP2UTL($PIECE(BGPLDL,U,2))_" "_$PIECE(BGPLDL,U,3)
+4 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,BGPLDL,BGPHDL,BGPTRI,BGPLP
24 ;micro or pos urine & GFR
+1 SET BGPGFR=$$GFR^BGP2D211(DFN,BGP365,BGPEDATE)
+2 SET BGPESRD=$$ESRD^BGP2D211(DFN,$PIECE(^DPT(DFN,0),U,3),BGPEDATE)
+3 SET BGPQUP=$$QUANTUP^BGP2D211(DFN,BGPBDATE,BGPEDATE)
+4 IF $PIECE(BGPESRD,U)
SET BGPN4=1
+5 IF BGPGFR&(BGPQUP)
SET BGPN4=1
+6 IF BGPN4
Begin DoDot:1
+7 IF BGPESRD
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")_$SELECT(BGPESRD]"":"ESRD: "_$$DATE^BGP2UTL($PIECE(BGPESRD,U,3))_" "_$PIECE(BGPESRD,U,2),1:"")
QUIT
+8 SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")_"GFR: "_$$DATE^BGP2UTL($PIECE(BGPGFR,U,2))
+9 SET BGPVALUE=BGPVALUE_" & QUANT UP: "_$$DATE^BGP2UTL($PIECE(BGPQUP,U,3))_" "_$PIECE(BGPQUP,U,2)
End DoDot:1
+10 KILL BGPX,BGPC
25 ;
+1 SET BGPEYE=$$EYE^BGP2D21(DFN,BGP365,BGPEDATE,1)
+2 SET A=0
IF $PIECE(BGPEYE,U)=1
SET A=1
+3 SET B=0
IF $PIECE(BGPEYE,U)=2
SET B=1
+4 SET C=0
IF $PIECE(BGPEYE,U)=3
SET C=1
+5 SET BGPN5=0
IF A!(B)!(C)
SET BGPN5=1
+6 IF BGPN5
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")_"EYE: "_$$DATE^BGP2UTL($PIECE(BGPEYE,U,2))_" "_$PIECE(BGPEYE,U,3)
+7 KILL BGPG
+8 KILL ^TMP($JOB,"A")
26 ;FOOT EXAM
+1 ;if had amputation don't put in d7 denom
SET X=$$AMP^BGP2D27(DFN,BGPEDATE)
IF X
SET BGPD7=0
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")_"FOOT AMPUTATION"
GOTO ALL
+2 SET BGPFOOT=$$FOOT(DFN,BGPBDATE,BGPEDATE,1)
+3 SET BGPN8=$PIECE(BGPFOOT,U)
+4 IF BGPN8
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")_"FOOT EXAM: "_$$DATE^BGP2UTL($PIECE(BGPFOOT,U,2))_" "_$PIECE(BGPFOOT,U,3)
ALL IF BGPN1
IF BGPN2
IF BGPN3
IF BGPN4
IF BGPN5
IF $SELECT(BGPD7:BGPN8,1:1)
SET BGPN6=1
+1 SET BGPVALUE="AD|||"_BGPVALUE
IF BGPN6
SET BGPVALUE=$PIECE(BGPVALUE,"|||")_"|||*ALL* "_$PIECE(BGPVALUE,"|||",2)
+2 KILL BGPBP,BGPLDL,BGPEYE,BGPUP,BGPLHGB,BGPG,BGPX,BGPC,BGPGFR,BGPFOOT
+3 KILL ^TMP($JOB,"A")
+4 QUIT
IOMW ;EP
+1 SET (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0
+2 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7)=0
+3 IF BGPAGEB<67
SET BGPSTOP=1
QUIT
+4 IF $PIECE(^DPT(DFN,0),U,2)'="F"
SET BGPSTOP=1
QUIT
+5 SET BGPFRAC=$$FRACTURE^BGP2EL3(DFN,$$FMADD^XLFDT(BGPBDATE,-182),$$FMADD^XLFDT(BGPBDATE,182))
+6 IF '$PIECE(BGPFRAC,U)
SET BGPSTOP=1
QUIT
+7 IF BGPACTCL
SET BGPD1=1
+8 IF BGPACTUP
SET BGPD2=1
+9 SET BGPISD=$PIECE(BGPFRAC,U,2)
SET BGPISV=$PIECE(BGPFRAC,U,3)
SET BGPISV=$PIECE(BGPFRAC,U,4)
+10 SET BGPBMD=""
+11 IF $PIECE(BGPFRAC,U,3)="H"
SET BGPBMD=$$TXBMD^BGP2EL4(DFN,$PIECE($PIECE(^AUPNVSIT(BGPISV,0),U),"."),$$DSCHDATE^APCLV(BGPISV,"I"),1)
+12 IF $PIECE(BGPFRAC,U,3)'="H"
SET BGPBMD=$$TXBMD^BGP2EL4(DFN,BGPISD,$$FMADD^XLFDT(BGPISD,182))
+13 IF $PIECE(BGPBMD,U)
SET BGPN1=1
+14 SET BGPVALUE=$SELECT(BGPRTYPE=3:"AC",BGPD1:"UP,AC",1:"UP")
+15 SET Y=""
+16 FOR X=5,6,7
SET V=$PIECE(BGPFRAC,U,X)
IF V]""
IF Y]""
SET Y=Y_";"
SET Y=Y_V
+17 SET BGPVALUE=BGPVALUE_" FX: "_$$DATE^BGP2UTL($PIECE(BGPFRAC,U,2))_" "_Y_"|||"_$SELECT($PIECE(BGPBMD,U,2)]"":"TX: "_$PIECE(BGPBMD,U,2),1:"")
+18 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T,FBD,FED
+19 QUIT
IAS ;EP
+1 SET (BGPN1,BGPN2,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8)=0
+2 IF BGPAGEB<5
SET BGPSTOP=1
QUIT
+3 IF BGPAGEB>56
SET BGPSTOP=1
QUIT
+4 IF $$EMP(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
SET BGPSTOP=1
QUIT
+5 IF $$COPD(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)
SET BGPSTOP=1
QUIT
+6 SET (BGPASTH1,BGPASTH2)=$$ASSEV(DFN,BGPEDATE)
+7 IF BGPASTH1=""
SET BGPASTH1=$$PERASTH(DFN,$$FMADD^XLFDT(BGPBDATE,-365),BGPBDATE)
+8 IF BGPASTH2=""
SET BGPASTH2=$$PERASTH(DFN,BGPBDATE,BGPEDATE)
+9 ;not asthma in both time periods
IF 'BGPASTH1!('BGPASTH2)
KILL ^TMP($JOB,"A")
SET BGPSTOP=1
QUIT
+10 KILL ^TMP($JOB,"A")
+11 IF BGPACTCL
SET BGPD1=1
+12 IF BGPACTUP
SET BGPD2=1
+13 IF BGPACTCL
IF BGPAGEB>4
IF BGPAGEB<10
SET BGPD3=1
+14 IF BGPACTCL
IF BGPAGEB>9
IF BGPAGEB<18
SET BGPD4=1
+15 IF BGPACTCL
IF BGPAGEB>17
IF BGPAGEB<57
SET BGPD5=1
+16 IF BGPACTUP
IF BGPAGEB>4
IF BGPAGEB<10
SET BGPD6=1
+17 IF BGPACTUP
IF BGPAGEB>9
IF BGPAGEB<18
SET BGPD7=1
+18 IF BGPACTUP
IF BGPAGEB>17
IF BGPAGEB<57
SET BGPD8=1
+19 SET BGPVALUE=$$ASTHTHER(DFN,BGPBDATE,BGPEDATE)
+20 IF $PIECE(BGPVALUE,U)=1
SET BGPN1=1
+21 SET BGPVALUE=$SELECT(BGPRTYPE=3:"",BGPD2:"UP",1:"")_$SELECT(BGPD1:",AC",1:"")_","_$PIECE(BGPASTH1,U,2)_","_$SELECT(BGPASTH1'=BGPASTH2:$PIECE(BGPASTH2,U,2),1:"")_"|||"_$SELECT($PIECE(BGPVALUE,U,1):"NUM: "_$PIECE(BGPVALUE,U,3)_", "_...
... $PIECE(BGPVALUE,U,2),1:"")
+22 KILL ^TMP($JOB,"A")
+23 QUIT
IL ;EP
+1 SET (BGPN1,BGPN2,BGPN3,BGPD1,BGPD2)=0
+2 IF BGPAGEB<18
SET BGPSTOP=1
QUIT
+3 IF BGPACTCL
SET BGPD1=1
+4 IF BGPACTUP
SET BGPD2=1
+5 IF '(BGPD1+BGPD2)
SET BGPSTOP=1
QUIT
+6 ;no serum creatinine test
SET X=$$CREAT(DFN,BGP365,BGPEDATE)
IF 'X
SET BGPSTOP=1
QUIT
+7 SET BGPGFR=$$GFRV(DFN,BGP365,BGPEDATE)
+8 IF $PIECE(BGPGFR,U)
Begin DoDot:1
+9 SET BGPN1=1
+10 SET V=$PIECE(BGPGFR,U,2)
+11 IF V]""
Begin DoDot:2
+12 IF V[">"
SET BGPN3=1
QUIT
+13 IF V["<"
SET BGPN2=1
QUIT
End DoDot:2
+14 SET V=+V
IF V
IF V<60
SET BGPN2=1
QUIT
+15 IF V
SET BGPN3=1
+16 QUIT
End DoDot:1
+17 SET BGPVALUE=$SELECT(BGPD2:"UP",1:"")_$SELECT(BGPD1:",AC",1:"")_"|||"
+18 IF $PIECE(BGPGFR,U)
SET BGPVALUE=BGPVALUE_$$DATE^BGP2UTL($PIECE(BGPGFR,U,3))_" GFR: "_$PIECE(BGPGFR,U,2)
+19 KILL BGPGFR
+20 QUIT
CREAT(P,BDATE,EDATE) ;EP
+1 KILL BGPC
+2 SET BGPC=0
+3 SET T=$ORDER(^ATXAX("B","BGP CREATININE CPTS",0))
+4 IF T
Begin DoDot:1
+5 SET X=$$CPT^BGP2DU(P,BDATE,EDATE,T,1)
IF X]""
QUIT
+6 SET X=$$TRAN^BGP2DU(P,BDATE,EDATE,T,1)
End DoDot:1
IF X
QUIT 1
+7 ;now get all loinc/taxonomy tests
+8 SET T=$ORDER(^ATXAX("B","BGP CREATININE LOINC CODES",0))
+9 SET BGPLT=$ORDER(^ATXLAB("B","DM AUDIT CREATININE TAX",0))
+10 SET B=9999999-BDATE
SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(D>B)!(BGPC)
QUIT
Begin DoDot:1
+11 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!(BGPC)
QUIT
Begin DoDot:2
+12 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!(BGPC)
QUIT
Begin DoDot:3
+13 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+14 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPC=1_U_(9999999-D)
+15 IF 'T
QUIT
+16 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+17 IF '$$LOINC(J,T)
QUIT
+18 SET BGPC=1_U_(9999999-D)
+19 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+20 QUIT BGPC
GFRV(P,BDATE,EDATE) ;
+1 SET BGPC=""
+2 SET T=$ORDER(^LAB(60,"B","ESTIMATED GFR",0))
+3 SET T1=$ORDER(^ATXLAB("B","BGP GPRA ESTIMATED GFR TAX",0))
+4 SET B=9999999-BDATE
SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(D>B)!(BGPC]"")
QUIT
Begin DoDot:1
+5 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!(BGPC]"")
QUIT
Begin DoDot:2
+6 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!(BGPC]"")
QUIT
Begin DoDot:3
+7 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+8 IF T
IF $PIECE(^AUPNVLAB(X,0),U)=T
SET BGPC=1_U_$PIECE(^AUPNVLAB(X,0),U,4)_U_(9999999-D)
QUIT
+9 IF T1
IF $DATA(^ATXLAB(T1,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPC=1_U_$PIECE(^AUPNVLAB(X,0),U,4)_U_(9999999-D)
QUIT
+10 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+11 SET %=$PIECE($GET(^LAB(95.3,J,9999999)),U,2)
+12 IF %="33914-3"
SET BGPC=1_U_$PIECE(^AUPNVLAB(X,0),U,4)_U_(9999999-D)
QUIT
+13 SET J=$PIECE($GET(^LAB(95.3,J,0)),U)_"-"_$PIECE($GET(^LAB(95.3,J,0)),U,15)
+14 IF J="33914-3"
SET BGPC=1_U_$PIECE(^AUPNVLAB(X,0),U,4)_U_(9999999-D)
QUIT
+15 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+16 QUIT BGPC
LOINC(A,B) ;
+1 NEW %
+2 SET %=$PIECE($GET(^LAB(95.3,A,9999999)),U,2)
+3 IF %]""
IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+4 SET %=$PIECE($GET(^LAB(95.3,A,0)),U)_"-"_$PIECE($GET(^LAB(95.3,A,0)),U,15)
+5 IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+6 QUIT ""
EMP(P,BDATE,EDATE) ;EP
+1 KILL BGPG
+2 SET Y="BGPG("
+3 SET X=P_"^LAST DX [BGP EMPHYSEMA DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+4 IF $DATA(BGPG(1))
QUIT 1
+5 QUIT 0
COPD(P,BDATE,EDATE) ;EP
+1 KILL BGPG
+2 SET Y="BGPG("
+3 SET X=P_"^LAST DX [BGP COPD DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+4 IF $DATA(BGPG(1))
QUIT 1
+5 QUIT 0
PERASTH(P,BDATE,EDATE) ;EP
+1 ;item 1 - one visit to er w/493 OR hosp
+2 KILL ^TMP($JOB,"A")
+3 SET A="^TMP($J,""A"","
SET B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(B,A)
+4 IF '$DATA(^TMP($JOB,"A",1))
QUIT 0
+5 SET T=$ORDER(^ATXAX("B","BGP ASTHMA DXS",0))
+6 SET (X,G)=0
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X!(G)
QUIT
SET V=$PIECE(^TMP($JOB,"A",X),U,5)
Begin DoDot:1
+7 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+8 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+9 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+10 SET K=0
+11 IF $PIECE(^AUPNVSIT(V,0),U,7)="H"
SET K=1
+12 IF $$CLINIC^APCLV(V,"C")=30
SET K=1
+13 IF 'K
QUIT
+14 IF "V"[$PIECE(^AUPNVSIT(V,0),U,3)
QUIT
+15 SET Y=$$PRIMPOV^APCLV(V,"I")
+16 IF '$$ICD^ATXCHK(Y,T,9)
QUIT
+17 ;got one
SET G=1_U_$$DATE^BGP2UTL($PIECE($PIECE(^AUPNVSIT(V,0),U),"."))
End DoDot:1
+18 ;
+19 ;had prim dx on 30 or H so meets denom
IF G
QUIT 1_U_"DX ON HOSP/OR ER ON "_$PIECE(G,U,2)
PER3 ;
+1 ;meds
+2 SET BGPT=$ORDER(^ATXAX("B","BGP ASTHMA DXS",0))
+3 SET T=$ORDER(^ATXAX("B","BGP HEDIS ASTHMA MEDS",0))
+4 SET T3=$ORDER(^ATXAX("B","BGP HEDIS ASTHMA NDC",0))
+5 SET T1=$ORDER(^ATXAX("B","BGP HEDIS ASTHMA INHALED MEDS",0))
+6 SET T4=$ORDER(^ATXAX("B","BGP HEDIS ASTHMA INHALED NDC",0))
+7 SET T2=$ORDER(^ATXAX("B","BGP HEDIS ASTHMA LEUK MEDS",0))
+8 SET T5=$ORDER(^ATXAX("B","BGP HEDIS ASTHMA LEUK NDC",0))
+9 SET (X,G,M,D,E)=0
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X
QUIT
SET V=$PIECE(^TMP($JOB,"A",X),U,5)
Begin DoDot:1
+10 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+11 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+12 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+13 IF "AOS"'[$PIECE(^AUPNVSIT(V,0),U,7)
QUIT
+14 SET (D,Y)=0
FOR
SET Y=$ORDER(^AUPNVPOV("AD",V,Y))
IF Y'=+Y!(D)
QUIT
IF $DATA(^AUPNVPOV(Y,0))
SET %=$PIECE(^AUPNVPOV(Y,0),U)
IF $$ICD^ATXCHK(%,BGPT,9)
SET D=1
+15 ;got one visit
IF D
SET G=G+1
+16 SET Y=0
FOR
SET Y=$ORDER(^AUPNVMED("AD",V,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+17 SET S=0
+18 IF '$DATA(^AUPNVMED(Y,0))
QUIT
+19 IF $$UP^XLFSTR($PIECE($GET(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"
QUIT
+20 ;get drug ien
SET Z=$PIECE($GET(^AUPNVMED(Y,0)),U)
+21 ;it is an inhaled steroid that wasn't d/c'ed so 1 dispensing event
IF $DATA(^ATXAX(T1,21,"B",Z))!($$NDC(Z,T4))
IF $PIECE(^AUPNVMED(Y,0),U,8)=""
SET M=M+1
QUIT
+22 IF $DATA(^ATXAX(T,21,"B",Z))!($$NDC(Z,T3))
Begin DoDot:3
+23 ;don't count if it is a leukotriene
IF $$LEUK(Z,T2,T5)
QUIT
+24 SET J=$PIECE(^AUPNVMED(Y,0),U,8)
+25 IF J]""
SET S=$$FMDIFF^XLFDT(J,$PIECE($PIECE(^AUPNVSIT(V,0),U),"."))
+26 IF J=""
SET S=$PIECE(^AUPNVMED(Y,0),U,7)
+27 ;S K=S/30,M=M+K
+28 SET K=S\30
IF K<1
SET K=1
SET M=M+K
End DoDot:3
+29 IF $DATA(^ATXAX(T2,21,"B",Z))!($$NDC(Z,T5))
Begin DoDot:3
+30 SET J=$PIECE(^AUPNVMED(Y,0),U,8)
+31 IF J]""
SET S=$$FMDIFF^XLFDT(J,$PIECE($PIECE(^AUPNVSIT(V,0),U),"."))
+32 IF J=""
SET S=$PIECE(^AUPNVMED(Y,0),U,7)
+33 SET K=S\30
IF K<1
SET K=1
SET M=M+K
SET E=E+K
End DoDot:3
QUIT
End DoDot:2
End DoDot:1
+34 IF G>3
IF M>1
QUIT 1_U_"4 POVS AND 2 MEDS"
+35 ;had 4 meds, not all were leuko
IF M>3
IF E<M
QUIT 1_U_"4 meds"
+36 ;had all leuk and 1 dx
IF M>3
IF E=M
IF G>0
QUIT 1_U_"LEUKOTRIENE AND 1 DX"
+37 QUIT ""
+38 ;
ASSEV(P,EDATE) ;EP - NOW CHECK ASTHMA PACKAGE SEV
+1 ;find problem list active for asthma with 2, 3 or 4 in 15th piece
+2 NEW S,A,B,T,X,G,V,Y
+3 SET G=""
+4 SET T=$ORDER(^ATXAX("B","BGP ASTHMA DXS",0))
+5 SET X=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+6 ;if added to pl after end
IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+7 SET Y=$PIECE(^AUPNPROB(X,0),U)
+8 IF $PIECE(^AUPNPROB(X,0),U,12)'="A"
QUIT
+9 IF '$$ICD^ATXCHK(Y,T,9)
QUIT
+10 IF $PIECE(^AUPNPROB(X,0),U,15)=""
QUIT
+11 IF $PIECE(^AUPNPROB(X,0),U,15)<2
QUIT
+12 SET G=1_U_"Severity >1 on PL for "_$PIECE(^ICD9(Y,0),U)
+13 QUIT
End DoDot:1
+14 IF G
QUIT G
+15 SET D=9999999-EDATE-1
SET G=""
+16 SET D=$ORDER(^AUPNVAST("AS",P,D))
IF D]""
Begin DoDot:1
+17 SET I=""
FOR
SET I=$ORDER(^AUPNVAST("AS",P,D,I))
IF I'=+I
QUIT
Begin DoDot:2
+18 SET S=^AUPNVAST("AS",P,D,I)
+19 IF S>1
SET G="1^Severity "_S_" in V Asthma "_$$DATE^BGP2UTL((9999999-D))
End DoDot:2
End DoDot:1
+20 QUIT G
+21 ;
NDC(A,B) ;
+1 ;a is drug ien
+2 ;b is taxonomy ien
+3 SET BGPNDC=$PIECE($GET(^PSDRUG(A,2)),U,4)
+4 IF BGPNDC]""
IF B
IF $DATA(^ATXAX(B,21,"B",BGPNDC))
QUIT 1
+5 QUIT 0
LEUK(A,B,C) ;
+1 ;a drug ien
+2 ;b tax ien
+3 ;c tax ien for ndc
+4 IF $DATA(^ATXAX(B,21,"B",A))
QUIT 1
+5 IF $$NDC(A,C)
QUIT 1
+6 QUIT ""
ASTHTHER(P,BDATE,EDATE) ;EP
+1 ;get number of asthma medication events
+2 KILL BGPMEDS1
+3 DO GETMEDS^BGP2UTL2(P,BDATE,EDATE,,,,,.BGPMEDS1)
+4 IF '$DATA(BGPMEDS1)
QUIT ""
+5 SET T=$ORDER(^ATXAX("B","BGP HEDIS PRIMARY ASTHMA MEDS",0))
+6 SET T3=$ORDER(^ATXAX("B","BGP HEDIS PRIMARY ASTHMA NDC",0))
+7 SET (X,G,M,E)=0
SET D=""
FOR
SET X=$ORDER(BGPMEDS1(X))
IF X'=+X!(D]"")
QUIT
SET V=$PIECE(BGPMEDS1(X),U,5)
SET Y=+$PIECE(BGPMEDS1(X),U,4)
Begin DoDot:1
+8 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+9 IF '$DATA(^AUPNVMED(Y,0))
QUIT
+10 IF $$UP^XLFSTR($PIECE($GET(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"
QUIT
+11 ;get drug ien
SET Z=$PIECE($GET(^AUPNVMED(Y,0)),U)
+12 IF $DATA(^ATXAX(T,21,"B",Z))!($$NDC(Z,T3))
IF $PIECE(^AUPNVMED(Y,0),U,8)=""
SET D=1_U_$PIECE(^PSDRUG(Z,0),U)_U_$$DATE^BGP2UTL($PIECE($PIECE(^AUPNVSIT(V,0),U),"."))
QUIT
End DoDot:1
+13 QUIT D
+1 NEW BGPG,%,E,A,Y,X,R,G
+2 ;if =1 then don't look for Refusal
SET REFUSAL=$GET(REFUSAL)
+3 KILL BGPG
SET %=P_"^LAST EXAM DIABETIC FOOT EXAM;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+4 IF $DATA(BGPG(1))
QUIT "1^"_$PIECE(BGPG(1),U)_"^Diab Foot Ex"
+5 KILL ^TMP($JOB,"A")
+6 SET A="^TMP($J,""A"","
+7 SET %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,A)
+8 SET X=0
SET Y=0
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X!(Y)
QUIT
SET R=$$CLINIC^APCLV($PIECE(^TMP($JOB,"A",X),U,5),"C")
IF R=65
IF '$$DNKA^BGP2D21($PIECE(^TMP($JOB,"A",X),U,5))
SET Y=1
SET D=$PIECE(^TMP($JOB,"A",X),U)
+9 IF Y
QUIT 1_"^"_D_"^Cl "_R
+10 SET (X,Y)=0
SET D=""
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X!(Y)
QUIT
SET R=$$PRIMPROV^APCLV($PIECE(^TMP($JOB,"A",X),U,5),"D")
IF (R=33!(R=84)!(R=25))
IF '$$DNKA^BGP2D21($PIECE(^TMP($JOB,"A",X),U,5))
SET Y=1
SET D=$PIECE(^TMP($JOB,"A",X),U)
+11 IF Y
QUIT "1^"_D_"^Prv "_R
+12 ;now check for Refusal
+13 SET G=$$CPTI^BGP2DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("2028F"))
+14 IF G
QUIT G_"^CPT: 2028F"
+15 IF $GET(REFUSAL)
QUIT ""
+16 SET G=$$REFUSAL^BGP2UTL1(P,9999999.15,$ORDER(^AUTTEXAM("B","DIABETIC FOOT EXAM, COMPLETE",0)),BDATE,EDATE)
+17 IF $PIECE(G,U)=1
QUIT "1^"_$PIECE(G,U,2)_"^Refused"
+18 QUIT ""
BPCPT(P,BDATE,EDATE,GDEV) ;EP
+1 NEW S,D,C,E,BGPG,X,Y,G,T,M,A,Z,L
+2 KILL BGPG
SET Y="BGPG("
SET X=P_"^ALL VISIT;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,Y)
+3 ;go through and get all cpt codes in the 2 taxonomies and table by date using the lowest value on that day, skip ER visits
+4 SET X=0
SET G=""
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
Begin DoDot:1
+5 ;visit ien
SET V=$PIECE(BGPG(X),U,5)
+6 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+7 ;clinic ER
IF $$CLINIC^APCLV(V,"C")=30
QUIT
+8 IF $GET(GDEV)
IF $$GDEV^BGP2D2(V)
QUIT
+9 SET E=0
FOR
SET E=$ORDER(^AUPNVCPT("AD",V,E))
IF E'=+E
QUIT
Begin DoDot:2
+10 SET C=$PIECE($GET(^AUPNVCPT(E,0)),U)
+11 IF 'C
QUIT
+12 SET D=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
SET D=(9999999-D)_"."_$PIECE(D,".",2)
+13 IF $$ICD^ATXCHK(C,$ORDER(^ATXAX("B","BGP SYSTOLIC BP CPTS",0)),1)
Begin DoDot:3
+14 SET Y=$PIECE($$CPT^ICPTCOD(C),U,2)
+15 IF '$DATA(S(D))
SET S(D)=Y
SET A(D)=Y_U_"S"
+16 IF +S(D)>+Y
SET S(D)=Y
End DoDot:3
+17 IF $$ICD^ATXCHK(C,$ORDER(^ATXAX("B","BGP DIASTOLIC BP CPTS",0)),1)
Begin DoDot:3
+18 SET Y=$PIECE($$CPT^ICPTCOD(C),U,2)
+19 IF '$DATA(T(D))
SET T(D)=Y
SET A(D)=Y_U_"T"
+20 IF +T(D)>+Y
SET T(D)=Y
End DoDot:3
+21 IF $$ICD^ATXCHK(C,$ORDER(^ATXAX("B","BGP BP MEASURED CPT",0)),1)
Begin DoDot:3
+22 SET Y=$PIECE($$CPT^ICPTCOD(C),U,2)
+23 IF '$DATA(M(D))
SET M(D)=Y
SET A(D)=Y_U_"M"
End DoDot:3
End DoDot:2
+24 SET E=0
FOR
SET E=$ORDER(^AUPNVPOV("AD",V,E))
IF E'=+E
QUIT
Begin DoDot:2
+25 SET Y=$$VAL^XBDIQ1(9000010.07,E,.01)
+26 IF Y=""
QUIT
+27 IF '$$ICD^ATXCHK($$VALI^XBDIQ1(9000010.07,E,.01),$ORDER(^ATXAX("B","BGP HYPERTENSION SCREEN DXS",0)),9)
QUIT
+28 SET D=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
SET D=(9999999-D)_"."_$PIECE(D,".",2)
+29 IF '$DATA(M(D))
SET M(D)=Y
SET A(D)=Y_U_"M"
End DoDot:2
End DoDot:1
+30 ;
IF '$DATA(S)
IF '$DATA(T)
IF '$DATA(M)
QUIT ""
+31 SET L=$ORDER(A(0))
SET Z=$PIECE(A(L),U,2)
IF Z="M"
QUIT 0_U_$PIECE(A(L),U,1)
+32 SET S=$ORDER(S(0))
IF S
SET S=S(S)
+33 SET D=$ORDER(T(0))
IF D
SET D=T(D)
+34 IF S=""!(D="")
QUIT 0_U_S_"/"_D
+35 IF S="3074F"
IF D="3078F"
QUIT 1_U_S_"/"_D
+36 QUIT 0_U_S_"/"_D
