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

BGP5D74.m

Go to the documentation of this file.
BGP5D74 ; IHS/CMI/LAB - measure 1,2,3,4 05 Apr 2010 1:44 PM ;
 ;;15.1;IHS CLINICAL REPORTING;;MAY 06, 2015;Build 143
 ;
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
 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^BGP5UTL($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=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^BGP5UTL($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^BGP5UTL($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^BGP5UTL($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^BGP5UTL($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^BGP5UTL($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
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^BGP5UTL2(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^BGP5UTL2(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^BGP5UTL2(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^BGP5UTL2(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^BGP5UTL2(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^BGP5UTL2(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^BGP5UTL2(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^BGP5UTL2(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^BGP5UTL2(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^BGP5UTL($P(BGPG(1),U))
 S %=$$CPT^BGP5DU(P,BDATE,EDATE,$O(^ATXAX("B","BGP FALL RISK EXAM CPTS",0)),6)
 I % Q "1^CPT "_$P(%,U,3)_"^"_$$DATE^BGP5UTL($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^BGP5UTL($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^BGP5UTL2(E,T,9) S G=1_U_"E-CODE "_$P($$ICDDX^BGP5UTL2(E),U,2)_U_"Fall Injury: "_$$DATE^BGP5UTL($P(BGPG(X),U,1)) Q
 .S E=$P(^AUPNVPOV(Y,0),U,18) I E,$$ICD^BGP5UTL2(E,T,9) S G=1_U_"E-CODE "_$P($$ICDDX^BGP5UTL2(E),U,2)_U_"Fall Injury: "_$$DATE^BGP5UTL($P(BGPG(X),U,1)) Q
 .S E=$P(^AUPNVPOV(Y,0),U,19) I E,$$ICD^BGP5UTL2(E,T,9) S G=1_U_"E-CODE "_$P($$ICDDX^BGP5UTL2(E),U,2)_U_"Fall Injury: "_$$DATE^BGP5UTL($P(BGPG(X),U,1)) Q
 I G Q G
 Q ""
AGM(P,BDATE,EDATE) ;EP
 S BGPG=$$LASTDX^BGP5UTL1(P,"BGP ABNORMAL GAIT OR MOBILITY",BDATE,EDATE)
 I $P(BGPG,U) Q 1_U_"POV "_$P(BGPG,U,2)_U_"Abnormal Gait: "_$$DATE^BGP5UTL($P(BGPG,U,3))
 Q ""
REFFRE(P,BDATE,EDATE) ;EP
 ;add Refusal for exam 37
 S G=$$REFUSAL^BGP5UTL1(P,9999999.15,$O(^AUTTEXAM("C",37,0)),$$FMADD^XLFDT(EDATE,-365),EDATE)
 I $P(G,U)=1 Q 1_"^Ex 37^"_"Refused "_$$DATE^BGP5UTL($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