BGP8PC14.m

BGP8PC14 ; IHS/CMI/LAB - measure I2 ; 26 Jul 2018  3:40 PM

 ;;18.1;IHS CLINICAL REPORTING;**1**;MAY 25, 2018;Build 65

 ;

BMI ;EP - CALLED FROM IPC REPORT

 S (BGPN1,BGPD1)=0

 S BGPBMIE="",BGPBMI="",BGPFU=""

 ;

 ;

 ;GATHER UP ALL BMI ENC VISITS

 ;Let's check all Visits, looping through once

 S G=""  ;return variable

 S BGPBMIE=$$MRBMIE(DFN,BGPBDATE,BGPEDATE) I BGPBMIE="" S BGPSTOP=1 G BMIE  ;no BMI encounter

 ;AGE ON bmi encounter

 S A=$$AGE^AUPNPAT(DFN,BGPBMIE)

 I A<18 S BGPSTOP=1 G BMIE

 ;

 ;now what about exclusions?

 ;might as well process exclusions first;

 ;palliative care

 I $$PALLCARE^BGP8PC13(DFN,$$DOB^AUPNPAT(DFN),BGPBMIE) S BGPSTOP=1 G BMIE

 ;

 ;pregnancy

 I $$PREG(DFN,BGPBDATE,BGPEDATE) S BGPSTOP=1 G BMIE

 ;

 ;REFUSAL ON SAME DAY AS MOST RECENT BMI ENCOUNTER OF BOTH HT/WT

 I $$REFWTHT(DFN,BGPBMIE) S BGPSTOP=1 G BMIE

 ;MEDICAL REASON NOT DONE

 I $$MRND(DFN,$$FMADD^XLFDT(BGPBMIE,-365),$$FMADD^XLFDT(BGPBMIE,-1)) S BGPSTOP=1 G BMIE

 ;FINALLY MADE DENOMINATOR

 S BGPD1=1

 S BGPBMI=$$MRBMI(DFN,$$FMADD^XLFDT(BGPBMIE,-365),BGPBMIE) I BGPBMI]"" S BGPBMI=$J(BGPBMI,5,2)

 I BGPBMI'<18.5,BGPBMI<25 S BGPN1=1 G BMI1

 I BGPBMI'<25 S BGPFU=$$ANFU(DFN,$$FMADD^XLFDT(BGPBMIE,-365),BGPBMIE) S:BGPFU BGPN1=1 G BMI1

 S BGPFU=$$BLFU(DFN,$$FMADD^XLFDT(BGPBMIE,-365),BGPBMIE) S:BGPFU BGPN1=1 G BMI1

BMI1 ;

 S BGPVALUE=""

 S BGPVALUE="ENC "_$$DATE^BGP8UTL(BGPBMIE)_"|||"  ;hit denominator

 I BGPN1 S BGPVALUE=BGPVALUE_"*** BMI: "_BGPBMI I BGPFU S BGPVALUE=BGPVALUE_" F/U PLAN: "_$$DATE^BGP8UTL($P(BGPFU,U,2))_" "_$P(BGPFU,U,3)

 I 'BGPN1 S BGPVALUE=BGPVALUE_$S(BGPBMI:"BMI: "_BGPBMI,1:"")

BMIE ;

 K D,V,X,Y,BGPV,BGPBMI,BGPBMIE,G,BGPFU

 Q

