BGP8PC13.m

BGP8PC13 ; IHS/CMI/LAB - measure I2 ; 26 Jul 2018  3:37 PM

 ;;18.1;IHS CLINICAL REPORTING;**1**;MAY 25, 2018;Build 65

 ;

TEST ;

 S DFN=13474

 S BGPVALUE=""

 S BGPBDATE=3171001

 S BGPEDATE=3180930

 D DRM

 W !,BGPVALUE

 Q

DRM ;EP - CALLED FROM IPC REPORT

 S (BGPN1,BGPD1)=0

 S BGPISD="" K BGPDEPV,BGPV,BGPDOV

 ;

 ;

 ;GATHER UP ALL DEP SCRN VISITS

 ;Let's check all Visits, looping through once

 S G=""  ;return variable

 K BGPV

 ;get all visits in date range in BGPV

 S BGPXBD=$$FMADD^XLFDT(BGPBDATE,-(397))

 S BGPXED=$$FMADD^XLFDT(BGPBDATE,-1)

 D ALLV^APCLAPIU(DFN,BGPXBD,BGPXED,"BGPV")

 ;now loop through and check SNOMED and .17 in visit and check v cpts attached to the visit

 ;REORDER BY DATE

 S X=0 F  S X=$O(BGPV(X)) Q:X'=+X  S BGPDOV($P(BGPV(X),U,1),"V",$P(BGPV(X),U,5))=BGPV(X)

 ;ADD IN BH VISITS BETWEEN BGPBD AND BGPED THAT AREN'T IN PCC

 S D=0,E=9999999-BGPXBD,D=9999999-BGPXED-1_".99" F  S D=$O(^AMHREC("AE",DFN,D)) Q:D'=+D!($P(D,".")>E)  S V=0 F  S V=$O(^AMHREC("AE",DFN,D,V)) Q:V'=+V  D

 .Q:$P(^AMHREC(V,0),U,16)  ;ALREADY IN PCC SO WOULD HAVE GOT IT ALREADY

 .S S=$P($$VALI^XBDIQ1(9002011,V,.01),".")

 .S BGPDOV(S,"Z",V)=S_U_U_U_U_V

 S BGPDD=0,G=0 F  S BGPDD=$O(BGPDOV(BGPDD)) Q:BGPDD'=+BGPDD!(BGPISD)  S T="" F  S T=$O(BGPDOV(BGPDD,T)) Q:T=""!(BGPISD)  S V=0 F  S V=$O(BGPDOV(BGPDD,T,V)) Q:V'=+V!(BGPISD)  D

 .S BGPP=0,BGPO=0

 .I T="V" D V Q

 .I T="Z" D BH Q

 ;

N1 I 'BGPISD S BGPSTOP=1 G DRME

 ;

 ;

 ;AGE ON INDEX START DATE?

 S A=$$AGE^AUPNPAT(DFN,$P(BGPISD,U,1))

 I A<18 S BGPSTOP=1 G DRME

 ;

 ;now what about exclusions?

 ;might as well process exclusions first;

 ;palliative care

 I $$PALLCARE(DFN,BGPBDATE,BGPEDATE) S BGPSTOP=1 G DRME

 ;

 ;long term care services

 I $$CARESERV(DFN,BGPBDATE,BGPEDATE) S BGPSTOP=1 G DRME

 ;

 ;has bipolar or personality disorder before end of report period

 I $$HASBPPD(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE) S BGPSTOP=1 G DRME

 ;

 ;FINALLY MADE DENOMINATOR

 S BGPD1=1

 S G=$$PHQ9N(DFN,$$FMADD^XLFDT($P(BGPISD,U,1),336),$$FMADD^XLFDT($P(BGPISD,U,1),397))

 I G S BGPN1=1 G DRM1

 S G=$$PHQ9NBH(DFN,$$FMADD^XLFDT($P(BGPISD,U,1),336),$$FMADD^XLFDT($P(BGPISD,U,1),397))

 I G S BGPN1=1

