BGP8D23 ; IHS/CMI/LAB - measure I2 ; 23 Jun 2008 10:08 AM
;;8.0;IHS CLINICAL REPORTING;**2**;MAR 12, 2008
;
IMS ;EP
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPD1,BGPD2)=0
S BGPVALUE=""
I $$LASTDX^BGP8UTL1(DFN,"SURVEILLANCE DIABETES",$P(^DPT(DFN,0),U,3),BGPEDATE) S BGPSTOP=1 Q ;had diabetes dx
S BGPD=$$MS(DFN,BGPBDATE,BGPEDATE)
I BGPD="" S BGPSTOP=1 Q ;not in denominator
I BGPACTCL S BGPD1=1
I BGPACTUP S BGPD2=1
S BGPVALUE="UP"
I BGPD1 S BGPVALUE=BGPVALUE_";AC"
S BGPVALUE=BGPVALUE_" "_$P(BGPD,U,2)_"|||"
;now set up numerators
IMS1 ;EP
S C=0
S BGPBP=$$BPSD(DFN,BGPBDATE,BGPEDATE)
I BGPBP S BGPN1=1
I BGPBP="" S BGPBP=$$BPCPT^BGP8D22(DFN,BGP365,BGPEDATE),C=1 I $P(BGPBP,U,2)]"" S BGPN1=1
I BGPN1 S BGPVALUE=BGPVALUE_" 2 BPs" I C S BGPVALUE=BGPVALUE_" - CPT "_$P(BGPBP,U,2)
IMS2 ;LDL done
S BGPLDL=$$LDL^BGP8D2(DFN,BGPBDATE,BGPEDATE,1)
S BGPN2=$P(BGPLDL,U)
I BGPN2 S BGPVALUE=BGPVALUE_";LDL: "_$$DATE^BGP8UTL($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
IMS3 ;fasting glucose
S BGPFG=$$FGT(DFN,BGPBDATE,BGPEDATE)
S BGPN3=$P(BGPFG,U)
I BGPN3 S BGPVALUE=BGPVALUE_";FG: "_$$DATE^BGP8UTL($P(BGPFG,U,2))
;S BGPUP=$$POSUR^BGP8D21A(DFN,BGP365,BGPEDATE)
S BGPGFR=$$GFR^BGP8D211(DFN,BGP365,BGPEDATE)
S BGPESRD=$$ESRD^BGP8D211(DFN,$P(^DPT(DFN,0),U,3),BGPEDATE)
S BGPQUP=$$QUANTUP^BGP8D211(DFN,BGPBDATE,BGPEDATE)
I BGPESRD S BGPN4=1
I $P(BGPGFR,U),$P(BGPQUP,U,1) S BGPN4=1
I BGPN4 D
.I BGPESRD S BGPVALUE=BGPVALUE_$S(BGPESRD]"":";ESRD: "_$P(BGPESRD,U,2)_"-"_$$DATE^BGP8UTL($P(BGPESRD,U,3)),1:"") Q
.S BGPVALUE=BGPVALUE_";GFR: "_$$DATE^BGP8UTL($P(BGPGFR,U,2))
.S BGPVALUE=BGPVALUE_" & QUANT UP: "_$P(BGPQUP,U,2)_"-"_$$DATE^BGP8UTL($P(BGPQUP,U,3))
K BGPFG
IMS5 ;
K BGPX,BGPC1,X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F
S BGPTOBV=""
S BGPTOB=$$TOBACCO^BGP8D7(DFN,BGPBDATE,BGPEDATE)
S BGPN5=$S(BGPTOB]"":1,1:0),BGPTOBV=$P(BGPTOB,U,2)
S BGPSDX=$$DX^BGP8D7(DFN,BGPBDATE,BGPEDATE)
S BGPXPED=$$PED^BGP8D7(DFN,BGPBDATE,BGPEDATE)
S BGP1320=$$DENT^BGP8D7(DFN,BGPBDATE,BGPEDATE)
S BGPSCPT=$$CPTSM^BGP8D7(DFN,BGPBDATE,BGPEDATE)
I BGPSDX]"" S BGPN5=1 I BGPTOBV="" S BGPTOBV=$$DATE^BGP8UTL($P(BGPSDX,U,2))
I BGPXPED]"" S BGPN5=1 I BGPTOBV="" S BGPTOBV=$$DATE^BGP8UTL($P(BGPXPED,U,2))
I BGP1320]"" S BGPN5=1 I BGPTOBV="" S BGPTOBV=$$DATE^BGP8UTL($P(BGP1320,U,2))
I BGPSCPT]"" S BGPN5=1 I BGPTOBV="" S BGPTOBV=$$DATE^BGP8UTL($P(BGPSCPT,U,2))
I BGPN5 S BGPVALUE=BGPVALUE_";TOB SCRN: "_BGPTOBV
IMS6 ;
S BGPBMI=$$BMI^BGP8D6(DFN,BGPEDATE,BGPAGEE)
I $P(BGPBMI,U)="" S BGPBMI=$$REF^BGP8D6(DFN,BGPBDATE,BGPEDATE,BGPAGEB)
I $P(BGPBMI,U)]"" S BGPN6=1
I BGPN6 S BGPVALUE=BGPVALUE_";BMI: "_$S(BGPBMI["HT":"ref "_$P(BGPBMI,U,2)_" "_$$DATE^BGP8UTL($P(BGPBMI,U,3))_" "_$P(BGPBMI,U,5)_" "_$$DATE^BGP8UTL($P(BGPBMI,U,6)),BGPBMI]"":$$SB^BGP8PDL1($J($P(BGPBMI,U),6,2)),1:"")
IMS7 ;
S BGPLIFE=$$LIFE^BGP8D41(DFN,BGPBDATE,BGPEDATE)
I $P(BGPLIFE,U) S BGPN7=1
I BGPN7 S BGPVALUE=BGPVALUE_";LIFE: "_$$DATE^BGP8UTL($P(BGPLIFE,U,2))_":"_$P(BGPLIFE,U,3)
IMS8 ;
S BGPDEP=$$DEP^BGP8D25(DFN,BGP365,BGPEDATE) I $P(BGPDEP,U)=1 S BGPN8=1
S BGPDEPS=$$DEPSCR^BGP8D25(DFN,BGP365,BGPEDATE) I $P(BGPDEPS,U)=1 S BGPN8=1
S BGPREF="" I 'BGPN8 S BGPREF=$$DEPREF^BGP8D25(DFN,BGP365,BGPEDATE) I $P(BGPREF,U)=1 S BGPN8=1
I BGPDEP]"" S BGPVALUE=BGPVALUE_";DEPR SCRN: "_$P(BGPDEP,U,2)_":"_$P(BGPDEP,U,3)
E I BGPDEPS]"" S BGPVALUE=BGPVALUE_";DEPR SCRN: "_$P(BGPDEPS,U,2)_":"_$P(BGPDEPS,U,3)
E I BGPREF]"" S BGPVALUE=BGPVALUE_";DEPR SCRN: "_$P(BGPREF,U,2)_":"_$P(BGPREF,U,3)
IMS9 ;
I BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN8 S BGPN9=1,BGPVALUE=$P(BGPVALUE,"|||",1)_"|||*ALL* "_$P(BGPVALUE,"|||",2)
K BGPDEP,BGPDEPS,BGPREF,BGPLIFE,BGPBMI,BGPSDX,BGP1320,BGPTOB,BGPUP,BGPFG,BGPHDL
K ^TMP($J,"A")
Q
MS(P,BDATE,EDATE) ;EP
;2 visits with 277.7?
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 ""
S (X,G)=0 F S X=$O(^TMP($J,"A",X)) Q:X'=+X!($P(G,U)>2) 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:"SAHO"'[$P(^AUPNVSIT(V,0),U,7)
.Q:"V"[$P(^AUPNVSIT(V,0),U,3)
.S (D,Y)=0 F S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(D) D
..Q:'$D(^AUPNVPOV(Y,0))
..S %=$P(^AUPNVPOV(Y,0),U)
..Q:'%
..I $P($$ICDDX^ICDCODE(%),U,2)=277.7 S D=1
.Q:'D
.S $P(G,U)=$P(G,U)+1,$P(G,U,($P(G,U)+1))=$P($P(^AUPNVSIT(V,0),U),".")
.Q
K ^TMP($J,"A")
I $P(G,U)>1 Q 1_U_"277.7 on "_$$DATE^BGP8UTL($P(G,U,2))_"; "_$$DATE^BGP8UTL($P(G,U,3))
;now check for 3 or more of the following
S BGPC=0,BGPK=""
S X=$$BMI^BGP8D6(P,EDATE,$$AGE^AUPNPAT(P,EDATE))
I $E(X,1,2)>29 S BGPC=BGPC+1,BGPK="BMI="_$$STRIP^XLFSTR($J(X,6,2)," ")
S X=$$TRIG(P,BDATE,EDATE) I X]"" S BGPC=BGPC+1 S:BGPK]"" BGPK=BGPK_"; " S BGPK=BGPK_X
S X=$$HDL(P,BDATE,EDATE) I X]"" S BGPC=BGPC+1 S:BGPK]"" BGPK=BGPK_"; " S BGPK=BGPK_X
S BGPHTN=$$LASTDX^BGP8UTL1(P,"SURVEILLANCE HYPERTENSION",BGP365,EDATE)
S BGPMBP=$$MEANBP(P,BGPBDATE,BGPEDATE)
I $P(BGPHTN,U)!(BGPMBP]"") S BGPC=BGPC+1 S:BGPK]"" BGPK=BGPK_"; " S:$P(BGPHTN,U)=1 BGPK=BGPK_"HTN DX: "_$$DATE^BGP8UTL($P(BGPHTN,U,3)) I BGPMBP]"" S:BGPK]""&($P(BGPHTN,U)=1) BGPK=BGPK_"; " S BGPK=BGPK_BGPMBP
S X=$$FG(P,BGPBDATE,BGPEDATE) I X]"" S BGPC=BGPC+1 S:BGPK]"" BGPK=BGPK_"; " S BGPK=BGPK_X
S X=$$WC(P,BGPBDATE,BGPEDATE) I X]"" S BGPC=BGPC+1 S:BGPK]"" BGPK=BGPK_"; " S BGPK=BGPK_X
I BGPC>2 Q BGPC_"^"_BGPK
Q ""
BMI(P,BDATE,EDATE,AGE) ;EP
KILL %,W,H,B,D,%DT
S BGPBMIH=""
I AGE>18,AGE<51 D Q BGPBMIH
.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) 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),BGPBMIH=(W/H)
I AGE>50 D Q BGPBMIH
.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) 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),BGPBMIH=(W/H)
I AGE<19 D Q BGPBMIH
.S BDATE=$$FMADD^XLFDT(EDATE,-365),BDATE=$$FMTE^XLFDT(BDATE),EDATE=$$FMTE^XLFDT(EDATE)
.S X=$$HTWTSD(P,BDATE,EDATE)
.I '$P(X,"^") Q
.I '$P(X,"^",2) Q
.S W=$P(X,"^"),H=$P(X,"^",2)
.S W=W*.45359,H=(H*.0254),H=(H*H),BGPBMIH=(W/H)
.Q
Q
WC(P,BDATE,EDATE) ;EP
I 'P Q ""
KILL %,BGPARRY,H,E
S %=P_"^LAST MEAS WC;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(%,"BGPARRY(") S H=$P($G(BGPARRY(1)),U,2)
I H="" Q H
I H["?" Q ""
I $P(^DPT(P,0),U,2)="M",H>40 Q "WC="_H
I $P(^DPT(P,0),U,2)="F",H>35 Q "WC="_H
Q ""
HT(P,BDATE,EDATE) ;EP
I 'P Q ""
KILL %,BGPARRY,H,E
S %=P_"^LAST MEAS HT;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(%,"BGPARRY(") S H=$P($G(BGPARRY(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 ""
KILL %,E,BGPLW,X,BGPLN,BGPL,BGPLD,BGPLZ,BGPLX,ICD
K BGPL S BGPLW="" S BGPLX=P_"^LAST 24 MEAS WT;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(BGPLX,"BGPL(")
S BGPLN=0 F S BGPLN=$O(BGPL(BGPLN)) Q:BGPLN'=+BGPLN!(BGPLW]"") D
.S BGPLZ=$P(BGPL(BGPLN),U,5)
.I '$D(^AUPNVPOV("AD",BGPLZ)) S BGPLW=$P(BGPL(BGPLN),U,2) Q
. S BGPLD=0 F S BGPLD=$O(^AUPNVPOV("AD",BGPLZ,BGPLD)) Q:'BGPLD!(BGPLW]"") D
.. S D=$P(BGPL(BGPLN),U)
.. S ICD=$P($$ICDDX^ICDCODE($P(^AUPNVPOV(BGPLD,0),U),D),U,2) D
...I $E(ICD,1,3)="V22" Q
...I $E(ICD,1,3)="V23" Q
...I $E(ICD,1,3)="V27" Q
...I $E(ICD,1,3)="V28" Q
...I ICD>629.9999&(ICD<676.95) Q
...I ICD>61.49&(ICD<61.71) Q
...S BGPLW=$P(BGPL(BGPLN),U,2)
..Q
Q BGPLW
HTWTSD(P,BDATE,EDATE) ;get last ht / wt on same day
I '$G(P) Q ""
KILL BGPLWTS,BGPLHTS,%,X,BGPLWTS1,BGPLHTS1,Y
;get all hts during time frame
S %=P_"^ALL MEAS HT;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(%,"BGPLHTS(")
S Y=0 F S Y=$O(BGPLHTS(Y)) Q:Y'=+Y I $P(BGPLHTS(Y),U,2)="?"!($P(BGPLHTS(Y),U,2)="") K BGPLHTS(Y)
;set the array up by date
K BGPLHTS1 S X=0 F S X=$O(BGPLHTS(X)) Q:X'=+X S BGPLHTS1($P(BGPLHTS(X),U))=X
;get all wts during time frame
S %=P_"^ALL MEAS WT;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(%,"BGPLWTS(")
S Y=0 F S Y=$O(BGPLWTS(Y)) Q:Y'=+Y I $P(BGPLWTS(Y),U,2)="?"!($P(BGPLWTS(Y),U,2)="") K BGPLWTS(Y)
;set the array up by date
K BGPLWTS1 S X=0 F S X=$O(BGPLWTS(X)) Q:X'=+X S BGPLWTS1($P(BGPLWTS(X),U))=X
S BGPLCHT="",X=9999999 F S X=$O(BGPLWTS1(X),-1) Q:X=""!(BGPLCHT]"") I $D(BGPLHTS1(X)) S BGPLCHT=$P(BGPLWTS(BGPLWTS1(X)),U,2)_U_$P(BGPLHTS(BGPLHTS1(X)),U,2)
Q BGPLCHT
;
TRIG(P,BDATE,EDATE) ;EP
;now get all loinc/taxonomy tests
S T=$O(^ATXAX("B","BGP TRIGLYCERIDE LOINC CODES",0))
S BGPLT=$O(^ATXLAB("B","DM AUDIT TRIGLYCERIDE TAX",0))
S R=""
S B=9999999-BDATE,E=9999999-EDATE S D=E-1 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(D>B)!(R]"") D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(R]"") D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(R]"") D
...Q:'$D(^AUPNVLAB(X,0))
...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) D Q:R]""
....S V=$P(^AUPNVLAB(X,0),U,4) Q:V="" Q:'V Q:+V<150 S R="TRIG="_V
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,T)
...S V=$P(^AUPNVLAB(X,0),U,4)
...Q:V="" Q:V'=+V
...Q:+V<150
...S R="TRIG="_V
...Q
Q R
HDL(P,BDATE,EDATE) ;EP
K BGPC1
S BGPC1=0,R=""
;S %="",E=+$$CODEN^ICPTCOD(83718),%=$$CPTI^BGP8DU(P,BDATE,EDATE,E)
;I %]"" Q 1_U_$P(%,U,2)
;S %="",E=+$$CODEN^ICPTCOD(83718),%=$$TRANI^BGP8DU(P,BDATE,EDATE,E)
;I %]"" Q 1_U_$P(%,U,2)
;now get all loinc/taxonomy tests
S S=$P(^DPT(DFN,0),U,2)
S T=$O(^ATXAX("B","BGP HDL LOINC CODES",0))
S BGPLT=$O(^ATXLAB("B","DM AUDIT HDL 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)!(BGPC1) D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(R]"") D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(R]"") D
...Q:'$D(^AUPNVLAB(X,0))
...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) D Q:R]""
....S V=$P(^AUPNVLAB(X,0),U,4) D
.....I V="" Q
.....I 'V Q
.....I S="M",+V<40 S R="HDL="_V
.....I S="F",+V<50 S R="HDL="_V
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,T)
...S V=$P(^AUPNVLAB(X,0),U,4)
...I V="" Q
...I V'=+V Q
...I S="M",+V<40 S R="HDL="_V Q
...I S="F",+V<50 S R="HDL="_V Q
...Q
Q R
;
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 ""
MEANBP(P,BDATE,EDATE) ;EP
S X=$$BPS(P,BDATE,EDATE,"I")
S S=$$SYSMEAN(X) I S="" Q ""
S DS=$$DIAMEAN(X) I DS="" Q ""
I S>129 Q "BP="_S_"/"_DS
I DS>84 Q "BP="_S_"/"_DS
Q ""
;
SYSMEAN(X) ;EP
I X="" Q ""
S C=0 F Y=1:1:3 I $P(X,";",Y)]"" S C=C+1
I C<2 Q ""
S T=0 F Y=1:1:3 S T=$P($P(X,";",Y),"/")+T
;Q $$STRIP^XLFSTR($J((T/C),5,1)," ")
Q T\C
;
DIAMEAN(X) ;EP
I X="" Q ""
S C=0 F Y=1:1:3 I $P(X,";",Y)]"" S C=C+1
I C<2 Q ""
S T=0 F Y=1:1:3 S T=$P($P(X,";",Y),"/",2)+T
;Q $$STRIP^XLFSTR($J((T/C),5,1)," ")
Q T\C
;
BPSD(P,BDATE,EDATE) ;EP
S X=$$BPS(P,BDATE,EDATE,"I")
S C=0 F Y=1:1:2 I $P(X,";",Y)]"" S C=C+1
I C<2 Q ""
Q 1
BPS(P,BDATE,EDATE,F) ;EP ;
I $G(F)="" S F="E"
S BGPGLL=0,BGPGV=""
K BGPG
K ^TMP($J,"BPV")
S A="^TMP($J,""BPV"",",B=P_"^LAST 365 VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
I '$D(^TMP($J,"BPV",1)) Q ""
S Y=0 F S Y=$O(^TMP($J,"BPV",Y)) Q:Y'=+Y!(BGPGLL=3) D
.S V=$P(^TMP($J,"BPV",Y),U,5)
.Q:$$CLINIC^APCLV(V,"C")=30 ;NO ER CLINIC VISITS COUNTED
.Q:'$D(^AUPNVMSR("AD",V)) ;no measurements to look at
.;NOW GET ALL BPS ON THIS VISIT
.S BGPBP=""
.S X=0 F S X=$O(^AUPNVMSR("AD",V,X)) Q:X'=+X D
..Q:'$D(^AUPNVMSR(X,0)) ;BAD AD XREF
..S T=$P($G(^AUPNVMSR(X,0)),U)
..Q:T="" ;BAD AD XREF
..Q:$P($G(^AUTTMSR(T,0)),U)'="BP" ;not a BP measurement type
..S Z=$P(^AUPNVMSR(X,0),U,4) ;blood pressure value
..I BGPBP="" S BGPBP=Z Q
..I $P(Z,"/")'>$P(BGPBP,"/") S BGPBP=Z
.Q:BGPBP=""
.S BGPGLL=BGPGLL+1
.I F="E" S $P(BGPGV,";",BGPGLL)=BGPBP_" "_$$FMTE^XLFDT($P(^TMP($J,"BPV",V),U))
.I F="I" S $P(BGPGV,";",BGPGLL)=$P(BGPBP," ")
K ^TMP($J,"BPV")
Q BGPGV
FG(P,BDATE,EDATE) ;EP
K BGPC1
S BGPC1=0,R=""
;now get all loinc/taxonomy tests
S T=$O(^ATXAX("B","DM AUDIT FASTING GLUC LOINC",0))
S BGPLT=$O(^ATXLAB("B","DM AUDIT FASTING GLUCOSE TESTS",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)!(R]"") D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(R]"") D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(R]"") D
...Q:'$D(^AUPNVLAB(X,0))
...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) D Q:R]""
....S V=$P(^AUPNVLAB(X,0),U,4) Q:+V<100 Q:+V>125.9999 S R="FAST GLUC="_V
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,T)
...S V=$P(^AUPNVLAB(X,0),U,4)
...Q:V=""
...Q:'V
...Q:+V<100
...Q:+V>125.9999
...S R="FASTING GLUC="_V
...Q
Q R
FGT(P,BDATE,EDATE) ;EP
K BGPG,BGPT,BGPC
K BGPG
S Y="BGPG("
S X=P_"^LAST DX 790.21;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(BGPG(1)) Q 1_U_$P(BGPG(1),U)_U_"790.21" ;has a dx
S BGPC=0
;now get all loinc/taxonomy tests
S T=$O(^ATXAX("B","DM AUDIT FASTING GLUC LOINC",0))
S BGPLT=$O(^ATXLAB("B","DM AUDIT FASTING GLUCOSE TESTS",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) D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X 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=BGPC+1,BGPT(D,BGPC)=$P(^AUPNVLAB(X,0),U,4) Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,T)
...S R=$P(^AUPNVLAB(X,0),U,4)
...S BGPC=BGPC+1,BGPT(D,BGPC)=R
...Q
; now got though and set return value of done 1 or 0^VALUE^date
I '$D(BGPT) Q "" ;no tests
Q 1_U_(9999999-$O(BGPT(0)))
BGP8D23 ; IHS/CMI/LAB - measure I2 ; 23 Jun 2008 10:08 AM
+1 ;;8.0;IHS CLINICAL REPORTING;**2**;MAR 12, 2008
+2 ;
IMS ;EP
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPD1,BGPD2)=0
+2 SET BGPVALUE=""
+3 ;had diabetes dx
IF $$LASTDX^BGP8UTL1(DFN,"SURVEILLANCE DIABETES",$PIECE(^DPT(DFN,0),U,3),BGPEDATE)
SET BGPSTOP=1
QUIT
+4 SET BGPD=$$MS(DFN,BGPBDATE,BGPEDATE)
+5 ;not in denominator
IF BGPD=""
SET BGPSTOP=1
QUIT
+6 IF BGPACTCL
SET BGPD1=1
+7 IF BGPACTUP
SET BGPD2=1
+8 SET BGPVALUE="UP"
+9 IF BGPD1
SET BGPVALUE=BGPVALUE_";AC"
+10 SET BGPVALUE=BGPVALUE_" "_$PIECE(BGPD,U,2)_"|||"
+11 ;now set up numerators
IMS1 ;EP
+1 SET C=0
+2 SET BGPBP=$$BPSD(DFN,BGPBDATE,BGPEDATE)
+3 IF BGPBP
SET BGPN1=1
+4 IF BGPBP=""
SET BGPBP=$$BPCPT^BGP8D22(DFN,BGP365,BGPEDATE)
SET C=1
IF $PIECE(BGPBP,U,2)]""
SET BGPN1=1
+5 IF BGPN1
SET BGPVALUE=BGPVALUE_" 2 BPs"
IF C
SET BGPVALUE=BGPVALUE_" - CPT "_$PIECE(BGPBP,U,2)
IMS2 ;LDL done
+1 SET BGPLDL=$$LDL^BGP8D2(DFN,BGPBDATE,BGPEDATE,1)
+2 SET BGPN2=$PIECE(BGPLDL,U)
+3 IF BGPN2
SET BGPVALUE=BGPVALUE_";LDL: "_$$DATE^BGP8UTL($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
IMS3 ;fasting glucose
+1 SET BGPFG=$$FGT(DFN,BGPBDATE,BGPEDATE)
+2 SET BGPN3=$PIECE(BGPFG,U)
+3 IF BGPN3
SET BGPVALUE=BGPVALUE_";FG: "_$$DATE^BGP8UTL($PIECE(BGPFG,U,2))
+4 ;S BGPUP=$$POSUR^BGP8D21A(DFN,BGP365,BGPEDATE)
+5 SET BGPGFR=$$GFR^BGP8D211(DFN,BGP365,BGPEDATE)
+6 SET BGPESRD=$$ESRD^BGP8D211(DFN,$PIECE(^DPT(DFN,0),U,3),BGPEDATE)
+7 SET BGPQUP=$$QUANTUP^BGP8D211(DFN,BGPBDATE,BGPEDATE)
+8 IF BGPESRD
SET BGPN4=1
+9 IF $PIECE(BGPGFR,U)
IF $PIECE(BGPQUP,U,1)
SET BGPN4=1
+10 IF BGPN4
Begin DoDot:1
+11 IF BGPESRD
SET BGPVALUE=BGPVALUE_$SELECT(BGPESRD]"":";ESRD: "_$PIECE(BGPESRD,U,2)_"-"_$$DATE^BGP8UTL($PIECE(BGPESRD,U,3)),1:"")
QUIT
+12 SET BGPVALUE=BGPVALUE_";GFR: "_$$DATE^BGP8UTL($PIECE(BGPGFR,U,2))
+13 SET BGPVALUE=BGPVALUE_" & QUANT UP: "_$PIECE(BGPQUP,U,2)_"-"_$$DATE^BGP8UTL($PIECE(BGPQUP,U,3))
End DoDot:1
+14 KILL BGPFG
IMS5 ;
+1 KILL BGPX,BGPC1,X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F
+2 SET BGPTOBV=""
+3 SET BGPTOB=$$TOBACCO^BGP8D7(DFN,BGPBDATE,BGPEDATE)
+4 SET BGPN5=$SELECT(BGPTOB]"":1,1:0)
SET BGPTOBV=$PIECE(BGPTOB,U,2)
+5 SET BGPSDX=$$DX^BGP8D7(DFN,BGPBDATE,BGPEDATE)
+6 SET BGPXPED=$$PED^BGP8D7(DFN,BGPBDATE,BGPEDATE)
+7 SET BGP1320=$$DENT^BGP8D7(DFN,BGPBDATE,BGPEDATE)
+8 SET BGPSCPT=$$CPTSM^BGP8D7(DFN,BGPBDATE,BGPEDATE)
+9 IF BGPSDX]""
SET BGPN5=1
IF BGPTOBV=""
SET BGPTOBV=$$DATE^BGP8UTL($PIECE(BGPSDX,U,2))
+10 IF BGPXPED]""
SET BGPN5=1
IF BGPTOBV=""
SET BGPTOBV=$$DATE^BGP8UTL($PIECE(BGPXPED,U,2))
+11 IF BGP1320]""
SET BGPN5=1
IF BGPTOBV=""
SET BGPTOBV=$$DATE^BGP8UTL($PIECE(BGP1320,U,2))
+12 IF BGPSCPT]""
SET BGPN5=1
IF BGPTOBV=""
SET BGPTOBV=$$DATE^BGP8UTL($PIECE(BGPSCPT,U,2))
+13 IF BGPN5
SET BGPVALUE=BGPVALUE_";TOB SCRN: "_BGPTOBV
IMS6 ;
+1 SET BGPBMI=$$BMI^BGP8D6(DFN,BGPEDATE,BGPAGEE)
+2 IF $PIECE(BGPBMI,U)=""
SET BGPBMI=$$REF^BGP8D6(DFN,BGPBDATE,BGPEDATE,BGPAGEB)
+3 IF $PIECE(BGPBMI,U)]""
SET BGPN6=1
+4 IF BGPN6
SET BGPVALUE=BGPVALUE_";BMI: "_$SELECT(BGPBMI["HT":"ref "_$PIECE(BGPBMI,U,2)_" "_$$DATE^BGP8UTL($PIECE(BGPBMI,U,3))_" "_$PIECE(BGPBMI,U,5)_" "_$$DATE^BGP8UTL($PIECE(BGPBMI,U,6)),BGPBMI]"":$$SB^BGP8PDL1($JUSTIFY($PIECE(BGPBMI,U),6,2)),1:"")
IMS7 ;
+1 SET BGPLIFE=$$LIFE^BGP8D41(DFN,BGPBDATE,BGPEDATE)
+2 IF $PIECE(BGPLIFE,U)
SET BGPN7=1
+3 IF BGPN7
SET BGPVALUE=BGPVALUE_";LIFE: "_$$DATE^BGP8UTL($PIECE(BGPLIFE,U,2))_":"_$PIECE(BGPLIFE,U,3)
IMS8 ;
+1 SET BGPDEP=$$DEP^BGP8D25(DFN,BGP365,BGPEDATE)
IF $PIECE(BGPDEP,U)=1
SET BGPN8=1
+2 SET BGPDEPS=$$DEPSCR^BGP8D25(DFN,BGP365,BGPEDATE)
IF $PIECE(BGPDEPS,U)=1
SET BGPN8=1
+3 SET BGPREF=""
IF 'BGPN8
SET BGPREF=$$DEPREF^BGP8D25(DFN,BGP365,BGPEDATE)
IF $PIECE(BGPREF,U)=1
SET BGPN8=1
+4 IF BGPDEP]""
SET BGPVALUE=BGPVALUE_";DEPR SCRN: "_$PIECE(BGPDEP,U,2)_":"_$PIECE(BGPDEP,U,3)
+5 IF '$TEST
IF BGPDEPS]""
SET BGPVALUE=BGPVALUE_";DEPR SCRN: "_$PIECE(BGPDEPS,U,2)_":"_$PIECE(BGPDEPS,U,3)
+6 IF '$TEST
IF BGPREF]""
SET BGPVALUE=BGPVALUE_";DEPR SCRN: "_$PIECE(BGPREF,U,2)_":"_$PIECE(BGPREF,U,3)
IMS9 ;
+1 IF BGPN1
IF BGPN2
IF BGPN3
IF BGPN4
IF BGPN5
IF BGPN6
IF BGPN8
SET BGPN9=1
SET BGPVALUE=$PIECE(BGPVALUE,"|||",1)_"|||*ALL* "_$PIECE(BGPVALUE,"|||",2)
+2 KILL BGPDEP,BGPDEPS,BGPREF,BGPLIFE,BGPBMI,BGPSDX,BGP1320,BGPTOB,BGPUP,BGPFG,BGPHDL
+3 KILL ^TMP($JOB,"A")
+4 QUIT
MS(P,BDATE,EDATE) ;EP
+1 ;2 visits with 277.7?
+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 ""
+5 SET (X,G)=0
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X!($PIECE(G,U)>2)
QUIT
SET V=$PIECE(^TMP($JOB,"A",X),U,5)
Begin DoDot:1
+6 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+7 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+8 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+9 IF "SAHO"'[$PIECE(^AUPNVSIT(V,0),U,7)
QUIT
+10 IF "V"[$PIECE(^AUPNVSIT(V,0),U,3)
QUIT
+11 SET (D,Y)=0
FOR
SET Y=$ORDER(^AUPNVPOV("AD",V,Y))
IF Y'=+Y!(D)
QUIT
Begin DoDot:2
+12 IF '$DATA(^AUPNVPOV(Y,0))
QUIT
+13 SET %=$PIECE(^AUPNVPOV(Y,0),U)
+14 IF '%
QUIT
+15 IF $PIECE($$ICDDX^ICDCODE(%),U,2)=277.7
SET D=1
End DoDot:2
+16 IF 'D
QUIT
+17 SET $PIECE(G,U)=$PIECE(G,U)+1
SET $PIECE(G,U,($PIECE(G,U)+1))=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
+18 QUIT
End DoDot:1
+19 KILL ^TMP($JOB,"A")
+20 IF $PIECE(G,U)>1
QUIT 1_U_"277.7 on "_$$DATE^BGP8UTL($PIECE(G,U,2))_"; "_$$DATE^BGP8UTL($PIECE(G,U,3))
+21 ;now check for 3 or more of the following
+22 SET BGPC=0
SET BGPK=""
+23 SET X=$$BMI^BGP8D6(P,EDATE,$$AGE^AUPNPAT(P,EDATE))
+24 IF $EXTRACT(X,1,2)>29
SET BGPC=BGPC+1
SET BGPK="BMI="_$$STRIP^XLFSTR($JUSTIFY(X,6,2)," ")
+25 SET X=$$TRIG(P,BDATE,EDATE)
IF X]""
SET BGPC=BGPC+1
IF BGPK]""
SET BGPK=BGPK_"; "
SET BGPK=BGPK_X
+26 SET X=$$HDL(P,BDATE,EDATE)
IF X]""
SET BGPC=BGPC+1
IF BGPK]""
SET BGPK=BGPK_"; "
SET BGPK=BGPK_X
+27 SET BGPHTN=$$LASTDX^BGP8UTL1(P,"SURVEILLANCE HYPERTENSION",BGP365,EDATE)
+28 SET BGPMBP=$$MEANBP(P,BGPBDATE,BGPEDATE)
+29 IF $PIECE(BGPHTN,U)!(BGPMBP]"")
SET BGPC=BGPC+1
IF BGPK]""
SET BGPK=BGPK_"; "
IF $PIECE(BGPHTN,U)=1
SET BGPK=BGPK_"HTN DX: "_$$DATE^BGP8UTL($PIECE(BGPHTN,U,3))
IF BGPMBP]""
IF BGPK]""&($PIECE(BGPHTN,U)=1)
SET BGPK=BGPK_"; "
SET BGPK=BGPK_BGPMBP
+30 SET X=$$FG(P,BGPBDATE,BGPEDATE)
IF X]""
SET BGPC=BGPC+1
IF BGPK]""
SET BGPK=BGPK_"; "
SET BGPK=BGPK_X
+31 SET X=$$WC(P,BGPBDATE,BGPEDATE)
IF X]""
SET BGPC=BGPC+1
IF BGPK]""
SET BGPK=BGPK_"; "
SET BGPK=BGPK_X
+32 IF BGPC>2
QUIT BGPC_"^"_BGPK
+33 QUIT ""
BMI(P,BDATE,EDATE,AGE) ;EP
+1 KILL %,W,H,B,D,%DT
+2 SET BGPBMIH=""
+3 IF AGE>18
IF AGE<51
Begin DoDot:1
+4 SET HDATE=$$FMADD^XLFDT(BDATE,-(5*365))
SET HDATE=$$FMTE^XLFDT(HDATE)
+5 SET BDATE=$$FMADD^XLFDT(BDATE,-(5*365))
+6 SET BDATE=$$FMTE^XLFDT(BDATE)
SET EDATE=$$FMTE^XLFDT(EDATE)
+7 SET W=$$WT(P,BDATE,EDATE)
IF W=""!(W="?")
QUIT
+8 ;S HDATE=$$FMTE^XLFDT($$FMADD^XLFDT($P(^DPT(P,0),U,3),(19*365)))
+9 ;S HDATE=BDATE
+10 SET H=$$HT(P,HDATE,EDATE)
IF H=""
QUIT
+11 SET W=W*.45359
SET H=(H*.0254)
SET H=(H*H)
SET BGPBMIH=(W/H)
End DoDot:1
QUIT BGPBMIH
+12 IF AGE>50
Begin DoDot:1
+13 SET HDATE=$$FMADD^XLFDT(BDATE,-(2*365))
SET HDATE=$$FMTE^XLFDT(HDATE)
+14 SET BDATE=$$FMTE^XLFDT(BDATE)
SET EDATE=$$FMTE^XLFDT(EDATE)
+15 SET W=$$WT(P,BDATE,EDATE)
IF W=""!(W="?")
QUIT
+16 ;S HDATE=$$FMTE^XLFDT($$FMADD^XLFDT($P(^DPT(P,0),U,3),(19*365)))
+17 SET HDATE=BDATE
+18 SET H=$$HT(P,HDATE,EDATE)
IF H=""
QUIT
+19 SET W=W*.45359
SET H=(H*.0254)
SET H=(H*H)
SET BGPBMIH=(W/H)
End DoDot:1
QUIT BGPBMIH
+20 IF AGE<19
Begin DoDot:1
+21 SET BDATE=$$FMADD^XLFDT(EDATE,-365)
SET BDATE=$$FMTE^XLFDT(BDATE)
SET EDATE=$$FMTE^XLFDT(EDATE)
+22 SET X=$$HTWTSD(P,BDATE,EDATE)
+23 IF '$PIECE(X,"^")
QUIT
+24 IF '$PIECE(X,"^",2)
QUIT
+25 SET W=$PIECE(X,"^")
SET H=$PIECE(X,"^",2)
+26 SET W=W*.45359
SET H=(H*.0254)
SET H=(H*H)
SET BGPBMIH=(W/H)
+27 QUIT
End DoDot:1
QUIT BGPBMIH
+28 QUIT
WC(P,BDATE,EDATE) ;EP
+1 IF 'P
QUIT ""
+2 KILL %,BGPARRY,H,E
+3 SET %=P_"^LAST MEAS WC;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPARRY(")
SET H=$PIECE($GET(BGPARRY(1)),U,2)
+4 IF H=""
QUIT H
+5 IF H["?"
QUIT ""
+6 IF $PIECE(^DPT(P,0),U,2)="M"
IF H>40
QUIT "WC="_H
+7 IF $PIECE(^DPT(P,0),U,2)="F"
IF H>35
QUIT "WC="_H
+8 QUIT ""
HT(P,BDATE,EDATE) ;EP
+1 IF 'P
QUIT ""
+2 KILL %,BGPARRY,H,E
+3 SET %=P_"^LAST MEAS HT;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPARRY(")
SET H=$PIECE($GET(BGPARRY(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 KILL %,E,BGPLW,X,BGPLN,BGPL,BGPLD,BGPLZ,BGPLX,ICD
+3 KILL BGPL
SET BGPLW=""
SET BGPLX=P_"^LAST 24 MEAS WT;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(BGPLX,"BGPL(")
+4 SET BGPLN=0
FOR
SET BGPLN=$ORDER(BGPL(BGPLN))
IF BGPLN'=+BGPLN!(BGPLW]"")
QUIT
Begin DoDot:1
+5 SET BGPLZ=$PIECE(BGPL(BGPLN),U,5)
+6 IF '$DATA(^AUPNVPOV("AD",BGPLZ))
SET BGPLW=$PIECE(BGPL(BGPLN),U,2)
QUIT
+7 SET BGPLD=0
FOR
SET BGPLD=$ORDER(^AUPNVPOV("AD",BGPLZ,BGPLD))
IF 'BGPLD!(BGPLW]"")
QUIT
Begin DoDot:2
+8 SET D=$PIECE(BGPL(BGPLN),U)
+9 SET ICD=$PIECE($$ICDDX^ICDCODE($PIECE(^AUPNVPOV(BGPLD,0),U),D),U,2)
Begin DoDot:3
+10 IF $EXTRACT(ICD,1,3)="V22"
QUIT
+11 IF $EXTRACT(ICD,1,3)="V23"
QUIT
+12 IF $EXTRACT(ICD,1,3)="V27"
QUIT
+13 IF $EXTRACT(ICD,1,3)="V28"
QUIT
+14 IF ICD>629.9999&(ICD<676.95)
QUIT
+15 IF ICD>61.49&(ICD<61.71)
QUIT
+16 SET BGPLW=$PIECE(BGPL(BGPLN),U,2)
End DoDot:3
+17 QUIT
End DoDot:2
End DoDot:1
+18 QUIT BGPLW
HTWTSD(P,BDATE,EDATE) ;get last ht / wt on same day
+1 IF '$GET(P)
QUIT ""
+2 KILL BGPLWTS,BGPLHTS,%,X,BGPLWTS1,BGPLHTS1,Y
+3 ;get all hts during time frame
+4 SET %=P_"^ALL MEAS HT;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPLHTS(")
+5 SET Y=0
FOR
SET Y=$ORDER(BGPLHTS(Y))
IF Y'=+Y
QUIT
IF $PIECE(BGPLHTS(Y),U,2)="?"!($PIECE(BGPLHTS(Y),U,2)="")
KILL BGPLHTS(Y)
+6 ;set the array up by date
+7 KILL BGPLHTS1
SET X=0
FOR
SET X=$ORDER(BGPLHTS(X))
IF X'=+X
QUIT
SET BGPLHTS1($PIECE(BGPLHTS(X),U))=X
+8 ;get all wts during time frame
+9 SET %=P_"^ALL MEAS WT;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPLWTS(")
+10 SET Y=0
FOR
SET Y=$ORDER(BGPLWTS(Y))
IF Y'=+Y
QUIT
IF $PIECE(BGPLWTS(Y),U,2)="?"!($PIECE(BGPLWTS(Y),U,2)="")
KILL BGPLWTS(Y)
+11 ;set the array up by date
+12 KILL BGPLWTS1
SET X=0
FOR
SET X=$ORDER(BGPLWTS(X))
IF X'=+X
QUIT
SET BGPLWTS1($PIECE(BGPLWTS(X),U))=X
+13 SET BGPLCHT=""
SET X=9999999
FOR
SET X=$ORDER(BGPLWTS1(X),-1)
IF X=""!(BGPLCHT]"")
QUIT
IF $DATA(BGPLHTS1(X))
SET BGPLCHT=$PIECE(BGPLWTS(BGPLWTS1(X)),U,2)_U_$PIECE(BGPLHTS(BGPLHTS1(X)),U,2)
+14 QUIT BGPLCHT
+15 ;
TRIG(P,BDATE,EDATE) ;EP
+1 ;now get all loinc/taxonomy tests
+2 SET T=$ORDER(^ATXAX("B","BGP TRIGLYCERIDE LOINC CODES",0))
+3 SET BGPLT=$ORDER(^ATXLAB("B","DM AUDIT TRIGLYCERIDE TAX",0))
+4 SET R=""
+5 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)!(R]"")
QUIT
Begin DoDot:1
+6 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!(R]"")
QUIT
Begin DoDot:2
+7 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!(R]"")
QUIT
Begin DoDot:3
+8 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+9 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
Begin DoDot:4
+10 SET V=$PIECE(^AUPNVLAB(X,0),U,4)
IF V=""
QUIT
IF 'V
QUIT
IF +V<150
QUIT
SET R="TRIG="_V
End DoDot:4
IF R]""
QUIT
+11 IF 'T
QUIT
+12 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+13 IF '$$LOINC(J,T)
QUIT
+14 SET V=$PIECE(^AUPNVLAB(X,0),U,4)
+15 IF V=""
QUIT
IF V'=+V
QUIT
+16 IF +V<150
QUIT
+17 SET R="TRIG="_V
+18 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+19 QUIT R
HDL(P,BDATE,EDATE) ;EP
+1 KILL BGPC1
+2 SET BGPC1=0
SET R=""
+3 ;S %="",E=+$$CODEN^ICPTCOD(83718),%=$$CPTI^BGP8DU(P,BDATE,EDATE,E)
+4 ;I %]"" Q 1_U_$P(%,U,2)
+5 ;S %="",E=+$$CODEN^ICPTCOD(83718),%=$$TRANI^BGP8DU(P,BDATE,EDATE,E)
+6 ;I %]"" Q 1_U_$P(%,U,2)
+7 ;now get all loinc/taxonomy tests
+8 SET S=$PIECE(^DPT(DFN,0),U,2)
+9 SET T=$ORDER(^ATXAX("B","BGP HDL LOINC CODES",0))
+10 SET BGPLT=$ORDER(^ATXLAB("B","DM AUDIT HDL TAX",0))
+11 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)!(BGPC1)
QUIT
Begin DoDot:1
+12 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!(R]"")
QUIT
Begin DoDot:2
+13 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!(R]"")
QUIT
Begin DoDot:3
+14 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+15 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
Begin DoDot:4
+16 SET V=$PIECE(^AUPNVLAB(X,0),U,4)
Begin DoDot:5
+17 IF V=""
QUIT
+18 IF 'V
QUIT
+19 IF S="M"
IF +V<40
SET R="HDL="_V
+20 IF S="F"
IF +V<50
SET R="HDL="_V
End DoDot:5
End DoDot:4
IF R]""
QUIT
+21 IF 'T
QUIT
+22 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+23 IF '$$LOINC(J,T)
QUIT
+24 SET V=$PIECE(^AUPNVLAB(X,0),U,4)
+25 IF V=""
QUIT
+26 IF V'=+V
QUIT
+27 IF S="M"
IF +V<40
SET R="HDL="_V
QUIT
+28 IF S="F"
IF +V<50
SET R="HDL="_V
QUIT
+29 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+30 QUIT R
+31 ;
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 ""
MEANBP(P,BDATE,EDATE) ;EP
+1 SET X=$$BPS(P,BDATE,EDATE,"I")
+2 SET S=$$SYSMEAN(X)
IF S=""
QUIT ""
+3 SET DS=$$DIAMEAN(X)
IF DS=""
QUIT ""
+4 IF S>129
QUIT "BP="_S_"/"_DS
+5 IF DS>84
QUIT "BP="_S_"/"_DS
+6 QUIT ""
+7 ;
SYSMEAN(X) ;EP
+1 IF X=""
QUIT ""
+2 SET C=0
FOR Y=1:1:3
IF $PIECE(X,";",Y)]""
SET C=C+1
+3 IF C<2
QUIT ""
+4 SET T=0
FOR Y=1:1:3
SET T=$PIECE($PIECE(X,";",Y),"/")+T
+5 ;Q $$STRIP^XLFSTR($J((T/C),5,1)," ")
+6 QUIT T\C
+7 ;
DIAMEAN(X) ;EP
+1 IF X=""
QUIT ""
+2 SET C=0
FOR Y=1:1:3
IF $PIECE(X,";",Y)]""
SET C=C+1
+3 IF C<2
QUIT ""
+4 SET T=0
FOR Y=1:1:3
SET T=$PIECE($PIECE(X,";",Y),"/",2)+T
+5 ;Q $$STRIP^XLFSTR($J((T/C),5,1)," ")
+6 QUIT T\C
+7 ;
BPSD(P,BDATE,EDATE) ;EP
+1 SET X=$$BPS(P,BDATE,EDATE,"I")
+2 SET C=0
FOR Y=1:1:2
IF $PIECE(X,";",Y)]""
SET C=C+1
+3 IF C<2
QUIT ""
+4 QUIT 1
BPS(P,BDATE,EDATE,F) ;EP ;
+1 IF $GET(F)=""
SET F="E"
+2 SET BGPGLL=0
SET BGPGV=""
+3 KILL BGPG
+4 KILL ^TMP($JOB,"BPV")
+5 SET A="^TMP($J,""BPV"","
SET B=P_"^LAST 365 VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(B,A)
+6 IF '$DATA(^TMP($JOB,"BPV",1))
QUIT ""
+7 SET Y=0
FOR
SET Y=$ORDER(^TMP($JOB,"BPV",Y))
IF Y'=+Y!(BGPGLL=3)
QUIT
Begin DoDot:1
+8 SET V=$PIECE(^TMP($JOB,"BPV",Y),U,5)
+9 ;NO ER CLINIC VISITS COUNTED
IF $$CLINIC^APCLV(V,"C")=30
QUIT
+10 ;no measurements to look at
IF '$DATA(^AUPNVMSR("AD",V))
QUIT
+11 ;NOW GET ALL BPS ON THIS VISIT
+12 SET BGPBP=""
+13 SET X=0
FOR
SET X=$ORDER(^AUPNVMSR("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:2
+14 ;BAD AD XREF
IF '$DATA(^AUPNVMSR(X,0))
QUIT
+15 SET T=$PIECE($GET(^AUPNVMSR(X,0)),U)
+16 ;BAD AD XREF
IF T=""
QUIT
+17 ;not a BP measurement type
IF $PIECE($GET(^AUTTMSR(T,0)),U)'="BP"
QUIT
+18 ;blood pressure value
SET Z=$PIECE(^AUPNVMSR(X,0),U,4)
+19 IF BGPBP=""
SET BGPBP=Z
QUIT
+20 IF $PIECE(Z,"/")'>$PIECE(BGPBP,"/")
SET BGPBP=Z
End DoDot:2
+21 IF BGPBP=""
QUIT
+22 SET BGPGLL=BGPGLL+1
+23 IF F="E"
SET $PIECE(BGPGV,";",BGPGLL)=BGPBP_" "_$$FMTE^XLFDT($PIECE(^TMP($JOB,"BPV",V),U))
+24 IF F="I"
SET $PIECE(BGPGV,";",BGPGLL)=$PIECE(BGPBP," ")
End DoDot:1
+25 KILL ^TMP($JOB,"BPV")
+26 QUIT BGPGV
FG(P,BDATE,EDATE) ;EP
+1 KILL BGPC1
+2 SET BGPC1=0
SET R=""
+3 ;now get all loinc/taxonomy tests
+4 SET T=$ORDER(^ATXAX("B","DM AUDIT FASTING GLUC LOINC",0))
+5 SET BGPLT=$ORDER(^ATXLAB("B","DM AUDIT FASTING GLUCOSE TESTS",0))
+6 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)!(R]"")
QUIT
Begin DoDot:1
+7 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!(R]"")
QUIT
Begin DoDot:2
+8 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!(R]"")
QUIT
Begin DoDot:3
+9 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+10 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
Begin DoDot:4
+11 SET V=$PIECE(^AUPNVLAB(X,0),U,4)
IF +V<100
QUIT
IF +V>125.9999
QUIT
SET R="FAST GLUC="_V
End DoDot:4
IF R]""
QUIT
+12 IF 'T
QUIT
+13 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+14 IF '$$LOINC(J,T)
QUIT
+15 SET V=$PIECE(^AUPNVLAB(X,0),U,4)
+16 IF V=""
QUIT
+17 IF 'V
QUIT
+18 IF +V<100
QUIT
+19 IF +V>125.9999
QUIT
+20 SET R="FASTING GLUC="_V
+21 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+22 QUIT R
FGT(P,BDATE,EDATE) ;EP
+1 KILL BGPG,BGPT,BGPC
+2 KILL BGPG
+3 SET Y="BGPG("
+4 SET X=P_"^LAST DX 790.21;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+5 ;has a dx
IF $DATA(BGPG(1))
QUIT 1_U_$PIECE(BGPG(1),U)_U_"790.21"
+6 SET BGPC=0
+7 ;now get all loinc/taxonomy tests
+8 SET T=$ORDER(^ATXAX("B","DM AUDIT FASTING GLUC LOINC",0))
+9 SET BGPLT=$ORDER(^ATXLAB("B","DM AUDIT FASTING GLUCOSE TESTS",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)
QUIT
Begin DoDot:1
+11 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+12 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
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=BGPC+1
SET BGPT(D,BGPC)=$PIECE(^AUPNVLAB(X,0),U,4)
QUIT
+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 R=$PIECE(^AUPNVLAB(X,0),U,4)
+19 SET BGPC=BGPC+1
SET BGPT(D,BGPC)=R
+20 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+21 ; now got though and set return value of done 1 or 0^VALUE^date
+22 ;no tests
IF '$DATA(BGPT)
QUIT ""
+23 QUIT 1_U_(9999999-$ORDER(BGPT(0)))
