BGP1D74 ; IHS/CMI/LAB - measure 1,2,3,4 05 Apr 2010 1:44 PM ;
;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
;
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,3)
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
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^BGP1UTL($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:",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
S BGPD1=1
K BGPBFR
D GETIFC(DFN,BGPBDATE,BGPEDATE,.BGPBFR)
I $D(BGPBFR) S BGPN1=1 ;has a screening
;n2
D
.S X=44,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) S BGPN6=1
.S BGPV2="2 MOS: "_X_" DO, "_$$DATE^BGP1UTL($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) S BGPN7=1
.S BGPV3="6 MOS: "_X_" DO, "_$$DATE^BGP1UTL($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) S BGPN8=1
.S BGPV4="9 MOS: "_X_" DO, "_$$DATE^BGP1UTL($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) S BGPN9=1
.S BGPV5="1 YR: "_X_" DO, "_$$DATE^BGP1UTL($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
S BGPVALUE="AC|||"_BGPVALUE
K BGPV1,BGPV2,BGPV3,BGPV4,BGPV5,BGPV6,BGPBFR
Q
GETDAE(P,BDATE,EDATE,BGPRET,BGPRET1) ;EP
;get all meds in all taxonomies
K BGPMEDS,BGPMEDST,BGPRET,BGPRET1
K BGPMEDS1 S BGPXXX="ANTIANXIETY",BGPGOT=0 D GETMEDS^BGP1UTL2(P,BGPBDATE,BGPEDATE,"BGP HEDIS ANTIANXIETY MEDS","BGP HEDIS ANTIANXIETY NDC",,,.BGPMEDS1)
D ADDINMED
I BGPGOT S BGPRET1(1)=1
K BGPMEDS1 S BGPXXX="ANTIEMETIC",BGPGOT=0 D GETMEDS^BGP1UTL2(P,BGPBDATE,BGPEDATE,"BGP HEDIS ANTIEMETIC MEDS","BGP HEDIS ANTIEMETIC NDC",,,.BGPMEDS1)
D ADDINMED
I BGPGOT S BGPRET1(2)=1
K BGPMEDS1 S BGPXXX="ANALGESIC",BGPGOT=0 D GETMEDS^BGP1UTL2(P,BGPBDATE,BGPEDATE,"BGP HEDIS ANALGESIC MEDS","BGP HEDIS ANALGESIC NDC",,,.BGPMEDS1)
D ADDINMED
I BGPGOT S BGPRET1(3)=1
K BGPMEDS1 S BGPXXX="ANTIHISTAMINE",BGPGOT=0 D GETMEDS^BGP1UTL2(P,BGPBDATE,BGPEDATE,"BGP HEDIS ANTIHISTAMINE MEDS","BGP HEDIS ANTIHISTAMINE NDC",,,.BGPMEDS1)
D ADDINMED
I BGPGOT S BGPRET1(4)=1
K BGPMEDS1 S BGPXXX=" ANTIPSYCHOTIC",BGPGOT=0 D GETMEDS^BGP1UTL2(P,BGPBDATE,BGPEDATE,"BGP HEDIS ANTIPSYCHOTIC MEDS","BGP HEDIS ANTIPSYCHOTIC NDC",,,.BGPMEDS1)
D ADDINMED
I BGPGOT S BGPRET1(5)=1
K BGPMEDS1 S BGPXXX="AMPHETAMINE",BGPGOT=0 D GETMEDS^BGP1UTL2(P,BGPBDATE,BGPEDATE,"BGP HEDIS AMPHETAMINE MEDS","BGP HEDIS AMPHETAMINE NDC",,,.BGPMEDS1)
D ADDINMED
I BGPGOT S BGPRET1(6)=1
K BGPMEDS1 S BGPXXX="BARBITURATE",BGPGOT=0 D GETMEDS^BGP1UTL2(P,BGPBDATE,BGPEDATE,"BGP HEDIS BARBITURATE MEDS","BGP HEDIS BARBITURATE NDC",,,.BGPMEDS1)
D ADDINMED
I BGPGOT S BGPRET1(7)=1
K BGPMEDS1 S BGPXXX="BENZODIAZEPINE",BGPGOT=0 D GETMEDS^BGP1UTL2(P,BGPBDATE,BGPEDATE,"BGP HEDIS BENZODIAZEPINE MEDS","BGP HEDIS BENZODIAZEPINE NDC",,,.BGPMEDS1)
D ADDINMED
I BGPGOT S BGPRET1(8)=1
;K BGPMEDS1 S BGPXXX="OTHER BENZODIAZEPNE",BGPGOT=0 D GETMEDS^BGP1UTL2(P,BGPBDATE,BGPEDATE,"BGP HEDIS OTHER BENZODIAZEPINE","BGP HEDIS OTHER BENZO NDC",,,.BGPMEDS1)
;D ADDINMED
;I BGPGOT S BGPRET1(9)=1
K BGPMEDS1 S BGPXXX="CALCIUM CHANNEL",BGPGOT=0 D GETMEDS^BGP1UTL2(P,BGPBDATE,BGPEDATE,"BGP HEDIS CALCIUM CHANNEL MEDS","BGP HEDIS CALCIUM CHANNEL NDC",,,.BGPMEDS1)
D ADDINMED
I BGPGOT S BGPRET1(10)=1
K BGPMEDS1 S BGPXXX="GASTRO ANTISPASM",BGPGOT=0 D GETMEDS^BGP1UTL2(P,BGPBDATE,BGPEDATE,"BGP HEDIS GASTRO ANTISPASM MED","BGP HEDIS GASTRO ANTISPASM NDC",,,.BGPMEDS1)
D ADDINMED
I BGPGOT S BGPRET1(11)=1
K BGPMEDS1 S BGPXXX="BELLADONNA",BGPGOT=0 D GETMEDS^BGP1UTL2(P,BGPBDATE,BGPEDATE,"BGP HEDIS BELLADONNA ALKA MEDS","BGP HEDIS BELLADONNA ALKA NDC",,,.BGPMEDS1)
D ADDINMED
I BGPGOT S BGPRET1(12)=1
K BGPMEDS1 S BGPXXX="SKL MUSCLE",BGPGOT=0 D GETMEDS^BGP1UTL2(P,BGPBDATE,BGPEDATE,"BGP HEDIS SKL MUSCLE RELAX MED","BGP HEDIS SKL MUSCLE RELAX NDC",,,.BGPMEDS1)
D ADDINMED
I BGPGOT S BGPRET1(13)=1
K BGPMEDS1 S BGPXXX="ORAL ESTROGEN",BGPGOT=0 D GETMEDS^BGP1UTL2(P,BGPBDATE,BGPEDATE,"BGP HEDIS ORAL ESTROGEN MEDS","BGP HEDIS ORAL ESTROGEN NDC",,,.BGPMEDS1)
D ADDINMED
I BGPGOT S BGPRET1(14)=1
K BGPMEDS1 S BGPXXX="ORAL HYPOGLYCEMIC",BGPGOT=0 D GETMEDS^BGP1UTL2(P,BGPBDATE,BGPEDATE,"BGP HEDIS ORAL HYPOGLYCEMIC RX","BGP HEDIS ORAL HYPOGLYCEMIC ND",,,.BGPMEDS1)
D ADDINMED
I BGPGOT S BGPRET1(15)=1
K BGPMEDS1 S BGPXXX="NARCOTIC",BGPGOT=0 D GETMEDS^BGP1UTL2(P,BGPBDATE,BGPEDATE,"BGP HEDIS NARCOTIC MEDS","BGP HEDIS NARCOTIC NDC",,,.BGPMEDS1)
D ADDINMED
I BGPGOT S BGPRET1(16)=1
K BGPMEDS1 S BGPXXX="VASODILATOR",BGPGOT=0 D GETMEDS^BGP1UTL2(P,BGPBDATE,BGPEDATE,"BGP HEDIS VASODILATOR MEDS","BGP HEDIS VASODILATOR NDC",,,.BGPMEDS1)
D ADDINMED
I BGPGOT S BGPRET1(17)=1
K BGPMEDS1 S BGPXXX="OTHER MEDS",BGPGOT=0 D GETMEDS^BGP1UTL2(P,BGPBDATE,BGPEDATE,"BGP HEDIS OTHER MEDS AVOID ELD","BGP HEDIS OTHER NDC AVOID ELD",,,.BGPMEDS1)
D ADDINMED
I BGPGOT S BGPRET1(18)=1
K BGPMEDS1
Q
ADDINMED ;
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
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_"^Exam 37^"_$$DATE^BGP1UTL($P(BGPG(1),U))
S %=$$CPT^BGP1DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP FALL RISK EXAM CPTS",0)),6)
I % Q "1^CPT "_$P(%,U,3)_"^"_$$DATE^BGP1UTL($P(%,U,2))
Q ""
DHF(P,BDATE,EDATE) ;EP
K BGPG
S Y="BGPG("
S X=P_"^LAST DX V15.88;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(BGPG(1)) Q 1_U_$P(BGPG(1),U,2)_U_"Hx of Fall: "_$$DATE^BGP1UTL($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^ATXCHK(E,T,9) S G=1_U_U_$$DATE^BGP1UTL($P(BGPG(X),U,1)) Q
.S E=$P(^AUPNVPOV(Y,0),U,18) I E,$$ICD^ATXCHK(E,T,9) S G=1_U_$P($$ICDDX^ICDCODE(E),U,2)_U_"Fall Injury: "_$$DATE^BGP1UTL($P(BGPG(X),U,1)) Q
.S E=$P(^AUPNVPOV(Y,0),U,19) I E,$$ICD^ATXCHK(E,T,9) S G=1_U_$P($$ICDDX^ICDCODE(E),U,2)_U_"Fall Injury: "_$$DATE^BGP1UTL($P(BGPG(X),U,1)) Q
I G Q G
Q ""
AGM(P,BDATE,EDATE) ;EP
S BGPG=$$LASTDX^BGP1UTL1(P,"BGP ABNORMAL GAIT OR MOBILITY",BDATE,EDATE)
I $P(BGPG,U) Q 1_U_$P(BGPG,U,2)_U_"Abnormal Gait: "_$$DATE^BGP1UTL($P(BGPG,U,3))
Q ""
REFFRE(P,BDATE,EDATE) ;EP
;add refusal for exam 37
S G=$$REFUSAL^BGP1UTL1(P,9999999.15,$O(^AUTTEXAM("C",37,0)),$$FMADD^XLFDT(EDATE,-365),EDATE)
I $P(G,U)=1 Q 1_"^exam 37^"_"Refused: "_$$DATE^BGP1UTL($P(G,U,2))
Q ""
BGP1D74 ; IHS/CMI/LAB - measure 1,2,3,4 05 Apr 2010 1:44 PM ;
+1 ;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
+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,3)
+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 ;user pop
SET BGPD4=1
+6 ;active clinical
IF BGPACTCL
SET BGPD1=1
+7 ;elder only wants active clinical
IF BGPRTYPE=5
IF 'BGPD1
SET BGPSTOP=1
QUIT
+8 IF BGPD1
IF BGPSEX="M"
SET BGPD2=1
+9 IF BGPD1
IF BGPSEX="F"
SET BGPD3=1
+10 IF BGPD4
IF BGPSEX="M"
SET BGPD5=1
+11 IF BGPD4
IF BGPSEX="F"
SET BGPD6=1
+12 IF BGPAGEB>64
IF BGPAGEB<75
IF BGPD1
SET BGPD7=1
+13 IF BGPAGEB>74
IF BGPAGEB<85
IF BGPD1
SET BGPD8=1
+14 IF BGPAGEB>84
IF BGPD1
SET BGPD9=1
+15 KILL BGPMEDS,BGPDAE
+16 DO GETDAE(DFN,BGPBDATE,BGPEDATE,.BGPDAE,.BGPNUMV)
+17 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^BGP1UTL($PIECE(BGPDAE(X),U,3))_" "_$PIECE(BGPDAE(X),U,2)_" ("_$PIECE(BGPDAE(X),U,4)_")"
+18 IF C>0
SET BGPN1=1
+19 IF C>1
SET BGPN2=1
+20 FOR X=1:1:18
IF '$DATA(BGPNUMV(X))
SET BGPNUMV(X)=0
+21 SET BGPVALUE="UP"
+22 IF BGPRTYPE=3!(BGPRTYPE=5)
SET BGPVALUE=""
+23 SET BGPVALUE=BGPVALUE_$SELECT(BGPD1:",AC",1:"")_"|||"
IF C
SET BGPVALUE=BGPVALUE_C_" drug"_$SELECT(C>1:"s: ",1:":")_J
+24 KILL BGPMEDS,BGPMEDS1,J,X,C,Y,BGPDAE
+25 KILL ^TMP($JOB,"MEDS")
+26 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 IF 'BGPACTCL
SET BGPSTOP=1
QUIT
+8 SET BGPD1=1
+9 KILL BGPBFR
+10 DO GETIFC(DFN,BGPBDATE,BGPEDATE,.BGPBFR)
+11 ;has a screening
IF $DATA(BGPBFR)
SET BGPN1=1
+12 ;n2
+13 Begin DoDot:1
+14 SET X=44
SET G=""
KILL Z
FOR
SET X=$ORDER(BGPBFR(X))
IF X'=+X!(X>89)
QUIT
SET Z($$ABS^XLFMTH(X-60))=X
+15 IF '$DATA(Z)
QUIT
+16 ;this is the lowest/closest to 60 days
SET X=$ORDER(Z(""))
SET X=Z(X)
+17 SET BGPN2=1
+18 SET Y=BGPBFR(X)
+19 IF +Y=1!(+Y=2)
SET BGPN6=1
+20 SET BGPV2="2 MOS: "_X_" DO, "_$$DATE^BGP1UTL($PIECE(Y,U,2))_" "_$$EXTSET^XBFUNC(9000010.44,.01,+Y)
+21 SET G=1
End DoDot:1
+22 Begin DoDot:1
+23 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
+24 IF '$DATA(Z)
QUIT
+25 ;this is the lowest/closest to 180 days
SET X=$ORDER(Z(""))
SET X=Z(X)
+26 SET BGPN3=1
+27 SET Y=BGPBFR(X)
+28 IF +Y=1!(+Y=2)
SET BGPN7=1
+29 SET BGPV3="6 MOS: "_X_" DO, "_$$DATE^BGP1UTL($PIECE(Y,U,2))_" "_$$EXTSET^XBFUNC(9000010.44,.01,+Y)
+30 SET G=1
End DoDot:1
+31 Begin DoDot:1
+32 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
+33 IF '$DATA(Z)
QUIT
+34 ;this is the lowest/closest to 270 days
SET X=$ORDER(Z(""))
SET X=Z(X)
+35 SET BGPN4=1
+36 SET Y=BGPBFR(X)
+37 IF +Y=1!(+Y=2)
SET BGPN8=1
+38 SET BGPV4="9 MOS: "_X_" DO, "_$$DATE^BGP1UTL($PIECE(Y,U,2))_" "_$$EXTSET^XBFUNC(9000010.44,.01,+Y)
+39 SET G=1
End DoDot:1
+40 Begin DoDot:1
+41 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
+42 IF '$DATA(Z)
QUIT
+43 ;this is the lowest/closest to 365 days
SET X=$ORDER(Z(""))
SET X=Z(X)
+44 SET BGPN5=1
+45 SET Y=BGPBFR(X)
+46 IF +Y=1!(+Y=2)
SET BGPN9=1
+47 SET BGPV5="1 YR: "_X_" DO, "_$$DATE^BGP1UTL($PIECE(Y,U,2))_" "_$$EXTSET^XBFUNC(9000010.44,.01,+Y)
+48 SET G=1
End DoDot:1
+49 SET BGPVALUE=$SELECT(BGPN1=1:"Scrn",1:"")
SET BGPVALUE=BGPVALUE_$SELECT(BGPV2]""!(BGPV3]"")!(BGPV4]"")!(BGPV5)]"":": ",1:"")
+50 SET C=0
+51 IF BGPV2]""
SET BGPVALUE=BGPVALUE_$SELECT(C=1:"; ",1:"")_BGPV2
SET C=1
+52 IF BGPV3]""
SET BGPVALUE=BGPVALUE_$SELECT(C=1:"; ",1:"")_BGPV3
SET C=1
+53 IF BGPV4]""
SET BGPVALUE=BGPVALUE_$SELECT(C=1:"; ",1:"")_BGPV4
SET C=1
+54 IF BGPV5]""
SET BGPVALUE=BGPVALUE_$SELECT(C=1:"; ",1:"")_BGPV5
SET C=1
+55 SET BGPVALUE="AC|||"_BGPVALUE
+56 KILL BGPV1,BGPV2,BGPV3,BGPV4,BGPV5,BGPV6,BGPBFR
+57 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="ANTIANXIETY"
SET BGPGOT=0
DO GETMEDS^BGP1UTL2(P,BGPBDATE,BGPEDATE,"BGP HEDIS ANTIANXIETY MEDS","BGP HEDIS ANTIANXIETY NDC",,,.BGPMEDS1)
+4 DO ADDINMED
+5 IF BGPGOT
SET BGPRET1(1)=1
+6 KILL BGPMEDS1
SET BGPXXX="ANTIEMETIC"
SET BGPGOT=0
DO GETMEDS^BGP1UTL2(P,BGPBDATE,BGPEDATE,"BGP HEDIS ANTIEMETIC MEDS","BGP HEDIS ANTIEMETIC NDC",,,.BGPMEDS1)
+7 DO ADDINMED
+8 IF BGPGOT
SET BGPRET1(2)=1
+9 KILL BGPMEDS1
SET BGPXXX="ANALGESIC"
SET BGPGOT=0
DO GETMEDS^BGP1UTL2(P,BGPBDATE,BGPEDATE,"BGP HEDIS ANALGESIC MEDS","BGP HEDIS ANALGESIC NDC",,,.BGPMEDS1)
+10 DO ADDINMED
+11 IF BGPGOT
SET BGPRET1(3)=1
+12 KILL BGPMEDS1
SET BGPXXX="ANTIHISTAMINE"
SET BGPGOT=0
DO GETMEDS^BGP1UTL2(P,BGPBDATE,BGPEDATE,"BGP HEDIS ANTIHISTAMINE MEDS","BGP HEDIS ANTIHISTAMINE NDC",,,.BGPMEDS1)
+13 DO ADDINMED
+14 IF BGPGOT
SET BGPRET1(4)=1
+15 KILL BGPMEDS1
SET BGPXXX=" ANTIPSYCHOTIC"
SET BGPGOT=0
DO GETMEDS^BGP1UTL2(P,BGPBDATE,BGPEDATE,"BGP HEDIS ANTIPSYCHOTIC MEDS","BGP HEDIS ANTIPSYCHOTIC NDC",,,.BGPMEDS1)
+16 DO ADDINMED
+17 IF BGPGOT
SET BGPRET1(5)=1
+18 KILL BGPMEDS1
SET BGPXXX="AMPHETAMINE"
SET BGPGOT=0
DO GETMEDS^BGP1UTL2(P,BGPBDATE,BGPEDATE,"BGP HEDIS AMPHETAMINE MEDS","BGP HEDIS AMPHETAMINE NDC",,,.BGPMEDS1)
+19 DO ADDINMED
+20 IF BGPGOT
SET BGPRET1(6)=1
+21 KILL BGPMEDS1
SET BGPXXX="BARBITURATE"
SET BGPGOT=0
DO GETMEDS^BGP1UTL2(P,BGPBDATE,BGPEDATE,"BGP HEDIS BARBITURATE MEDS","BGP HEDIS BARBITURATE NDC",,,.BGPMEDS1)
+22 DO ADDINMED
+23 IF BGPGOT
SET BGPRET1(7)=1
+24 KILL BGPMEDS1
SET BGPXXX="BENZODIAZEPINE"
SET BGPGOT=0
DO GETMEDS^BGP1UTL2(P,BGPBDATE,BGPEDATE,"BGP HEDIS BENZODIAZEPINE MEDS","BGP HEDIS BENZODIAZEPINE NDC",,,.BGPMEDS1)
+25 DO ADDINMED
+26 IF BGPGOT
SET BGPRET1(8)=1
+27 ;K BGPMEDS1 S BGPXXX="OTHER BENZODIAZEPNE",BGPGOT=0 D GETMEDS^BGP1UTL2(P,BGPBDATE,BGPEDATE,"BGP HEDIS OTHER BENZODIAZEPINE","BGP HEDIS OTHER BENZO NDC",,,.BGPMEDS1)
+28 ;D ADDINMED
+29 ;I BGPGOT S BGPRET1(9)=1
+30 KILL BGPMEDS1
SET BGPXXX="CALCIUM CHANNEL"
SET BGPGOT=0
DO GETMEDS^BGP1UTL2(P,BGPBDATE,BGPEDATE,"BGP HEDIS CALCIUM CHANNEL MEDS","BGP HEDIS CALCIUM CHANNEL NDC",,,.BGPMEDS1)
+31 DO ADDINMED
+32 IF BGPGOT
SET BGPRET1(10)=1
+33 KILL BGPMEDS1
SET BGPXXX="GASTRO ANTISPASM"
SET BGPGOT=0
DO GETMEDS^BGP1UTL2(P,BGPBDATE,BGPEDATE,"BGP HEDIS GASTRO ANTISPASM MED","BGP HEDIS GASTRO ANTISPASM NDC",,,.BGPMEDS1)
+34 DO ADDINMED
+35 IF BGPGOT
SET BGPRET1(11)=1
+36 KILL BGPMEDS1
SET BGPXXX="BELLADONNA"
SET BGPGOT=0
DO GETMEDS^BGP1UTL2(P,BGPBDATE,BGPEDATE,"BGP HEDIS BELLADONNA ALKA MEDS","BGP HEDIS BELLADONNA ALKA NDC",,,.BGPMEDS1)
+37 DO ADDINMED
+38 IF BGPGOT
SET BGPRET1(12)=1
+39 KILL BGPMEDS1
SET BGPXXX="SKL MUSCLE"
SET BGPGOT=0
DO GETMEDS^BGP1UTL2(P,BGPBDATE,BGPEDATE,"BGP HEDIS SKL MUSCLE RELAX MED","BGP HEDIS SKL MUSCLE RELAX NDC",,,.BGPMEDS1)
+40 DO ADDINMED
+41 IF BGPGOT
SET BGPRET1(13)=1
+42 KILL BGPMEDS1
SET BGPXXX="ORAL ESTROGEN"
SET BGPGOT=0
DO GETMEDS^BGP1UTL2(P,BGPBDATE,BGPEDATE,"BGP HEDIS ORAL ESTROGEN MEDS","BGP HEDIS ORAL ESTROGEN NDC",,,.BGPMEDS1)
+43 DO ADDINMED
+44 IF BGPGOT
SET BGPRET1(14)=1
+45 KILL BGPMEDS1
SET BGPXXX="ORAL HYPOGLYCEMIC"
SET BGPGOT=0
DO GETMEDS^BGP1UTL2(P,BGPBDATE,BGPEDATE,"BGP HEDIS ORAL HYPOGLYCEMIC RX","BGP HEDIS ORAL HYPOGLYCEMIC ND",,,.BGPMEDS1)
+46 DO ADDINMED
+47 IF BGPGOT
SET BGPRET1(15)=1
+48 KILL BGPMEDS1
SET BGPXXX="NARCOTIC"
SET BGPGOT=0
DO GETMEDS^BGP1UTL2(P,BGPBDATE,BGPEDATE,"BGP HEDIS NARCOTIC MEDS","BGP HEDIS NARCOTIC NDC",,,.BGPMEDS1)
+49 DO ADDINMED
+50 IF BGPGOT
SET BGPRET1(16)=1
+51 KILL BGPMEDS1
SET BGPXXX="VASODILATOR"
SET BGPGOT=0
DO GETMEDS^BGP1UTL2(P,BGPBDATE,BGPEDATE,"BGP HEDIS VASODILATOR MEDS","BGP HEDIS VASODILATOR NDC",,,.BGPMEDS1)
+52 DO ADDINMED
+53 IF BGPGOT
SET BGPRET1(17)=1
+54 KILL BGPMEDS1
SET BGPXXX="OTHER MEDS"
SET BGPGOT=0
DO GETMEDS^BGP1UTL2(P,BGPBDATE,BGPEDATE,"BGP HEDIS OTHER MEDS AVOID ELD","BGP HEDIS OTHER NDC AVOID ELD",,,.BGPMEDS1)
+55 DO ADDINMED
+56 IF BGPGOT
SET BGPRET1(18)=1
+57 KILL BGPMEDS1
+58 QUIT
ADDINMED ;
+1 SET X=0
FOR
SET X=$ORDER(BGPMEDS1(X))
IF X'=+X
QUIT
Begin DoDot:1
+2 ;vmed ien
SET Y=$PIECE(BGPMEDS1(X),U,4)
+3 IF '$DATA(^AUPNVMED(Y,0))
QUIT
+4 IF $$UP^XLFSTR($PIECE($GET(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"
QUIT
+5 ;drug ien
SET D=$PIECE(^AUPNVMED(Y,0),U,1)
+6 ;DAYS SUPPLY MUST BE >0
+7 ;date discontinued
SET E=$PIECE(^AUPNVMED(Y,0),U,8)
+8 ;DAYS SUPPLY
SET S=$PIECE(^AUPNVMED(Y,0),U,7)
+9 IF 'S
QUIT
+10 ;at least one day
IF E
IF E'>$PIECE(BGPMEDS1(X),U,1)
QUIT
+11 SET $PIECE(BGPRET(D),U)=$PIECE($GET(BGPRET(D)),U)+1
+12 SET $PIECE(BGPRET(D),U,2)=$PIECE(^PSDRUG(D,0),U)
+13 ;LAST FILL
SET $PIECE(BGPRET(D),U,3)=$PIECE(BGPMEDS1(X),U,1)
+14 SET $PIECE(BGPRET(D),U,4)=BGPXXX
+15 SET BGPGOT=1
+16 QUIT
End DoDot:1
+17 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_"^Exam 37^"_$$DATE^BGP1UTL($PIECE(BGPG(1),U))
+4 SET %=$$CPT^BGP1DU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP FALL RISK EXAM CPTS",0)),6)
+5 IF %
QUIT "1^CPT "_$PIECE(%,U,3)_"^"_$$DATE^BGP1UTL($PIECE(%,U,2))
+6 QUIT ""
DHF(P,BDATE,EDATE) ;EP
+1 KILL BGPG
+2 SET Y="BGPG("
+3 SET X=P_"^LAST DX V15.88;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+4 IF $DATA(BGPG(1))
QUIT 1_U_$PIECE(BGPG(1),U,2)_U_"Hx of Fall: "_$$DATE^BGP1UTL($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^ATXCHK(E,T,9)
SET G=1_U_U_$$DATE^BGP1UTL($PIECE(BGPG(X),U,1))
QUIT
+10 SET E=$PIECE(^AUPNVPOV(Y,0),U,18)
IF E
IF $$ICD^ATXCHK(E,T,9)
SET G=1_U_$PIECE($$ICDDX^ICDCODE(E),U,2)_U_"Fall Injury: "_$$DATE^BGP1UTL($PIECE(BGPG(X),U,1))
QUIT
+11 SET E=$PIECE(^AUPNVPOV(Y,0),U,19)
IF E
IF $$ICD^ATXCHK(E,T,9)
SET G=1_U_$PIECE($$ICDDX^ICDCODE(E),U,2)_U_"Fall Injury: "_$$DATE^BGP1UTL($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^BGP1UTL1(P,"BGP ABNORMAL GAIT OR MOBILITY",BDATE,EDATE)
+2 IF $PIECE(BGPG,U)
QUIT 1_U_$PIECE(BGPG,U,2)_U_"Abnormal Gait: "_$$DATE^BGP1UTL($PIECE(BGPG,U,3))
+3 QUIT ""
REFFRE(P,BDATE,EDATE) ;EP
+1 ;add refusal for exam 37
+2 SET G=$$REFUSAL^BGP1UTL1(P,9999999.15,$ORDER(^AUTTEXAM("C",37,0)),$$FMADD^XLFDT(EDATE,-365),EDATE)
+3 IF $PIECE(G,U)=1
QUIT 1_"^exam 37^"_"Refused: "_$$DATE^BGP1UTL($PIECE(G,U,2))
+4 QUIT ""
