BGP7D74 ; IHS/CMI/LAB - measure 1,2,3,4 05 Apr 2010 1:44 PM ;
;;17.1;IHS CLINICAL REPORTING;;MAY 10, 2017;Build 29
;
IEFR ;EP
S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7)=0
I BGPAGEB<65 S BGPSTOP=1 Q
S BGPD2=1 ;user pop
I BGPACTCL S BGPD1=1 ;active clinical
I BGPAGEB>64,BGPAGEB<75,BGPD1 S BGPD3=1
I BGPAGEB>74,BGPAGEB<85,BGPD1 S BGPD4=1
I BGPAGEB>84,BGPD1 S BGPD5=1
S BGPVALUE=""
S BGPFREX=$$FALLEX(DFN,BGPBDATE,BGPEDATE)
I BGPFREX S BGPN2=1,BGPVALUE="Screen: "_$P(BGPFREX,U,3)_" "_$P(BGPFREX,U,2)
S BGPDHF=$$DHF(DFN,BGPBDATE,BGPEDATE)
I BGPDHF S BGPN3=1,BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"")_$P(BGPDHF,U,3)_" "_$P(BGPDHF,U,2)
S BGPFID=$$FID(DFN,BGPBDATE,BGPEDATE)
I BGPFID S BGPN4=1,BGPVALUE=BGPVALUE_$S(BGPVALUE]"":";",1:"")_$P(BGPFID,U,3)_" "_$P(BGPFID,U,2)
S BGPAGM=$$AGM(DFN,BGPBDATE,BGPEDATE)
I BGPAGM S BGPN5=1,BGPVALUE=BGPVALUE_$S(BGPVALUE]"":";",1:"")_$P(BGPAGM,U,3)_" "_$P(BGPAGM,U,2)
S BGPREFEX=$$REFFRE(DFN,BGPBDATE,BGPEDATE)
I BGPREFEX S BGPN6=1,BGPVALUE=BGPVALUE_$S(BGPVALUE]"":";",1:"")_$P(BGPREFEX,U,3)_" "_$P(BGPREFEX,U,2)
S BGPVALUE=$S(BGPRTYPE=5:"",1:"UP")_$S(BGPD1:",AC",1:"")_"|||"_BGPVALUE
I BGPN2!(BGPN3)!(BGPN4)!(BGPN5) S BGPN1=1
K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T,BGPG
Q
IEDA ;EP
S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7)=0
K BGPNUMV ;FOR ELDER 20 NUMERATORS
I BGPAGEB<65 S BGPSTOP=1 Q
;v17.0, if hospice indicator then skip
I $$HOSPICE(DFN,BGPBDATE,BGPEDATE) S BGPSTOP=1 Q
S BGPD4=1 ;user pop
I BGPACTCL S BGPD1=1 ;active clinical
I BGPRTYPE=5,'BGPD1 S BGPSTOP=1 Q ;elder only wants active clinical
I BGPD1,BGPSEX="M" S BGPD2=1
I BGPD1,BGPSEX="F" S BGPD3=1
I BGPD4,BGPSEX="M" S BGPD5=1
I BGPD4,BGPSEX="F" S BGPD6=1
I BGPAGEB>64,BGPAGEB<75,BGPD1 S BGPD7=1
I BGPAGEB>74,BGPAGEB<85,BGPD1 S BGPD8=1
I BGPAGEB>84,BGPD1 S BGPD9=1
K BGPMEDS,BGPDAE
D GETDAE(DFN,BGPBDATE,BGPEDATE,.BGPDAE,.BGPNUMV)
S X=0,C=0,J="" F S X=$O(BGPDAE(X)) Q:X'=+X S C=C+1,J=J_$S(J]"":"; ",1:"")_$$DATE^BGP7UTL($P(BGPDAE(X),U,3))_" "_$P(BGPDAE(X),U,2)_" ("_$P(BGPDAE(X),U,4)_")"
I C>0 S BGPN1=1
I C>1 S BGPN2=1
F X=1:1:18 I '$D(BGPNUMV(X)) S BGPNUMV(X)=0
S BGPVALUE="UP"
I BGPRTYPE=3!(BGPRTYPE=5) S BGPVALUE=""
S BGPVALUE=BGPVALUE_$S(BGPD1&(BGPVALUE]""):",AC",BGPD1&(BGPVALUE=""):"AC",1:"")_"|||" I C S BGPVALUE=BGPVALUE_C_" drug"_$S(C>1:"s: ",1:":")_J
K BGPMEDS,BGPMEDS1,J,X,C,Y,BGPDAE
K ^TMP($J,"MEDS")
Q
IBFR ;EP
S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9)=0
S (BGPV2,BGPV3,BGPV4,BGPV5,BGPV6)=""
S BGPADAY=$$FMDIFF^XLFDT(BGPBDATE,$P(^DPT(DFN,0),U,3))
I BGPADAY<30 S BGPSTOP=1 Q
I BGPADAY>394 S BGPSTOP=1 Q
;I 'BGPACTCL S BGPSTOP=1 Q
I BGPACTCL S BGPD1=1
I BGPACTUP S BGPD2=1
K BGPBFR
D GETIFC(DFN,BGPBDATE,BGPEDATE,.BGPBFR)
I $D(BGPBFR) S BGPN1=1 ;has a screening
;n2
D
.S X=37,G="" K Z F S X=$O(BGPBFR(X)) Q:X'=+X!(X>89) S Z($$ABS^XLFMTH(X-60))=X
.Q:'$D(Z)
.S X=$O(Z("")),X=Z(X) ;this is the lowest/closest to 60 days
.S BGPN2=1
.S Y=BGPBFR(X)
.I +Y=1!(+Y=2)!(+Y=6) S BGPN6=1
.S BGPV2="2 MOS: "_X_" DO, "_$$DATE^BGP7UTL($P(Y,U,2))_" "_$$EXTSET^XBFUNC(9000010.44,.01,+Y)
.S G=1
D
.S X=164,G="" K Z F S X=$O(BGPBFR(X)) Q:X'=+X!(X>209) S Z($$ABS^XLFMTH(X-180))=X
.Q:'$D(Z)
.S X=$O(Z("")),X=Z(X) ;this is the lowest/closest to 180 days
.S BGPN3=1
.S Y=BGPBFR(X)
.I +Y=1!(+Y=2)!(+Y=6) S BGPN7=1
.S BGPV3="6 MOS: "_X_" DO, "_$$DATE^BGP7UTL($P(Y,U,2))_" "_$$EXTSET^XBFUNC(9000010.44,.01,+Y)
.S G=1
D
.S X=254,G="" K Z F S X=$O(BGPBFR(X)) Q:X'=+X!(X>299) S Z($$ABS^XLFMTH(X-270))=X
.Q:'$D(Z)
.S X=$O(Z("")),X=Z(X) ;this is the lowest/closest to 270 days
.S BGPN4=1
.S Y=BGPBFR(X)
.I +Y=1!(+Y=2)!(+Y=6) S BGPN8=1
.S BGPV4="9 MOS: "_X_" DO, "_$$DATE^BGP7UTL($P(Y,U,2))_" "_$$EXTSET^XBFUNC(9000010.44,.01,+Y)
.S G=1
D
.S X=349,G="" K Z F S X=$O(BGPBFR(X)) Q:X'=+X!(X>394) S Z($$ABS^XLFMTH(X-365))=X
.Q:'$D(Z)
.S X=$O(Z("")),X=Z(X) ;this is the lowest/closest to 365 days
.S BGPN5=1
.S Y=BGPBFR(X)
.I +Y=1!(+Y=2)!(+Y=6) S BGPN9=1
.S BGPV5="1 YR: "_X_" DO, "_$$DATE^BGP7UTL($P(Y,U,2))_" "_$$EXTSET^XBFUNC(9000010.44,.01,+Y)
.S G=1
S BGPVALUE=$S(BGPN1=1:"Scrn: ",1:"") ;,BGPVALUE=BGPVALUE_$S(BGPV2]""!(BGPV3]"")!(BGPV4]"")!(BGPV5)]"":": ",1:"")
S C=0
I BGPV2]"" S BGPVALUE=BGPVALUE_$S(C=1:"; ",1:"")_BGPV2,C=1
I BGPV3]"" S BGPVALUE=BGPVALUE_$S(C=1:"; ",1:"")_BGPV3,C=1
I BGPV4]"" S BGPVALUE=BGPVALUE_$S(C=1:"; ",1:"")_BGPV4,C=1
I BGPV5]"" S BGPVALUE=BGPVALUE_$S(C=1:"; ",1:"")_BGPV5,C=1
I BGPN1,BGPV2="",BGPV3="",BGPV4="",BGPV5="" D
.S X=$O(BGPBFR("")) S Y=BGPBFR(X) S BGPVALUE="Scrn: "_X_" DO, "_$$DATE^BGP7UTL($P(Y,U,2))_" "_$$EXTSET^XBFUNC(9000010.44,.01,+Y)
S BGPVALUE="UP"_$S(BGPD1:",AC",1:"")_"|||"_BGPVALUE
K BGPV1,BGPV2,BGPV3,BGPV4,BGPV5,BGPV6,BGPBFR
Q
HOSPICE(P,BDATE,EDATE) ;ep hospice
;check for cpt in BGP CPT HOSPICE
I $$CPT^BGP7DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP CPT HOSPICE",0)),5) Q 1
;CHECK V POV FOR SNOMED CODES
NEW S,Y,T,G,D,M,O
S T=$O(^BGPSNOMG("B","HOSPICE CARE",0))
S G=""
S BD=9999999-BDATE
S S=0 F S S=$O(^BGPSNOMG(T,11,"B",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<BDATE
..Q:Y>EDATE
..S G=1
I G Q G
Q ""
GETDAE(P,BDATE,EDATE,BGPRET,BGPRET1) ;EP
;get all meds in all taxonomies
K BGPMEDS,BGPMEDST,BGPRET,BGPRET1
K BGPMEDS1 S BGPXXX="ANTICHOLINERGIC",BGPGOT=0 D GETMEDS^BGP7UTL2(P,BGPBDATE,BGPEDATE,"BGP HEDIS ANTICHOLINERGIC MEDS","BGP HEDIS ANTICHOLINERGIC NDC",,,.BGPMEDS1)
D ADDINMED
I BGPGOT S BGPRET1(1)=1
K BGPMEDS1 S BGPXXX="ANTITHROMBOTIC",BGPGOT=0 D GETMEDS^BGP7UTL2(P,BGPBDATE,BGPEDATE,"BGP HEDIS ANTITHROMBOTIC MEDS","BGP HEDIS ANTITHROMBOTIC NDC",,,.BGPMEDS1)
D ADDINMED
I BGPGOT S BGPRET1(2)=1
K BGPMEDS1 S BGPXXX="ANTI-INFECTIVE",BGPGOT=0 D GETMEDS^BGP7UTL2(P,BGPBDATE,BGPEDATE,"BGP HEDIS ANTI-INFECTIVE MEDS","BGP HEDIS ANTI-INFECTIVE NDC",,,.BGPMEDS1)
D ADDINMED
I BGPGOT S BGPRET1(3)=1
K BGPMEDS1 S BGPXXX="CARDIOVASCULAR",BGPGOT=0 D GETMEDS^BGP7UTL2(P,BGPBDATE,BGPEDATE,"BGP HEDIS CARDIOVASCULAR MEDS","BGP HEDIS CARDIOVASCULAR NDC",,,.BGPMEDS1)
D ADDINMED
I BGPGOT S BGPRET1(4)=1
K BGPMEDS1 S BGPXXX="CENTRAL NERVOUS",BGPGOT=0 D GETMEDS^BGP7UTL2(P,BGPBDATE,BGPEDATE,"BGP HEDIS CENTRAL NERVOUS MEDS","BGP HEDIS CENTRAL NERVOUS NDC",,,.BGPMEDS1)
D ADDINMED
I BGPGOT S BGPRET1(5)=1
K BGPMEDS1 S BGPXXX="ENDOCRINE",BGPGOT=0 D GETMEDS^BGP7UTL2(P,BGPBDATE,BGPEDATE,"BGP HEDIS ENDOCRINE MEDS","BGP HEDIS ENDOCRINE NDC",,,.BGPMEDS1)
D ADDINMED
I BGPGOT S BGPRET1(6)=1
K BGPMEDS1 S BGPXXX="GASTROINTESTINAL",BGPGOT=0 D GETMEDS^BGP7UTL2(P,BGPBDATE,BGPEDATE,"BGP HEDIS GASTROINTESTINAL MED","BGP HEDIS GASTROINTESTINAL NDC",,,.BGPMEDS1)
D ADDINMED
I BGPGOT S BGPRET1(7)=1
K BGPMEDS1 S BGPXXX="PAIN",BGPGOT=0 D GETMEDS^BGP7UTL2(P,BGPBDATE,BGPEDATE,"BGP HEDIS PAIN MEDS","BGP HEDIS PAIN NDC",,,.BGPMEDS1)
D ADDINMED
I BGPGOT S BGPRET1(8)=1
K BGPMEDS1 S BGPXXX="SKL MUSCLE",BGPGOT=0 D GETMEDS^BGP7UTL2(P,BGPBDATE,BGPEDATE,"BGP HEDIS SKL MUSCLE RELAX MED","BGP HEDIS SKL MUSCLE RELAX NDC",,,.BGPMEDS1)
D ADDINMED
I BGPGOT S BGPRET1(9)=1
K BGPMEDS1
Q
ADDINMED ;
I BGPXXX="ANTI-INFECTIVE" D ANTIINF Q
I BGPXXX="CENTRAL NERVOUS" D CENNERV Q
S X=0 F S X=$O(BGPMEDS1(X)) Q:X'=+X D
.S Y=$P(BGPMEDS1(X),U,4) ;vmed ien
.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 $P(BGPRET(D),U)=$P($G(BGPRET(D)),U)+1
.S $P(BGPRET(D),U,2)=$P(^PSDRUG(D,0),U)
.S $P(BGPRET(D),U,3)=$P(BGPMEDS1(X),U,1) ;LAST FILL
.S $P(BGPRET(D),U,4)=BGPXXX
.S BGPGOT=1
.Q
Q
ANTIINF ;
;FOR THIS GROUP DAYS SUPPLY MUST BE AT LEAST 90 DAYS TOTAL
NEW Z,A,T
S X=0,T=0 F S X=$O(BGPMEDS1(X)) Q:X'=+X D
.S Y=$P(BGPMEDS1(X),U,4) ;vmed ien
.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 Z=$P(BGPMEDS1(X),U,1)
.S A=$$FMADD^XLFDT(Z,S)
.I E,E<A S S=$$FMDIFF^XLFDT(E,Z)
.S T=T+S
I T<91 Q
S $P(BGPRET(D),U)=$P($G(BGPRET(D)),U)+1
S $P(BGPRET(D),U,2)=$P(^PSDRUG(D,0),U)
S $P(BGPRET(D),U,3)=Z ;LAST FILL
S $P(BGPRET(D),U,4)=BGPXXX
S BGPGOT=1
Q
CENNERV ;
;FOR THIS GROUP DAYS SUPPLY MUST BE AT LEAST 90 DAYS TOTAL
NEW Z,A,T,T1,T2,X,G,F
S T1=$O(^ATXAX("B","BGP HEDIS NONBENZODIAZ MEDS",0))
S T2=$O(^ATXAX("B","BGP HEDIS NONBENZODIAZ NDC",0))
S X=0,G=0 F S X=$O(BGPMEDS1(X)) Q:X'=+X D
.S Y=$P(BGPMEDS1(X),U,4)
.S D=$P(^AUPNVMED(Y,0),U,1)
.I $D(^ATXAX(T1,21,"B",D)) S G=1 Q
.I $$NDC(D,T2) S G=1 Q
S X=0,T=0 F S X=$O(BGPMEDS1(X)) Q:X'=+X D
.S Y=$P(BGPMEDS1(X),U,4) ;vmed ien
.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 Z=$P(BGPMEDS1(X),U,1)
.S A=$$FMADD^XLFDT(Z,S)
.I E,E<A S S=$$FMDIFF^XLFDT(E,Z)
.S T=T+S
I G,T<91 Q
I T=0 Q
S $P(BGPRET(D),U)=$P($G(BGPRET(D)),U)+1
S $P(BGPRET(D),U,2)=$P(^PSDRUG(D,0),U)
S $P(BGPRET(D),U,3)=Z ;LAST FILL
S $P(BGPRET(D),U,4)=BGPXXX
S BGPGOT=1
Q
GETIFC(P,BDATE,EDATE,BGPRET) ;EP
K BGPRET,BGPG,C,X
S X=0 F S X=$O(^AUPNVIF("AC",P,X)) Q:X'=+X D
.Q:'$D(^AUPNVIF(X))
.S V=$P(^AUPNVIF(X,0),U,3),C=$P(^AUPNVIF(X,0),U,1)
.Q:V=""
.Q:'$D(^AUPNVSIT(V,0))
.S V=$P($P(^AUPNVSIT(V,0),U),".")
.;I V<BDATE Q
.;I V>EDATE Q
.S BGPRET($$FMDIFF^XLFDT(V,$P(^DPT(P,0),U,3)))=C_U_V
.Q
Q
FALLEX(P,BDATE,EDATE) ;EP
NEW %,BGPG,E
K BGPG S %=P_"^LAST EXAM 37;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q 1_"^Ex 37^"_$$DATE^BGP7UTL($P(BGPG(1),U))
S %=$$CPT^BGP7DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP FALL RISK EXAM CPTS",0)),6)
I % Q "1^CPT "_$P(%,U,3)_"^"_$$DATE^BGP7UTL($P(%,U,2))
Q ""
DHF(P,BDATE,EDATE) ;EP
K BGPG
S Y="BGPG("
S X=P_"^LAST DX [BGP HISTORY OF FALL DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(BGPG(1)) Q 1_U_"POV "_$P(BGPG(1),U,2)_U_"Hx of Fall: "_$$DATE^BGP7UTL($P(BGPG(1),U))
Q ""
FID(P,BDATE,EDATE) ;EP
S Y="BGPG("
K BGPG
S X=P_"^ALL DX;DURING "_BDATE_-EDATE S E=$$START1^APCLDF(X,Y)
S G=""
S T=$O(^ATXAX("B","BGP FALL RELATED E-CODES",0))
S X=0 F S X=$O(BGPG(X)) Q:X'=+X!(G) D
.S Y=+$P(BGPG(X),U,4),D=$P(^AUPNVPOV(Y,0),U)
.I $P(^AUPNVPOV(Y,0),U,9)="",$P(^AUPNVPOV(Y,0),U,18)="",$P(^AUPNVPOV(Y,0),U,19)="" Q
.S E=$P(^AUPNVPOV(Y,0),U,9) I E,$$ICD^BGP7UTL2(E,T,9) S G=1_U_"E-CODE "_$P($$ICDDX^BGP7UTL2(E),U,2)_U_"Fall Injury: "_$$DATE^BGP7UTL($P(BGPG(X),U,1)) Q
.S E=$P(^AUPNVPOV(Y,0),U,18) I E,$$ICD^BGP7UTL2(E,T,9) S G=1_U_"E-CODE "_$P($$ICDDX^BGP7UTL2(E),U,2)_U_"Fall Injury: "_$$DATE^BGP7UTL($P(BGPG(X),U,1)) Q
.S E=$P(^AUPNVPOV(Y,0),U,19) I E,$$ICD^BGP7UTL2(E,T,9) S G=1_U_"E-CODE "_$P($$ICDDX^BGP7UTL2(E),U,2)_U_"Fall Injury: "_$$DATE^BGP7UTL($P(BGPG(X),U,1)) Q
I G Q G
Q ""
AGM(P,BDATE,EDATE) ;EP
S BGPG=$$LASTDX^BGP7UTL1(P,"BGP ABNORMAL GAIT OR MOBILITY",BDATE,EDATE)
I $P(BGPG,U) Q 1_U_"POV "_$P(BGPG,U,2)_U_"Abnormal Gait: "_$$DATE^BGP7UTL($P(BGPG,U,3))
Q ""
REFFRE(P,BDATE,EDATE) ;EP
;add Refusal for exam 37
S G=$$REFUSAL^BGP7UTL1(P,9999999.15,$O(^AUTTEXAM("C",37,0)),$$FMADD^XLFDT(EDATE,-365),EDATE)
I $P(G,U)=1 Q 1_"^Ex 37^"_"Refused "_$$DATE^BGP7UTL($P(G,U,2))
Q ""
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
BGP7D74 ; IHS/CMI/LAB - measure 1,2,3,4 05 Apr 2010 1:44 PM ;
+1 ;;17.1;IHS CLINICAL REPORTING;;MAY 10, 2017;Build 29
+2 ;
IEFR ;EP
+1 SET (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
+2 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7)=0
+3 IF BGPAGEB<65
SET BGPSTOP=1
QUIT
+4 ;user pop
SET BGPD2=1
+5 ;active clinical
IF BGPACTCL
SET BGPD1=1
+6 IF BGPAGEB>64
IF BGPAGEB<75
IF BGPD1
SET BGPD3=1
+7 IF BGPAGEB>74
IF BGPAGEB<85
IF BGPD1
SET BGPD4=1
+8 IF BGPAGEB>84
IF BGPD1
SET BGPD5=1
+9 SET BGPVALUE=""
+10 SET BGPFREX=$$FALLEX(DFN,BGPBDATE,BGPEDATE)
+11 IF BGPFREX
SET BGPN2=1
SET BGPVALUE="Screen: "_$PIECE(BGPFREX,U,3)_" "_$PIECE(BGPFREX,U,2)
+12 SET BGPDHF=$$DHF(DFN,BGPBDATE,BGPEDATE)
+13 IF BGPDHF
SET BGPN3=1
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")_$PIECE(BGPDHF,U,3)_" "_$PIECE(BGPDHF,U,2)
+14 SET BGPFID=$$FID(DFN,BGPBDATE,BGPEDATE)
+15 IF BGPFID
SET BGPN4=1
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":";",1:"")_$PIECE(BGPFID,U,3)_" "_$PIECE(BGPFID,U,2)
+16 SET BGPAGM=$$AGM(DFN,BGPBDATE,BGPEDATE)
+17 IF BGPAGM
SET BGPN5=1
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":";",1:"")_$PIECE(BGPAGM,U,3)_" "_$PIECE(BGPAGM,U,2)
+18 SET BGPREFEX=$$REFFRE(DFN,BGPBDATE,BGPEDATE)
+19 IF BGPREFEX
SET BGPN6=1
SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":";",1:"")_$PIECE(BGPREFEX,U,3)_" "_$PIECE(BGPREFEX,U,2)
+20 SET BGPVALUE=$SELECT(BGPRTYPE=5:"",1:"UP")_$SELECT(BGPD1:",AC",1:"")_"|||"_BGPVALUE
+21 IF BGPN2!(BGPN3)!(BGPN4)!(BGPN5)
SET BGPN1=1
+22 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T,BGPG
+23 QUIT
IEDA ;EP
+1 SET (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
+2 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7)=0
+3 ;FOR ELDER 20 NUMERATORS
KILL BGPNUMV
+4 IF BGPAGEB<65
SET BGPSTOP=1
QUIT
+5 ;v17.0, if hospice indicator then skip
+6 IF $$HOSPICE(DFN,BGPBDATE,BGPEDATE)
SET BGPSTOP=1
QUIT
+7 ;user pop
SET BGPD4=1
+8 ;active clinical
IF BGPACTCL
SET BGPD1=1
+9 ;elder only wants active clinical
IF BGPRTYPE=5
IF 'BGPD1
SET BGPSTOP=1
QUIT
+10 IF BGPD1
IF BGPSEX="M"
SET BGPD2=1
+11 IF BGPD1
IF BGPSEX="F"
SET BGPD3=1
+12 IF BGPD4
IF BGPSEX="M"
SET BGPD5=1
+13 IF BGPD4
IF BGPSEX="F"
SET BGPD6=1
+14 IF BGPAGEB>64
IF BGPAGEB<75
IF BGPD1
SET BGPD7=1
+15 IF BGPAGEB>74
IF BGPAGEB<85
IF BGPD1
SET BGPD8=1
+16 IF BGPAGEB>84
IF BGPD1
SET BGPD9=1
+17 KILL BGPMEDS,BGPDAE
+18 DO GETDAE(DFN,BGPBDATE,BGPEDATE,.BGPDAE,.BGPNUMV)
+19 SET X=0
SET C=0
SET J=""
FOR
SET X=$ORDER(BGPDAE(X))
IF X'=+X
QUIT
SET C=C+1
SET J=J_$SELECT(J]"":"; ",1:"")_$$DATE^BGP7UTL($PIECE(BGPDAE(X),U,3))_" "_$PIECE(BGPDAE(X),U,2)_" ("_$PIECE(BGPDAE(X),U,4)_")"
+20 IF C>0
SET BGPN1=1
+21 IF C>1
SET BGPN2=1
+22 FOR X=1:1:18
IF '$DATA(BGPNUMV(X))
SET BGPNUMV(X)=0
+23 SET BGPVALUE="UP"
+24 IF BGPRTYPE=3!(BGPRTYPE=5)
SET BGPVALUE=""
+25 SET BGPVALUE=BGPVALUE_$SELECT(BGPD1&(BGPVALUE]""):",AC",BGPD1&(BGPVALUE=""):"AC",1:"")_"|||"
IF C
SET BGPVALUE=BGPVALUE_C_" drug"_$SELECT(C>1:"s: ",1:":")_J
+26 KILL BGPMEDS,BGPMEDS1,J,X,C,Y,BGPDAE
+27 KILL ^TMP($JOB,"MEDS")
+28 QUIT
IBFR ;EP
+1 SET (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
+2 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9)=0
+3 SET (BGPV2,BGPV3,BGPV4,BGPV5,BGPV6)=""
+4 SET BGPADAY=$$FMDIFF^XLFDT(BGPBDATE,$PIECE(^DPT(DFN,0),U,3))
+5 IF BGPADAY<30
SET BGPSTOP=1
QUIT
+6 IF BGPADAY>394
SET BGPSTOP=1
QUIT
+7 ;I 'BGPACTCL S BGPSTOP=1 Q
+8 IF BGPACTCL
SET BGPD1=1
+9 IF BGPACTUP
SET BGPD2=1
+10 KILL BGPBFR
+11 DO GETIFC(DFN,BGPBDATE,BGPEDATE,.BGPBFR)
+12 ;has a screening
IF $DATA(BGPBFR)
SET BGPN1=1
+13 ;n2
+14 Begin DoDot:1
+15 SET X=37
SET G=""
KILL Z
FOR
SET X=$ORDER(BGPBFR(X))
IF X'=+X!(X>89)
QUIT
SET Z($$ABS^XLFMTH(X-60))=X
+16 IF '$DATA(Z)
QUIT
+17 ;this is the lowest/closest to 60 days
SET X=$ORDER(Z(""))
SET X=Z(X)
+18 SET BGPN2=1
+19 SET Y=BGPBFR(X)
+20 IF +Y=1!(+Y=2)!(+Y=6)
SET BGPN6=1
+21 SET BGPV2="2 MOS: "_X_" DO, "_$$DATE^BGP7UTL($PIECE(Y,U,2))_" "_$$EXTSET^XBFUNC(9000010.44,.01,+Y)
+22 SET G=1
End DoDot:1
+23 Begin DoDot:1
+24 SET X=164
SET G=""
KILL Z
FOR
SET X=$ORDER(BGPBFR(X))
IF X'=+X!(X>209)
QUIT
SET Z($$ABS^XLFMTH(X-180))=X
+25 IF '$DATA(Z)
QUIT
+26 ;this is the lowest/closest to 180 days
SET X=$ORDER(Z(""))
SET X=Z(X)
+27 SET BGPN3=1
+28 SET Y=BGPBFR(X)
+29 IF +Y=1!(+Y=2)!(+Y=6)
SET BGPN7=1
+30 SET BGPV3="6 MOS: "_X_" DO, "_$$DATE^BGP7UTL($PIECE(Y,U,2))_" "_$$EXTSET^XBFUNC(9000010.44,.01,+Y)
+31 SET G=1
End DoDot:1
+32 Begin DoDot:1
+33 SET X=254
SET G=""
KILL Z
FOR
SET X=$ORDER(BGPBFR(X))
IF X'=+X!(X>299)
QUIT
SET Z($$ABS^XLFMTH(X-270))=X
+34 IF '$DATA(Z)
QUIT
+35 ;this is the lowest/closest to 270 days
SET X=$ORDER(Z(""))
SET X=Z(X)
+36 SET BGPN4=1
+37 SET Y=BGPBFR(X)
+38 IF +Y=1!(+Y=2)!(+Y=6)
SET BGPN8=1
+39 SET BGPV4="9 MOS: "_X_" DO, "_$$DATE^BGP7UTL($PIECE(Y,U,2))_" "_$$EXTSET^XBFUNC(9000010.44,.01,+Y)
+40 SET G=1
End DoDot:1
+41 Begin DoDot:1
+42 SET X=349
SET G=""
KILL Z
FOR
SET X=$ORDER(BGPBFR(X))
IF X'=+X!(X>394)
QUIT
SET Z($$ABS^XLFMTH(X-365))=X
+43 IF '$DATA(Z)
QUIT
+44 ;this is the lowest/closest to 365 days
SET X=$ORDER(Z(""))
SET X=Z(X)
+45 SET BGPN5=1
+46 SET Y=BGPBFR(X)
+47 IF +Y=1!(+Y=2)!(+Y=6)
SET BGPN9=1
+48 SET BGPV5="1 YR: "_X_" DO, "_$$DATE^BGP7UTL($PIECE(Y,U,2))_" "_$$EXTSET^XBFUNC(9000010.44,.01,+Y)
+49 SET G=1
End DoDot:1
+50 ;,BGPVALUE=BGPVALUE_$S(BGPV2]""!(BGPV3]"")!(BGPV4]"")!(BGPV5)]"":": ",1:"")
SET BGPVALUE=$SELECT(BGPN1=1:"Scrn: ",1:"")
+51 SET C=0
+52 IF BGPV2]""
SET BGPVALUE=BGPVALUE_$SELECT(C=1:"; ",1:"")_BGPV2
SET C=1
+53 IF BGPV3]""
SET BGPVALUE=BGPVALUE_$SELECT(C=1:"; ",1:"")_BGPV3
SET C=1
+54 IF BGPV4]""
SET BGPVALUE=BGPVALUE_$SELECT(C=1:"; ",1:"")_BGPV4
SET C=1
+55 IF BGPV5]""
SET BGPVALUE=BGPVALUE_$SELECT(C=1:"; ",1:"")_BGPV5
SET C=1
+56 IF BGPN1
IF BGPV2=""
IF BGPV3=""
IF BGPV4=""
IF BGPV5=""
Begin DoDot:1
+57 SET X=$ORDER(BGPBFR(""))
SET Y=BGPBFR(X)
SET BGPVALUE="Scrn: "_X_" DO, "_$$DATE^BGP7UTL($PIECE(Y,U,2))_" "_$$EXTSET^XBFUNC(9000010.44,.01,+Y)
End DoDot:1
+58 SET BGPVALUE="UP"_$SELECT(BGPD1:",AC",1:"")_"|||"_BGPVALUE
+59 KILL BGPV1,BGPV2,BGPV3,BGPV4,BGPV5,BGPV6,BGPBFR
+60 QUIT
HOSPICE(P,BDATE,EDATE) ;ep hospice
+1 ;check for cpt in BGP CPT HOSPICE
+2 IF $$CPT^BGP7DU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP CPT HOSPICE",0)),5)
QUIT 1
+3 ;CHECK V POV FOR SNOMED CODES
+4 NEW S,Y,T,G,D,M,O
+5 SET T=$ORDER(^BGPSNOMG("B","HOSPICE CARE",0))
+6 SET G=""
+7 SET BD=9999999-BDATE
+8 SET S=0
FOR
SET S=$ORDER(^BGPSNOMG(T,11,"B",S))
IF S=""!(G)
QUIT
Begin DoDot:1
+9 IF '$DATA(^AUPNVPOV("ASNC",P,S))
QUIT
+10 SET D=0
FOR
SET D=$ORDER(^AUPNVPOV("ASNC",P,S,D))
IF D=""!(G)
QUIT
Begin DoDot:2
+11 SET Y=9999999-D
+12 IF Y<BDATE
QUIT
+13 IF Y>EDATE
QUIT
+14 SET G=1
End DoDot:2
End DoDot:1
+15 IF G
QUIT G
+16 QUIT ""
GETDAE(P,BDATE,EDATE,BGPRET,BGPRET1) ;EP
+1 ;get all meds in all taxonomies
+2 KILL BGPMEDS,BGPMEDST,BGPRET,BGPRET1
+3 KILL BGPMEDS1
SET BGPXXX="ANTICHOLINERGIC"
SET BGPGOT=0
DO GETMEDS^BGP7UTL2(P,BGPBDATE,BGPEDATE,"BGP HEDIS ANTICHOLINERGIC MEDS","BGP HEDIS ANTICHOLINERGIC NDC",,,.BGPMEDS1)
+4 DO ADDINMED
+5 IF BGPGOT
SET BGPRET1(1)=1
+6 KILL BGPMEDS1
SET BGPXXX="ANTITHROMBOTIC"
SET BGPGOT=0
DO GETMEDS^BGP7UTL2(P,BGPBDATE,BGPEDATE,"BGP HEDIS ANTITHROMBOTIC MEDS","BGP HEDIS ANTITHROMBOTIC NDC",,,.BGPMEDS1)
+7 DO ADDINMED
+8 IF BGPGOT
SET BGPRET1(2)=1
+9 KILL BGPMEDS1
SET BGPXXX="ANTI-INFECTIVE"
SET BGPGOT=0
DO GETMEDS^BGP7UTL2(P,BGPBDATE,BGPEDATE,"BGP HEDIS ANTI-INFECTIVE MEDS","BGP HEDIS ANTI-INFECTIVE NDC",,,.BGPMEDS1)
+10 DO ADDINMED
+11 IF BGPGOT
SET BGPRET1(3)=1
+12 KILL BGPMEDS1
SET BGPXXX="CARDIOVASCULAR"
SET BGPGOT=0
DO GETMEDS^BGP7UTL2(P,BGPBDATE,BGPEDATE,"BGP HEDIS CARDIOVASCULAR MEDS","BGP HEDIS CARDIOVASCULAR NDC",,,.BGPMEDS1)
+13 DO ADDINMED
+14 IF BGPGOT
SET BGPRET1(4)=1
+15 KILL BGPMEDS1
SET BGPXXX="CENTRAL NERVOUS"
SET BGPGOT=0
DO GETMEDS^BGP7UTL2(P,BGPBDATE,BGPEDATE,"BGP HEDIS CENTRAL NERVOUS MEDS","BGP HEDIS CENTRAL NERVOUS NDC",,,.BGPMEDS1)
+16 DO ADDINMED
+17 IF BGPGOT
SET BGPRET1(5)=1
+18 KILL BGPMEDS1
SET BGPXXX="ENDOCRINE"
SET BGPGOT=0
DO GETMEDS^BGP7UTL2(P,BGPBDATE,BGPEDATE,"BGP HEDIS ENDOCRINE MEDS","BGP HEDIS ENDOCRINE NDC",,,.BGPMEDS1)
+19 DO ADDINMED
+20 IF BGPGOT
SET BGPRET1(6)=1
+21 KILL BGPMEDS1
SET BGPXXX="GASTROINTESTINAL"
SET BGPGOT=0
DO GETMEDS^BGP7UTL2(P,BGPBDATE,BGPEDATE,"BGP HEDIS GASTROINTESTINAL MED","BGP HEDIS GASTROINTESTINAL NDC",,,.BGPMEDS1)
+22 DO ADDINMED
+23 IF BGPGOT
SET BGPRET1(7)=1
+24 KILL BGPMEDS1
SET BGPXXX="PAIN"
SET BGPGOT=0
DO GETMEDS^BGP7UTL2(P,BGPBDATE,BGPEDATE,"BGP HEDIS PAIN MEDS","BGP HEDIS PAIN NDC",,,.BGPMEDS1)
+25 DO ADDINMED
+26 IF BGPGOT
SET BGPRET1(8)=1
+27 KILL BGPMEDS1
SET BGPXXX="SKL MUSCLE"
SET BGPGOT=0
DO GETMEDS^BGP7UTL2(P,BGPBDATE,BGPEDATE,"BGP HEDIS SKL MUSCLE RELAX MED","BGP HEDIS SKL MUSCLE RELAX NDC",,,.BGPMEDS1)
+28 DO ADDINMED
+29 IF BGPGOT
SET BGPRET1(9)=1
+30 KILL BGPMEDS1
+31 QUIT
ADDINMED ;
+1 IF BGPXXX="ANTI-INFECTIVE"
DO ANTIINF
QUIT
+2 IF BGPXXX="CENTRAL NERVOUS"
DO CENNERV
QUIT
+3 SET X=0
FOR
SET X=$ORDER(BGPMEDS1(X))
IF X'=+X
QUIT
Begin DoDot:1
+4 ;vmed ien
SET Y=$PIECE(BGPMEDS1(X),U,4)
+5 IF '$DATA(^AUPNVMED(Y,0))
QUIT
+6 IF $$UP^XLFSTR($PIECE($GET(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"
QUIT
+7 ;drug ien
SET D=$PIECE(^AUPNVMED(Y,0),U,1)
+8 ;DAYS SUPPLY MUST BE >0
+9 ;date discontinued
SET E=$PIECE(^AUPNVMED(Y,0),U,8)
+10 ;DAYS SUPPLY
SET S=$PIECE(^AUPNVMED(Y,0),U,7)
+11 IF 'S
QUIT
+12 ;at least one day
IF E
IF E'>$PIECE(BGPMEDS1(X),U,1)
QUIT
+13 SET $PIECE(BGPRET(D),U)=$PIECE($GET(BGPRET(D)),U)+1
+14 SET $PIECE(BGPRET(D),U,2)=$PIECE(^PSDRUG(D,0),U)
+15 ;LAST FILL
SET $PIECE(BGPRET(D),U,3)=$PIECE(BGPMEDS1(X),U,1)
+16 SET $PIECE(BGPRET(D),U,4)=BGPXXX
+17 SET BGPGOT=1
+18 QUIT
End DoDot:1
+19 QUIT
ANTIINF ;
+1 ;FOR THIS GROUP DAYS SUPPLY MUST BE AT LEAST 90 DAYS TOTAL
+2 NEW Z,A,T
+3 SET X=0
SET T=0
FOR
SET X=$ORDER(BGPMEDS1(X))
IF X'=+X
QUIT
Begin DoDot:1
+4 ;vmed ien
SET Y=$PIECE(BGPMEDS1(X),U,4)
+5 IF '$DATA(^AUPNVMED(Y,0))
QUIT
+6 IF $$UP^XLFSTR($PIECE($GET(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"
QUIT
+7 ;drug ien
SET D=$PIECE(^AUPNVMED(Y,0),U,1)
+8 ;DAYS SUPPLY MUST BE >0
+9 ;date discontinued
SET E=$PIECE(^AUPNVMED(Y,0),U,8)
+10 ;DAYS SUPPLY
SET S=$PIECE(^AUPNVMED(Y,0),U,7)
+11 IF 'S
QUIT
+12 ;at least one day
IF E
IF E'>$PIECE(BGPMEDS1(X),U,1)
QUIT
+13 SET Z=$PIECE(BGPMEDS1(X),U,1)
+14 SET A=$$FMADD^XLFDT(Z,S)
+15 IF E
IF E<A
SET S=$$FMDIFF^XLFDT(E,Z)
+16 SET T=T+S
End DoDot:1
+17 IF T<91
QUIT
+18 SET $PIECE(BGPRET(D),U)=$PIECE($GET(BGPRET(D)),U)+1
+19 SET $PIECE(BGPRET(D),U,2)=$PIECE(^PSDRUG(D,0),U)
+20 ;LAST FILL
SET $PIECE(BGPRET(D),U,3)=Z
+21 SET $PIECE(BGPRET(D),U,4)=BGPXXX
+22 SET BGPGOT=1
+23 QUIT
CENNERV ;
+1 ;FOR THIS GROUP DAYS SUPPLY MUST BE AT LEAST 90 DAYS TOTAL
+2 NEW Z,A,T,T1,T2,X,G,F
+3 SET T1=$ORDER(^ATXAX("B","BGP HEDIS NONBENZODIAZ MEDS",0))
+4 SET T2=$ORDER(^ATXAX("B","BGP HEDIS NONBENZODIAZ NDC",0))
+5 SET X=0
SET G=0
FOR
SET X=$ORDER(BGPMEDS1(X))
IF X'=+X
QUIT
Begin DoDot:1
+6 SET Y=$PIECE(BGPMEDS1(X),U,4)
+7 SET D=$PIECE(^AUPNVMED(Y,0),U,1)
+8 IF $DATA(^ATXAX(T1,21,"B",D))
SET G=1
QUIT
+9 IF $$NDC(D,T2)
SET G=1
QUIT
End DoDot:1
+10 SET X=0
SET T=0
FOR
SET X=$ORDER(BGPMEDS1(X))
IF X'=+X
QUIT
Begin DoDot:1
+11 ;vmed ien
SET Y=$PIECE(BGPMEDS1(X),U,4)
+12 IF '$DATA(^AUPNVMED(Y,0))
QUIT
+13 IF $$UP^XLFSTR($PIECE($GET(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"
QUIT
+14 ;drug ien
SET D=$PIECE(^AUPNVMED(Y,0),U,1)
+15 ;DAYS SUPPLY MUST BE >0
+16 ;date discontinued
SET E=$PIECE(^AUPNVMED(Y,0),U,8)
+17 ;DAYS SUPPLY
SET S=$PIECE(^AUPNVMED(Y,0),U,7)
+18 IF 'S
QUIT
+19 ;at least one day
IF E
IF E'>$PIECE(BGPMEDS1(X),U,1)
QUIT
+20 SET Z=$PIECE(BGPMEDS1(X),U,1)
+21 SET A=$$FMADD^XLFDT(Z,S)
+22 IF E
IF E<A
SET S=$$FMDIFF^XLFDT(E,Z)
+23 SET T=T+S
End DoDot:1
+24 IF G
IF T<91
QUIT
+25 IF T=0
QUIT
+26 SET $PIECE(BGPRET(D),U)=$PIECE($GET(BGPRET(D)),U)+1
+27 SET $PIECE(BGPRET(D),U,2)=$PIECE(^PSDRUG(D,0),U)
+28 ;LAST FILL
SET $PIECE(BGPRET(D),U,3)=Z
+29 SET $PIECE(BGPRET(D),U,4)=BGPXXX
+30 SET BGPGOT=1
+31 QUIT
GETIFC(P,BDATE,EDATE,BGPRET) ;EP
+1 KILL BGPRET,BGPG,C,X
+2 SET X=0
FOR
SET X=$ORDER(^AUPNVIF("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+3 IF '$DATA(^AUPNVIF(X))
QUIT
+4 SET V=$PIECE(^AUPNVIF(X,0),U,3)
SET C=$PIECE(^AUPNVIF(X,0),U,1)
+5 IF V=""
QUIT
+6 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+7 SET V=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
+8 ;I V<BDATE Q
+9 ;I V>EDATE Q
+10 SET BGPRET($$FMDIFF^XLFDT(V,$PIECE(^DPT(P,0),U,3)))=C_U_V
+11 QUIT
End DoDot:1
+12 QUIT
FALLEX(P,BDATE,EDATE) ;EP
+1 NEW %,BGPG,E
+2 KILL BGPG
SET %=P_"^LAST EXAM 37;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+3 IF $DATA(BGPG(1))
QUIT 1_"^Ex 37^"_$$DATE^BGP7UTL($PIECE(BGPG(1),U))
+4 SET %=$$CPT^BGP7DU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP FALL RISK EXAM CPTS",0)),6)
+5 IF %
QUIT "1^CPT "_$PIECE(%,U,3)_"^"_$$DATE^BGP7UTL($PIECE(%,U,2))
+6 QUIT ""
DHF(P,BDATE,EDATE) ;EP
+1 KILL BGPG
+2 SET Y="BGPG("
+3 SET X=P_"^LAST DX [BGP HISTORY OF FALL DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+4 IF $DATA(BGPG(1))
QUIT 1_U_"POV "_$PIECE(BGPG(1),U,2)_U_"Hx of Fall: "_$$DATE^BGP7UTL($PIECE(BGPG(1),U))
+5 QUIT ""
FID(P,BDATE,EDATE) ;EP
+1 SET Y="BGPG("
+2 KILL BGPG
+3 SET X=P_"^ALL DX;DURING "_BDATE_-EDATE
SET E=$$START1^APCLDF(X,Y)
+4 SET G=""
+5 SET T=$ORDER(^ATXAX("B","BGP FALL RELATED E-CODES",0))
+6 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+7 SET Y=+$PIECE(BGPG(X),U,4)
SET D=$PIECE(^AUPNVPOV(Y,0),U)
+8 IF $PIECE(^AUPNVPOV(Y,0),U,9)=""
IF $PIECE(^AUPNVPOV(Y,0),U,18)=""
IF $PIECE(^AUPNVPOV(Y,0),U,19)=""
QUIT
+9 SET E=$PIECE(^AUPNVPOV(Y,0),U,9)
IF E
IF $$ICD^BGP7UTL2(E,T,9)
SET G=1_U_"E-CODE "_$PIECE($$ICDDX^BGP7UTL2(E),U,2)_U_"Fall Injury: "_$$DATE^BGP7UTL($PIECE(BGPG(X),U,1))
QUIT
+10 SET E=$PIECE(^AUPNVPOV(Y,0),U,18)
IF E
IF $$ICD^BGP7UTL2(E,T,9)
SET G=1_U_"E-CODE "_$PIECE($$ICDDX^BGP7UTL2(E),U,2)_U_"Fall Injury: "_$$DATE^BGP7UTL($PIECE(BGPG(X),U,1))
QUIT
+11 SET E=$PIECE(^AUPNVPOV(Y,0),U,19)
IF E
IF $$ICD^BGP7UTL2(E,T,9)
SET G=1_U_"E-CODE "_$PIECE($$ICDDX^BGP7UTL2(E),U,2)_U_"Fall Injury: "_$$DATE^BGP7UTL($PIECE(BGPG(X),U,1))
QUIT
End DoDot:1
+12 IF G
QUIT G
+13 QUIT ""
AGM(P,BDATE,EDATE) ;EP
+1 SET BGPG=$$LASTDX^BGP7UTL1(P,"BGP ABNORMAL GAIT OR MOBILITY",BDATE,EDATE)
+2 IF $PIECE(BGPG,U)
QUIT 1_U_"POV "_$PIECE(BGPG,U,2)_U_"Abnormal Gait: "_$$DATE^BGP7UTL($PIECE(BGPG,U,3))
+3 QUIT ""
REFFRE(P,BDATE,EDATE) ;EP
+1 ;add Refusal for exam 37
+2 SET G=$$REFUSAL^BGP7UTL1(P,9999999.15,$ORDER(^AUTTEXAM("C",37,0)),$$FMADD^XLFDT(EDATE,-365),EDATE)
+3 IF $PIECE(G,U)=1
QUIT 1_"^Ex 37^"_"Refused "_$$DATE^BGP7UTL($PIECE(G,U,2))
+4 QUIT ""
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