MRBMIE(P,BDATE,EDATE) ;EP  - MOST RECENT BMI ENCOUNTER DURING BDATE TO EDATE

 NEW X,Y,Z,G,BGPV,D,A,B,BGPDO,ID

 ;Let's check all Visits, looping through once

 S G=""  ;return variable

 ;get all visits in date range in BGPV

 D ALLV^APCLAPIU(P,BDATE,EDATE,"BGPV")

 ;REORDER BY DATE

 K BGPDO

 S X=0 F  S X=$O(BGPV(X)) Q:X'=+X  S V=$P(BGPV(X),U,5)  S BGPDO((9999999-$P(BGPV(X),U,1)),V)=""

 S ID=0 F  S ID=$O(BGPDO(ID)) Q:ID=""!(G)  S V=0 F  S V=$O(BGPDO(ID,V)) Q:V'=+V  D

 .Q:'$P(^AUPNVSIT(V,0),U,9)  ;no dependent entries

 .Q:$P(^AUPNVSIT(V,0),U,11)  ;deleted

 .S D=$$VD^APCLV(V)

 .S Y=$$BMIENC(V) I Y]"" S G=D Q   ;ITEM 18

 .;is .17 a cpt we want?

 .S Y=$$VALI^XBDIQ1(9000010,V,.17)

 .I Y,$$BMIECPT(Y) S G=D Q

 .;now check all V CPTs

 .S Z=0 F  S Z=$O(^AUPNVCPT("AD",V,Z)) Q:Z'=+Z!(G)  D

 ..S Y=$P($G(^AUPNVCPT(Z,0)),U,1)

 ..I Y,$$BMIECPT(Y) S G=D Q

 .S Z=0 F  S Z=$O(^AUPNVDEN("AD",V,Z)) Q:Z'=+Z!(G)  D

 ..S Y=$$VALI^XBDIQ1(9000010.05,Z,.01)

 ..S T=$O(^ATXAX("B","BGP IPC BMI ADA CODES",0))

 ..I $D(^ATXAX(T,21,"B",Y)) S G=D Q

 Q G

MRBMI(P,BDATE,EDATE) ;

 NEW X,Y,H,W,BMI

 S X=$$LASTITEM^BGP8DU(P,BDATE,EDATE,"MEASUREMENT","BMI")

 I X Q $P(X,U,4)

 ;get last ht within bdate and edate

 S X=$$LASTITEM^BGP8DU(P,BDATE,EDATE,"MEASUREMENT","WT")

 I X="" Q ""

 S W=$P(X,U,4)

 S X=$$LASTITEM^BGP8DU(P,BDATE,EDATE,"MEASUREMENT","HT")

 I X="" Q ""

 S H=$P(X,U,4)

 ;calculate BMI

 S W=W*.45359,H=(H*.0254),H=(H*H),BMI=(W/H)

 Q BMI

BMIENC(V) ;EP

 NEW A,B,C

 S A=0,B=""

 F  S A=$O(^AUPNVSIT(V,28,"B",A)) Q:A=""!(B]"")  D

 .I $D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP IPC BMI ENC",A)) S B=A

 I B Q B

 S A=0,B=""

 F  S A=$O(^AUPNVSIT(V,26,"B",A)) Q:A=""!(B]"")  D

 .I $D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP IPC BMI ENC",A)) S B=A

 Q B

BMIECPT(C) ;

 I $$ICD^ATXAPI(C,$O(^ATXAX("B","BGP IPC BMI ENCOUNTER CPTS",0)),1) Q 1

 I $$ICD^ATXAPI(C,$O(^ATXAX("B","BGP IPC BMI ADA CPTS",0)),1) Q 1

 Q ""

PREG(P,BDATE,EDATE) ;

 NEW X,Y,Z,G,A

 I $P(^DPT(P,0),U,2)'="F" Q ""

 ;check dx

 S X=$$LASTDX^BGP8UTL1(P,"BGP IPC PREGNANCY CMS69 DXS",BDATE,EDATE) I X Q 1

 S T=$O(^ATXAX("B","BGP IPC PREGNANCY CMS69 DXS",0))

 S (X,G,A)=0 F  S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G)  D

 .Q:$P(^AUPNPROB(X,0),U,12)="D"

 .S A=0

 .S D=$P(^AUPNPROB(X,0),U,13)

 .I D'<BDATE,D'>EDATE S A=1

 .I A G PREGN

 .;I D Q  ;had a doo and it didn't match

 .Q:$P(^AUPNPROB(X,0),U,8)>EDATE

 .Q:$P(^AUPNPROB(X,0),U,8)<BDATE