DRM1 ;

 S BGPVALUE=""

 S BGPVALUE="ENC "_$$DATE^BGP8UTL($P(BGPISD,U,1))_"|||"  ; PHQ9: "_$$VAL^XBDIQ1(9000010.01,$P(BGPISD,U,2),.04)_"|||"  ;hit denominator

 I BGPN1 S BGPVALUE=BGPVALUE_"*** "_$$DATE^BGP8UTL($P(G,U,2))_" "_$P(G,U,3)_": "_$P(G,U,4)

DRME ;

 K D,V,X,Y,BGPV,BGPDEPV,BGPISD,BGPDOV,G,BGPXBD,BGPXED,BGPDD,BGPP,BGPO

 Q

V ;

 Q:'$P(^AUPNVSIT(V,0),U,9)  ;no dependent entries

 Q:$P(^AUPNVSIT(V,0),U,11)  ;deleted

 ;is there a PHQ9 > 9?  if not, don't bother???

 S Q=$$PHQ9(V)

 I Q="" Q

 S Y=$$DEPV1(V) I Y S BGPISD=Q Q

 S Y=$$DEPV2(V) I Y S BGPISD=Q Q

 Q

BH ;

 ;is there a PHQ9 > 9?  if not, don't bother???

 S Q=$$PHQ9BH(V)

 I Q="" Q

 ;now check all V CPTs

 S Z=0 F  S Z=$O(^AMHRPROC("AD",V,Z)) Q:Z'=+Z!(BGPO)!(BGPP)  D

 .S Y=$P($G(^AMHRPROC(Z,0)),U,1)

 .I Y,$$ICD^ATXAPI(Y,$O(^ATXAX("B","BGP IPC OFFICE VISIT CPTS",0)),1) S BGPO=1 Q

 .I Y,$$ICD^ATXAPI(Y,$O(^ATXAX("B","BGP IPC PSYCH VISIT CPTS",0)),1) S BGPP=1 Q

 ;GO ON?

BHN ;

 ;now check for active problem list or primary POV 

 I BGPO S G=0 D  Q

 .;is there a primary or secondary V POV or an active PL entry

 .S X=0 F  S X=$O(^AMHRPRO("AD",V,X)) Q:X'=+X!(G)  D

 ..S Z=$P($G(^AMHRPRO(X,0)),U,1)

 ..I 'Z Q

 ..Q:'$D(^AMHPROB(Z,0))

 ..S C=$P(^AMHPROB(Z,0),U,5)

 ..I C="" S C=$P(^AMHPROB(Z,0),U,17)

 ..I C="" Q

 ..S C=+$$CODEN^BGP8UTL2(C,80)

 ..I 'C Q

 ..I $$ICD^BGP8UTL2(C,$O(^ATXAX("B","BGP IPC MAJOR DEPRESSION DXS",0)),1) S G=1,BGPISD=Q Q

 ..I $$ICD^BGP8UTL2(C,$O(^ATXAX("B","BGP IPC DYSTHYMIA DXS",0)),1) S G=1,BGPISD=Q Q

 .I G Q

 .I $$PLTAXND^BGP8DU(DFN,"BGP IPC MAJOR DEPRESSION DXS",BGPDD,1) S G=1,BGPISD=Q Q

 .I $$IPLSNOND^BGP8DU(DFN,"PXRM BGP IPC MAJOR DEP",BGPDD,1) S G=1,BGPISD=Q Q

 .I $$PLTAXND^BGP8DU(DFN,"BGP IPC DYSTHYMIA DXS",BGPDD,1) S G=1,BGPISD=Q Q

 .I $$IPLSNOND^BGP8DU(DFN,"PXRM BGP IPC DYSTHYMIA",BGPDD,1) S G=1,BGPISD=Q Q

 I BGPP S G=0 D  Q

 .S X=$O(^AMHRPRO("AD",V,0))

 .I 'X Q

 .S Z=$P($G(^AMHRPRO(X,0)),U,1)

 .I 'Z Q

 .Q:'$D(^AMHPROB(Z,0))

 .S C=$P(^AMHPROB(Z,0),U,5)

 .I C="" S C=$P(^AMHPROB(Z,0),U,17)

 .I C="" Q

 .S C=+$$CODEN^BGP8UTL2(C,80)

 .I 'C Q

 .I C,$$ICD^BGP8UTL2(C,$O(^ATXAX("B","BGP IPC MAJOR DEPRESSION DXS",0)),1) S G=1,BGPISD=Q Q

 .I C,$$ICD^BGP8UTL2(C,$O(^ATXAX("B","BGP IPC DYSTHYMIA DXS",0)),1) S G=1,BGPISD=Q

 Q

