Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BGP1EL2

BGP1EL2.m

Go to the documentation of this file.
BGP1EL2 ; IHS/CMI/LAB - measure 1,2,3,4 17 Jan 2010 6:49 AM ;
 ;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
 ;
I1 ;EP - measure 1 general processing
 S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPN1,BGPN1)=0
 S BGPN1=0,BGPVALUE="",BGPD1=0
 I BGPAGEB<55 S BGPSTOP=1 Q
 S BGPD1=1
 I BGPAGEB>54,BGPAGEB<65 S BGPD2=1
 I BGPAGEB>64,BGPAGEB<75 S BGPD3=1
 I BGPAGEB>74,BGPAGEB<85 S BGPD4=1
 I BGPAGEB>84 S BGPD5=1
 K BGPG
 S Y="BGPG("
 S X=DFN_"^LAST DX [SURVEILLANCE DIABETES;DURING "_$$DOB^AUPNPAT(DFN,"E")_"-"_$$FMTE^XLFDT(BGPEDATE) S E=$$START1^APCLDF(X,Y)
 I BGPDM1 S BGPN1=1
 I '$D(BGPG(1)) S BGPVALUE="" Q
 S BGPVALUE="UP|||"_$$DATE^BGP1UTL($P(BGPG(1),U))_" "_$P(BGPG(1),U,2)
 Q
 ;
I2 ;EP
 K BGPN1,BGPN2,BGPN3,BGPN4,BGPVALUE,BGPLHGB,BGPN5,BGPN6,BGPN7,BGPN8
 S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0
 I BGPAGEB<55 S BGPSTOP=1 Q
 I 'BGPDMD2 S BGPSTOP=1 Q  ;don't process this measure, pt not diabetic
 S BGPD1=1
 I BGPAGEB>54,BGPAGEB<65 S BGPD2=1
 I BGPAGEB>64,BGPAGEB<75 S BGPD3=1
 I BGPAGEB>74,BGPAGEB<85 S BGPD4=1
 I BGPAGEB>84 S BGPD5=1
 D DMGC^BGP1D2
 S BGPVALUE="AD|||"_$P(BGPVALUE,"|||",2)
 K BGPXPBV
 Q
 ;
I3 ;EP
 K BGPN1,BGPN2,BGPN3,BGPVALUE,BGPLBP
 S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0
 I BGPAGEB<55 S BGPSTOP=1 Q
 I 'BGPDMD2 S BGPSTOP=1 Q  ;don't process this measure, pt not diabetic
 S BGPD1=1
 I BGPAGEB>54,BGPAGEB<65 S BGPD2=1
 I BGPAGEB>64,BGPAGEB<75 S BGPD3=1
 I BGPAGEB>74,BGPAGEB<85 S BGPD4=1
 I BGPAGEB>84 S BGPD5=1
 D DMBP^BGP1D2
 S BGPVALUE="AD|||"_$P(BGPVALUE,"|||",2)
 K BGPXPBV
 Q
 ;
I4 ;EP
 K BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPVALUE,BGPLD,BGPLDL,BGPTRI,BGPHDL
 S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5)=0
 S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0
 I BGPAGEB<55 S BGPSTOP=1 Q
 I 'BGPDMD2 S BGPSTOP=1 Q  ;don't process this measure, pt not diabetic
 S BGPD1=1
 I BGPAGEB>54,BGPAGEB<65 S BGPD2=1
 I BGPAGEB>64,BGPAGEB<75 S BGPD3=1
 I BGPAGEB>74,BGPAGEB<85 S BGPD4=1
 I BGPAGEB>84 S BGPD5=1
 D DMLDL^BGP1D2
 S BGPVALUE="AD|||"_$P(BGPVALUE,"|||",2)
 K BGPXPBV
 Q
 ;