PREGN .I $$ICD^ATXAPI($P(^AUPNPROB(X,0),U,1),T,9) S G=1 Q

 .S S=$$VAL^XBDIQ1(9000011,X,80001)

 .I S]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP IPC PREGNANCY BMI",S)) S G=1 Q

 Q G

REFWTHT(P,BDATE) ;

 NEW F,G,I,ID,C,X,D,H,W,R

 S G=0

 S F=9999999.07,I=$O(^AUTTMSR("B","BMI",0))

 S ID=0 F  S ID=$O(^AUPNPREF("AA",P,F,I,ID)) Q:ID=""!(G)  D

 .S D=9999999-ID

 .Q:D'=BDATE

 .S X=0 F  S X=$O(^AUPNPREF("AA",P,F,I,ID,X)) Q:X'=+X!(G)  D

 ..;get snomed reason not done and it must be in one of the subsets

 ..S R=$$VALI^XBDIQ1(9000022,X,1.01)  ;SNOMED REASON NOT DONE

 ..I R]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP IPC NOT DONE PAT",R)) S G=1 Q

 ..S R=$$VALI^XBDIQ1(9000022,X,.07)

 ..I R="R"!(R="N")!(R="U") S G=1 Q

 I G Q G

 ;now check for WT or HT

 S (W,H)=""

 S F=9999999.07,I=$O(^AUTTMSR("B","WT",0))

 S ID=0 F  S ID=$O(^AUPNPREF("AA",P,F,I,ID)) Q:ID=""!(W)  D

 .S D=9999999-ID

 .Q:D'=BDATE

 .S X=0 F  S X=$O(^AUPNPREF("AA",P,F,I,ID,X)) Q:X'=+X!(W)  D

 ..S R=$$VALI^XBDIQ1(9000022,X,.07)

 ..I R="R"!(R="N")!(R="U") S W=1

 I W Q 1

 S F=9999999.07,I=$O(^AUTTMSR("B","HT",0))

 S ID=0 F  S ID=$O(^AUPNPREF("AA",P,F,I,ID)) Q:ID=""!(H)  D

 .S D=9999999-ID

 .Q:D'=BDATE

 .S X=0 F  S X=$O(^AUPNPREF("AA",P,F,I,ID,X)) Q:X'=+X!(H)  D

 ..S R=$$VALI^XBDIQ1(9000022,X,.07)

 ..I R="R"!(R="N")!(R="U") S H=1

 I H Q 1

 Q ""