PHQ9(VST) ;

 NEW X,Y,Z

 S X=0,Z="" F  S X=$O(^AUPNVMSR("AD",VST,X)) Q:X'=+X  D

 .Q:$P($G(^AUPNVMSR(X,2)),U,1)  ;entered in error

 .S E=$$VAL^XBDIQ1(9000010.01,X,.01)

 .I E'="PHQ9" Q

 .S R=$$VAL^XBDIQ1(9000010.01,X,.04)

 .I R<10 Q

 .S Z=$$VD^APCLV(VST)

 Q Z

PHQ9BH(VST) ;

 NEW X,Y,Z

 S X=0,Z="" F  S X=$O(^AMHRMSR("AD",VST,X)) Q:X'=+X!(Z)  D

 .S E=$$VAL^XBDIQ1(9002011.12,X,.01)

 .I E'="PHQ9" Q

 .S R=$$VAL^XBDIQ1(9002011.12,X,.04)

 .I R<10 Q

 .S Z=$P($G(^AMHRMSR(X,0)),U,3)

 .I Z="" Q

 .S Z=$P($P($G(^AMHREC(Z,0)),U,1),".")

 Q Z

PHQ9N(P,BDATE,EDATE) ;

 NEW X,Y,Z,BGPG,G,E

 K BGPG

 S Y="BGPG(",G=""

 S X=P_"^ALL MEAS PHQ9;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)

 S E=0 F  S E=$O(BGPG(E)) Q:E'=+E!(G)  D

 .I $P(BGPG(E),U,2)<5 S G=1_U_$P(BGPG(E),U,1)_U_$P(BGPG(1),U,3)_U_$P(BGPG(1),U,2)

 Q G

PHQ9NBH(P,BDATE,EDATE) ;

 NEW X,Y,Z,ED,R

 S Z=$O(^AUTTMSR("B","PHQ9",0))

 S Y=""

 I 'Z Q ""

 S D=0 F  S D=$O(^AMHRMSR("AA",P,Z,D)) Q:D'=+D!(Y)  D

 .S ED=9999999-$P(D,".")

 .Q:ED<BDATE

 .Q:ED>EDATE

 .S X=0 F  S X=$O(^AMHRMSR("AA",P,Z,D,X)) Q:X'=+X!(Y)  D

 ..Q:'$D(^AMHRMSR(X,0))

 ..S R=$P(^AMHRMSR(X,0),U,4)

 ..I R]"",R<5 S Y=1_U_ED_U_"BH PHQ9"_U_R

 Q Y