I5 ;EP
 K BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPVALUE,BGPLD,BGPLDL,BGPTRI,BGPHDL
 S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5)=0
 S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0
 I BGPAGEB<55 S BGPSTOP=1 Q
 I 'BGPDMD2 S BGPSTOP=1 Q  ;don't process this measure, pt not diabetic
 S BGPD1=1
 I BGPAGEB>54,BGPAGEB<65 S BGPD2=1
 I BGPAGEB>64,BGPAGEB<75 S BGPD3=1
 I BGPAGEB>74,BGPAGEB<85 S BGPD4=1
 I BGPAGEB>84 S BGPD5=1
 D DMNA^BGP1D21
 S BGPVALUE="AD|||"_$P(BGPVALUE,"|||",2)
 K BGPXPBV
 Q
 ;
 ;
I6 ;EP
 K BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPVALUE,BGPLD,BGPLDL,BGPTRI,BGPHDL
 S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5)=0
 S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0
 I BGPAGEB<55 S BGPSTOP=1 Q
 I 'BGPDMD2 S BGPSTOP=1 Q  ;don't process this measure, pt not diabetic
 S BGPD1=1
 I BGPAGEB>54,BGPAGEB<65 S BGPD2=1
 I BGPAGEB>64,BGPAGEB<75 S BGPD3=1
 I BGPAGEB>74,BGPAGEB<85 S BGPD4=1
 I BGPAGEB>84 S BGPD5=1
 D DMEYE^BGP1D21
 S BGPVALUE="AD|||"_$P(BGPVALUE,"|||",2)
 K ^TMP($J,"A")
 K BGPUP,BGPGFR,BGPX,BGPY,BGPC,BGPG
 K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F
 Q
I7 ;EP
 K BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPVALUE,BGPLD,BGPLDL,BGPTRI,BGPHDL
 S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5)=0
 S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0
 I BGPAGEB<55 S BGPSTOP=1 Q
 I 'BGPDMD2 S BGPSTOP=1 Q  ;don't process this measure, pt not diabetic
 S BGPD1=1
 I BGPAGEB>54,BGPAGEB<65 S BGPD2=1
 I BGPAGEB>64,BGPAGEB<75 S BGPD3=1
 I BGPAGEB>74,BGPAGEB<85 S BGPD4=1
 I BGPAGEB>84 S BGPD5=1
 S BGPVALUE=$$DENTSRV^BGP1D21(DFN,BGPBDATE,BGPEDATE)
 S BGPN1=0 I $P(BGPVALUE,U)=1 S BGPN1=1
 S BGPN2=0 I $P(BGPVALUE,U)=2 S BGPN2=1
 S BGPVALUE="AD|||"_$$DATE^BGP1UTL($P(BGPVALUE,U,2))_" "_$P(BGPVALUE,U,3)
 K ^TMP($J,"A")
 K BGPUP,BGPGFR,BGPX,BGPY,BGPC,BGPG
 K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F
 Q