MRND(P,BDATE,EDATE) ;EP

 NEW F,G,I,ID,C,X,D,H,W,R

 S G=0

 S F=81,I=""

 F  S I=$O(^AUPNPREF("AA",P,F,I)) Q:I=""!(G)  D

 .I '$$ICD^BGP8UTL2(I,$O(^ATXAX("B","BGP IPC ABOVE NORMAL FU CPTS",0)),1),'$$ICD^BGP8UTL2(I,$O(^ATXAX("B","BGP IPC BELOW NORMAL FU CPTS",0)),1) Q

 .S ID=0 F  S ID=$O(^AUPNPREF("AA",P,F,I,ID)) Q:ID=""!(G)  D

 ..S D=9999999-ID

 ..Q:D<BDATE

 ..Q:D>EDATE

 ..S X=0 F  S X=$O(^AUPNPREF("AA",P,F,I,ID,X)) Q:X'=+X!(G)  D

 ...;get snomed reason not done and it must be in one of the subsets

 ...S R=$$VALI^XBDIQ1(9000022,X,1.01)  ;SNOMED REASON NOT DONE

 ...I R]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP IPC NOT DONE MED",R)) S G=1 Q

 ...S R=$$VALI^XBDIQ1(9000022,X,.07)

 ...I R="N"!(R="U") S G=1

 I G Q G

 S F=9002318.4,I=""

 F  S I=$O(^AUPNPREF("AA",P,F,I)) Q:I=""!(G)  D

 .I '$D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP IPC ABOVE NORM",I)),'$D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP IPC BELOW NORM",I)) Q

 .S ID=0 F  S ID=$O(^AUPNPREF("AA",P,F,I,ID)) Q:ID=""!(G)  D

 ..S D=9999999-ID

 ..Q:D<BDATE

 ..Q:D>EDATE

 ..S X=0 F  S X=$O(^AUPNPREF("AA",P,F,I,ID,X)) Q:X'=+X!(G)  D

 ...;get snomed reason not done and it must be in one of the subsets

 ...S R=$$VALI^XBDIQ1(9000022,X,1.01)  ;SNOMED REASON NOT DONE

 ...I R]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP IPC NOT DONE MED",R)) S G=1 Q

 ...S R=$$VALI^XBDIQ1(9000022,X,.07)

 ...I R="N"!(R="U") S G=1

 I G Q G

 ;MEDS

 S F=50,I=""

 NEW T,T1

 S T=$O(^ATXAX("B","BGP IPC BELOW NORMAL MEDS",0))

 S T1=$O(^ATXAX("B","BGP IPC ABOVE NORMAL MEDS",0))

 F  S I=$O(^AUPNPREF("AA",P,F,I)) Q:I=""!(G)  D

 .I '$D(^ATXAX(T,21,"B",I)),'$D(^ATXAX(T,21,"B",I)) Q

 .S ID=0 F  S ID=$O(^AUPNPREF("AA",P,F,I,ID)) Q:ID=""!(G)  D

 ..S D=9999999-ID

 ..Q:D<BDATE

 ..Q:D>EDATE

 ..S X=0 F  S X=$O(^AUPNPREF("AA",P,F,I,ID,X)) Q:X'=+X!(G)  D

 ...;get snomed reason not done and it must be in one of the subsets

 ...S R=$$VALI^XBDIQ1(9000022,X,1.01)  ;SNOMED REASON NOT DONE

 ...I R]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP IPC NOT DONE MED",R)) S G=1 Q

 I G Q G

 Q ""

