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))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+7 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+8 SET A=0
+9 SET D=$PIECE(^AUPNPROB(X,0),U,13)
+10 IF D'<BDATE
IF D'>EDATE
SET A=1
+11 IF A
GOTO PREGN
+12 ;I D Q ;had a doo and it didn't match
+13 IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+14 IF $PIECE(^AUPNPROB(X,0),U,8)<BDATE
QUIT
PREGN IF $$ICD^ATXAPI($PIECE(^AUPNPROB(X,0),U,1),T,9)
SET G=1
QUIT
+1 SET S=$$VAL^XBDIQ1(9000011,X,80001)
+2 IF S]""
IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM BGP IPC PREGNANCY BMI",S))
SET G=1
QUIT
End DoDot:1
+3 QUIT G
REFWTHT(P,BDATE) ;
+1 NEW F,G,I,ID,C,X,D,H,W,R
+2 SET G=0
+3 SET F=9999999.07
SET I=$ORDER(^AUTTMSR("B","BMI",0))
+4 SET ID=0
FOR
SET ID=$ORDER(^AUPNPREF("AA",P,F,I,ID))
IF ID=""!(G)
QUIT
Begin DoDot:1
+5 SET D=9999999-ID
+6 IF D'=BDATE
QUIT
+7 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,F,I,ID,X))
IF X'=+X!(G)
QUIT
Begin DoDot:2
+8 ;get snomed reason not done and it must be in one of the subsets
+9 ;SNOMED REASON NOT DONE
SET R=$$VALI^XBDIQ1(9000022,X,1.01)
+10 IF R]""
IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM BGP IPC NOT DONE PAT",R))
SET G=1
QUIT
+11 SET R=$$VALI^XBDIQ1(9000022,X,.07)
+12 IF R="R"!(R="N")!(R="U")
SET G=1
QUIT
End DoDot:2
End DoDot:1
+13 IF G
QUIT G
+14 ;now check for WT or HT
+15 SET (W,H)=""
+16 SET F=9999999.07
SET I=$ORDER(^AUTTMSR("B","WT",0))
+17 SET ID=0
FOR
SET ID=$ORDER(^AUPNPREF("AA",P,F,I,ID))
IF ID=""!(W)
QUIT
Begin DoDot:1
+18 SET D=9999999-ID
+19 IF D'=BDATE
QUIT
+20 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,F,I,ID,X))
IF X'=+X!(W)
QUIT
Begin DoDot:2
+21 SET R=$$VALI^XBDIQ1(9000022,X,.07)
+22 IF R="R"!(R="N")!(R="U")
SET W=1
End DoDot:2
End DoDot:1
+23 IF W
QUIT 1
+24 SET F=9999999.07
SET I=$ORDER(^AUTTMSR("B","HT",0))
+25 SET ID=0
FOR
SET ID=$ORDER(^AUPNPREF("AA",P,F,I,ID))
IF ID=""!(H)
QUIT
Begin DoDot:1
+26 SET D=9999999-ID
+27 IF D'=BDATE
QUIT
+28 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,F,I,ID,X))
IF X'=+X!(H)
QUIT
Begin DoDot:2
+29 SET R=$$VALI^XBDIQ1(9000022,X,.07)
+30 IF R="R"!(R="N")!(R="U")
SET H=1
End DoDot:2
End DoDot:1
+31 IF H
QUIT 1
+32 QUIT ""
MRND(P,BDATE,EDATE) ;EP
+1 NEW F,G,I,ID,C,X,D,H,W,R
+2 SET G=0
+3 SET F=81
SET I=""
+4 FOR
SET I=$ORDER(^AUPNPREF("AA",P,F,I))
IF I=""!(G)
QUIT
Begin DoDot:1
+5 IF '$$ICD^BGP8UTL2(I,$ORDER(^ATXAX("B","BGP IPC ABOVE NORMAL FU CPTS",0)),1)
IF '$$ICD^BGP8UTL2(I,$ORDER(^ATXAX("B","BGP IPC BELOW NORMAL FU CPTS",0)),1)
QUIT
+6 SET ID=0
FOR
SET ID=$ORDER(^AUPNPREF("AA",P,F,I,ID))
IF ID=""!(G)
QUIT
Begin DoDot:2
+7 SET D=9999999-ID
+8 IF D<BDATE
QUIT
+9 IF D>EDATE
QUIT
+10 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,F,I,ID,X))
IF X'=+X!(G)
QUIT
Begin DoDot:3
+11 ;get snomed reason not done and it must be in one of the subsets
+12 ;SNOMED REASON NOT DONE
SET R=$$VALI^XBDIQ1(9000022,X,1.01)
+13 IF R]""
IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM BGP IPC NOT DONE MED",R))
SET G=1
QUIT
+14 SET R=$$VALI^XBDIQ1(9000022,X,.07)
+15 IF R="N"!(R="U")
SET G=1
End DoDot:3
End DoDot:2
End DoDot:1
+16 IF G
QUIT G
+17 SET F=9002318.4
SET I=""
+18 FOR
SET I=$ORDER(^AUPNPREF("AA",P,F,I))
IF I=""!(G)
QUIT
Begin DoDot:1
+19 IF '$DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM BGP IPC ABOVE NORM",I))
IF '$DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM BGP IPC BELOW NORM",I))
QUIT
+20 SET ID=0
FOR
SET ID=$ORDER(^AUPNPREF("AA",P,F,I,ID))
IF ID=""!(G)
QUIT
Begin DoDot:2
+21 SET D=9999999-ID
+22 IF D<BDATE
QUIT
+23 IF D>EDATE
QUIT
+24 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,F,I,ID,X))
IF X'=+X!(G)
QUIT
Begin DoDot:3
+25 ;get snomed reason not done and it must be in one of the subsets
+26 ;SNOMED REASON NOT DONE
SET R=$$VALI^XBDIQ1(9000022,X,1.01)
+27 IF R]""
IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM BGP IPC NOT DONE MED",R))
SET G=1
QUIT
+28 SET R=$$VALI^XBDIQ1(9000022,X,.07)
+29 IF R="N"!(R="U")
SET G=1
End DoDot:3
End DoDot:2
End DoDot:1
+30 IF G
QUIT G
+31 ;MEDS
+32 SET F=50
SET I=""
+33 NEW T,T1
+34 SET T=$ORDER(^ATXAX("B","BGP IPC BELOW NORMAL MEDS",0))
+35 SET T1=$ORDER(^ATXAX("B","BGP IPC ABOVE NORMAL MEDS",0))
+36 FOR
SET I=$ORDER(^AUPNPREF("AA",P,F,I))
IF I=""!(G)
QUIT
Begin DoDot:1
+37 IF '$DATA(^ATXAX(T,21,"B",I))
IF '$DATA(^ATXAX(T,21,"B",I))
QUIT
+38 SET ID=0
FOR
SET ID=$ORDER(^AUPNPREF("AA",P,F,I,ID))
IF ID=""!(G)
QUIT
Begin DoDot:2
+39 SET D=9999999-ID
+40 IF D<BDATE
QUIT
+41 IF D>EDATE
QUIT
+42 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,F,I,ID,X))
IF X'=+X!(G)
QUIT
Begin DoDot:3
+43 ;get snomed reason not done and it must be in one of the subsets
+44 ;SNOMED REASON NOT DONE
SET R=$$VALI^XBDIQ1(9000022,X,1.01)
+45 IF R]""
IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM BGP IPC NOT DONE MED",R))
SET G=1
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+46 IF G
QUIT G
+47 QUIT ""
ANFU(P,BDATE,EDATE) ;EP
+1 NEW A,B,C,X,Y,Z,T,V,R,G
+2 ;is there a dx
+3 SET X=$$LASTDX^BGP8UTL1(P,"BGP IPC ABOVE NORMAL FU DXS",BDATE,EDATE)
IF X
QUIT 1_U_$PIECE(X,U,3)_U_"DX: "_$PIECE(X,U,2)
+4 ;now check cpts
+5 SET T=$ORDER(^ATXAX("B","BGP IPC ABOVE NORMAL FU CPTS",0))
+6 IF T
Begin DoDot:1
+7 SET X=$$CPT^BGP8DU(P,BDATE,EDATE,T,5)
IF X]""
QUIT
+8 SET X=$$TRAN^BGP8DU(P,BDATE,EDATE,T,5)
End DoDot:1
IF X]""
QUIT 1_U_$PIECE(X,U,1)_U_"CPT: "_$PIECE(X,U,2)
+9 IF X
QUIT X
+10 ;HOW ABOUT REFERRALS BETWEEN BDATE AND EDATE
+11 ;GET ALL VISITS
+12 KILL BGPV
+13 SET G=""
+14 DO ALLV^APCLAPIU(P,BDATE,EDATE,"BGPV")
+15 SET G=""
+16 SET X=0
FOR
SET X=$ORDER(BGPV(X))
IF X'=+X!(G)
QUIT
SET Y=$PIECE(BGPV(X),U,5)
Begin DoDot:1
+17 IF '$DATA(^AUPNVREF("AD",Y))
QUIT
+18 SET Z=0
FOR
SET Z=$ORDER(^AUPNVREF("AD",Y,Z))
IF Z'=+Z!(G)
QUIT
Begin DoDot:2
+19 SET S=$PIECE($GET(^AUPNVREF(Z,0)),U,1)
IF S=""
QUIT
+20 IF '$DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM BGP IPC WT ASMT REFER",S))
QUIT
+21 ;NOW GO GET SNOMED REASON
+22 SET R=$PIECE($GET(^AUPNVREF(Z,0)),U,6)
+23 IF 'R
QUIT
+24 IF '$DATA(^BMCREF(R,0))
QUIT
+25 SET A=0
SET G=""
FOR
SET A=$ORDER(^BMCREF(R,22,"B",A))
IF A=""!(G)
QUIT
IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM BGP IPC OVERWEIGHT",A))
SET G=1_U_$$VD^APCLV(Y)_U_"Refer: "_S_"/"_A
End DoDot:2
End DoDot:1
+26 IF G
QUIT G
+27 SET G=""
+28 DO GETMEDS^BGP8UTL2(P,BDATE,EDATE,"BGP IPC ABOVE NORMAL MEDS","",,,.BGPMEDS1,"BGP IPC ABOVE NORMAL RXNORM")
+29 SET X=0
SET T=0
SET W=""
FOR
SET X=$ORDER(BGPMEDS1(X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+30 ;vmed ien
SET Y=$PIECE(BGPMEDS1(X),U,4)
+31 SET V=$PIECE(BGPMEDS1(X),U,5)
+32 IF '$DATA(^AUPNVMED(Y,0))
QUIT
+33 IF $$UP^XLFSTR($PIECE($GET(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"
QUIT
+34 ;drug ien
SET D=$PIECE(^AUPNVMED(Y,0),U,1)
+35 ;DAYS SUPPLY MUST BE >0
+36 ;date discontinued
SET E=$PIECE(^AUPNVMED(Y,0),U,8)
+37 ;DAYS SUPPLY
SET S=$PIECE(^AUPNVMED(Y,0),U,7)
+38 IF 'S
QUIT
+39 ;at least one day
IF E
IF E'>$PIECE(BGPMEDS1(X),U,1)
QUIT
+40 SET G=1_U_$$VD^APCLV(V)_U_"Med "_$$VAL^XBDIQ1(9000010.14,Y,.01)
End DoDot:1
+41 IF G
QUIT G
+42 ;NOW V POV FOR SNOMED
+43 ;NOW SNOMED USING ASNC
+44 SET T="PXRM BGP IPC ABOVE NORM"
+45 SET S=0
FOR
SET S=$ORDER(^XTMP("BGPSNOMEDSUBSET",$JOB,T,S))
IF S=""!(G)
QUIT
Begin DoDot:1
+46 IF '$DATA(^AUPNVPOV("ASNC",P,S))
QUIT
+47 SET D=0
FOR
SET D=$ORDER(^AUPNVPOV("ASNC",P,S,D))
IF D=""!(G)
QUIT
Begin DoDot:2
+48 SET Y=9999999-D
+49 IF Y>EDATE
QUIT
+50 IF Y<BDATE
QUIT
+51 SET G=1_U_D_U_"SNOMED: "_S
End DoDot:2
End DoDot:1
+52 IF G
QUIT G
+53 QUIT ""
BLFU(P,BDATE,EDATE) ;EP
+1 NEW A,B,C,X,Y,Z,T,V,G
+2 ;is there a dx
+3 SET X=$$LASTDX^BGP8UTL1(P,"BGP IPC BELOW NORMAL FU DXS",BDATE,EDATE)
IF X
QUIT 1_U_$PIECE(X,U,3)_U_"DX: "_$PIECE(X,U,2)
+4 ;now check cpts
+5 SET T=$ORDER(^ATXAX("B","BGP IPC BELOW NORMAL FU CPTS",0))
+6 IF T
Begin DoDot:1
+7 SET X=$$CPT^BGP8DU(P,BDATE,EDATE,T,5)
IF X]""
QUIT
+8 SET X=$$TRAN^BGP8DU(P,BDATE,EDATE,T,5)
End DoDot:1
IF X]""
QUIT 1_U_$PIECE(X,U,1)_U_"CPT: "_$PIECE(X,U,2)
+9 IF X
QUIT X
+10 ;HOW ABOUT REFERRALS BETWEEN BDATE AND EDATE
+11 ;GET ALL VISITS
+12 KILL BGPV
+13 SET G=""
+14 DO ALLV^APCLAPIU(P,BDATE,EDATE,"BGPV")
+15 SET X=0
FOR
SET X=$ORDER(BGPV(X))
IF X'=+X!(G)
QUIT
SET Y=$PIECE(BGPV(X),U,5)
Begin DoDot:1
+16 IF '$DATA(^AUPNVREF("AD",Y))
QUIT
+17 SET Z=0
FOR
SET Z=$ORDER(^AUPNVREF("AD",Y,Z))
IF Z'=+Z!(G)
QUIT
Begin DoDot:2
+18 SET S=$PIECE($GET(^AUPNVREF(Z,0)),U,1)
IF S=""
QUIT
+19 IF '$DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM BGP IPC WT ASMT REFER",S))
QUIT
+20 ;NOW GO GET SNOMED REASON
+21 SET R=$PIECE($GET(^AUPNVREF(Z,0)),U,6)
+22 IF 'R
QUIT
+23 IF '$DATA(^BMCREF(R,0))
QUIT
+24 SET A=0
FOR
SET A=$ORDER(^BMCREF(R,22,"B",A))
IF A=""
QUIT
IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM BGP IPC UNDERWEIGHT",A))
SET G=1_U_$$VD^APCLV(Y)_U_"Refer: "_S_"/"_A
QUIT
End DoDot:2
End DoDot:1
+25 IF G
QUIT G
+26 ;NOW MEDS
+27 SET G=""
+28 DO GETMEDS^BGP8UTL2(P,BDATE,EDATE,"BGP IPC BELOW NORMAL MEDS","",,,.BGPMEDS1,"BGP IPC BELOW NORMAL RXNORM")
+29 SET X=0
SET T=0
SET W=""
FOR
SET X=$ORDER(BGPMEDS1(X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+30 ;vmed ien
SET Y=$PIECE(BGPMEDS1(X),U,4)
+31 SET V=$PIECE(BGPMEDS1(X),U,5)
+32 IF '$DATA(^AUPNVMED(Y,0))
QUIT
+33 IF $$UP^XLFSTR($PIECE($GET(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"
QUIT
+34 ;drug ien
SET D=$PIECE(^AUPNVMED(Y,0),U,1)
+35 ;DAYS SUPPLY MUST BE >0
+36 ;date discontinued
SET E=$PIECE(^AUPNVMED(Y,0),U,8)
+37 ;DAYS SUPPLY
SET S=$PIECE(^AUPNVMED(Y,0),U,7)
+38 IF 'S
QUIT
+39 ;at least one day
IF E
IF E'>$PIECE(BGPMEDS1(X),U,1)
QUIT
+40 SET G=1_U_$$VD^APCLV(V)_U_"Med "_$$VAL^XBDIQ1(9000010.14,Y,.01)
End DoDot:1
+41 IF G
QUIT G
+42 ;NOW V POV FOR SNOMED
+43 ;NOW SNOMED USING ASNC
+44 SET T="PXRM BGP IPC BELOW NORM"
+45 SET S=0
FOR
SET S=$ORDER(^XTMP("BGPSNOMEDSUBSET",$JOB,T,S))
IF S=""!(G)
QUIT
Begin DoDot:1
+46 IF '$DATA(^AUPNVPOV("ASNC",P,S))
QUIT
+47 SET D=0
FOR
SET D=$ORDER(^AUPNVPOV("ASNC",P,S,D))
IF D=""!(G)
QUIT
Begin DoDot:2
+48 SET Y=9999999-D
+49 IF Y>EDATE
QUIT
+50 IF Y<BDATE
QUIT
+51 SET G=1_U_D_U_"SNOMED: "_S
End DoDot:2
End DoDot:1
+52 IF G
QUIT G
+53 QUIT ""
TEST ;
+1 DO ^CIMZSUS
+2 SET DFN=13474
+3 SET BGPVALUE=""
+4 SET BGPBDATE=3171001
+5 SET BGPEDATE=3180930
+6 DO BMI
+7 WRITE !,BGPVALUE
+8 QUIT