PALLCARE(P,BDATE,EDATE) ;EP

 NEW X,Y,Z,BGPV,G,A,B

 I $$LASTDX^BGP8UTL1(P,"BGP IPC PALLIATIVE CARE DXS",BDATE,EDATE) Q 1

 ;SNOMED IN VISIT OR V POV

 D ALLV^APCLAPIU(DFN,BDATE,EDATE,"BGPV")

 ;

 ;now loop through and check SNOMED and .17 in visit and check v cpts attached to the visit

 ;REORDER BY DATE

 S X=0,G="" F  S X=$O(BGPV(X)) Q:X'=+X!(G)  S V=$P(BGPV(X),U,5) D

 .Q:'$P(^AUPNVSIT(V,0),U,9)  ;no dependent entries

 .Q:$P(^AUPNVSIT(V,0),U,11)  ;deleted

 .S A=0 F  S A=$O(^AUPNVSIT(V,28,"B",A)) Q:A=""!(G]"")  D

 ..I $D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP IPC PALLIATIVE",A)) S G=1 Q

 .I G Q

 .S A=0

 .F  S A=$O(^AUPNVSIT(V,26,"B",A)) Q:A=""!(G)  D

 ..I $D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP IPC PALLIATIVE",A)) S G=1

 .I G Q

 .;V POV

 .S A=0 F  S A=$O(^AUPNVPOV("AD",V,A)) Q:A=""!(G)  D

 ..S S=$$VALI^XBDIQ1(9000010.07,A,1101)

 ..Q:S=""

 ..I $D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP IPC PALLIATIVE",S)) S G=1

 I G Q G

 ;NOW REFERRALS

 S Z=0,G=0 F  S Z=$O(^AUPNVREF("AC",P,Z)) Q:Z'=+Z!(G)  D

 .S V=$P($G(^AUPNVREF(Z,0)),U,3)

 .S D=$$VD^APCLV(V)

 .Q:D<BDATE

 .Q:D>EDATE

 .S S=$P($G(^AUPNVREF(Z,0)),U,1) Q:S=""

 .Q:'$D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP IPC PALLIATIVE",S))

 .S G=1 Q

 Q G

DEPV1(V) ;EP

 NEW A,B,C,G,BGPISD

 S G=0

 S A=0,B="",BGPISD=""

 F  S A=$O(^AUPNVSIT(V,28,"B",A)) Q:A=""!(B]"")  D

 .I $D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP IPC FC2FC NO ED",A)) S B=A

 I B]"" G DEPV1N

 S A=0,B=""

 F  S A=$O(^AUPNVSIT(V,26,"B",A)) Q:A=""!(B]"")  D

 .I $D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP IPC FC2FC NO ED",A)) S B=A

 I B]"" G DEPV1N

 ;cpts?

 ;is .17 a cpt we want?

 S Y=$$VALI^XBDIQ1(9000010,V,.17)

 I Y,$$ICD^ATXAPI(Y,$O(^ATXAX("B","BGP IPC OFFICE VISIT CPTS",0)),1) G DEPV1N

 ;now check all V CPTs

 S Z=0 F  S Z=$O(^AUPNVCPT("AD",V,Z)) Q:Z'=+Z!(B)  D

 .S Y=$P($G(^AUPNVCPT(Z,0)),U,1)

 .I Y,$$ICD^ATXAPI(Y,$O(^ATXAX("B","BGP IPC OFFICE VISIT CPTS",0)),1) S B=1 Q

 I B G DEPV1N

 Q ""

DEPV1N ;

 ;now check for active problem list or primary POV 

 S G=0,BGPISD="" D

 .;is there a primary or secondary V POV or an active PL entry

 .S X=0 F  S X=$O(^AUPNVPOV("AD",V,X)) Q:X'=+X!(G)  D

 ..S C=$P($G(^AUPNVPOV(X,0)),U,1)

 ..I 'C Q

 ..I $$ICD^BGP8UTL2(C,$O(^ATXAX("B","BGP IPC MAJOR DEPRESSION DXS",0)),1) S G=1,BGPISD=Q Q

 ..I $$ICD^BGP8UTL2(C,$O(^ATXAX("B","BGP IPC DYSTHYMIA DXS",0)),1) S G=1,BGPISD=Q Q

 ..S C=$$VALI^XBDIQ1(9000010.07,X,1101)

 ..I C]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP IPC MAJOR DEP",C)) S G=1,BGPISD=Q Q

 ..I C]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP IPC DYSTHYMIA",C)) S G=1,BGPISD=Q Q

 .I G Q

 .I $$PLTAXND^BGP8DU(DFN,"BGP IPC MAJOR DEPRESSION DXS",BGPDD,1) S G=1,BGPISD=Q Q

 .I $$IPLSNOND^BGP8DU(DFN,"PXRM BGP IPC MAJOR DEP",BGPDD,1) S G=1,BGPISD=Q Q

 .I $$PLTAXND^BGP8DU(DFN,"BGP IPC DYSTHYMIA DXS",BGPDD,1) S G=1,BGPISD=Q Q

 .I $$IPLSNOND^BGP8DU(DFN,"PXRM BGP IPC DYSTHYMIA",BGPDD,1) S G=1,BGPISD=Q Q

 Q BGPISD

