BGP8D39 ; IHS/CMI/LAB - measure C ; 11 Jan 2018 12:20 PM
;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
;
MEDCOV ;EP
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPN11,BGPN12,BGPN13,BGPN14,BGPN15,BGPN16,BGPN17,BGPN18,BGPN19,BGPN20)=0
S (BGPN21,BGPN22,BGPN23,BGPN24,BGPN25,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11,BGPD12,BGPD13)=0
NEW BGPBETA,BGPACEI,BGPCCB,BGPBIG,BGPSULF,BGPTHIA,BGPSTATI,BGPANTI,BGPDPP,BGPDMALL,BGPNWARI,BGPBRONC,BGPINFU
S (BGPBETA,BGPACEI,BGPCCB,BGPBIG,BGPSULF,BGPTHIA,BGPSTATI,BGPANTI,BGPDPP,BGPDMALL,BGPNWARI,BGPBRONC,BGPINFU)=""
S BGPVALUE=""
I 'BGPACTUP S BGPSTOP=1 Q
I 'BGPACTCL S BGPSTOP=1 Q
I BGPAGEB>17 S BGPBETA=$$COVERAGE(DFN,BGPBDATE,BGPEDATE,"BGP PQA BETA BLOCKER MEDS","BGP PQA BETA BLOCKER NDC","BB") ; return 1 if meets denominator^%coverage^# gap days^# prescriptions
I $P(BGPBETA,U,1) D
.S BGPD1=1
.S %=$P(BGPBETA,U,2) I %>79 S BGPN1=1
.S BGPN2=$P(BGPBETA,U,3)
.S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"")_$P(BGPBETA,U,4)
I BGPAGEB>17 S BGPACEI=$$COVERAGE(DFN,BGPBDATE,BGPEDATE,"BGP PQA RASA MEDS","BGP PQA RASA NDC","RASA")
I $P(BGPACEI,U,1) D
.S BGPD2=1
.S %=$P(BGPACEI,U,2) I %>79 S BGPN3=1
.S BGPN4=$P(BGPACEI,U,3)
.S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"")_$P(BGPACEI,U,4)
I BGPAGEB>17 S BGPCCB=$$COVERAGE(DFN,BGPBDATE,BGPEDATE,"BGP PQA CCB MEDS","BGP PQA CCB NDC","CCB") ; return 1 if meets denominator^%coverage^# gap days^# prescriptions
I $P(BGPCCB,U,1) D
.S BGPD3=1
.S %=$P(BGPCCB,U,2) I %>79 S BGPN5=1
.S BGPN6=$P(BGPCCB,U,3)
.S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"")_$P(BGPCCB,U,4)
I BGPAGEB>17 S BGPBIG=$$COVERAGE(DFN,BGPBDATE,BGPEDATE,"BGP PQA BIGUANIDE MEDS","BGP PQA BIGUANIDE NDC","BIG") ; return 1 if meets denominator^%coverage^# gap days^# prescriptions
I $P(BGPBIG,U,1) D
.S BGPD4=1
.S %=$P(BGPBIG,U,2) I %>79 S BGPN7=1
.S BGPN8=$P(BGPBIG,U,3)
.S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"")_$P(BGPBIG,U,4)
I BGPAGEB>17 S BGPSULF=$$COVERAGE(DFN,BGPBDATE,BGPEDATE,"BGP PQA SULFONYLUREA MEDS","BGP PQA SULFONYLUREA NDC","SULF") ; return 1 if meets denominator^%coverage^# gap days^# prescriptions
I $P(BGPSULF,U,1) D
.S BGPD5=1
.S %=$P(BGPSULF,U,2) I %>79 S BGPN9=1
.S BGPN10=$P(BGPSULF,U,3)
.S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"")_$P(BGPSULF,U,4)
I BGPAGEB>17 S BGPTHIA=$$COVERAGE(DFN,BGPBDATE,BGPEDATE,"BGP PQA THIAZOLIDINEDIONE MEDS","BGP PQA THIAZOLIDINEDIONE NDC","THIAZ") ; return 1 if meets denominator^%coverage^# gap days^# prescriptions
I $P(BGPTHIA,U,1) D
.S BGPD6=1
.S %=$P(BGPTHIA,U,2) I %>79 S BGPN11=1
.S BGPN12=$P(BGPTHIA,U,3)
.S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"")_$P(BGPTHIA,U,4)
I BGPAGEB>17 S BGPDPP=$$COVERAGE(DFN,BGPBDATE,BGPEDATE,"BGP PQA DPP IV MEDS","BGP PQA DPP IV NDC","DPP") ; return 1 if meets denominator^%coverage^# gap days^# prescriptions
I $P(BGPDPP,U,1) D
.S BGPD9=1
.S %=$P(BGPDPP,U,2) I %>79 S BGPN16=1
.S BGPN17=$P(BGPDPP,U,3)
.S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"")_$P(BGPDPP,U,4)
I BGPAGEB>17 S BGPDMALL=$$COVERAGE(DFN,BGPBDATE,BGPEDATE,"BGP PQA DIABETES ALL CLASS","BGP PQA DIABETES ALL CLASS NDC","DMALL") ; return 1 if meets denominator^%coverage^# gap days^# prescriptions
I $P(BGPDMALL,U,1) D
.S BGPD10=1
.S %=$P(BGPDMALL,U,2) I %>79 S BGPN18=1
.S BGPN19=$P(BGPDMALL,U,3)
.S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"")_$P(BGPDMALL,U,4)
I BGPAGEB>17 S BGPSTATI=$$COVERAGE(DFN,BGPBDATE,BGPEDATE,"BGP PQA STATIN MEDS","BGP PQA STATIN NDC","STATIN") ; return 1 if meets denominator^%coverage^# gap days^# prescriptions
I $P(BGPSTATI,U,1) D
.S BGPD7=1
.S %=$P(BGPSTATI,U,2) I %>79 S BGPN13=1
.S BGPN14=$P(BGPSTATI,U,3)
.S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"")_$P(BGPSTATI,U,4)
I BGPAGEB>17 S BGPNWARI=$$COVERAGE(DFN,BGPBDATE,BGPEDATE,"BGP PQA NON-WARF ANTICOAG MEDS","BGP PQA NON-WARF ANTICOAG NDC","ANTICOAG") ; return 1 if meets denominator^%coverage^# gap days^# prescriptions
I $P(BGPNWARI,U,1) D
.S BGPD11=1
.S %=$P(BGPNWARI,U,2) I %>79 S BGPN20=1
.S BGPN21=$P(BGPNWARI,U,3)
.S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"")_$P(BGPNWARI,U,4)
I BGPAGEB>17 S BGPANTI=$$COVERAGE(DFN,BGPBDATE,BGPEDATE,"BGP PQA ANTIRETROVIRAL MEDS","BGP PQA ANTIRETROVIRAL NDC","ANTIRET") ; return 1 if meets denominator^%coverage^# gap days^# prescriptions
I $P(BGPANTI,U,1) D
.S BGPD8=1
.S %=$P(BGPANTI,U,2) I %>89 S BGPN15=1
.;S BGPN14=$P(BGPSTATI,U,3)
.S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"")_$P(BGPANTI,U,4)
;V18 P1 - ADDED COPD/BRONCHO BGPN22, BGPN23, BGPD12
I $$COPD^BGP8D22(DFN,BGPBDATE,BGPEDATE)!($$EMP^BGP8D213(DFN,BGPBDATE,BGPEDATE)) S BGPBRONC=$$COVERAGE(DFN,BGPBDATE,BGPEDATE,"BGP PQA LA INHALED BRONCHO MED","BGP PQA LA INHALED BRONCHO NDC","BRONCHO")
I $P(BGPBRONC,U,1) D
.S BGPD12=1
.S %=$P(BGPBRONC,U,2) I %>79 S BGPN22=1
.S BGPN23=$P(BGPBRONC,U,3)
.S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"")_$P(BGPBRONC,U,4)
;V18 P1 BGPN24, BGPN25, BGPD13
I BGPAGEB>17 S BGPINFU=$$COVERAGE(DFN,BGPBDATE,BGPEDATE,"BGP PQA NON-INFUSED MS MEDS","BGP PQA NON-INFUSED MS NDC","MS") ; return 1 if meets denominator^%coverage^# gap days^# prescriptions
I $P(BGPINFU,U,1) D
.S BGPD13=1
.S %=$P(BGPINFU,U,2) I %>79 S BGPN24=1
.S BGPN25=$P(BGPINFU,U,3)
.S BGPVALUE=BGPVALUE_$S(BGPVALUE]"":"; ",1:"")_$P(BGPINFU,U,4)
S BGPVALUE="AC"_"|||"_BGPVALUE
K A,B,C,D,E,F,G,H,I,J,K,M,N,O,P,Q,R,S,T,V,W,X,Y,Z,BDATE,EDATE,BGPDN,BGPN,BGPG,BGPC,BGPDMALL,BGPSTATI,BGPANTI
K ^TMP($J,"A"),BGPMEDS1
Q
;
COVERAGE(P,BDATE,EDATE,MTAX,NTAX,TYPE) ;
K ^TMP($J,"A")
NEW A,B,E,Z,X,D,V,Y,G,M,T,T1,BGPMEDS1,C,BGPISD,BGPMP,DAYS,LEND,SD,DC,N,S,PER,GAP,Q
S A="" I TYPE="RASA"!(TYPE="DMALL")!(TYPE="BIG")!(TYPE="SULF")!(TYPE="THIAZ")!(TYPE="DPP") S A=1
I A,$$ESRD^BGP8D211(P,$P(^DPT(P,0),U,3),BGPEDATE) Q ""
I TYPE="RASA",$$HASARB(P,BDATE,EDATE) Q ""
I TYPE="BRONCHO",$$HASNEB(P,BDATE,EDATE) Q ""
I TYPE="MS",$$HASINFU(P,BDATE,EDATE) Q ""
I TYPE="ANTICOAG" I $$HADWARF^BGP8D36(P,BDATE,EDATE) Q "" ;HAD WARFARIN IN TIME PERIOD
K BGPMEDS1
D GETMEDS^BGP8UTL2(P,BDATE,EDATE,MTAX,NTAX,,,.BGPMEDS1)
I '$D(BGPMEDS1) Q "" ; no meds
S BGPISD=""
S (A,C)=0 F S A=$O(BGPMEDS1(A)) Q:A'=+A D
.S M=$P(BGPMEDS1(A),U,4) ;IEN OF V MED
.Q:'$D(^AUPNVMED(M,0))
.I $$UP^XLFSTR($P($G(^AUPNVMED(M,11)),U))["RETURNED TO STOCK" K BGPMEDS1(A) Q
.I $P(^AUPNVMED(M,0),U,8)=$P(BGPMEDS1(A),U,1) K BGPMEDS1(A) Q ;d/c'ed on same day as visit so no days suppply
.I '$P(^AUPNVMED(M,0),U,7) K BGPMEDS1(A) Q ;no days supply
.;GET PRESCRIPTION #
.S Q=$S($D(^PSRX("APCC",M)):$O(^(M,0)),1:0)
.I Q,$E($P($G(^PSRX(Q,0)),U,1))="X" Q ; no POS
.I $E($$VAL^XBDIQ1(9000010.14,M,1102))="X" Q ;no POS
.I $$VAL^XBDIQ1(9000010.14,M,1108)]"" Q ;NO EHR OUTSIDE
.I BGPISD="" S BGPISD=$P(BGPMEDS1(A),U,1) ;first date
.S C=C+1
I C<2 Q "" ;does not have 2 scripts
I BGPISD>$$FMADD^XLFDT(EDATE,-90) Q "" ;INDEX START DATE AFTER EDATE-90
I TYPE="ANTICOAG" S G=0 D NONW180 I G Q ""
S BGPMP=$$FMDIFF^XLFDT(EDATE,BGPISD)
;COVERAGE
S DAYS=0,LEND="",GAP=""
S X=0 F S X=$O(BGPMEDS1(X)) Q:X'=+X D
.S M=+$P(BGPMEDS1(X),U,4)
.;GET PRESCRIPTION #
.S Q=$S($D(^PSRX("APCC",M)):$O(^(M,0)),1:0)
.I Q,$E($P($G(^PSRX(Q,0)),U,1))="X" Q ; no POS
.I $E($$VAL^XBDIQ1(9000010.14,M,1102))="X" Q ;no POS
.I $$VAL^XBDIQ1(9000010.14,M,1108)]"" Q ;NO EHR OUTSIDE
.S V=$P(BGPMEDS1(X),U,5)
.S SD=$$VD^APCLV(V) ;start date of med
.I LEND="" S LEND=SD
.I LEND,LEND>SD S SD=LEND
.S G=$$FMDIFF^XLFDT(SD,LEND) I G>30,GAP="" S GAP=G
.S M=+$P(BGPMEDS1(X),U,4)
.S DC=$P(^AUPNVMED(M,0),U,8) ;date discontinued
.S N=$P(^AUPNVMED(M,0),U,7) ;days supply
.I $$FMADD^XLFDT(SD,N)>EDATE S N=$$FMDIFF^XLFDT(EDATE,SD)
.S S=0 I DC]"",SD]"" S S=$$FMDIFF^XLFDT(DC,SD)
.I S>0,S<N S N=S
.;N IS DAYS SUPPLY
.S LEND=$$FMADD^XLFDT(SD,(N+1)) ;new end date
.S DAYS=DAYS+N
I DAYS<61,TYPE="ANTICOAG" Q ""
I DAYS<56,TYPE="MS" Q ""
I LEND]"" S G=$$FMDIFF^XLFDT(EDATE,LEND) I G>30,GAP="" S GAP=G
S PER=$J(((DAYS/BGPMP)*100),3,0)
S PER=$$STRIP^XLFSTR(PER," ")
S C=1_U_PER_U_$S(GAP:1,1:"")_U_TYPE_": IXRD: "_$$DATE^BGP8UTL(BGPISD)_" ["_BGPMP_"] Days="_DAYS
I TYPE'="ANTIRET" S %=$S(PER>79:">80",1:"<80") S C=C_" "_%
I TYPE="ANTIRET" S %=$S(PER>89:">90",1:"<90") S C=C_" "_%
I TYPE'="ANTIRET" S C=C_$S(GAP:", GAP="_GAP,1:"")
;CALULATE %COVERAGE AND GAP DAYS
Q C
HASARB(P,BDATE,EDATE) ;
NEW BGPMEDS1,C,A,M
K BGPMEDS1
D GETMEDS^BGP8UTL2(P,BDATE,EDATE,"BGP PQA ARB NEPRILYSIN MEDS","BGP PQA ARB NEPRILYSIN NDC",,,.BGPMEDS1)
I '$D(BGPMEDS1) Q "" ; NO MEDS
S (A,C)=0 F S A=$O(BGPMEDS1(A)) Q:A'=+A D
.S M=$P(BGPMEDS1(A),U,4) ;IEN OF V MED
.Q:'$D(^AUPNVMED(M,0))
.;GET PRESCRIPTION #
.S Q=$S($D(^PSRX("APCC",M)):$O(^(M,0)),1:0)
.I Q,$E($P($G(^PSRX(Q,0)),U,1))="X" Q ; no POS
.I $E($$VAL^XBDIQ1(9000010.14,M,1102))="X" Q ;no POS
.I $$VAL^XBDIQ1(9000010.14,M,1108)]"" Q
.I $$UP^XLFSTR($P($G(^AUPNVMED(M,11)),U))["RETURNED TO STOCK" K BGPMEDS1(A) Q
.I $P(^AUPNVMED(M,0),U,8)=$P(BGPMEDS1(A),U,1) K BGPMEDS1(A) Q
.I '$P(^AUPNVMED(M,0),U,7) K BGPMEDS1(A) Q
.S C=C+1
.Q
Q C
HASINFU(P,BDATE,EDATE) ;
NEW BGPMEDS1,C,A,M,T
K BGPMEDS1
D GETMEDS^BGP8UTL2(P,BDATE,EDATE,"BGP PQA INFUSED MS MEDS","BGP PQA INFUSED MS NDC",,,.BGPMEDS1)
I '$D(BGPMEDS1) Q "" ; NO MEDS
S (A,C,T)=0 F S A=$O(BGPMEDS1(A)) Q:A'=+A D
.S M=$P(BGPMEDS1(A),U,4) ;IEN OF V MED
.Q:'$D(^AUPNVMED(M,0))
.;GET PRESCRIPTION #
.S Q=$S($D(^PSRX("APCC",M)):$O(^(M,0)),1:0)
.I Q,$E($P($G(^PSRX(Q,0)),U,1))="X" Q ; no POS
.I $E($$VAL^XBDIQ1(9000010.14,M,1102))="X" Q ;no POS
.I $$VAL^XBDIQ1(9000010.14,M,1108)]"" Q ;NO EHR OUTSIDE
.I $$UP^XLFSTR($P($G(^AUPNVMED(M,11)),U))["RETURNED TO STOCK" K BGPMEDS1(A) Q
.I $P(^AUPNVMED(M,0),U,8)=$P(BGPMEDS1(A),U,1) K BGPMEDS1(A) Q ;d/c'ed on same day as visit so no days suppply
.I '$P(^AUPNVMED(M,0),U,7) K BGPMEDS1(A) Q ;no days supply
.S T=T+$P(^AUPNVMED(M,0),U,7) ;days supply
.S C=C+1
.Q
;I C>1,T>55 Q 1
I C Q 1
Q 0
HASNEB(P,BDATE,EDATE) ;
NEW BGPMEDS1,C,A,M
K BGPMEDS1
D GETMEDS^BGP8UTL2(P,BDATE,EDATE,"BGP PQA NEBULIZED BRONCHO MEDS","BGP PQA NEBULIZED BRONCHO NDC",,,.BGPMEDS1)
I '$D(BGPMEDS1) Q "" ; NO MEDS
S (A,C)=0 F S A=$O(BGPMEDS1(A)) Q:A'=+A D
.S M=$P(BGPMEDS1(A),U,4) ;IEN OF V MED
.Q:'$D(^AUPNVMED(M,0))
.;GET PRESCRIPTION #
.S Q=$S($D(^PSRX("APCC",M)):$O(^(M,0)),1:0)
.I Q,$E($P($G(^PSRX(Q,0)),U,1))="X" Q ; no POS
.I $E($$VAL^XBDIQ1(9000010.14,M,1102))="X" Q ;no POS
.I $$VAL^XBDIQ1(9000010.14,M,1108)]"" Q ;NO EHR OUTSIDE
.I $$UP^XLFSTR($P($G(^AUPNVMED(M,11)),U))["RETURNED TO STOCK" K BGPMEDS1(A) Q
.I $P(^AUPNVMED(M,0),U,8)=$P(BGPMEDS1(A),U,1) K BGPMEDS1(A) Q ;d/c'ed on same day as visit so no days suppply
.I '$P(^AUPNVMED(M,0),U,7) K BGPMEDS1(A) Q ;no days supply
.S C=C+1
.Q
Q C
NONW180 ;
;is the index start greater that 180 from last fill date? if so set g=1
NEW A,B,C,D
S A=0 F S A=$O(BGPMEDS1(A)) Q:A'=+A S B=A
S D=$P(BGPMEDS1(B),U,1) ;LAST FILL
I $$FMDIFF^XLFDT(D,BGPISD)<180 S G=1
Q
COB ;EP
S (BGPD1,BGPN1)=0
S BGPVALUE=""
I 'BGPACTCL S BGPSTOP=1 Q ;NOT AC
I BGPAGEB<18 S BGPSTOP=1 Q ;NOT 18+
I $$HOSPICE^BGP8D74(DFN,BGPBDATE,BGPEDATE) S BGPSTOP=1 Q ;HAS HOSPICE INDICATOR
I $$LASTDX^BGP8UTL1(DFN,"BGP PQA CANCER DXS",BGPBDATE,BGPEDATE) S BGPSTOP=1 Q ;HAS CANCER DX
D GETOP
S (X,C,S)=0 F S X=$O(BGPOPI(X)) Q:X'=+X S C=C+1,S=S+$P(BGPOPI(X),U,8)
I C<2 S BGPSTOP=1 Q ;did not have 2 scripts on 2 different days
I S<15 S BGPSTOP=1 Q ;must have at least days supply of 15
S BGPD1=1
;GET BENZOS
D GETBENZO
;get # of days that have both opi and benzo
K ^TMP($J,"A")
S (C,X)=0 F S X=$O(BGPBENZO(X)) Q:X'=+X S C=C+1
I C<2 S T=0 G S
I '$D(BGPBENZO) S T=0 G S ;not benzos
S X=0 F S X=$O(BGPOPI(X)) Q:X'=+X S D=$P(BGPOPI(X),U,1),S=$P(BGPOPI(X),U,8),E=$$FMADD^XLFDT(D,S) S ^TMP($J,"A","OPI",D)=BGPOPI(X) F Y=1:1 S G=$$FMADD^XLFDT(D,Y) Q:G>E S ^TMP($J,"A","OPI",G)=BGPOPI(X)
S X=0 F S X=$O(BGPBENZO(X)) Q:X'=+X S D=$P(BGPBENZO(X),U,1),S=$P(BGPBENZO(X),U,8),E=$$FMADD^XLFDT(D,S) S ^TMP($J,"A","BENZO",D)=BGPBENZO(X) F Y=1:1 S G=$$FMADD^XLFDT(D,Y) Q:G>E S ^TMP($J,"A","BENZO",G)=BGPBENZO(X)
S T=0,X=0
K BGPUDO,BGPBENO
F S X=$O(^TMP($J,"A","OPI",X)) Q:X'=+X I $D(^TMP($J,"A","BENZO",X)) D
.S T=T+1,BGPUDO($P(^TMP($J,"A","OPI",X),U,1))=$P(^TMP($J,"A","OPI",X),U,2)_U_$P(^TMP($J,"A","OPI",X),U,8),BGPBENO($P(^TMP($J,"A","BENZO",X),U,1))=$P(^TMP($J,"A","BENZO",X),U,2)_U_$P(^TMP($J,"A","BENZO",X),U,8)
S (C,X)=0 F S X=$O(BGPUDO(X)) Q:X'=+X S C=C+1
I C<2 S X=0 F S X=$O(BGPOPI(X)) Q:X'=+X!(C>1) I '$D(BGPUDO(X)) S BGPUDO(X)=$P(BGPOPI(X),U,2),C=C+1
I T>30 S BGPN1=1
S X="" S Y=0 F S Y=$O(BGPUDO(Y)) Q:Y'=+Y S:X]"" X=X_"; " S X=X_$$DATE^BGP8UTL(Y)_" "_$P(BGPOPI(Y),U,2)_" ["_$P(BGPOPI(Y),U,8)_"]"
S S (BGPVALUE,BGPVALUD)="AC "_X_"|||"
;SET NUMERATOR
S X="" D
.I BGPN1 D
..S Y=0,X="" F S Y=$O(BGPBENO(Y)) Q:Y'=+Y S:X]"" X=X_"; " S X=X_$$DATE^BGP8UTL(Y)_" "_$P(BGPBENZO(Y),U,2)_" ["_$P(BGPBENZO(Y),U,8)_"]"
..S X=X_" (OVERLAP: "_T_")"
S BGPVALUE=BGPVALUE_X
S BGPVALUD=BGPVALUD_X
K BGPUDO,BGPBENO,BGPOPI,BGPBENZO
Q
;
GETOP ;GET OPIOD MEDS
K BGPMEDS1
D GETMEDS^BGP8UTL2(DFN,BGPBDATE,BGPEDATE,"BGP PQA OPIOID MEDS","BGP PQA OPIOID NDC",,,.BGPMEDS1)
I '$D(BGPMEDS1) Q
K BGPOPI
S (A,C)=0 F S A=$O(BGPMEDS1(A)) Q:A'=+A D
.S M=$P(BGPMEDS1(A),U,4)
.Q:'$D(^AUPNVMED(M,0))
.I $$UP^XLFSTR($P($G(^AUPNVMED(M,11)),U))["RETURNED TO STOCK" K BGPMEDS1(A) Q
.I $P(^AUPNVMED(M,0),U,8)=$P(BGPMEDS1(A),U,1) K BGPMEDS1(A) Q
.S S=$P(^AUPNVMED(M,0),U,7) I 'S K BGPMEDS1(A) Q
.S Q=$S($D(^PSRX("APCC",M)):$O(^(M,0)),1:0)
.I Q,$E($P($G(^PSRX(Q,0)),U,1))="X" Q
.I $E($$VAL^XBDIQ1(9000010.14,M,1102))="X" Q
.I $$VAL^XBDIQ1(9000010.14,M,1108)]"" Q
.S D=$P(BGPMEDS1(A),U,1)
.I $D(BGPOPI(D)),S>$P(BGPOPI(D),U,8) S BGPOPI(D)=BGPMEDS1(A),$P(BGPOPI(D),U,8)=S Q
.S BGPOPI(D)=BGPMEDS1(A),$P(BGPOPI(D),U,8)=S
.Q
K BGPMEDS1
Q
GETBENZO ;GET OPIOD MEDS
K BGPMEDS1
D GETMEDS^BGP8UTL2(DFN,BGPBDATE,BGPEDATE,"BGP PQA BENZODIAZ OP MEDS","BGP PQA BENZODIAZ OP NDC",,,.BGPMEDS1)
I '$D(BGPMEDS1) Q ; no meds
K BGPBENZO
S (A,C)=0 F S A=$O(BGPMEDS1(A)) Q:A'=+A D
.S M=$P(BGPMEDS1(A),U,4) ;IEN OF V MED
.Q:'$D(^AUPNVMED(M,0))
.I $$UP^XLFSTR($P($G(^AUPNVMED(M,11)),U))["RETURNED TO STOCK" K BGPMEDS1(A) Q
.I $P(^AUPNVMED(M,0),U,8)=$P(BGPMEDS1(A),U,1) K BGPMEDS1(A) Q
.S S=$P(^AUPNVMED(M,0),U,7) I 'S K BGPMEDS1(A) Q
.;GET PRESCRIPTION #
.S Q=$S($D(^PSRX("APCC",M)):$O(^(M,0)),1:0)
.I Q,$E($P($G(^PSRX(Q,0)),U,1))="X" Q
.I $E($$VAL^XBDIQ1(9000010.14,M,1102))="X" Q
.I $$VAL^XBDIQ1(9000010.14,M,1108)]"" Q
.S D=$P(BGPMEDS1(A),U,1)
.I $D(BGPBENZO(D)),S>$P(BGPBENZO(D),U,8) S BGPBENZO(D)=BGPMEDS1(A),$P(BGPBENZO(D),U,8)=S Q
.S BGPBENZO(D)=BGPMEDS1(A),$P(BGPBENZO(D),U,8)=S
.Q
K BGPMEDS1
Q
BGP8D39 ; IHS/CMI/LAB - measure C ; 11 Jan 2018 12:20 PM
+1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
+2 ;
MEDCOV ;EP
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPN11,BGPN12,BGPN13,BGPN14,BGPN15,BGPN16,BGPN17,BGPN18,BGPN19,BGPN20)=0
+2 SET (BGPN21,BGPN22,BGPN23,BGPN24,BGPN25,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11,BGPD12,BGPD13)=0
+3 NEW BGPBETA,BGPACEI,BGPCCB,BGPBIG,BGPSULF,BGPTHIA,BGPSTATI,BGPANTI,BGPDPP,BGPDMALL,BGPNWARI,BGPBRONC,BGPINFU
+4 SET (BGPBETA,BGPACEI,BGPCCB,BGPBIG,BGPSULF,BGPTHIA,BGPSTATI,BGPANTI,BGPDPP,BGPDMALL,BGPNWARI,BGPBRONC,BGPINFU)=""
+5 SET BGPVALUE=""
+6 IF 'BGPACTUP
SET BGPSTOP=1
QUIT
+7 IF 'BGPACTCL
SET BGPSTOP=1
QUIT
+8 ; return 1 if meets denominator^%coverage^# gap days^# prescriptions
IF BGPAGEB>17
SET BGPBETA=$$COVERAGE(DFN,BGPBDATE,BGPEDATE,"BGP PQA BETA BLOCKER MEDS","BGP PQA BETA BLOCKER NDC","BB")
+9 IF $PIECE(BGPBETA,U,1)
Begin DoDot:1
+10 SET BGPD1=1
+11 SET %=$PIECE(BGPBETA,U,2)
IF %>79
SET BGPN1=1
+12 SET BGPN2=$PIECE(BGPBETA,U,3)
+13 SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")_$PIECE(BGPBETA,U,4)
End DoDot:1
+14 IF BGPAGEB>17
SET BGPACEI=$$COVERAGE(DFN,BGPBDATE,BGPEDATE,"BGP PQA RASA MEDS","BGP PQA RASA NDC","RASA")
+15 IF $PIECE(BGPACEI,U,1)
Begin DoDot:1
+16 SET BGPD2=1
+17 SET %=$PIECE(BGPACEI,U,2)
IF %>79
SET BGPN3=1
+18 SET BGPN4=$PIECE(BGPACEI,U,3)
+19 SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")_$PIECE(BGPACEI,U,4)
End DoDot:1
+20 ; return 1 if meets denominator^%coverage^# gap days^# prescriptions
IF BGPAGEB>17
SET BGPCCB=$$COVERAGE(DFN,BGPBDATE,BGPEDATE,"BGP PQA CCB MEDS","BGP PQA CCB NDC","CCB")
+21 IF $PIECE(BGPCCB,U,1)
Begin DoDot:1
+22 SET BGPD3=1
+23 SET %=$PIECE(BGPCCB,U,2)
IF %>79
SET BGPN5=1
+24 SET BGPN6=$PIECE(BGPCCB,U,3)
+25 SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")_$PIECE(BGPCCB,U,4)
End DoDot:1
+26 ; return 1 if meets denominator^%coverage^# gap days^# prescriptions
IF BGPAGEB>17
SET BGPBIG=$$COVERAGE(DFN,BGPBDATE,BGPEDATE,"BGP PQA BIGUANIDE MEDS","BGP PQA BIGUANIDE NDC","BIG")
+27 IF $PIECE(BGPBIG,U,1)
Begin DoDot:1
+28 SET BGPD4=1
+29 SET %=$PIECE(BGPBIG,U,2)
IF %>79
SET BGPN7=1
+30 SET BGPN8=$PIECE(BGPBIG,U,3)
+31 SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")_$PIECE(BGPBIG,U,4)
End DoDot:1
+32 ; return 1 if meets denominator^%coverage^# gap days^# prescriptions
IF BGPAGEB>17
SET BGPSULF=$$COVERAGE(DFN,BGPBDATE,BGPEDATE,"BGP PQA SULFONYLUREA MEDS","BGP PQA SULFONYLUREA NDC","SULF")
+33 IF $PIECE(BGPSULF,U,1)
Begin DoDot:1
+34 SET BGPD5=1
+35 SET %=$PIECE(BGPSULF,U,2)
IF %>79
SET BGPN9=1
+36 SET BGPN10=$PIECE(BGPSULF,U,3)
+37 SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")_$PIECE(BGPSULF,U,4)
End DoDot:1
+38 ; return 1 if meets denominator^%coverage^# gap days^# prescriptions
IF BGPAGEB>17
SET BGPTHIA=$$COVERAGE(DFN,BGPBDATE,BGPEDATE,"BGP PQA THIAZOLIDINEDIONE MEDS","BGP PQA THIAZOLIDINEDIONE NDC","THIAZ")
+39 IF $PIECE(BGPTHIA,U,1)
Begin DoDot:1
+40 SET BGPD6=1
+41 SET %=$PIECE(BGPTHIA,U,2)
IF %>79
SET BGPN11=1
+42 SET BGPN12=$PIECE(BGPTHIA,U,3)
+43 SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")_$PIECE(BGPTHIA,U,4)
End DoDot:1
+44 ; return 1 if meets denominator^%coverage^# gap days^# prescriptions
IF BGPAGEB>17
SET BGPDPP=$$COVERAGE(DFN,BGPBDATE,BGPEDATE,"BGP PQA DPP IV MEDS","BGP PQA DPP IV NDC","DPP")
+45 IF $PIECE(BGPDPP,U,1)
Begin DoDot:1
+46 SET BGPD9=1
+47 SET %=$PIECE(BGPDPP,U,2)
IF %>79
SET BGPN16=1
+48 SET BGPN17=$PIECE(BGPDPP,U,3)
+49 SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")_$PIECE(BGPDPP,U,4)
End DoDot:1
+50 ; return 1 if meets denominator^%coverage^# gap days^# prescriptions
IF BGPAGEB>17
SET BGPDMALL=$$COVERAGE(DFN,BGPBDATE,BGPEDATE,"BGP PQA DIABETES ALL CLASS","BGP PQA DIABETES ALL CLASS NDC","DMALL")
+51 IF $PIECE(BGPDMALL,U,1)
Begin DoDot:1
+52 SET BGPD10=1
+53 SET %=$PIECE(BGPDMALL,U,2)
IF %>79
SET BGPN18=1
+54 SET BGPN19=$PIECE(BGPDMALL,U,3)
+55 SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")_$PIECE(BGPDMALL,U,4)
End DoDot:1
+56 ; return 1 if meets denominator^%coverage^# gap days^# prescriptions
IF BGPAGEB>17
SET BGPSTATI=$$COVERAGE(DFN,BGPBDATE,BGPEDATE,"BGP PQA STATIN MEDS","BGP PQA STATIN NDC","STATIN")
+57 IF $PIECE(BGPSTATI,U,1)
Begin DoDot:1
+58 SET BGPD7=1
+59 SET %=$PIECE(BGPSTATI,U,2)
IF %>79
SET BGPN13=1
+60 SET BGPN14=$PIECE(BGPSTATI,U,3)
+61 SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")_$PIECE(BGPSTATI,U,4)
End DoDot:1
+62 ; return 1 if meets denominator^%coverage^# gap days^# prescriptions
IF BGPAGEB>17
SET BGPNWARI=$$COVERAGE(DFN,BGPBDATE,BGPEDATE,"BGP PQA NON-WARF ANTICOAG MEDS","BGP PQA NON-WARF ANTICOAG NDC","ANTICOAG")
+63 IF $PIECE(BGPNWARI,U,1)
Begin DoDot:1
+64 SET BGPD11=1
+65 SET %=$PIECE(BGPNWARI,U,2)
IF %>79
SET BGPN20=1
+66 SET BGPN21=$PIECE(BGPNWARI,U,3)
+67 SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")_$PIECE(BGPNWARI,U,4)
End DoDot:1
+68 ; return 1 if meets denominator^%coverage^# gap days^# prescriptions
IF BGPAGEB>17
SET BGPANTI=$$COVERAGE(DFN,BGPBDATE,BGPEDATE,"BGP PQA ANTIRETROVIRAL MEDS","BGP PQA ANTIRETROVIRAL NDC","ANTIRET")
+69 IF $PIECE(BGPANTI,U,1)
Begin DoDot:1
+70 SET BGPD8=1
+71 SET %=$PIECE(BGPANTI,U,2)
IF %>89
SET BGPN15=1
+72 ;S BGPN14=$P(BGPSTATI,U,3)
+73 SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")_$PIECE(BGPANTI,U,4)
End DoDot:1
+74 ;V18 P1 - ADDED COPD/BRONCHO BGPN22, BGPN23, BGPD12
+75 IF $$COPD^BGP8D22(DFN,BGPBDATE,BGPEDATE)!($$EMP^BGP8D213(DFN,BGPBDATE,BGPEDATE))
SET BGPBRONC=$$COVERAGE(DFN,BGPBDATE,BGPEDATE,"BGP PQA LA INHALED BRONCHO MED","BGP PQA LA INHALED BRONCHO NDC","BRONCHO")
+76 IF $PIECE(BGPBRONC,U,1)
Begin DoDot:1
+77 SET BGPD12=1
+78 SET %=$PIECE(BGPBRONC,U,2)
IF %>79
SET BGPN22=1
+79 SET BGPN23=$PIECE(BGPBRONC,U,3)
+80 SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")_$PIECE(BGPBRONC,U,4)
End DoDot:1
+81 ;V18 P1 BGPN24, BGPN25, BGPD13
+82 ; return 1 if meets denominator^%coverage^# gap days^# prescriptions
IF BGPAGEB>17
SET BGPINFU=$$COVERAGE(DFN,BGPBDATE,BGPEDATE,"BGP PQA NON-INFUSED MS MEDS","BGP PQA NON-INFUSED MS NDC","MS")
+83 IF $PIECE(BGPINFU,U,1)
Begin DoDot:1
+84 SET BGPD13=1
+85 SET %=$PIECE(BGPINFU,U,2)
IF %>79
SET BGPN24=1
+86 SET BGPN25=$PIECE(BGPINFU,U,3)
+87 SET BGPVALUE=BGPVALUE_$SELECT(BGPVALUE]"":"; ",1:"")_$PIECE(BGPINFU,U,4)
End DoDot:1
+88 SET BGPVALUE="AC"_"|||"_BGPVALUE
+89 KILL A,B,C,D,E,F,G,H,I,J,K,M,N,O,P,Q,R,S,T,V,W,X,Y,Z,BDATE,EDATE,BGPDN,BGPN,BGPG,BGPC,BGPDMALL,BGPSTATI,BGPANTI
+90 KILL ^TMP($JOB,"A"),BGPMEDS1
+91 QUIT
+92 ;
COVERAGE(P,BDATE,EDATE,MTAX,NTAX,TYPE) ;
+1 KILL ^TMP($JOB,"A")
+2 NEW A,B,E,Z,X,D,V,Y,G,M,T,T1,BGPMEDS1,C,BGPISD,BGPMP,DAYS,LEND,SD,DC,N,S,PER,GAP,Q
+3 SET A=""
IF TYPE="RASA"!(TYPE="DMALL")!(TYPE="BIG")!(TYPE="SULF")!(TYPE="THIAZ")!(TYPE="DPP")
SET A=1
+4 IF A
IF $$ESRD^BGP8D211(P,$PIECE(^DPT(P,0),U,3),BGPEDATE)
QUIT ""
+5 IF TYPE="RASA"
IF $$HASARB(P,BDATE,EDATE)
QUIT ""
+6 IF TYPE="BRONCHO"
IF $$HASNEB(P,BDATE,EDATE)
QUIT ""
+7 IF TYPE="MS"
IF $$HASINFU(P,BDATE,EDATE)
QUIT ""
+8 ;HAD WARFARIN IN TIME PERIOD
IF TYPE="ANTICOAG"
IF $$HADWARF^BGP8D36(P,BDATE,EDATE)
QUIT ""
+9 KILL BGPMEDS1
+10 DO GETMEDS^BGP8UTL2(P,BDATE,EDATE,MTAX,NTAX,,,.BGPMEDS1)
+11 ; no meds
IF '$DATA(BGPMEDS1)
QUIT ""
+12 SET BGPISD=""
+13 SET (A,C)=0
FOR
SET A=$ORDER(BGPMEDS1(A))
IF A'=+A
QUIT
Begin DoDot:1
+14 ;IEN OF V MED
SET M=$PIECE(BGPMEDS1(A),U,4)
+15 IF '$DATA(^AUPNVMED(M,0))
QUIT
+16 IF $$UP^XLFSTR($PIECE($GET(^AUPNVMED(M,11)),U))["RETURNED TO STOCK"
KILL BGPMEDS1(A)
QUIT
+17 ;d/c'ed on same day as visit so no days suppply
IF $PIECE(^AUPNVMED(M,0),U,8)=$PIECE(BGPMEDS1(A),U,1)
KILL BGPMEDS1(A)
QUIT
+18 ;no days supply
IF '$PIECE(^AUPNVMED(M,0),U,7)
KILL BGPMEDS1(A)
QUIT
+19 ;GET PRESCRIPTION #
+20 SET Q=$SELECT($DATA(^PSRX("APCC",M)):$ORDER(^(M,0)),1:0)
+21 ; no POS
IF Q
IF $EXTRACT($PIECE($GET(^PSRX(Q,0)),U,1))="X"
QUIT
+22 ;no POS
IF $EXTRACT($$VAL^XBDIQ1(9000010.14,M,1102))="X"
QUIT
+23 ;NO EHR OUTSIDE
IF $$VAL^XBDIQ1(9000010.14,M,1108)]""
QUIT
+24 ;first date
IF BGPISD=""
SET BGPISD=$PIECE(BGPMEDS1(A),U,1)
+25 SET C=C+1
End DoDot:1
+26 ;does not have 2 scripts
IF C<2
QUIT ""
+27 ;INDEX START DATE AFTER EDATE-90
IF BGPISD>$$FMADD^XLFDT(EDATE,-90)
QUIT ""
+28 IF TYPE="ANTICOAG"
SET G=0
DO NONW180
IF G
QUIT ""
+29 SET BGPMP=$$FMDIFF^XLFDT(EDATE,BGPISD)
+30 ;COVERAGE
+31 SET DAYS=0
SET LEND=""
SET GAP=""
+32 SET X=0
FOR
SET X=$ORDER(BGPMEDS1(X))
IF X'=+X
QUIT
Begin DoDot:1
+33 SET M=+$PIECE(BGPMEDS1(X),U,4)
+34 ;GET PRESCRIPTION #
+35 SET Q=$SELECT($DATA(^PSRX("APCC",M)):$ORDER(^(M,0)),1:0)
+36 ; no POS
IF Q
IF $EXTRACT($PIECE($GET(^PSRX(Q,0)),U,1))="X"
QUIT
+37 ;no POS
IF $EXTRACT($$VAL^XBDIQ1(9000010.14,M,1102))="X"
QUIT
+38 ;NO EHR OUTSIDE
IF $$VAL^XBDIQ1(9000010.14,M,1108)]""
QUIT
+39 SET V=$PIECE(BGPMEDS1(X),U,5)
+40 ;start date of med
SET SD=$$VD^APCLV(V)
+41 IF LEND=""
SET LEND=SD
+42 IF LEND
IF LEND>SD
SET SD=LEND
+43 SET G=$$FMDIFF^XLFDT(SD,LEND)
IF G>30
IF GAP=""
SET GAP=G
+44 SET M=+$PIECE(BGPMEDS1(X),U,4)
+45 ;date discontinued
SET DC=$PIECE(^AUPNVMED(M,0),U,8)
+46 ;days supply
SET N=$PIECE(^AUPNVMED(M,0),U,7)
+47 IF $$FMADD^XLFDT(SD,N)>EDATE
SET N=$$FMDIFF^XLFDT(EDATE,SD)
+48 SET S=0
IF DC]""
IF SD]""
SET S=$$FMDIFF^XLFDT(DC,SD)
+49 IF S>0
IF S<N
SET N=S
+50 ;N IS DAYS SUPPLY
+51 ;new end date
SET LEND=$$FMADD^XLFDT(SD,(N+1))
+52 SET DAYS=DAYS+N
End DoDot:1
+53 IF DAYS<61
IF TYPE="ANTICOAG"
QUIT ""
+54 IF DAYS<56
IF TYPE="MS"
QUIT ""
+55 IF LEND]""
SET G=$$FMDIFF^XLFDT(EDATE,LEND)
IF G>30
IF GAP=""
SET GAP=G
+56 SET PER=$JUSTIFY(((DAYS/BGPMP)*100),3,0)
+57 SET PER=$$STRIP^XLFSTR(PER," ")
+58 SET C=1_U_PER_U_$SELECT(GAP:1,1:"")_U_TYPE_": IXRD: "_$$DATE^BGP8UTL(BGPISD)_" ["_BGPMP_"] Days="_DAYS
+59 IF TYPE'="ANTIRET"
SET %=$SELECT(PER>79:">80",1:"<80")
SET C=C_" "_%
+60 IF TYPE="ANTIRET"
SET %=$SELECT(PER>89:">90",1:"<90")
SET C=C_" "_%
+61 IF TYPE'="ANTIRET"
SET C=C_$SELECT(GAP:", GAP="_GAP,1:"")
+62 ;CALULATE %COVERAGE AND GAP DAYS
+63 QUIT C
HASARB(P,BDATE,EDATE) ;
+1 NEW BGPMEDS1,C,A,M
+2 KILL BGPMEDS1
+3 DO GETMEDS^BGP8UTL2(P,BDATE,EDATE,"BGP PQA ARB NEPRILYSIN MEDS","BGP PQA ARB NEPRILYSIN NDC",,,.BGPMEDS1)
+4 ; NO MEDS
IF '$DATA(BGPMEDS1)
QUIT ""
+5 SET (A,C)=0
FOR
SET A=$ORDER(BGPMEDS1(A))
IF A'=+A
QUIT
Begin DoDot:1
+6 ;IEN OF V MED
SET M=$PIECE(BGPMEDS1(A),U,4)
+7 IF '$DATA(^AUPNVMED(M,0))
QUIT
+8 ;GET PRESCRIPTION #
+9 SET Q=$SELECT($DATA(^PSRX("APCC",M)):$ORDER(^(M,0)),1:0)
+10 ; no POS
IF Q
IF $EXTRACT($PIECE($GET(^PSRX(Q,0)),U,1))="X"
QUIT
+11 ;no POS
IF $EXTRACT($$VAL^XBDIQ1(9000010.14,M,1102))="X"
QUIT
+12 IF $$VAL^XBDIQ1(9000010.14,M,1108)]""
QUIT
+13 IF $$UP^XLFSTR($PIECE($GET(^AUPNVMED(M,11)),U))["RETURNED TO STOCK"
KILL BGPMEDS1(A)
QUIT
+14 IF $PIECE(^AUPNVMED(M,0),U,8)=$PIECE(BGPMEDS1(A),U,1)
KILL BGPMEDS1(A)
QUIT
+15 IF '$PIECE(^AUPNVMED(M,0),U,7)
KILL BGPMEDS1(A)
QUIT
+16 SET C=C+1
+17 QUIT
End DoDot:1
+18 QUIT C
HASINFU(P,BDATE,EDATE) ;
+1 NEW BGPMEDS1,C,A,M,T
+2 KILL BGPMEDS1
+3 DO GETMEDS^BGP8UTL2(P,BDATE,EDATE,"BGP PQA INFUSED MS MEDS","BGP PQA INFUSED MS NDC",,,.BGPMEDS1)
+4 ; NO MEDS
IF '$DATA(BGPMEDS1)
QUIT ""
+5 SET (A,C,T)=0
FOR
SET A=$ORDER(BGPMEDS1(A))
IF A'=+A
QUIT
Begin DoDot:1
+6 ;IEN OF V MED
SET M=$PIECE(BGPMEDS1(A),U,4)
+7 IF '$DATA(^AUPNVMED(M,0))
QUIT
+8 ;GET PRESCRIPTION #
+9 SET Q=$SELECT($DATA(^PSRX("APCC",M)):$ORDER(^(M,0)),1:0)
+10 ; no POS
IF Q
IF $EXTRACT($PIECE($GET(^PSRX(Q,0)),U,1))="X"
QUIT
+11 ;no POS
IF $EXTRACT($$VAL^XBDIQ1(9000010.14,M,1102))="X"
QUIT
+12 ;NO EHR OUTSIDE
IF $$VAL^XBDIQ1(9000010.14,M,1108)]""
QUIT
+13 IF $$UP^XLFSTR($PIECE($GET(^AUPNVMED(M,11)),U))["RETURNED TO STOCK"
KILL BGPMEDS1(A)
QUIT
+14 ;d/c'ed on same day as visit so no days suppply
IF $PIECE(^AUPNVMED(M,0),U,8)=$PIECE(BGPMEDS1(A),U,1)
KILL BGPMEDS1(A)
QUIT
+15 ;no days supply
IF '$PIECE(^AUPNVMED(M,0),U,7)
KILL BGPMEDS1(A)
QUIT
+16 ;days supply
SET T=T+$PIECE(^AUPNVMED(M,0),U,7)
+17 SET C=C+1
+18 QUIT
End DoDot:1
+19 ;I C>1,T>55 Q 1
+20 IF C
QUIT 1
+21 QUIT 0
HASNEB(P,BDATE,EDATE) ;
+1 NEW BGPMEDS1,C,A,M
+2 KILL BGPMEDS1
+3 DO GETMEDS^BGP8UTL2(P,BDATE,EDATE,"BGP PQA NEBULIZED BRONCHO MEDS","BGP PQA NEBULIZED BRONCHO NDC",,,.BGPMEDS1)
+4 ; NO MEDS
IF '$DATA(BGPMEDS1)
QUIT ""
+5 SET (A,C)=0
FOR
SET A=$ORDER(BGPMEDS1(A))
IF A'=+A
QUIT
Begin DoDot:1
+6 ;IEN OF V MED
SET M=$PIECE(BGPMEDS1(A),U,4)
+7 IF '$DATA(^AUPNVMED(M,0))
QUIT
+8 ;GET PRESCRIPTION #
+9 SET Q=$SELECT($DATA(^PSRX("APCC",M)):$ORDER(^(M,0)),1:0)
+10 ; no POS
IF Q
IF $EXTRACT($PIECE($GET(^PSRX(Q,0)),U,1))="X"
QUIT
+11 ;no POS
IF $EXTRACT($$VAL^XBDIQ1(9000010.14,M,1102))="X"
QUIT
+12 ;NO EHR OUTSIDE
IF $$VAL^XBDIQ1(9000010.14,M,1108)]""
QUIT
+13 IF $$UP^XLFSTR($PIECE($GET(^AUPNVMED(M,11)),U))["RETURNED TO STOCK"
KILL BGPMEDS1(A)
QUIT
+14 ;d/c'ed on same day as visit so no days suppply
IF $PIECE(^AUPNVMED(M,0),U,8)=$PIECE(BGPMEDS1(A),U,1)
KILL BGPMEDS1(A)
QUIT
+15 ;no days supply
IF '$PIECE(^AUPNVMED(M,0),U,7)
KILL BGPMEDS1(A)
QUIT
+16 SET C=C+1
+17 QUIT
End DoDot:1
+18 QUIT C
NONW180 ;
+1 ;is the index start greater that 180 from last fill date? if so set g=1
+2 NEW A,B,C,D
+3 SET A=0
FOR
SET A=$ORDER(BGPMEDS1(A))
IF A'=+A
QUIT
SET B=A
+4 ;LAST FILL
SET D=$PIECE(BGPMEDS1(B),U,1)
+5 IF $$FMDIFF^XLFDT(D,BGPISD)<180
SET G=1
+6 QUIT
COB ;EP
+1 SET (BGPD1,BGPN1)=0
+2 SET BGPVALUE=""
+3 ;NOT AC
IF 'BGPACTCL
SET BGPSTOP=1
QUIT
+4 ;NOT 18+
IF BGPAGEB<18
SET BGPSTOP=1
QUIT
+5 ;HAS HOSPICE INDICATOR
IF $$HOSPICE^BGP8D74(DFN,BGPBDATE,BGPEDATE)
SET BGPSTOP=1
QUIT
+6 ;HAS CANCER DX
IF $$LASTDX^BGP8UTL1(DFN,"BGP PQA CANCER DXS",BGPBDATE,BGPEDATE)
SET BGPSTOP=1
QUIT
+7 DO GETOP
+8 SET (X,C,S)=0
FOR
SET X=$ORDER(BGPOPI(X))
IF X'=+X
QUIT
SET C=C+1
SET S=S+$PIECE(BGPOPI(X),U,8)
+9 ;did not have 2 scripts on 2 different days
IF C<2
SET BGPSTOP=1
QUIT
+10 ;must have at least days supply of 15
IF S<15
SET BGPSTOP=1
QUIT
+11 SET BGPD1=1
+12 ;GET BENZOS
+13 DO GETBENZO
+14 ;get # of days that have both opi and benzo
+15 KILL ^TMP($JOB,"A")
+16 SET (C,X)=0
FOR
SET X=$ORDER(BGPBENZO(X))
IF X'=+X
QUIT
SET C=C+1
+17 IF C<2
SET T=0
GOTO S
+18 ;not benzos
IF '$DATA(BGPBENZO)
SET T=0
GOTO S
+19 SET X=0
FOR
SET X=$ORDER(BGPOPI(X))
IF X'=+X
QUIT
SET D=$PIECE(BGPOPI(X),U,1)
SET S=$PIECE(BGPOPI(X),U,8)
SET E=$$FMADD^XLFDT(D,S)
SET ^TMP($JOB,"A","OPI",D)=BGPOPI(X)
FOR Y=1:1
SET G=$$FMADD^XLFDT(D,Y)
IF G>E
QUIT
SET ^TMP($JOB,"A","OPI",G)=BGPOPI(X)
+20 SET X=0
FOR
SET X=$ORDER(BGPBENZO(X))
IF X'=+X
QUIT
SET D=$PIECE(BGPBENZO(X),U,1)
SET S=$PIECE(BGPBENZO(X),U,8)
SET E=$$FMADD^XLFDT(D,S)
SET ^TMP($JOB,"A","BENZO",D)=BGPBENZO(X)
FOR Y=1:1
SET G=$$FMADD^XLFDT(D,Y)
IF G>E
QUIT
SET ^TMP($JOB,"A","BENZO",G)=BGPBENZO(X)
+21 SET T=0
SET X=0
+22 KILL BGPUDO,BGPBENO
+23 FOR
SET X=$ORDER(^TMP($JOB,"A","OPI",X))
IF X'=+X
QUIT
IF $DATA(^TMP($JOB,"A","BENZO",X))
Begin DoDot:1
+24 SET T=T+1
SET BGPUDO($PIECE(^TMP($JOB,"A","OPI",X),U,1))=$PIECE(^TMP($JOB,"A","OPI",X),U,2)_U_$PIECE(^TMP($JOB,"A","OPI",X),U,8)
SET BGPBENO($PIECE(^TMP($JOB,"A","BENZO",X),U,1))=$PIECE(^TMP($JOB,"A","BENZO",X),U,2)_U_$PIECE(^TMP($JOB,"A","BENZO",X),U,8)
End DoDot:1
+25 SET (C,X)=0
FOR
SET X=$ORDER(BGPUDO(X))
IF X'=+X
QUIT
SET C=C+1
+26 IF C<2
SET X=0
FOR
SET X=$ORDER(BGPOPI(X))
IF X'=+X!(C>1)
QUIT
IF '$DATA(BGPUDO(X))
SET BGPUDO(X)=$PIECE(BGPOPI(X),U,2)
SET C=C+1
+27 IF T>30
SET BGPN1=1
+28 SET X=""
SET Y=0
FOR
SET Y=$ORDER(BGPUDO(Y))
IF Y'=+Y
QUIT
IF X]""
SET X=X_"; "
SET X=X_$$DATE^BGP8UTL(Y)_" "_$PIECE(BGPOPI(Y),U,2)_" ["_$PIECE(BGPOPI(Y),U,8)_"]"
S SET (BGPVALUE,BGPVALUD)="AC "_X_"|||"
+1 ;SET NUMERATOR
+2 SET X=""
Begin DoDot:1
+3 IF BGPN1
Begin DoDot:2
+4 SET Y=0
SET X=""
FOR
SET Y=$ORDER(BGPBENO(Y))
IF Y'=+Y
QUIT
IF X]""
SET X=X_"; "
SET X=X_$$DATE^BGP8UTL(Y)_" "_$PIECE(BGPBENZO(Y),U,2)_" ["_$PIECE(BGPBENZO(Y),U,8)_"]"
+5 SET X=X_" (OVERLAP: "_T_")"
End DoDot:2
End DoDot:1
+6 SET BGPVALUE=BGPVALUE_X
+7 SET BGPVALUD=BGPVALUD_X
+8 KILL BGPUDO,BGPBENO,BGPOPI,BGPBENZO
+9 QUIT
+10 ;
GETOP ;GET OPIOD MEDS
+1 KILL BGPMEDS1
+2 DO GETMEDS^BGP8UTL2(DFN,BGPBDATE,BGPEDATE,"BGP PQA OPIOID MEDS","BGP PQA OPIOID NDC",,,.BGPMEDS1)
+3 IF '$DATA(BGPMEDS1)
QUIT
+4 KILL BGPOPI
+5 SET (A,C)=0
FOR
SET A=$ORDER(BGPMEDS1(A))
IF A'=+A
QUIT
Begin DoDot:1
+6 SET M=$PIECE(BGPMEDS1(A),U,4)
+7 IF '$DATA(^AUPNVMED(M,0))
QUIT
+8 IF $$UP^XLFSTR($PIECE($GET(^AUPNVMED(M,11)),U))["RETURNED TO STOCK"
KILL BGPMEDS1(A)
QUIT
+9 IF $PIECE(^AUPNVMED(M,0),U,8)=$PIECE(BGPMEDS1(A),U,1)
KILL BGPMEDS1(A)
QUIT
+10 SET S=$PIECE(^AUPNVMED(M,0),U,7)
IF 'S
KILL BGPMEDS1(A)
QUIT
+11 SET Q=$SELECT($DATA(^PSRX("APCC",M)):$ORDER(^(M,0)),1:0)
+12 IF Q
IF $EXTRACT($PIECE($GET(^PSRX(Q,0)),U,1))="X"
QUIT
+13 IF $EXTRACT($$VAL^XBDIQ1(9000010.14,M,1102))="X"
QUIT
+14 IF $$VAL^XBDIQ1(9000010.14,M,1108)]""
QUIT
+15 SET D=$PIECE(BGPMEDS1(A),U,1)
+16 IF $DATA(BGPOPI(D))
IF S>$PIECE(BGPOPI(D),U,8)
SET BGPOPI(D)=BGPMEDS1(A)
SET $PIECE(BGPOPI(D),U,8)=S
QUIT
+17 SET BGPOPI(D)=BGPMEDS1(A)
SET $PIECE(BGPOPI(D),U,8)=S
+18 QUIT
End DoDot:1
+19 KILL BGPMEDS1
+20 QUIT
GETBENZO ;GET OPIOD MEDS
+1 KILL BGPMEDS1
+2 DO GETMEDS^BGP8UTL2(DFN,BGPBDATE,BGPEDATE,"BGP PQA BENZODIAZ OP MEDS","BGP PQA BENZODIAZ OP NDC",,,.BGPMEDS1)
+3 ; no meds
IF '$DATA(BGPMEDS1)
QUIT
+4 KILL BGPBENZO
+5 SET (A,C)=0
FOR
SET A=$ORDER(BGPMEDS1(A))
IF A'=+A
QUIT
Begin DoDot:1
+6 ;IEN OF V MED
SET M=$PIECE(BGPMEDS1(A),U,4)
+7 IF '$DATA(^AUPNVMED(M,0))
QUIT
+8 IF $$UP^XLFSTR($PIECE($GET(^AUPNVMED(M,11)),U))["RETURNED TO STOCK"
KILL BGPMEDS1(A)
QUIT
+9 IF $PIECE(^AUPNVMED(M,0),U,8)=$PIECE(BGPMEDS1(A),U,1)
KILL BGPMEDS1(A)
QUIT
+10 SET S=$PIECE(^AUPNVMED(M,0),U,7)
IF 'S
KILL BGPMEDS1(A)
QUIT
+11 ;GET PRESCRIPTION #
+12 SET Q=$SELECT($DATA(^PSRX("APCC",M)):$ORDER(^(M,0)),1:0)
+13 IF Q
IF $EXTRACT($PIECE($GET(^PSRX(Q,0)),U,1))="X"
QUIT
+14 IF $EXTRACT($$VAL^XBDIQ1(9000010.14,M,1102))="X"
QUIT
+15 IF $$VAL^XBDIQ1(9000010.14,M,1108)]""
QUIT
+16 SET D=$PIECE(BGPMEDS1(A),U,1)
+17 IF $DATA(BGPBENZO(D))
IF S>$PIECE(BGPBENZO(D),U,8)
SET BGPBENZO(D)=BGPMEDS1(A)
SET $PIECE(BGPBENZO(D),U,8)=S
QUIT
+18 SET BGPBENZO(D)=BGPMEDS1(A)
SET $PIECE(BGPBENZO(D),U,8)=S
+19 QUIT
End DoDot:1
+20 KILL BGPMEDS1
+21 QUIT