ANFU(P,BDATE,EDATE) ;EP

 NEW A,B,C,X,Y,Z,T,V,R,G

 ;is there a dx

 S X=$$LASTDX^BGP8UTL1(P,"BGP IPC ABOVE NORMAL FU DXS",BDATE,EDATE) I X Q 1_U_$P(X,U,3)_U_"DX: "_$P(X,U,2)

 ;now check cpts

 S T=$O(^ATXAX("B","BGP IPC ABOVE NORMAL FU CPTS",0))

 I T D  I X]"" Q 1_U_$P(X,U,1)_U_"CPT: "_$P(X,U,2)

 .S X=$$CPT^BGP8DU(P,BDATE,EDATE,T,5) I X]"" Q

 .S X=$$TRAN^BGP8DU(P,BDATE,EDATE,T,5)

 I X Q X

 ;HOW ABOUT REFERRALS BETWEEN BDATE AND EDATE

 ;GET ALL VISITS

 K BGPV

 S G=""

 D ALLV^APCLAPIU(P,BDATE,EDATE,"BGPV")

 S G=""

 S X=0 F  S X=$O(BGPV(X)) Q:X'=+X!(G)  S Y=$P(BGPV(X),U,5) D

 .Q:'$D(^AUPNVREF("AD",Y))

 .S Z=0 F  S Z=$O(^AUPNVREF("AD",Y,Z)) Q:Z'=+Z!(G)  D

 ..S S=$P($G(^AUPNVREF(Z,0)),U,1) Q:S=""

 ..Q:'$D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP IPC WT ASMT REFER",S))

 ..;NOW GO GET SNOMED REASON

 ..S R=$P($G(^AUPNVREF(Z,0)),U,6)

 ..Q:'R

 ..Q:'$D(^BMCREF(R,0))

 ..S A=0,G="" F  S A=$O(^BMCREF(R,22,"B",A)) Q:A=""!(G)  I $D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP IPC OVERWEIGHT",A)) S G=1_U_$$VD^APCLV(Y)_U_"Refer: "_S_"/"_A

 I G Q G

 S G=""

 D GETMEDS^BGP8UTL2(P,BDATE,EDATE,"BGP IPC ABOVE NORMAL MEDS","",,,.BGPMEDS1,"BGP IPC ABOVE NORMAL RXNORM")

 S X=0,T=0,W="" F  S X=$O(BGPMEDS1(X)) Q:X'=+X!(G)  D

 .S Y=$P(BGPMEDS1(X),U,4)  ;vmed ien

 .S V=$P(BGPMEDS1(X),U,5)

 .Q:'$D(^AUPNVMED(Y,0))

 .Q:$$UP^XLFSTR($P($G(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"

 .S D=$P(^AUPNVMED(Y,0),U,1)  ;drug ien

 .;DAYS SUPPLY MUST BE >0

 .S E=$P(^AUPNVMED(Y,0),U,8) ;date discontinued

 .S S=$P(^AUPNVMED(Y,0),U,7) ;DAYS SUPPLY

 .Q:'S

 .I E,E'>$P(BGPMEDS1(X),U,1) Q  ;at least one day

 .S G=1_U_$$VD^APCLV(V)_U_"Med "_$$VAL^XBDIQ1(9000010.14,Y,.01)

 I G Q G

 ;NOW V POV FOR SNOMED

 ;NOW SNOMED USING ASNC

 S T="PXRM BGP IPC ABOVE NORM"

 S S=0 F  S S=$O(^XTMP("BGPSNOMEDSUBSET",$J,T,S)) Q:S=""!(G)  D

 .Q:'$D(^AUPNVPOV("ASNC",P,S))

 .S D=0 F  S D=$O(^AUPNVPOV("ASNC",P,S,D)) Q:D=""!(G)  D

 ..S Y=9999999-D

 ..Q:Y>EDATE

 ..Q:Y<BDATE

 ..S G=1_U_D_U_"SNOMED: "_S

 I G Q G

 Q ""

BLFU(P,BDATE,EDATE) ;EP

 NEW A,B,C,X,Y,Z,T,V,G

 ;is there a dx

 S X=$$LASTDX^BGP8UTL1(P,"BGP IPC BELOW NORMAL FU DXS",BDATE,EDATE) I X Q 1_U_$P(X,U,3)_U_"DX: "_$P(X,U,2)

 ;now check cpts

 S T=$O(^ATXAX("B","BGP IPC BELOW NORMAL FU CPTS",0))

 I T D  I X]"" Q 1_U_$P(X,U,1)_U_"CPT: "_$P(X,U,2)

 .S X=$$CPT^BGP8DU(P,BDATE,EDATE,T,5) I X]"" Q

 .S X=$$TRAN^BGP8DU(P,BDATE,EDATE,T,5)

 I X Q X

 ;HOW ABOUT REFERRALS BETWEEN BDATE AND EDATE

 ;GET ALL VISITS

 K BGPV

 S G=""

 D ALLV^APCLAPIU(P,BDATE,EDATE,"BGPV")

 S X=0 F  S X=$O(BGPV(X)) Q:X'=+X!(G)  S Y=$P(BGPV(X),U,5) D

 .Q:'$D(^AUPNVREF("AD",Y))

 .S Z=0 F  S Z=$O(^AUPNVREF("AD",Y,Z)) Q:Z'=+Z!(G)  D

 ..S S=$P($G(^AUPNVREF(Z,0)),U,1) Q:S=""

 ..Q:'$D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP IPC WT ASMT REFER",S))

 ..;NOW GO GET SNOMED REASON

 ..S R=$P($G(^AUPNVREF(Z,0)),U,6)

 ..Q:'R

 ..Q:'$D(^BMCREF(R,0))

 ..S A=0 F  S A=$O(^BMCREF(R,22,"B",A)) Q:A=""  I $D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP IPC UNDERWEIGHT",A)) S G=1_U_$$VD^APCLV(Y)_U_"Refer: "_S_"/"_A Q

 I G Q G

 ;NOW MEDS

 S G=""

 D GETMEDS^BGP8UTL2(P,BDATE,EDATE,"BGP IPC BELOW NORMAL MEDS","",,,.BGPMEDS1,"BGP IPC BELOW NORMAL RXNORM")

 S X=0,T=0,W="" F  S X=$O(BGPMEDS1(X)) Q:X'=+X!(G)  D

 .S Y=$P(BGPMEDS1(X),U,4)  ;vmed ien

 .S V=$P(BGPMEDS1(X),U,5)

 .Q:'$D(^AUPNVMED(Y,0))

 .Q:$$UP^XLFSTR($P($G(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"

 .S D=$P(^AUPNVMED(Y,0),U,1)  ;drug ien

 .;DAYS SUPPLY MUST BE >0

 .S E=$P(^AUPNVMED(Y,0),U,8) ;date discontinued

 .S S=$P(^AUPNVMED(Y,0),U,7) ;DAYS SUPPLY

 .Q:'S

 .I E,E'>$P(BGPMEDS1(X),U,1) Q  ;at least one day

 .S G=1_U_$$VD^APCLV(V)_U_"Med "_$$VAL^XBDIQ1(9000010.14,Y,.01)

 I G Q G

 ;NOW V POV FOR SNOMED

 ;NOW SNOMED USING ASNC

 S T="PXRM BGP IPC BELOW NORM"

 S S=0 F  S S=$O(^XTMP("BGPSNOMEDSUBSET",$J,T,S)) Q:S=""!(G)  D

 .Q:'$D(^AUPNVPOV("ASNC",P,S))

 .S D=0 F  S D=$O(^AUPNVPOV("ASNC",P,S,D)) Q:D=""!(G)  D

 ..S Y=9999999-D

 ..Q:Y>EDATE

 ..Q:Y<BDATE

 ..S G=1_U_D_U_"SNOMED: "_S

 I G Q G

 Q ""

TEST ;

 D ^CIMZSUS

 S DFN=13474

 S BGPVALUE=""

 S BGPBDATE=3171001

 S BGPEDATE=3180930

 D BMI

 W !,BGPVALUE

 Q

BGP8PC14  ; IHS/CMI/LAB - measure I2 ; 26 Jul 2018  3:40 PM

 +1       ;;18.1;IHS CLINICAL REPORTING;**1**;MAY 25, 2018;Build 65

 +2       ;

BMI       ;EP - CALLED FROM IPC REPORT

 +1        SET (BGPN1,BGPD1)=0

 +2        SET BGPBMIE=""

           SET BGPBMI=""

           SET BGPFU=""

 +3       ;

 +4       ;

 +5       ;GATHER UP ALL BMI ENC VISITS

 +6       ;Let's check all Visits, looping through once

 +7       ;return variable

           SET G=""

 +8       ;no BMI encounter

           SET BGPBMIE=$$MRBMIE(DFN,BGPBDATE,BGPEDATE)

           IF BGPBMIE=""

               SET BGPSTOP=1

               GOTO BMIE

 +9       ;AGE ON bmi encounter

 +10       SET A=$$AGE^AUPNPAT(DFN,BGPBMIE)

 +11       IF A<18

               SET BGPSTOP=1

               GOTO BMIE

 +12      ;

 +13      ;now what about exclusions?

 +14      ;might as well process exclusions first;

 +15      ;palliative care

 +16       IF $$PALLCARE^BGP8PC13(DFN,$$DOB^AUPNPAT(DFN),BGPBMIE)

               SET BGPSTOP=1

               GOTO BMIE

 +17      ;

 +18      ;pregnancy

 +19       IF $$PREG(DFN,BGPBDATE,BGPEDATE)

               SET BGPSTOP=1

               GOTO BMIE

 +20      ;

 +21      ;REFUSAL ON SAME DAY AS MOST RECENT BMI ENCOUNTER OF BOTH HT/WT

 +22       IF $$REFWTHT(DFN,BGPBMIE)

               SET BGPSTOP=1

               GOTO BMIE

 +23      ;MEDICAL REASON NOT DONE

 +24       IF $$MRND(DFN,$$FMADD^XLFDT(BGPBMIE,-365),$$FMADD^XLFDT(BGPBMIE,-1))

               SET BGPSTOP=1

               GOTO BMIE

 +25      ;FINALLY MADE DENOMINATOR

 +26       SET BGPD1=1

 +27       SET BGPBMI=$$MRBMI(DFN,$$FMADD^XLFDT(BGPBMIE,-365),BGPBMIE)

           IF BGPBMI]""

               SET BGPBMI=$JUSTIFY(BGPBMI,5,2)

 +28       IF BGPBMI'<18.5

               IF BGPBMI<25

                   SET BGPN1=1

                   GOTO BMI1

 +29       IF BGPBMI'<25

               SET BGPFU=$$ANFU(DFN,$$FMADD^XLFDT(BGPBMIE,-365),BGPBMIE)

               IF BGPFU

                   SET BGPN1=1

               GOTO BMI1

 +30       SET BGPFU=$$BLFU(DFN,$$FMADD^XLFDT(BGPBMIE,-365),BGPBMIE)

           IF BGPFU

               SET BGPN1=1

           GOTO BMI1

BMI1      ;

 +1        SET BGPVALUE=""

 +2       ;hit denominator

           SET BGPVALUE="ENC "_$$DATE^BGP8UTL(BGPBMIE)_"|||"

 +3        IF BGPN1

               SET BGPVALUE=BGPVALUE_"*** BMI: "_BGPBMI

               IF BGPFU

                   SET BGPVALUE=BGPVALUE_" F/U PLAN: "_$$DATE^BGP8UTL($PIECE(BGPFU,U,2))_" "_$PIECE(BGPFU,U,3)

 +4        IF 'BGPN1

               SET BGPVALUE=BGPVALUE_$SELECT(BGPBMI:"BMI: "_BGPBMI,1:"")

BMIE      ;

 +1        KILL D,V,X,Y,BGPV,BGPBMI,BGPBMIE,G,BGPFU

 +2        QUIT 

MRBMIE(P,BDATE,EDATE) ;EP  - MOST RECENT BMI ENCOUNTER DURING BDATE TO EDATE

 +1        NEW X,Y,Z,G,BGPV,D,A,B,BGPDO,ID

 +2       ;Let's check all Visits, looping through once

 +3       ;return variable

           SET G=""

 +4       ;get all visits in date range in BGPV

 +5        DO ALLV^APCLAPIU(P,BDATE,EDATE,"BGPV")

 +6       ;REORDER BY DATE

 +7        KILL BGPDO

 +8        SET X=0

           FOR 

               SET X=$ORDER(BGPV(X))

               IF X'=+X

                   QUIT 

               SET V=$PIECE(BGPV(X),U,5)

               SET BGPDO((9999999-$PIECE(BGPV(X),U,1)),V)=""

 +9        SET ID=0

           FOR 

               SET ID=$ORDER(BGPDO(ID))

               IF ID=""!(G)

                   QUIT 

               SET V=0

               FOR 

                   SET V=$ORDER(BGPDO(ID,V))

                   IF V'=+V

                       QUIT 

                   Begin DoDot:1

 +10      ;no dependent entries

                       IF '$PIECE(^AUPNVSIT(V,0),U,9)

                           QUIT 

 +11      ;deleted

                       IF $PIECE(^AUPNVSIT(V,0),U,11)

                           QUIT 

 +12                   SET D=$$VD^APCLV(V)

 +13      ;ITEM 18

                       SET Y=$$BMIENC(V)

                       IF Y]""

                           SET G=D

                           QUIT 

 +14      ;is .17 a cpt we want?

 +15                   SET Y=$$VALI^XBDIQ1(9000010,V,.17)

 +16                   IF Y

                           IF $$BMIECPT(Y)

                               SET G=D

                               QUIT 

 +17      ;now check all V CPTs

 +18                   SET Z=0

                       FOR 

                           SET Z=$ORDER(^AUPNVCPT("AD",V,Z))

                           IF Z'=+Z!(G)

                               QUIT 

                           Begin DoDot:2

 +19                           SET Y=$PIECE($GET(^AUPNVCPT(Z,0)),U,1)

 +20                           IF Y

                                   IF $$BMIECPT(Y)

                                       SET G=D

                                       QUIT 

                           End DoDot:2

 +21                   SET Z=0

                       FOR 

                           SET Z=$ORDER(^AUPNVDEN("AD",V,Z))

                           IF Z'=+Z!(G)

                               QUIT 

                           Begin DoDot:2

 +22                           SET Y=$$VALI^XBDIQ1(9000010.05,Z,.01)

 +23                           SET T=$ORDER(^ATXAX("B","BGP IPC BMI ADA CODES",0))

 +24                           IF $DATA(^ATXAX(T,21,"B",Y))

                                   SET G=D

                                   QUIT 

                           End DoDot:2

                   End DoDot:1

 +25       QUIT G

MRBMI(P,BDATE,EDATE) ;

 +1        NEW X,Y,H,W,BMI

 +2        SET X=$$LASTITEM^BGP8DU(P,BDATE,EDATE,"MEASUREMENT","BMI")

 +3        IF X

               QUIT $PIECE(X,U,4)

 +4       ;get last ht within bdate and edate

 +5        SET X=$$LASTITEM^BGP8DU(P,BDATE,EDATE,"MEASUREMENT","WT")

 +6        IF X=""

               QUIT ""

 +7        SET W=$PIECE(X,U,4)

 +8        SET X=$$LASTITEM^BGP8DU(P,BDATE,EDATE,"MEASUREMENT","HT")

 +9        IF X=""

               QUIT ""

 +10       SET H=$PIECE(X,U,4)

 +11      ;calculate BMI

 +12       SET W=W*.45359

           SET H=(H*.0254)

           SET H=(H*H)

           SET BMI=(W/H)

 +13       QUIT BMI

BMIENC(V) ;EP

 +1        NEW A,B,C

 +2        SET A=0

           SET B=""

 +3        FOR 

               SET A=$ORDER(^AUPNVSIT(V,28,"B",A))

               IF A=""!(B]"")

                   QUIT 

               Begin DoDot:1

 +4                IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM BGP IPC BMI ENC",A))

                       SET B=A

               End DoDot:1

 +5        IF B

               QUIT B

 +6        SET A=0

           SET B=""

 +7        FOR 

               SET A=$ORDER(^AUPNVSIT(V,26,"B",A))

               IF A=""!(B]"")

                   QUIT 

               Begin DoDot:1

 +8                IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM BGP IPC BMI ENC",A))

                       SET B=A

               End DoDot:1

 +9        QUIT B

BMIECPT(C) ;

 +1        IF $$ICD^ATXAPI(C,$ORDER(^ATXAX("B","BGP IPC BMI ENCOUNTER CPTS",0)),1)

               QUIT 1

 +2        IF $$ICD^ATXAPI(C,$ORDER(^ATXAX("B","BGP IPC BMI ADA CPTS",0)),1)

               QUIT 1

 +3        QUIT ""

PREG(P,BDATE,EDATE) ;

 +1        NEW X,Y,Z,G,A

 +2        IF $PIECE(^DPT(P,0),U,2)'="F"

               QUIT ""

 +3       ;check dx

 +4        SET X=$$LASTDX^BGP8UTL1(P,"BGP IPC PREGNANCY CMS69 DXS",BDATE,EDATE)

           IF X

               QUIT 1

 +5        SET T=$ORDER(^ATXAX("B","BGP IPC PREGNANCY CMS69 DXS",0))

 +6        SET (X,G,A)=0

           FOR 

               SET X=$ORDER(^AUPNPROB("AC",P,X))