DEPV2(V) ;EP

 NEW A,B,C,G,BGPISD

 S G=0

 S A=0,B="",BGPISD=""

 ;cpts?

 ;is .17 a cpt we want?

 S Y=$$VALI^XBDIQ1(9000010,V,.17)

 I Y,$$ICD^ATXAPI(Y,$O(^ATXAX("B","BGP IPC PSYCH VISIT CPTS",0)),1) G DEPV2N

 ;now check all V CPTs

 S Z=0 F  S Z=$O(^AUPNVCPT("AD",V,Z)) Q:Z'=+Z!(B)  D

 .S Y=$P($G(^AUPNVCPT(Z,0)),U,1)

 .I Y,$$ICD^ATXAPI(Y,$O(^ATXAX("B","BGP IPC PSYCH VISIT CPTS",0)),1) S B=1 Q

 I B G DEPV2N

 I 'B Q ""

DEPV2N ;

 ;now check for active problem list or primary POV 

 S G=0,BGPISD="" D

 .S C=$$PRIMPOV^APCLV(V,"I")

 .I $$ICD^BGP8UTL2(C,$O(^ATXAX("B","BGP IPC MAJOR DEPRESSION DXS",0)),1) S G=1,BGPISD=Q Q

 .I $$ICD^BGP8UTL2(C,$O(^ATXAX("B","BGP IPC DYSTHYMIA DXS",0)),1) S G=1,BGPISD=Q Q

 .S I=$$PRIMPOV^APCLV(V,5)

 .S C=$$VALI^XBDIQ1(9000010.07,I,1101)

 .I C]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP IPC MAJOR DEP",C)) S G=1,BGPISD=Q Q

 .I C]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP IPC DYSTHYMIA",C)) S G=1,BGPISD=Q Q

 Q BGPISD

CARESERV(P,BDATE,EDATE) ;

 NEW X,Y,Z,G,BGPV,D,A,B

 ;Let's check all Visits, looping through once

 S G=""  ;return variable

 ;get all visits in date range in BGPV

 D ALLV^APCLAPIU(P,BDATE,EDATE,"BGPV")

 ;now loop through and check Face to Face and .17 in visit and check v cpts attached to the visit

 S X=0 F  S X=$O(BGPV(X)) Q:X'=+X!(G)  S V=$P(BGPV(X),U,5)  D

 .Q:'$P(^AUPNVSIT(V,0),U,9)  ;no dependent entries

 .Q:$P(^AUPNVSIT(V,0),U,11)  ;deleted

 .;is .17 a cpt we want?

 .S Y=$$VALI^XBDIQ1(9000010,V,.17)

 .I Y,$$ICD^ATXAPI(Y,$O(^ATXAX("B","BGP IPC LONG TERM CARE CPTS",0)),1) S G=1

 .;now check all V CPTs

 .S Z=0 F  S Z=$O(^AUPNVCPT("AD",V,Z)) Q:Z'=+Z!(G)  D

 ..S Y=$P($G(^AUPNVCPT(Z,0)),U,1)

 ..I Y,$$ICD^ATXAPI(Y,$O(^ATXAX("B","BGP IPC LONG TERM CARE CPTS",0)),1) S G=1

 Q G