I8 ;EP
 K BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPVALUE,BGPLD,BGPLDL,BGPTRI,BGPHDL
 S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5)=0
 S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0
 I BGPAGEB<55 S BGPSTOP=1 Q
 S BGPD1=1
 I BGPAGEB>54,BGPAGEB<65 S BGPD2=1
 I BGPAGEB>64,BGPAGEB<75 S BGPD3=1
 I BGPAGEB>74,BGPAGEB<85 S BGPD4=1
 I BGPAGEB>84 S BGPD5=1
 S BGPVALUE=$$DENTSRV^BGP1D21(DFN,BGPBDATE,BGPEDATE)
 S BGPN1=0 I $P(BGPVALUE,U)=1 S BGPN1=1
 S BGPN2=0 I $P(BGPVALUE,U)=2 S BGPN2=1
 S BGPVALUE="UP|||"_$$DATE^BGP1UTL($P(BGPVALUE,U,2))_" "_$P(BGPVALUE,U,3)
 K ^TMP($J,"A")
 K BGPUP,BGPGFR,BGPX,BGPY,BGPC,BGPG
 K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F
 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<130&(DS<80) Q S_"/"_DS_" CON"_U_2
 Q S_"/"_DS_" UNC"_U_3
 ;
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)," ")
 ;
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)," ")
 ;
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 X=P_"^LAST 50 MEAS BP;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,"BGPG(")
 ;S BGPGL=0 F  S BGPGL=$O(BGPG(BGPGL)) Q:BGPGL'=+BGPGL!(BGPGLL=3)  S BGPGBP=$P($G(BGPG(BGPGL)),U,2) D
 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
LIPID(P,BDATE,EDATE) ;EP
 K BGPC
 S BGPC=0
 S %="",E=+$$CODEN^ICPTCOD(80061),%=$$CPTI^BGP1DU(P,BDATE,EDATE,E)
 I %]"" Q 1_U_$P(%,U,2)_U_"80061"
 S %="",E=+$$CODEN^ICPTCOD(80061),%=$$TRANI^BGP1DU(P,BDATE,EDATE,E)
 I %]"" Q 1_U_$P(%,U,2)_U_"80061 TRAN"
 ;now get all loinc/taxonomy tests
 S T=$O(^ATXAX("B","BGP LIPID PROFILE LOINC CODES",0))
 S BGPLT=$O(^ATXLAB("B","DM AUDIT LIPID PROFILE 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)!($P(BGPC,U))  D
 .S L=0 F  S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!($P(BGPC,U))  D
 ..S X=0 F  S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!($P(BGPC,U))  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)_U_"LAB" Q
 ...Q:'T
 ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
 ...Q:'$$LOINC(J,T)
 ...S BGPC=1_U_(9999999-D)_U_"LOINC"
 ...Q
 Q BGPC
 ;
TRIG(P,BDATE,EDATE) ;EP
 K BGPC
 S BGPC=0
 S %="",E=+$$CODEN^ICPTCOD(84478),%=$$CPTI^BGP1DU(P,BDATE,EDATE,E)
 I %]"" Q 1_U_$P(%,U,2)
 S %="",E=+$$CODEN^ICPTCOD(84478),%=$$TRANI^BGP1DU(P,BDATE,EDATE,E)
 I %]"" Q 1_U_$P(%,U,2)
 ;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 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
 ...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=1_U_(9999999-D)
 ...Q
 Q BGPC
HDL(P,BDATE,EDATE) ;EP
 K BGPC
 S BGPC=0
 S %="",E=+$$CODEN^ICPTCOD(83718),%=$$CPTI^BGP1DU(P,BDATE,EDATE,E)
 I %]"" Q 1_U_$P(%,U,2)
 S %="",E=+$$CODEN^ICPTCOD(83718),%=$$TRANI^BGP1DU(P,BDATE,EDATE,E)
 I %]"" Q 1_U_$P(%,U,2)
 ;now get all loinc/taxonomy tests
 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)!(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
 ...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=1_U_(9999999-D)
 ...Q
 Q BGPC
 ;
LDL(P,BDATE,EDATE) ;EP
 K BGPG,BGPT,BGPC
 S BGPC=0
 S %="",E=+$$CODEN^ICPTCOD(83721),%=$$CPTI^BGP1DU(P,BDATE,EDATE,E)
 I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,2),BGPC)=""
 S %="",E=+$$CODEN^ICPTCOD(83721),%=$$TRANI^BGP1DU(P,BDATE,EDATE,E)
 I %]"" S BGPC=BGPC+1,BGPT(9999999-$P(%,U,2),BGPC)=""
 ;now get all loinc/taxonomy tests
 S T=$O(^ATXAX("B","BGP LDL LOINC CODES",0))
 S BGPLT=$O(^ATXLAB("B","DM AUDIT LDL CHOLESTEROL 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)  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
 S D=0,G="" F  S D=$O(BGPT(D)) Q:D'=+D!(G]"")  D
 .S C=0 F  S C=$O(BGPT(D,C)) Q:C'=+C!(G]"")  D
 ..S X=BGPT(D,C)
 ..I $E(X)'=+$E(X) Q
 ..S G=(9999999-D)_U_X
 ..Q
 I G="" Q 1_"^"_(9999999-$O(BGPT(0)))
 Q 1_U_G
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 ""