BDMDF1B ; IHS/CMI/LAB - get dm audit values ;
;;2.0;DIABETES MANAGEMENT SYSTEM;**11**;JUN 14, 2007;Build 30
;
TD(P,EDATE) ;EP
;
NEW BDM1
S BDM1=$$TD^BDMS9B3(P,$$DOB^AUPNPAT(P),EDATE)
NEW D,X S D=$P(BDM1," ",2),X=""
I D]"" NEW X S X=D D ^%DT S X=$$DATE^BDMS9B1(Y)
I $E(BDM1)="Y" Q "1 "_$P(BDM1," ",1)_" "_X
I $E(BDM1)="N" Q "2 "_$P(BDM1," ",1)_" "_X
I $E(BDM1)="R" Q "3 "_$P(BDM1," ",1)_" "_X
Q ""
TDAP(P,BDMSED,F) ;EP
NEW BDMY,X,E,B,%DT,Y,TDD
S TDD=$$LASTTDAP(P,BDMSED)
I TDD Q "1 Yes "_$S($G(F)="A":$$DATE^BDMS9B1(TDD),1:$$DATE^BDMS9B1(TDD))
S R="",G="" F R=115 Q:R=""!(G) D
.S G=$$REFUSAL^BDMDF17(P,9999999.14,$O(^AUTTIMM("C",R,0)),$$FMADD^XLFDT(DT,-365),DT,"R")
I G Q "3 Refused "_$P(G,U,3)
;; BI REFUSALS
S G="" F Z=115 Q:G S X=0,Y=$O(^AUTTIMM("C",Z,0)) I Y F S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X!(G) D
.S R=$P(^BIPC(X,0),U,3)
.Q:R=""
.Q:'$D(^BICONT(R,0))
.Q:$P(^BICONT(R,0),U,1)'["Refusal"
.S D=$P(^BIPC(X,0),U,4)
.Q:D=""
.Q:D<$$FMADD^XLFDT(DT,-365)
.S G=1_U_D
I G Q "3 Refused "_$S($G(F)="A":$$DATE^BDMS9B1($P(G,U,2)),1:$$DATE^BDMS9B1($P(G,U,2)))
Q "2 No "_$S($G(F)="A":$$DATE^BDMS9B1(TDD),1:$$DATE^BDMS9B1(TDD))
LASTTDAP(BDMPDFN,BDMED) ;PEP - date of last TD
;
I $G(BDMPDFN)="" Q ""
S BDMBD=$$DOB^AUPNPAT(BDMPDFN)
I $G(BDMED)="" S BDMED=DT
NEW BDMLAST,BDMVAL,BDMX,R,X,Y,V,E,T,G,BDMY,BDMF
S BDMLAST=""
S BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"115","IMMUNIZATION",$S($P(BDMLAST,U)]"":$P(BDMLAST,U),1:BDMBD),BDMED,"A")
S BDMF=$$LASTCPTI^BDMSMU2(BDMPDFN,90715,BDMBD,BDMED)
I BDMF,$P(BDMF,U,3)>$P(BDMVAL,U,1) Q $P(BDMF,U,3)
Q $P(BDMVAL,U,1)
PREG(P,BDATE,EDATE,NORXCHR,NORX,CPBD,CPED) ;EP
I $P(^DPT(P,0),U,2)'="F" Q ""
NEW B,E,A,CNT,BDMD,BDMG,X,Y,BDMDX,C,D,G,T,%,CTR,VIEN,DXT,PXT,CPTT,BDMV,H
I '$G(FORM) S FORM=""
I $G(CPBD)="" S CPBD=BDATE
I $G(CPED)="" S CPED=EDATE
S A=""
I $P($G(^AUPNREP(P,11)),U,1)="Y" D I A S BDMD=B G MA
.S B=$P($G(^AUPNREP(P,11)),U,2) Q:B=""
.Q:B<CPBD
.Q:B>CPED
.S A=1
.Q
S BDMD=""
D ALLV^APCLAPIU(P,BDATE,EDATE,"BDMV")
I '$D(BDMV) G PROB
S B=0,CNT=0,BDMD="" ;if there is one before time frame set this to 1
S NORXCHR=$G(NORXCHR)
S NORX=$G(NORX)
K BDMG
S DXT="BGP PREGNANCY DIAGNOSES 2"
S PXT="BGP PREGNANCY ICD PROCEDURES"
S CPTT="BGP PREGNANCY CPT CODES"
;CHECK DX, PROCS, CPTS for 2 separate visits
S B=0,CTR=0 F S CTR=$O(BDMV(CTR)) Q:CTR'=+CTR D
.;get visit into VIEN
.S VIEN=$P(BDMV(CTR),U,5)
.S D=$$VD^APCLV(VIEN)
.S C=$$CLINIC^APCLV(VIEN,"C")
.I NORXCHR,C=39 Q
.I NORX,C=39 Q
.S C=$$PRIMPROV^APCLV(VIEN,"D")
.I NORXCHR,C=53 Q ;no chr as primary provider
.;now check for dx
.S Y=0,H="" F S Y=$O(^AUPNVPOV("AD",VIEN,Y)) Q:Y'=+Y D
..S %=+^AUPNVPOV(Y,0)
..I $$ICD^BDMUTL(%,DXT,9) S BDMDX(D)="",CNT=CNT+1,H=1 I D>$$FMADD^XLFDT(EDATE,-365) S B=1
.Q:H
.;NOW GO THROUGH CPTS
.S Y=0,H="" F S Y=$O(^AUPNVCPT("AD",VIEN,Y)) Q:Y'=+Y D
..S %=+^AUPNVCPT(Y,0)
..I $$ICD^BDMUTL(%,CPTT,1) I '$D(BDMDX(D)) S BDMDX(D)="",CNT=CNT+1,H=1 I D>$$FMADD^XLFDT(EDATE,-365) S B=1
.Q:H
.;NOW PROCEDURES
.S Y=0,H="" F S Y=$O(^AUPNVPRC("AD",VIEN,Y)) Q:Y'=+Y D
..S %=+^AUPNVPRC(Y,0)
..I $$ICD^BDMUTL(%,PXT,0) I '$D(BDMDX(D)) S BDMDX(D)="",CNT=CNT+1,H=1 I D>$$FMADD^XLFDT(EDATE,-365) S B=1
.Q:H
.Q
I CNT>1,B D G MA
.;SET BDMD TO SECOND VISIT DATE
.S X=0,C=0 F S X=$O(BDMDX(X)) Q:X'=+X!(C>1) S C=C+1 I C=2 S BDMD=X
;
PROB ;
I '$G(B) Q "" ;no pregnancy visit during time period ;-Lori fix in 09
S T=$O(^ATXAX("B","BGP PREGNANCY DIAGNOSES 2",0))
S (X,G)=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G) D
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.Q:$P(^AUPNPROB(X,0),U,12)="I"
.Q:$P(^AUPNPROB(X,0),U,8)>EDATE
.Q:$P(^AUPNPROB(X,0),U,8)<BDATE
.S Y=$P(^AUPNPROB(X,0),U)
.Q:'$$ICD^BDMUTL(Y,T,9)
.S G=$P(^AUPNPROB(X,0),U,8)
.Q
I G=0,BDMD="" Q 0
S BDMD=G
MA ;now check for abortion or miscarriage
K BDMG S Y="BDMG(" S X=P_"^LAST DX [BGP MISCARRIAGE/ABORTION DXS;DURING "_$$FMTE^XLFDT(BDMD)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(BDMG(1)) Q 0 ;HAD MIS/AB
S BDMG=$$LASTPRCT^BDMAPIU(P,BDATE,EDATE,"BGP ABORTION PROCEDURES","A")
I BDMG Q 0
S T=$O(^ATXAX("B","BGP MISCARRIAGE/ABORTION DXS",0))
S (X,G)=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G) D
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.Q:$P(^AUPNPROB(X,0),U,12)="I"
.Q:$P(^AUPNPROB(X,0),U,8)<BDMD
.Q:$P(^AUPNPROB(X,0),U,8)>EDATE
.S Y=$P(^AUPNPROB(X,0),U)
.Q:'$$ICD^BDMUTL(Y,T,9)
.S G=1
.Q
I G Q 0
;now check CPTs for Abortion and Miscarriage
S T=$O(^ATXAX("B","BGP CPT ABORTION",0))
S %=$$CPT^BDMDFDU(P,BDMD,EDATE,T,3)
I %]"" Q 0
S T=$O(^ATXAX("B","BGP CPT MISCARRIAGE",0))
S %=$$CPT^BDMDFDU(P,BDMD,EDATE,T,3)
I %]"" Q 0
S T=$O(^ATXAX("B","BGP CPT ABORTION",0))
S %=$$TRAN^BDMDFDU(P,BDMD,EDATE,T,3)
I %]"" Q 0
S T=$O(^ATXAX("B","BGP CPT MISCARRIAGE",0))
S %=$$TRAN^BDMDFDU(P,BDMD,EDATE,T,3)
I %]"" Q 0
I FORM="" Q 1
Q 1_U_$$DATE^BDMS9B1(BDMD)
PREGX(P,BDATE,EDATE,NORXCHR,NORX,RPBD) ;EP
NEW BDMDX,B,CNT,BDMD,BDMG,Y,X,D,C,T,G,%
I $P(^DPT(P,0),U,2)'="F" Q ""
S B=0,CNT=0,BDMD="" ;if there is one before time frame set this to 1
S NORXCHR=$G(NORXCHR)
S NORX=$G(NORX)
K BDMG
S Y="BDMG("
S X=P_"^ALL DX [BGP PREGNANCY DIAGNOSES 2;DURING "_$$DATE^BDMS9B1(BDATE)_"-"_$$DATE^BDMS9B1(EDATE) S E=$$START1^APCLDF(X,Y)
;now reorder by date of diagnosis and eliminate all chr and rx if necessary
I '$D(BDMG) G PROB ;no diagnoses
S B=0,X=0 F S X=$O(BDMG(X)) Q:X'=+X D
.;get date
.S D=$P(BDMG(X),U,1)
.S C=$$CLINIC^APCLV($P(BDMG(X),U,5),"C")
.I NORXCHR,C=39 Q
.I NORX,C=39 Q
.S C=$$PRIMPROV^APCLV($P(BDMG(X),U,5),"D")
.I NORXCHR,C=53 Q ;no chr as primary provider
.S BDMDX(D)="",CNT=CNT+1 I CNT=2 S BDMD=D
.Q
I CNT>1 Q 1
PROBX ;
I '$G(B) Q "" ;no pregnancy visit during time period ;-Lori fix in 09
S T=$O(^ATXAX("B","BGP PREGNANCY DIAGNOSES 2",0))
S (X,G)=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G) D
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.Q:$P(^AUPNPROB(X,0),U,12)="I"
.Q:$P(^AUPNPROB(X,0),U,8)>EDATE
.Q:$P(^AUPNPROB(X,0),U,8)<BDATE
.S Y=$P(^AUPNPROB(X,0),U)
.Q:'$$ICD^BDMUTL(Y,"BGP PREGNANCY DIAGNOSES 2",9)
.S G=$P(^AUPNPROB(X,0),U,8)
.Q
I G Q 1
Q 0
STATE(P) ;EP - STATE OF PATIENT1)
I '$G(P) Q ""
NEW X,C
S X=$$GET1^DIQ(2,P,.115,"I")
I 'X Q ""
I +$$GET1^DIQ(5,X,2)>69 Q ""
Q $$GET1^DIQ(5,X,1)
CESS ;EP - find any cessation hf in 12 months before
I '$G(P) Q ""
I $P($$TOBACCO^BDMDF1T(P,$$DOB^AUPNPAT(P),EDATE),U,1)'=1 Q ""
NEW BDM,E,X,G,T,O,D,H,C,Q,BDMLPED,SN,SNY
S BDMLPED=""
K BDM
S T=$O(^ATXAX("B","DM AUDIT CESSATION HLTH FACTOR",0))
S (H,D)=0 S O=""
S H=0 F S H=$O(^AUPNVHF("AA",P,H)) Q:H'=+H!(O]"") D
.S G=0
.I $D(^ATXAX(T,21,"AA",H)) S G=1
.I $P(^AUTTHF(H,0),U,1)["CESSATION",$$VAL^XBDIQ1(9999999.64,H,.03)["TOBACCO" S G=1
.Q:'G
.S D="" F S D=$O(^AUPNVHF("AA",P,H,D)) Q:D'=+D!(BDMLPED]"") D
..Q:(9999999-D)>EDATE ;after time frame
..Q:(9999999-D)<BDATE ;before time frame
..S BDMLPED=(9999999-D)_U_$P(^AUTTHF(H,0),U)
.Q
NEW BDMALLED,X,Y,%,T,G,A,B,E,Z,BDMMEDS1,Q,SN,SN1,SN2,SN3
K BDMALLED
S Y="BDMALLED("
S X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
S %="",SNY=$O(^BDMSNME("B",2018,0)),SN=$O(^BDMSNME(SNY,11,"B","PXRM BGP TOBACCO TOPICS",0))
S SN1=$O(^BDMSNME(SNY,11,"B","PXRM BGP TOBACCO SMOKER",0))
S SN2=$O(^BDMSNME(SNY,11,"B","PXRM BGP TOBACCO SMOKELESS",0))
S SN3=$O(^BDMSNME(SNY,11,"B","PXRM BGP QUIT TOBACCO",0))
I $D(BDMALLED(1)) S %="" D I %]"" S BDMLPED=%
.S (X,D)=0,T="" F S X=$O(BDMALLED(X)) Q:X'=+X D
..S T=$P(^AUPNVPED(+$P(BDMALLED(X),U,4),0),U)
..Q:'T
..Q:'$D(^AUTTEDT(T,0))
..S T=$P(^AUTTEDT(T,0),U,2)
..I $P(T,"-")="TO",$P(BDMLPED,U)<$P(BDMALLED(X),U) S %=$P(BDMALLED(X),U)_U_T Q
..I $P(T,"-",2)="TO",$P(BDMLPED,U)<$P(BDMALLED(X),U) S %=$P(BDMALLED(X),U)_U_T Q
..I $P(T,"-",2)="SHS",$P(BDMLPED,U)<$P(BDMALLED(X),U) S %=$P(BDMALLED(X),U)_U_T Q
..;make the call here to the BGP SMOKING DXS taxonomy
..;p8 ICD-10
..N CODE
..S CODE=$P($$CODEN^BDMUTL($P(T,"-",1),80),"~")
..I CODE>0 D
...N TAX
...S TAX=$O(^ATXAX("B","BGP TOBACCO USER DXS",0))
...I $$ICD^BDMUTL(CODE,"BGP TOBACCO USER DXS",9),$P(BDMLPED,U)<$P(BDMALLED(X),U) S %=$P(BDMALLED(X),U)_U_T Q
..I $P(T,"-",1)="D1320"!($P(T,"-")="99406")!($P(T,"-")="99407")!($P(T,"-")="G0375")!($P(T,"-")="G0376")!($P(T,"-")="4000F")!($P(T,"-")="G8402")!($P(T,"-")="G8453"),$P(BDMLPED,U)<$P(BDMALLED(X),U) S %=$P(BDMALLED(X),U)_U_T Q
..I $P(T,"-")]"",$D(^BDMSNME(SNY,11,SN,11,"B",$P(T,"-"))),$P(BDMLPED,U)<$P(BDMALLED(X),U) S %=$P(BDMALLED(X),U)_U_T Q
..I $P(T,"-")]"",$D(^BDMSNME(SNY,11,SN1,11,"B",$P(T,"-"))),$P(BDMLPED,U)<$P(BDMALLED(X),U) S %=$P(BDMALLED(X),U)_U_T Q
..I $P(T,"-")]"",$D(^BDMSNME(SNY,11,SN2,11,"B",$P(T,"-"))),$P(BDMLPED,U)<$P(BDMALLED(X),U) S %=$P(BDMALLED(X),U)_U_T Q
..I $P(T,"-")]"",$D(^BDMSNME(SNY,11,SN3,11,"B",$P(T,"-"))),$P(BDMLPED,U)<$P(BDMALLED(X),U) S %=$P(BDMALLED(X),U)_U_T Q
K ^TMP($J,"A")
S A="^TMP($J,""A"",",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
S X=0,G="" F S X=$O(^TMP($J,"A",X)) Q:X'=+X S V=$P(^TMP($J,"A",X),U,5) D
.Q:'$D(^AUPNVSIT(V,0))
.Q:'$P(^AUPNVSIT(V,0),U,9)
.Q:$P(^AUPNVSIT(V,0),U,11)
.S B=$$CLINIC^APCLV(V,"C")
.I B=94,$P(BDMLPED,U)<$P($P(^AUPNVSIT(V,0),U),".") S BDMLPED=$P($P(^AUPNVSIT(V,0),U),".")_U_"Clinic 94" Q
.S Z=0 F S Z=$O(^AUPNVDEN("AD",V,Z)) Q:Z'=+Z!(G) S B=$P($G(^AUPNVDEN(Z,0)),U) I B S B=$P($G(^AUTTADA(B,0)),U) I B=1320,$P(BDMLPED,U)<$P($P(^AUPNVSIT(V,0),U),".") S BDMLPED=$P($P(^AUPNVSIT(V,0),U),".")_U_"ADA 1320" Q
.Q
;I BDMLPED]"" Q "1 Yes "_$$DATE^BDMS9B1($P(BDMLPED,U,1))_" "_$P(BDMLPED,U,2)
S G=$$CPTI^BDMDFDU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("D1320")) I G,$P(BDMLPED,U)<$P(G,U,2) S BDMLPED=$P(G,U,2)_U_"CPT D1320"
S G=$$TRANI^BDMDFDU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("D1320")) I G,$P(BDMLPED,U)<$P(G,U,2) S BDMLPED=$P(G,U,2)_U_"TRAN D1320"
S G=$$CPTI^BDMDFDU(P,BDATE,EDATE,+$$CODEN^ICPTCOD(99406)) I G,$P(BDMLPED,U)<$P(G,U,2) S BDMLPED=$P(G,U,2)_U_"CPT 99406"
S G=$$TRANI^BDMDFDU(P,BDATE,EDATE,+$$CODEN^ICPTCOD(99406)) I G,$P(BDMLPED,U)<$P(G,U,2) S BDMLPED=$P(G,U,2)_U_"TRAN 99406"
S G=$$CPTI^BDMDFDU(P,BDATE,EDATE,+$$CODEN^ICPTCOD(99407)) I G,$P(BDMLPED,U)<$P(G,U,2) S BDMLPED=$P(G,U,2)_U_"CPT 99407"
S G=$$TRANI^BDMDFDU(P,BDATE,EDATE,+$$CODEN^ICPTCOD(99407)) I G,$P(BDMLPED,U)<$P(G,U,2) S BDMLPED=$P(G,U,2)_U_"TRAN 99407"
S G=$$CPTI^BDMDFDU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G0375")) I G,$P(BDMLPED,U)<$P(G,U,2) S BDMLPED=$P(G,U,2)_U_"CPT G0375"
S G=$$CPTI^BDMDFDU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G0376")) I G,$P(BDMLPED,U)<$P(G,U,2) S BDMLPED=$P(G,U,2)_U_"CPT G0376"
S G=$$CPTI^BDMDFDU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("4000F")) I G,$P(BDMLPED,U)<$P(G,U,2) S BDMLPED=$P(G,U,2)_U_"CPT 4000F"
S G=$$TRANI^BDMDFDU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G0375")) I G,$P(BDMLPED,U)<$P(G,U,2) S BDMLPED=$P(G,U,2)_U_"TRAN G0375"
S G=$$TRANI^BDMDFDU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G0376")) I G,$P(BDMLPED,U)<$P(G,U,2) S BDMLPED=$P(G,U,2)_U_"TRAN G0376"
S G=$$TRANI^BDMDFDU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("4000F")) I G,$P(BDMLPED,U)<$P(G,U,2) S BDMLPED=$P(G,U,2)_U_"TRAN 4000F"
S G=$$CPTI^BDMDFDU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("4001F")) I G,$P(BDMLPED,U)<$P(G,U,2) S BDMLPED=$P(G,U,2)_U_"CESSATION MED - CPT 4001F"
S G=$$TRANI^BDMDFDU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("4001F")) I G,$P(BDMLPED,U)<$P(G,U,2) S BDMLPED=$P(G,U,2)_U_"TRAN 4001F"
S G=$$CPTI^BDMDFDU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G8402")) I G,$P(BDMLPED,U)<$P(G,U,2) S BDMLPED=$P(G,U,2)_U_"CPT G8402"
S G=$$TRANI^BDMDFDU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G8402")) I G,$P(BDMLPED,U)<$P(G,U,2) S BDMLPED=$P(G,U,2)_U_"TRAN G8402"
S G=$$CPTI^BDMDFDU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G8453")) I G,$P(BDMLPED,U)<$P(G,U,2) S BDMLPED=$P(G,U,2)_U_"CPT G8453"
S G=$$TRANI^BDMDFDU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G8453")) I G,$P(BDMLPED,U)<$P(G,U,2) S BDMLPED=$P(G,U,2)_U_"TRAN G8453"
I BDMLPED]"" Q "1 Yes "_$$DATE^BDMS9B1($P(BDMLPED,U,1))_" "_$P(BDMLPED,U,2)
;now check meds
K BDMMEDS1
D GETMEDS^BDMDFDU(P,BDATE,EDATE,,,,,.BDMMEDS1)
S T=$O(^ATXAX("B","BGP CMS SMOKING CESSATION MEDS",0))
S T1=$O(^ATXAX("B","BGP CMS SMOKING CESSATION NDC",0))
S (X,G,M,E)=0,D="" F S X=$O(BDMMEDS1(X)) Q:X'=+X S V=$P(BDMMEDS1(X),U,5),Y=+$P(BDMMEDS1(X),U,4) D
.Q:'$D(^AUPNVSIT(V,0))
.Q:$$UP^XLFSTR($P($G(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK" ;new in v11.0
.S Z=$P($G(^AUPNVMED(Y,0)),U) ;get drug ien
.Q:'Z
.S N=$P($G(^PSDRUG(Z,0)),U)
.I $D(^ATXAX(T,21,"B",Z))!(N["NICOTINE TRANS")!(N["NICOTINE PATCH")!(N["NICOTINE POLACRILEX")!(N["NICOTINE INHALER")!(N["NICOTINE NASAL SPRAY") D
..I $P(BDMLPED,U)<$P($P(^AUPNVSIT(V,0),U),".") S BDMLPED=$P($P(^AUPNVSIT(V,0),U),".")_U_"CESSATION MED - "_N
.S C=$P($G(^PSDRUG(Z,2)),U,4)
.I C]"",$D(^ATXAX(T1,21,"B",C)) I $P(BDMLPED,U)<$P($P(^AUPNVSIT(V,0),U),".") S BDMLPED=$P($P(^AUPNVSIT(V,0),U),".")_U_"CESSATION MED - "_N
I BDMLPED]"" Q "1 Yes "_$$DATE^BDMS9B1($P(BDMLPED,U,1))_" "_$P(BDMLPED,U,2)
PEDREF ; REFUSALS REMOVED 2018 AUDIT
Q "2 No"
BDMDF1B ; IHS/CMI/LAB - get dm audit values ;
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**11**;JUN 14, 2007;Build 30
+2 ;
TD(P,EDATE) ;EP
+1 ;
+2 NEW BDM1
+3 SET BDM1=$$TD^BDMS9B3(P,$$DOB^AUPNPAT(P),EDATE)
+4 NEW D,X
SET D=$PIECE(BDM1," ",2)
SET X=""
+5 IF D]""
NEW X
SET X=D
DO ^%DT
SET X=$$DATE^BDMS9B1(Y)
+6 IF $EXTRACT(BDM1)="Y"
QUIT "1 "_$PIECE(BDM1," ",1)_" "_X
+7 IF $EXTRACT(BDM1)="N"
QUIT "2 "_$PIECE(BDM1," ",1)_" "_X
+8 IF $EXTRACT(BDM1)="R"
QUIT "3 "_$PIECE(BDM1," ",1)_" "_X
+9 QUIT ""
TDAP(P,BDMSED,F) ;EP
+1 NEW BDMY,X,E,B,%DT,Y,TDD
+2 SET TDD=$$LASTTDAP(P,BDMSED)
+3 IF TDD
QUIT "1 Yes "_$SELECT($GET(F)="A":$$DATE^BDMS9B1(TDD),1:$$DATE^BDMS9B1(TDD))
+4 SET R=""
SET G=""
FOR R=115
IF R=""!(G)
QUIT
Begin DoDot:1
+5 SET G=$$REFUSAL^BDMDF17(P,9999999.14,$ORDER(^AUTTIMM("C",R,0)),$$FMADD^XLFDT(DT,-365),DT,"R")
End DoDot:1
+6 IF G
QUIT "3 Refused "_$PIECE(G,U,3)
+7 ;; BI REFUSALS
+8 SET G=""
FOR Z=115
IF G
QUIT
SET X=0
SET Y=$ORDER(^AUTTIMM("C",Z,0))
IF Y
FOR
SET X=$ORDER(^BIPC("AC",P,Y,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+9 SET R=$PIECE(^BIPC(X,0),U,3)
+10 IF R=""
QUIT
+11 IF '$DATA(^BICONT(R,0))
QUIT
+12 IF $PIECE(^BICONT(R,0),U,1)'["Refusal"
QUIT
+13 SET D=$PIECE(^BIPC(X,0),U,4)
+14 IF D=""
QUIT
+15 IF D<$$FMADD^XLFDT(DT,-365)
QUIT
+16 SET G=1_U_D
End DoDot:1
+17 IF G
QUIT "3 Refused "_$SELECT($GET(F)="A":$$DATE^BDMS9B1($PIECE(G,U,2)),1:$$DATE^BDMS9B1($PIECE(G,U,2)))
+18 QUIT "2 No "_$SELECT($GET(F)="A":$$DATE^BDMS9B1(TDD),1:$$DATE^BDMS9B1(TDD))
LASTTDAP(BDMPDFN,BDMED) ;PEP - date of last TD
+1 ;
+2 IF $GET(BDMPDFN)=""
QUIT ""
+3 SET BDMBD=$$DOB^AUPNPAT(BDMPDFN)
+4 IF $GET(BDMED)=""
SET BDMED=DT
+5 NEW BDMLAST,BDMVAL,BDMX,R,X,Y,V,E,T,G,BDMY,BDMF
+6 SET BDMLAST=""
+7 SET BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"115","IMMUNIZATION",$SELECT($PIECE(BDMLAST,U)]"":$PIECE(BDMLAST,U),1:BDMBD),BDMED,"A")
+8 SET BDMF=$$LASTCPTI^BDMSMU2(BDMPDFN,90715,BDMBD,BDMED)
+9 IF BDMF
IF $PIECE(BDMF,U,3)>$PIECE(BDMVAL,U,1)
QUIT $PIECE(BDMF,U,3)
+10 QUIT $PIECE(BDMVAL,U,1)
PREG(P,BDATE,EDATE,NORXCHR,NORX,CPBD,CPED) ;EP
+1 IF $PIECE(^DPT(P,0),U,2)'="F"
QUIT ""
+2 NEW B,E,A,CNT,BDMD,BDMG,X,Y,BDMDX,C,D,G,T,%,CTR,VIEN,DXT,PXT,CPTT,BDMV,H
+3 IF '$GET(FORM)
SET FORM=""
+4 IF $GET(CPBD)=""
SET CPBD=BDATE
+5 IF $GET(CPED)=""
SET CPED=EDATE
+6 SET A=""
+7 IF $PIECE($GET(^AUPNREP(P,11)),U,1)="Y"
Begin DoDot:1
+8 SET B=$PIECE($GET(^AUPNREP(P,11)),U,2)
IF B=""
QUIT
+9 IF B<CPBD
QUIT
+10 IF B>CPED
QUIT
+11 SET A=1
+12 QUIT
End DoDot:1
IF A
SET BDMD=B
GOTO MA
+13 SET BDMD=""
+14 DO ALLV^APCLAPIU(P,BDATE,EDATE,"BDMV")
+15 IF '$DATA(BDMV)
GOTO PROB
+16 ;if there is one before time frame set this to 1
SET B=0
SET CNT=0
SET BDMD=""
+17 SET NORXCHR=$GET(NORXCHR)
+18 SET NORX=$GET(NORX)
+19 KILL BDMG
+20 SET DXT="BGP PREGNANCY DIAGNOSES 2"
+21 SET PXT="BGP PREGNANCY ICD PROCEDURES"
+22 SET CPTT="BGP PREGNANCY CPT CODES"
+23 ;CHECK DX, PROCS, CPTS for 2 separate visits
+24 SET B=0
SET CTR=0
FOR
SET CTR=$ORDER(BDMV(CTR))
IF CTR'=+CTR
QUIT
Begin DoDot:1
+25 ;get visit into VIEN
+26 SET VIEN=$PIECE(BDMV(CTR),U,5)
+27 SET D=$$VD^APCLV(VIEN)
+28 SET C=$$CLINIC^APCLV(VIEN,"C")
+29 IF NORXCHR
IF C=39
QUIT
+30 IF NORX
IF C=39
QUIT
+31 SET C=$$PRIMPROV^APCLV(VIEN,"D")
+32 ;no chr as primary provider
IF NORXCHR
IF C=53
QUIT
+33 ;now check for dx
+34 SET Y=0
SET H=""
FOR
SET Y=$ORDER(^AUPNVPOV("AD",VIEN,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+35 SET %=+^AUPNVPOV(Y,0)
+36 IF $$ICD^BDMUTL(%,DXT,9)
SET BDMDX(D)=""
SET CNT=CNT+1
SET H=1
IF D>$$FMADD^XLFDT(EDATE,-365)
SET B=1
End DoDot:2
+37 IF H
QUIT
+38 ;NOW GO THROUGH CPTS
+39 SET Y=0
SET H=""
FOR
SET Y=$ORDER(^AUPNVCPT("AD",VIEN,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+40 SET %=+^AUPNVCPT(Y,0)
+41 IF $$ICD^BDMUTL(%,CPTT,1)
IF '$DATA(BDMDX(D))
SET BDMDX(D)=""
SET CNT=CNT+1
SET H=1
IF D>$$FMADD^XLFDT(EDATE,-365)
SET B=1
End DoDot:2
+42 IF H
QUIT
+43 ;NOW PROCEDURES
+44 SET Y=0
SET H=""
FOR
SET Y=$ORDER(^AUPNVPRC("AD",VIEN,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+45 SET %=+^AUPNVPRC(Y,0)
+46 IF $$ICD^BDMUTL(%,PXT,0)
IF '$DATA(BDMDX(D))
SET BDMDX(D)=""
SET CNT=CNT+1
SET H=1
IF D>$$FMADD^XLFDT(EDATE,-365)
SET B=1
End DoDot:2
+47 IF H
QUIT
+48 QUIT
End DoDot:1
+49 IF CNT>1
IF B
Begin DoDot:1
+50 ;SET BDMD TO SECOND VISIT DATE
+51 SET X=0
SET C=0
FOR
SET X=$ORDER(BDMDX(X))
IF X'=+X!(C>1)
QUIT
SET C=C+1
IF C=2
SET BDMD=X
End DoDot:1
GOTO MA
+52 ;
PROB ;
+1 ;no pregnancy visit during time period ;-Lori fix in 09
IF '$GET(B)
QUIT ""
+2 SET T=$ORDER(^ATXAX("B","BGP PREGNANCY DIAGNOSES 2",0))
+3 SET (X,G)=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+4 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+5 IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+6 IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+7 IF $PIECE(^AUPNPROB(X,0),U,8)<BDATE
QUIT
+8 SET Y=$PIECE(^AUPNPROB(X,0),U)
+9 IF '$$ICD^BDMUTL(Y,T,9)
QUIT
+10 SET G=$PIECE(^AUPNPROB(X,0),U,8)
+11 QUIT
End DoDot:1
+12 IF G=0
IF BDMD=""
QUIT 0
+13 SET BDMD=G
MA ;now check for abortion or miscarriage
+1 KILL BDMG
SET Y="BDMG("
SET X=P_"^LAST DX [BGP MISCARRIAGE/ABORTION DXS;DURING "_$$FMTE^XLFDT(BDMD)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+2 ;HAD MIS/AB
IF $DATA(BDMG(1))
QUIT 0
+3 SET BDMG=$$LASTPRCT^BDMAPIU(P,BDATE,EDATE,"BGP ABORTION PROCEDURES","A")
+4 IF BDMG
QUIT 0
+5 SET T=$ORDER(^ATXAX("B","BGP MISCARRIAGE/ABORTION DXS",0))
+6 SET (X,G)=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+7 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+8 IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+9 IF $PIECE(^AUPNPROB(X,0),U,8)<BDMD
QUIT
+10 IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+11 SET Y=$PIECE(^AUPNPROB(X,0),U)
+12 IF '$$ICD^BDMUTL(Y,T,9)
QUIT
+13 SET G=1
+14 QUIT
End DoDot:1
+15 IF G
QUIT 0
+16 ;now check CPTs for Abortion and Miscarriage
+17 SET T=$ORDER(^ATXAX("B","BGP CPT ABORTION",0))
+18 SET %=$$CPT^BDMDFDU(P,BDMD,EDATE,T,3)
+19 IF %]""
QUIT 0
+20 SET T=$ORDER(^ATXAX("B","BGP CPT MISCARRIAGE",0))
+21 SET %=$$CPT^BDMDFDU(P,BDMD,EDATE,T,3)
+22 IF %]""
QUIT 0
+23 SET T=$ORDER(^ATXAX("B","BGP CPT ABORTION",0))
+24 SET %=$$TRAN^BDMDFDU(P,BDMD,EDATE,T,3)
+25 IF %]""
QUIT 0
+26 SET T=$ORDER(^ATXAX("B","BGP CPT MISCARRIAGE",0))
+27 SET %=$$TRAN^BDMDFDU(P,BDMD,EDATE,T,3)
+28 IF %]""
QUIT 0
+29 IF FORM=""
QUIT 1
+30 QUIT 1_U_$$DATE^BDMS9B1(BDMD)
PREGX(P,BDATE,EDATE,NORXCHR,NORX,RPBD) ;EP
+1 NEW BDMDX,B,CNT,BDMD,BDMG,Y,X,D,C,T,G,%
+2 IF $PIECE(^DPT(P,0),U,2)'="F"
QUIT ""
+3 ;if there is one before time frame set this to 1
SET B=0
SET CNT=0
SET BDMD=""
+4 SET NORXCHR=$GET(NORXCHR)
+5 SET NORX=$GET(NORX)
+6 KILL BDMG
+7 SET Y="BDMG("
+8 SET X=P_"^ALL DX [BGP PREGNANCY DIAGNOSES 2;DURING "_$$DATE^BDMS9B1(BDATE)_"-"_$$DATE^BDMS9B1(EDATE)
SET E=$$START1^APCLDF(X,Y)
+9 ;now reorder by date of diagnosis and eliminate all chr and rx if necessary
+10 ;no diagnoses
IF '$DATA(BDMG)
GOTO PROB
+11 SET B=0
SET X=0
FOR
SET X=$ORDER(BDMG(X))
IF X'=+X
QUIT
Begin DoDot:1
+12 ;get date
+13 SET D=$PIECE(BDMG(X),U,1)
+14 SET C=$$CLINIC^APCLV($PIECE(BDMG(X),U,5),"C")
+15 IF NORXCHR
IF C=39
QUIT
+16 IF NORX
IF C=39
QUIT
+17 SET C=$$PRIMPROV^APCLV($PIECE(BDMG(X),U,5),"D")
+18 ;no chr as primary provider
IF NORXCHR
IF C=53
QUIT
+19 SET BDMDX(D)=""
SET CNT=CNT+1
IF CNT=2
SET BDMD=D
+20 QUIT
End DoDot:1
+21 IF CNT>1
QUIT 1
PROBX ;
+1 ;no pregnancy visit during time period ;-Lori fix in 09
IF '$GET(B)
QUIT ""
+2 SET T=$ORDER(^ATXAX("B","BGP PREGNANCY DIAGNOSES 2",0))
+3 SET (X,G)=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+4 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+5 IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+6 IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+7 IF $PIECE(^AUPNPROB(X,0),U,8)<BDATE
QUIT
+8 SET Y=$PIECE(^AUPNPROB(X,0),U)
+9 IF '$$ICD^BDMUTL(Y,"BGP PREGNANCY DIAGNOSES 2",9)
QUIT
+10 SET G=$PIECE(^AUPNPROB(X,0),U,8)
+11 QUIT
End DoDot:1
+12 IF G
QUIT 1
+13 QUIT 0
STATE(P) ;EP - STATE OF PATIENT1)
+1 IF '$GET(P)
QUIT ""
+2 NEW X,C
+3 SET X=$$GET1^DIQ(2,P,.115,"I")
+4 IF 'X
QUIT ""
+5 IF +$$GET1^DIQ(5,X,2)>69
QUIT ""
+6 QUIT $$GET1^DIQ(5,X,1)
CESS ;EP - find any cessation hf in 12 months before
+1 IF '$GET(P)
QUIT ""
+2 IF $PIECE($$TOBACCO^BDMDF1T(P,$$DOB^AUPNPAT(P),EDATE),U,1)'=1
QUIT ""
+3 NEW BDM,E,X,G,T,O,D,H,C,Q,BDMLPED,SN,SNY
+4 SET BDMLPED=""
+5 KILL BDM
+6 SET T=$ORDER(^ATXAX("B","DM AUDIT CESSATION HLTH FACTOR",0))
+7 SET (H,D)=0
SET O=""
+8 SET H=0
FOR
SET H=$ORDER(^AUPNVHF("AA",P,H))
IF H'=+H!(O]"")
QUIT
Begin DoDot:1
+9 SET G=0
+10 IF $DATA(^ATXAX(T,21,"AA",H))
SET G=1
+11 IF $PIECE(^AUTTHF(H,0),U,1)["CESSATION"
IF $$VAL^XBDIQ1(9999999.64,H,.03)["TOBACCO"
SET G=1
+12 IF 'G
QUIT
+13 SET D=""
FOR
SET D=$ORDER(^AUPNVHF("AA",P,H,D))
IF D'=+D!(BDMLPED]"")
QUIT
Begin DoDot:2
+14 ;after time frame
IF (9999999-D)>EDATE
QUIT
+15 ;before time frame
IF (9999999-D)<BDATE
QUIT
+16 SET BDMLPED=(9999999-D)_U_$PIECE(^AUTTHF(H,0),U)
End DoDot:2
+17 QUIT
End DoDot:1
+18 NEW BDMALLED,X,Y,%,T,G,A,B,E,Z,BDMMEDS1,Q,SN,SN1,SN2,SN3
+19 KILL BDMALLED
+20 SET Y="BDMALLED("
+21 SET X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+22 SET %=""
SET SNY=$ORDER(^BDMSNME("B",2018,0))
SET SN=$ORDER(^BDMSNME(SNY,11,"B","PXRM BGP TOBACCO TOPICS",0))
+23 SET SN1=$ORDER(^BDMSNME(SNY,11,"B","PXRM BGP TOBACCO SMOKER",0))
+24 SET SN2=$ORDER(^BDMSNME(SNY,11,"B","PXRM BGP TOBACCO SMOKELESS",0))
+25 SET SN3=$ORDER(^BDMSNME(SNY,11,"B","PXRM BGP QUIT TOBACCO",0))
+26 IF $DATA(BDMALLED(1))
SET %=""
Begin DoDot:1
+27 SET (X,D)=0
SET T=""
FOR
SET X=$ORDER(BDMALLED(X))
IF X'=+X
QUIT
Begin DoDot:2
+28 SET T=$PIECE(^AUPNVPED(+$PIECE(BDMALLED(X),U,4),0),U)
+29 IF 'T
QUIT
+30 IF '$DATA(^AUTTEDT(T,0))
QUIT
+31 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+32 IF $PIECE(T,"-")="TO"
IF $PIECE(BDMLPED,U)<$PIECE(BDMALLED(X),U)
SET %=$PIECE(BDMALLED(X),U)_U_T
QUIT
+33 IF $PIECE(T,"-",2)="TO"
IF $PIECE(BDMLPED,U)<$PIECE(BDMALLED(X),U)
SET %=$PIECE(BDMALLED(X),U)_U_T
QUIT
+34 IF $PIECE(T,"-",2)="SHS"
IF $PIECE(BDMLPED,U)<$PIECE(BDMALLED(X),U)
SET %=$PIECE(BDMALLED(X),U)_U_T
QUIT
+35 ;make the call here to the BGP SMOKING DXS taxonomy
+36 ;p8 ICD-10
+37 NEW CODE
+38 SET CODE=$PIECE($$CODEN^BDMUTL($PIECE(T,"-",1),80),"~")
+39 IF CODE>0
Begin DoDot:3
+40 NEW TAX
+41 SET TAX=$ORDER(^ATXAX("B","BGP TOBACCO USER DXS",0))
+42 IF $$ICD^BDMUTL(CODE,"BGP TOBACCO USER DXS",9)
IF $PIECE(BDMLPED,U)<$PIECE(BDMALLED(X),U)
SET %=$PIECE(BDMALLED(X),U)_U_T
QUIT
End DoDot:3
+43 IF $PIECE(T,"-",1)="D1320"!($PIECE(T,"-")="99406")!($PIECE(T,"-")="99407")!($PIECE(T,"-")="G0375")!($PIECE(T,"-")="G0376")!($PIECE(T,"-")="4000F")!($PIECE(T,"-")="G8402")!($PIECE(T,"-")="G8453")
IF $PIECE(BDMLPED,U)<$PIECE(BDMALLED(X),U)
SET %=$PIECE(BDMALLED(X),U)_U_T
QUIT
+44 IF $PIECE(T,"-")]""
IF $DATA(^BDMSNME(SNY,11,SN,11,"B",$PIECE(T,"-")))
IF $PIECE(BDMLPED,U)<$PIECE(BDMALLED(X),U)
SET %=$PIECE(BDMALLED(X),U)_U_T
QUIT
+45 IF $PIECE(T,"-")]""
IF $DATA(^BDMSNME(SNY,11,SN1,11,"B",$PIECE(T,"-")))
IF $PIECE(BDMLPED,U)<$PIECE(BDMALLED(X),U)
SET %=$PIECE(BDMALLED(X),U)_U_T
QUIT
+46 IF $PIECE(T,"-")]""
IF $DATA(^BDMSNME(SNY,11,SN2,11,"B",$PIECE(T,"-")))
IF $PIECE(BDMLPED,U)<$PIECE(BDMALLED(X),U)
SET %=$PIECE(BDMALLED(X),U)_U_T
QUIT
+47 IF $PIECE(T,"-")]""
IF $DATA(^BDMSNME(SNY,11,SN3,11,"B",$PIECE(T,"-")))
IF $PIECE(BDMLPED,U)<$PIECE(BDMALLED(X),U)
SET %=$PIECE(BDMALLED(X),U)_U_T
QUIT
End DoDot:2
End DoDot:1
IF %]""
SET BDMLPED=%
+48 KILL ^TMP($JOB,"A")
+49 SET A="^TMP($J,""A"","
SET B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(B,A)
+50 SET X=0
SET G=""
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X
QUIT
SET V=$PIECE(^TMP($JOB,"A",X),U,5)
Begin DoDot:1
+51 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+52 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+53 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+54 SET B=$$CLINIC^APCLV(V,"C")
+55 IF B=94
IF $PIECE(BDMLPED,U)<$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
SET BDMLPED=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")_U_"Clinic 94"
QUIT
+56 SET Z=0
FOR
SET Z=$ORDER(^AUPNVDEN("AD",V,Z))
IF Z'=+Z!(G)
QUIT
SET B=$PIECE($GET(^AUPNVDEN(Z,0)),U)
IF B
SET B=$PIECE($GET(^AUTTADA(B,0)),U)
IF B=1320
IF $PIECE(BDMLPED,U)<$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
SET BDMLPED=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")_U_"ADA 1320"
QUIT
+57 QUIT
End DoDot:1
+58 ;I BDMLPED]"" Q "1 Yes "_$$DATE^BDMS9B1($P(BDMLPED,U,1))_" "_$P(BDMLPED,U,2)
+59 SET G=$$CPTI^BDMDFDU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("D1320"))
IF G
IF $PIECE(BDMLPED,U)<$PIECE(G,U,2)
SET BDMLPED=$PIECE(G,U,2)_U_"CPT D1320"
+60 SET G=$$TRANI^BDMDFDU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("D1320"))
IF G
IF $PIECE(BDMLPED,U)<$PIECE(G,U,2)
SET BDMLPED=$PIECE(G,U,2)_U_"TRAN D1320"
+61 SET G=$$CPTI^BDMDFDU(P,BDATE,EDATE,+$$CODEN^ICPTCOD(99406))
IF G
IF $PIECE(BDMLPED,U)<$PIECE(G,U,2)
SET BDMLPED=$PIECE(G,U,2)_U_"CPT 99406"
+62 SET G=$$TRANI^BDMDFDU(P,BDATE,EDATE,+$$CODEN^ICPTCOD(99406))
IF G
IF $PIECE(BDMLPED,U)<$PIECE(G,U,2)
SET BDMLPED=$PIECE(G,U,2)_U_"TRAN 99406"
+63 SET G=$$CPTI^BDMDFDU(P,BDATE,EDATE,+$$CODEN^ICPTCOD(99407))
IF G
IF $PIECE(BDMLPED,U)<$PIECE(G,U,2)
SET BDMLPED=$PIECE(G,U,2)_U_"CPT 99407"
+64 SET G=$$TRANI^BDMDFDU(P,BDATE,EDATE,+$$CODEN^ICPTCOD(99407))
IF G
IF $PIECE(BDMLPED,U)<$PIECE(G,U,2)
SET BDMLPED=$PIECE(G,U,2)_U_"TRAN 99407"
+65 SET G=$$CPTI^BDMDFDU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G0375"))
IF G
IF $PIECE(BDMLPED,U)<$PIECE(G,U,2)
SET BDMLPED=$PIECE(G,U,2)_U_"CPT G0375"
+66 SET G=$$CPTI^BDMDFDU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G0376"))
IF G
IF $PIECE(BDMLPED,U)<$PIECE(G,U,2)
SET BDMLPED=$PIECE(G,U,2)_U_"CPT G0376"
+67 SET G=$$CPTI^BDMDFDU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("4000F"))
IF G
IF $PIECE(BDMLPED,U)<$PIECE(G,U,2)
SET BDMLPED=$PIECE(G,U,2)_U_"CPT 4000F"
+68 SET G=$$TRANI^BDMDFDU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G0375"))
IF G
IF $PIECE(BDMLPED,U)<$PIECE(G,U,2)
SET BDMLPED=$PIECE(G,U,2)_U_"TRAN G0375"
+69 SET G=$$TRANI^BDMDFDU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G0376"))
IF G
IF $PIECE(BDMLPED,U)<$PIECE(G,U,2)
SET BDMLPED=$PIECE(G,U,2)_U_"TRAN G0376"
+70 SET G=$$TRANI^BDMDFDU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("4000F"))
IF G
IF $PIECE(BDMLPED,U)<$PIECE(G,U,2)
SET BDMLPED=$PIECE(G,U,2)_U_"TRAN 4000F"
+71 SET G=$$CPTI^BDMDFDU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("4001F"))
IF G
IF $PIECE(BDMLPED,U)<$PIECE(G,U,2)
SET BDMLPED=$PIECE(G,U,2)_U_"CESSATION MED - CPT 4001F"
+72 SET G=$$TRANI^BDMDFDU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("4001F"))
IF G
IF $PIECE(BDMLPED,U)<$PIECE(G,U,2)
SET BDMLPED=$PIECE(G,U,2)_U_"TRAN 4001F"
+73 SET G=$$CPTI^BDMDFDU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G8402"))
IF G
IF $PIECE(BDMLPED,U)<$PIECE(G,U,2)
SET BDMLPED=$PIECE(G,U,2)_U_"CPT G8402"
+74 SET G=$$TRANI^BDMDFDU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G8402"))
IF G
IF $PIECE(BDMLPED,U)<$PIECE(G,U,2)
SET BDMLPED=$PIECE(G,U,2)_U_"TRAN G8402"
+75 SET G=$$CPTI^BDMDFDU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G8453"))
IF G
IF $PIECE(BDMLPED,U)<$PIECE(G,U,2)
SET BDMLPED=$PIECE(G,U,2)_U_"CPT G8453"
+76 SET G=$$TRANI^BDMDFDU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G8453"))
IF G
IF $PIECE(BDMLPED,U)<$PIECE(G,U,2)
SET BDMLPED=$PIECE(G,U,2)_U_"TRAN G8453"
+77 IF BDMLPED]""
QUIT "1 Yes "_$$DATE^BDMS9B1($PIECE(BDMLPED,U,1))_" "_$PIECE(BDMLPED,U,2)
+78 ;now check meds
+79 KILL BDMMEDS1
+80 DO GETMEDS^BDMDFDU(P,BDATE,EDATE,,,,,.BDMMEDS1)
+81 SET T=$ORDER(^ATXAX("B","BGP CMS SMOKING CESSATION MEDS",0))
+82 SET T1=$ORDER(^ATXAX("B","BGP CMS SMOKING CESSATION NDC",0))
+83 SET (X,G,M,E)=0
SET D=""
FOR
SET X=$ORDER(BDMMEDS1(X))
IF X'=+X
QUIT
SET V=$PIECE(BDMMEDS1(X),U,5)
SET Y=+$PIECE(BDMMEDS1(X),U,4)
Begin DoDot:1
+84 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+85 ;new in v11.0
IF $$UP^XLFSTR($PIECE($GET(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"
QUIT
+86 ;get drug ien
SET Z=$PIECE($GET(^AUPNVMED(Y,0)),U)
+87 IF 'Z
QUIT
+88 SET N=$PIECE($GET(^PSDRUG(Z,0)),U)
+89 IF $DATA(^ATXAX(T,21,"B",Z))!(N["NICOTINE TRANS")!(N["NICOTINE PATCH")!(N["NICOTINE POLACRILEX")!(N["NICOTINE INHALER")!(N["NICOTINE NASAL SPRAY")
Begin DoDot:2
+90 IF $PIECE(BDMLPED,U)<$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
SET BDMLPED=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")_U_"CESSATION MED - "_N
End DoDot:2
+91 SET C=$PIECE($GET(^PSDRUG(Z,2)),U,4)
+92 IF C]""
IF $DATA(^ATXAX(T1,21,"B",C))
IF $PIECE(BDMLPED,U)<$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
SET BDMLPED=$PIECE($PIECE(^AUPNVSIT(V,0),U),".")_U_"CESSATION MED - "_N
End DoDot:1
+93 IF BDMLPED]""
QUIT "1 Yes "_$$DATE^BDMS9B1($PIECE(BDMLPED,U,1))_" "_$PIECE(BDMLPED,U,2)
PEDREF ; REFUSALS REMOVED 2018 AUDIT
+1 QUIT "2 No"