HASBPPD(P,BDATE,EDATE) ;

 NEW X,Y,Z,G

 I $$PLTAXND^BGP8DU(P,"BGP IPC BIPOLAR DISORDER DXS",EDATE,1) Q 1

 I $$IPLSNOND^BGP8DU(P,"PXRM BGP IPC BIPOLAR DX",EDATE,1) Q 1

 I $$LASTDX^BGP8UTL1(P,"BGP IPC BIPOLAR DISORDER DXS",BDATE,EDATE) Q 1

 I $$PLTAXND^BGP8DU(P,"BGP IPC PERSONALITY DIS DXS",EDATE,1) Q 1

 I $$IPLSNOND^BGP8DU(P,"PXRM BGP IPC PERSONAL DIS",EDATE,1) Q 1

 I $$LASTDX^BGP8UTL1(P,"BGP IPC PERSONALITY DIS DXS",BDATE,EDATE) Q 1

 ;NOW SNOMED USING ASNC

 S T="PXRM BGP IPC BIPOLAR DX"

 S S=0,G="" F  S S=$O(^XTMP("BGPSNOMEDSUBSET",$J,T,S)) Q:S=""!(G)  D

 .Q:'$D(^AUPNVPOV("ASNC",P,S))

 .S D=0 F  S D=$O(^AUPNVPOV("ASNC",P,S,D)) Q:D=""!(G)  D

 ..S Y=9999999-D

 ..Q:Y>EDATE

 ..S G=1

 ;

 S T="PXRM BGP IPC PERSONAL DIS"

 S S=0 F  S S=$O(^XTMP("BGPSNOMEDSUBSET",$J,T,S)) Q:S=""!(G)  D

 .Q:'$D(^AUPNVPOV("ASNC",P,S))

 .S D=0 F  S D=$O(^AUPNVPOV("ASNC",P,S,D)) Q:D=""!(G)  D

 ..S Y=9999999-D

 ..Q:Y>EDATE

 ..S G=1

 I G Q G

 I $$BHDX(P,BDATE,EDATE) Q 1

 Q G

BHDX(P,BDATE,EDATE) ;has a bh dx in either taxonomy BDATE to EDATE?

 NEW X,Y,Z,C,I,G

 S G=""

 S X=0 F  S X=$O(^AMHRPRO("AC",P,X)) Q:X'=+X!(G)  D

 .;DATE?

 .S Y=$$VALI^XBDIQ1(9002011.01,X,.01)

 .Q:'Y

 .S Y=$P($P($G(^AMHREC(Y,0)),U,1),".")

 .Q:'Y

 .Q:Y<BDATE

 .Q:Y>EDATE

 .S C=$P($G(^AMHRPRO(X,0)),U,1)

 .Q:'C

 .Q:'$D(^AMHPROB(C,0))

 .S I=$P(^AMHPROB(C,0),U,5)

 .I I="" S I=$P(^AMHPROB(C,0),U,17)

 .I I="" Q

 .S Z=+$$CODEN^BGP8UTL2(I,80)

 .I 'Z Q

 .I $$ICD^BGP8UTL2(Z,$O(^ATXAX("B","BGP IPC BIPOLAR DISORDER DXS",0)),9) S G=1 Q

 .I $$ICD^BGP8UTL2(Z,$O(^ATXAX("B","BGP IPC PERSONALITY DIS DXS",0)),9) S G=1 Q

 .Q

 Q G

TESTPALL ;

 S DFN=0 F  S DFN=$O(^AUPNPAT(DFN)) Q:DFN'=+DFN  S X=$$PALLCARE(DFN,3160101,DT) I X W !,DFN," ",X

 Q

TESTCARE ;

 S DFN=11700 F  S DFN=$O(^AUPNPAT(DFN)) Q:DFN'=+DFN  S X=$$CARESERV(DFN,3110101,DT) I X W !,DFN," ",X

 Q

TESTBPPD ;

 S DFN=0 F  S DFN=$O(^AUPNPAT(DFN)) Q:DFN'=+DFN  S X=$$HASBPPD(DFN,3010101,DT) I X W !,DFN," ",X

 Q

BGP8PC13  ; IHS/CMI/LAB - measure I2 ; 26 Jul 2018  3:37 PM

 +1       ;;18.1;IHS CLINICAL REPORTING;**1**;MAY 25, 2018;Build 65

 +2       ;

TEST      ;

 +1        SET DFN=13474

 +2        SET BGPVALUE=""

 +3        SET BGPBDATE=3171001

 +4        SET BGPEDATE=3180930

 +5        DO DRM

 +6        WRITE !,BGPVALUE

 +7        QUIT 

DRM       ;EP - CALLED FROM IPC REPORT

 +1        SET (BGPN1,BGPD1)=0

 +2        SET BGPISD=""

           KILL BGPDEPV,BGPV,BGPDOV

 +3       ;

 +4       ;

 +5       ;GATHER UP ALL DEP SCRN VISITS

 +6       ;Let's check all Visits, looping through once

 +7       ;return variable

           SET G=""

 +8        KILL BGPV

 +9       ;get all visits in date range in BGPV

 +10       SET BGPXBD=$$FMADD^XLFDT(BGPBDATE,-(397))

 +11       SET BGPXED=$$FMADD^XLFDT(BGPBDATE,-1)

 +12       DO ALLV^APCLAPIU(DFN,BGPXBD,BGPXED,"BGPV")

 +13      ;now loop through and check SNOMED and .17 in visit and check v cpts attached to the visit

 +14      ;REORDER BY DATE

 +15       SET X=0

           FOR 

               SET X=$ORDER(BGPV(X))

               IF X'=+X

                   QUIT 

               SET BGPDOV($PIECE(BGPV(X),U,1),"V",$PIECE(BGPV(X),U,5))=BGPV(X)

 +16      ;ADD IN BH VISITS BETWEEN BGPBD AND BGPED THAT AREN'T IN PCC

 +17       SET D=0

           SET E=9999999-BGPXBD

           SET D=9999999-BGPXED-1_".99"

           FOR 

               SET D=$ORDER(^AMHREC("AE",DFN,D))

               IF D'=+D!($PIECE(D,".")>E)

                   QUIT 

               SET V=0

               FOR 

                   SET V=$ORDER(^AMHREC("AE",DFN,D,V))

                   IF V'=+V

                       QUIT 

                   Begin DoDot:1

 +18      ;ALREADY IN PCC SO WOULD HAVE GOT IT ALREADY

                       IF $PIECE(^AMHREC(V,0),U,16)

                           QUIT 

 +19                   SET S=$PIECE($$VALI^XBDIQ1(9002011,V,.01),".")

 +20                   SET BGPDOV(S,"Z",V)=S_U_U_U_U_V

                   End DoDot:1

 +21       SET BGPDD=0

           SET G=0

           FOR 

               SET BGPDD=$ORDER(BGPDOV(BGPDD))

               IF BGPDD'=+BGPDD!(BGPISD)

                   QUIT 

               SET T=""

               FOR 

                   SET T=$ORDER(BGPDOV(BGPDD,T))

                   IF T=""!(BGPISD)

                       QUIT 

                   SET V=0

                   FOR 

                       SET V=$ORDER(BGPDOV(BGPDD,T,V))

                       IF V'=+V!(BGPISD)

                           QUIT 

                       Begin DoDot:1

 +22                       SET BGPP=0

                           SET BGPO=0

 +23                       IF T="V"

                               DO V

                               QUIT 

 +24                       IF T="Z"

                               DO BH

                               QUIT 

                       End DoDot:1

 +25      ;

N1         IF 'BGPISD

               SET BGPSTOP=1

               GOTO DRME

 +1       ;

 +2       ;

 +3       ;AGE ON INDEX START DATE?

 +4        SET A=$$AGE^AUPNPAT(DFN,$PIECE(BGPISD,U,1))

 +5        IF A<18

               SET BGPSTOP=1

               GOTO DRME

 +6       ;

 +7       ;now what about exclusions?

 +8       ;might as well process exclusions first;

 +9       ;palliative care

 +10       IF $$PALLCARE(DFN,BGPBDATE,BGPEDATE)

               SET BGPSTOP=1

               GOTO DRME

 +11      ;

 +12      ;long term care services

 +13       IF $$CARESERV(DFN,BGPBDATE,BGPEDATE)

               SET BGPSTOP=1

               GOTO DRME

 +14      ;

 +15      ;has bipolar or personality disorder before end of report period

 +16       IF $$HASBPPD(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE)

               SET BGPSTOP=1

               GOTO DRME

 +17      ;

 +18      ;FINALLY MADE DENOMINATOR

 +19       SET BGPD1=1

 +20       SET G=$$PHQ9N(DFN,$$FMADD^XLFDT($PIECE(BGPISD,U,1),336),$$FMADD^XLFDT($PIECE(BGPISD,U,1),397))

 +21       IF G

               SET BGPN1=1

               GOTO DRM1

 +22       SET G=$$PHQ9NBH(DFN,$$FMADD^XLFDT($PIECE(BGPISD,U,1),336),$$FMADD^XLFDT($PIECE(BGPISD,U,1),397))

 +23       IF G

               SET BGPN1=1

DRM1      ;

 +1        SET BGPVALUE=""

 +2       ; PHQ9: "_$$VAL^XBDIQ1(9000010.01,$P(BGPISD,U,2),.04)_"|||"  ;hit denominator

           SET BGPVALUE="ENC "_$$DATE^BGP8UTL($PIECE(BGPISD,U,1))_"|||"

 +3        IF BGPN1

               SET BGPVALUE=BGPVALUE_"*** "_$$DATE^BGP8UTL($PIECE(G,U,2))_" "_$PIECE(G,U,3)_": "_$PIECE(G,U,4)

DRME      ;

 +1        KILL D,V,X,Y,BGPV,BGPDEPV,BGPISD,BGPDOV,G,BGPXBD,BGPXED,BGPDD,BGPP,BGPO

 +2        QUIT 

V         ;

 +1       ;no dependent entries

           IF '$PIECE(^AUPNVSIT(V,0),U,9)

               QUIT 

 +2       ;deleted

           IF $PIECE(^AUPNVSIT(V,0),U,11)

               QUIT 

 +3       ;is there a PHQ9 > 9?  if not, don't bother???

 +4        SET Q=$$PHQ9(V)

 +5        IF Q=""

               QUIT 

 +6        SET Y=$$DEPV1(V)

           IF Y

               SET BGPISD=Q

               QUIT 

 +7        SET Y=$$DEPV2(V)

           IF Y

               SET BGPISD=Q

               QUIT 

 +8        QUIT 

BH        ;

 +1       ;is there a PHQ9 > 9?  if not, don't bother???

 +2        SET Q=$$PHQ9BH(V)

 +3        IF Q=""

               QUIT 

 +4       ;now check all V CPTs

 +5        SET Z=0

           FOR 

               SET Z=$ORDER(^AMHRPROC("AD",V,Z))

               IF Z'=+Z!(BGPO)!(BGPP)

                   QUIT 

               Begin DoDot:1

 +6                SET Y=$PIECE($GET(^AMHRPROC(Z,0)),U,1)

 +7                IF Y

                       IF $$ICD^ATXAPI(Y,$ORDER(^ATXAX("B","BGP IPC OFFICE VISIT CPTS",0)),1)

                           SET BGPO=1

                           QUIT 

 +8                IF Y

                       IF $$ICD^ATXAPI(Y,$ORDER(^ATXAX("B","BGP IPC PSYCH VISIT CPTS",0)),1)

                           SET BGPP=1

                           QUIT 

               End DoDot:1

 +9       ;GO ON?

BHN       ;

 +1       ;now check for active problem list or primary POV 

 +2        IF BGPO

               SET G=0

               Begin DoDot:1

 +3       ;is there a primary or secondary V POV or an active PL entry

 +4                SET X=0

                   FOR 

                       SET X=$ORDER(^AMHRPRO("AD",V,X))

                       IF X'=+X!(G)

                           QUIT 

                       Begin DoDot:2

 +5                        SET Z=$PIECE($GET(^AMHRPRO(X,0)),U,1)

 +6                        IF 'Z

                               QUIT 

 +7                        IF '$DATA(^AMHPROB(Z,0))

                               QUIT 

 +8                        SET C=$PIECE(^AMHPROB(Z,0),U,5)

 +9                        IF C=""

                               SET C=$PIECE(^AMHPROB(Z,0),U,17)

 +10                       IF C=""

                               QUIT