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
+11 SET C=+$$CODEN^BGP8UTL2(C,80)
+12 IF 'C
QUIT
+13 IF $$ICD^BGP8UTL2(C,$ORDER(^ATXAX("B","BGP IPC MAJOR DEPRESSION DXS",0)),1)
SET G=1
SET BGPISD=Q
QUIT
+14 IF $$ICD^BGP8UTL2(C,$ORDER(^ATXAX("B","BGP IPC DYSTHYMIA DXS",0)),1)
SET G=1
SET BGPISD=Q
QUIT
End DoDot:2
+15 IF G
QUIT
+16 IF $$PLTAXND^BGP8DU(DFN,"BGP IPC MAJOR DEPRESSION DXS",BGPDD,1)
SET G=1
SET BGPISD=Q
QUIT
+17 IF $$IPLSNOND^BGP8DU(DFN,"PXRM BGP IPC MAJOR DEP",BGPDD,1)
SET G=1
SET BGPISD=Q
QUIT
+18 IF $$PLTAXND^BGP8DU(DFN,"BGP IPC DYSTHYMIA DXS",BGPDD,1)
SET G=1
SET BGPISD=Q
QUIT
+19 IF $$IPLSNOND^BGP8DU(DFN,"PXRM BGP IPC DYSTHYMIA",BGPDD,1)
SET G=1
SET BGPISD=Q
QUIT
End DoDot:1
QUIT
+20 IF BGPP
SET G=0
Begin DoDot:1
+21 SET X=$ORDER(^AMHRPRO("AD",V,0))
+22 IF 'X
QUIT
+23 SET Z=$PIECE($GET(^AMHRPRO(X,0)),U,1)
+24 IF 'Z
QUIT
+25 IF '$DATA(^AMHPROB(Z,0))
QUIT
+26 SET C=$PIECE(^AMHPROB(Z,0),U,5)
+27 IF C=""
SET C=$PIECE(^AMHPROB(Z,0),U,17)
+28 IF C=""
QUIT
+29 SET C=+$$CODEN^BGP8UTL2(C,80)
+30 IF 'C
QUIT
+31 IF C
IF $$ICD^BGP8UTL2(C,$ORDER(^ATXAX("B","BGP IPC MAJOR DEPRESSION DXS",0)),1)
SET G=1
SET BGPISD=Q
QUIT
+32 IF C
IF $$ICD^BGP8UTL2(C,$ORDER(^ATXAX("B","BGP IPC DYSTHYMIA DXS",0)),1)
SET G=1
SET BGPISD=Q
End DoDot:1
QUIT
+33 QUIT
PHQ9(VST) ;
+1 NEW X,Y,Z
+2 SET X=0
SET Z=""
FOR
SET X=$ORDER(^AUPNVMSR("AD",VST,X))
IF X'=+X
QUIT
Begin DoDot:1
+3 ;entered in error
IF $PIECE($GET(^AUPNVMSR(X,2)),U,1)
QUIT
+4 SET E=$$VAL^XBDIQ1(9000010.01,X,.01)
+5 IF E'="PHQ9"
QUIT
+6 SET R=$$VAL^XBDIQ1(9000010.01,X,.04)
+7 IF R<10
QUIT
+8 SET Z=$$VD^APCLV(VST)
End DoDot:1
+9 QUIT Z
PHQ9BH(VST) ;
+1 NEW X,Y,Z
+2 SET X=0
SET Z=""
FOR
SET X=$ORDER(^AMHRMSR("AD",VST,X))
IF X'=+X!(Z)
QUIT
Begin DoDot:1
+3 SET E=$$VAL^XBDIQ1(9002011.12,X,.01)
+4 IF E'="PHQ9"
QUIT
+5 SET R=$$VAL^XBDIQ1(9002011.12,X,.04)
+6 IF R<10
QUIT
+7 SET Z=$PIECE($GET(^AMHRMSR(X,0)),U,3)
+8 IF Z=""
QUIT
+9 SET Z=$PIECE($PIECE($GET(^AMHREC(Z,0)),U,1),".")
End DoDot:1
+10 QUIT Z
PHQ9N(P,BDATE,EDATE) ;
+1 NEW X,Y,Z,BGPG,G,E
+2 KILL BGPG
+3 SET Y="BGPG("
SET G=""
+4 SET X=P_"^ALL MEAS PHQ9;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+5 SET E=0
FOR
SET E=$ORDER(BGPG(E))
IF E'=+E!(G)
QUIT
Begin DoDot:1
+6 IF $PIECE(BGPG(E),U,2)<5
SET G=1_U_$PIECE(BGPG(E),U,1)_U_$PIECE(BGPG(1),U,3)_U_$PIECE(BGPG(1),U,2)
End DoDot:1
+7 QUIT G
PHQ9NBH(P,BDATE,EDATE) ;
+1 NEW X,Y,Z,ED,R
+2 SET Z=$ORDER(^AUTTMSR("B","PHQ9",0))
+3 SET Y=""
+4 IF 'Z
QUIT ""
+5 SET D=0
FOR
SET D=$ORDER(^AMHRMSR("AA",P,Z,D))
IF D'=+D!(Y)
QUIT
Begin DoDot:1
+6 SET ED=9999999-$PIECE(D,".")
+7 IF ED<BDATE
QUIT
+8 IF ED>EDATE
QUIT
+9 SET X=0
FOR
SET X=$ORDER(^AMHRMSR("AA",P,Z,D,X))
IF X'=+X!(Y)
QUIT
Begin DoDot:2
+10 IF '$DATA(^AMHRMSR(X,0))
QUIT
+11 SET R=$PIECE(^AMHRMSR(X,0),U,4)
+12 IF R]""
IF R<5
SET Y=1_U_ED_U_"BH PHQ9"_U_R
End DoDot:2
End DoDot:1
+13 QUIT Y
PALLCARE(P,BDATE,EDATE) ;EP
+1 NEW X,Y,Z,BGPV,G,A,B
+2 IF $$LASTDX^BGP8UTL1(P,"BGP IPC PALLIATIVE CARE DXS",BDATE,EDATE)
QUIT 1
+3 ;SNOMED IN VISIT OR V POV
+4 DO ALLV^APCLAPIU(DFN,BDATE,EDATE,"BGPV")
+5 ;
+6 ;now loop through and check SNOMED and .17 in visit and check v cpts attached to the visit
+7 ;REORDER BY DATE
+8 SET X=0
SET G=""
FOR
SET X=$ORDER(BGPV(X))
IF X'=+X!(G)
QUIT
SET V=$PIECE(BGPV(X),U,5)
Begin DoDot:1
+9 ;no dependent entries
IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+10 ;deleted
IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+11 SET A=0
FOR
SET A=$ORDER(^AUPNVSIT(V,28,"B",A))
IF A=""!(G]"")
QUIT
Begin DoDot:2
+12 IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM BGP IPC PALLIATIVE",A))
SET G=1
QUIT
End DoDot:2
+13 IF G
QUIT
+14 SET A=0
+15 FOR
SET A=$ORDER(^AUPNVSIT(V,26,"B",A))
IF A=""!(G)
QUIT
Begin DoDot:2
+16 IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM BGP IPC PALLIATIVE",A))
SET G=1
End DoDot:2
+17 IF G
QUIT
+18 ;V POV
+19 SET A=0
FOR
SET A=$ORDER(^AUPNVPOV("AD",V,A))
IF A=""!(G)
QUIT
Begin DoDot:2
+20 SET S=$$VALI^XBDIQ1(9000010.07,A,1101)
+21 IF S=""
QUIT
+22 IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM BGP IPC PALLIATIVE",S))
SET G=1
End DoDot:2
End DoDot:1
+23 IF G
QUIT G
+24 ;NOW REFERRALS
+25 SET Z=0
SET G=0
FOR
SET Z=$ORDER(^AUPNVREF("AC",P,Z))
IF Z'=+Z!(G)
QUIT
Begin DoDot:1
+26 SET V=$PIECE($GET(^AUPNVREF(Z,0)),U,3)
+27 SET D=$$VD^APCLV(V)
+28 IF D<BDATE
QUIT
+29 IF D>EDATE
QUIT
+30 SET S=$PIECE($GET(^AUPNVREF(Z,0)),U,1)
IF S=""
QUIT
+31 IF '$DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM BGP IPC PALLIATIVE",S))
QUIT
+32 SET G=1
QUIT
End DoDot:1
+33 QUIT G
DEPV1(V) ;EP
+1 NEW A,B,C,G,BGPISD
+2 SET G=0
+3 SET A=0
SET B=""
SET BGPISD=""
+4 FOR
SET A=$ORDER(^AUPNVSIT(V,28,"B",A))
IF A=""!(B]"")
QUIT
Begin DoDot:1
+5 IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM BGP IPC FC2FC NO ED",A))
SET B=A
End DoDot:1
+6 IF B]""
GOTO DEPV1N
+7 SET A=0
SET B=""
+8 FOR
SET A=$ORDER(^AUPNVSIT(V,26,"B",A))
IF A=""!(B]"")
QUIT
Begin DoDot:1
+9 IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM BGP IPC FC2FC NO ED",A))
SET B=A
End DoDot:1
+10 IF B]""
GOTO DEPV1N
+11 ;cpts?
+12 ;is .17 a cpt we want?
+13 SET Y=$$VALI^XBDIQ1(9000010,V,.17)
+14 IF Y
IF $$ICD^ATXAPI(Y,$ORDER(^ATXAX("B","BGP IPC OFFICE VISIT CPTS",0)),1)
GOTO DEPV1N
+15 ;now check all V CPTs
+16 SET Z=0
FOR
SET Z=$ORDER(^AUPNVCPT("AD",V,Z))
IF Z'=+Z!(B)
QUIT
Begin DoDot:1
+17 SET Y=$PIECE($GET(^AUPNVCPT(Z,0)),U,1)
+18 IF Y
IF $$ICD^ATXAPI(Y,$ORDER(^ATXAX("B","BGP IPC OFFICE VISIT CPTS",0)),1)
SET B=1
QUIT
End DoDot:1
+19 IF B
GOTO DEPV1N
+20 QUIT ""
DEPV1N ;
+1 ;now check for active problem list or primary POV
+2 SET G=0
SET BGPISD=""
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(^AUPNVPOV("AD",V,X))
IF X'=+X!(G)
QUIT
Begin DoDot:2
+5 SET C=$PIECE($GET(^AUPNVPOV(X,0)),U,1)
+6 IF 'C
QUIT
+7 IF $$ICD^BGP8UTL2(C,$ORDER(^ATXAX("B","BGP IPC MAJOR DEPRESSION DXS",0)),1)
SET G=1
SET BGPISD=Q
QUIT
+8 IF $$ICD^BGP8UTL2(C,$ORDER(^ATXAX("B","BGP IPC DYSTHYMIA DXS",0)),1)
SET G=1
SET BGPISD=Q
QUIT
+9 SET C=$$VALI^XBDIQ1(9000010.07,X,1101)
+10 IF C]""
IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM BGP IPC MAJOR DEP",C))
SET G=1
SET BGPISD=Q
QUIT
+11 IF C]""
IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM BGP IPC DYSTHYMIA",C))
SET G=1
SET BGPISD=Q
QUIT
End DoDot:2
+12 IF G
QUIT
+13 IF $$PLTAXND^BGP8DU(DFN,"BGP IPC MAJOR DEPRESSION DXS",BGPDD,1)
SET G=1
SET BGPISD=Q
QUIT
+14 IF $$IPLSNOND^BGP8DU(DFN,"PXRM BGP IPC MAJOR DEP",BGPDD,1)
SET G=1
SET BGPISD=Q
QUIT
+15 IF $$PLTAXND^BGP8DU(DFN,"BGP IPC DYSTHYMIA DXS",BGPDD,1)
SET G=1
SET BGPISD=Q
QUIT
+16 IF $$IPLSNOND^BGP8DU(DFN,"PXRM BGP IPC DYSTHYMIA",BGPDD,1)
SET G=1
SET BGPISD=Q
QUIT
End DoDot:1
+17 QUIT BGPISD
DEPV2(V) ;EP
+1 NEW A,B,C,G,BGPISD
+2 SET G=0
+3 SET A=0
SET B=""
SET BGPISD=""
+4 ;cpts?
+5 ;is .17 a cpt we want?
+6 SET Y=$$VALI^XBDIQ1(9000010,V,.17)
+7 IF Y
IF $$ICD^ATXAPI(Y,$ORDER(^ATXAX("B","BGP IPC PSYCH VISIT CPTS",0)),1)
GOTO DEPV2N
+8 ;now check all V CPTs
+9 SET Z=0
FOR
SET Z=$ORDER(^AUPNVCPT("AD",V,Z))
IF Z'=+Z!(B)
QUIT
Begin DoDot:1
+10 SET Y=$PIECE($GET(^AUPNVCPT(Z,0)),U,1)
+11 IF Y
IF $$ICD^ATXAPI(Y,$ORDER(^ATXAX("B","BGP IPC PSYCH VISIT CPTS",0)),1)
SET B=1
QUIT
End DoDot:1
+12 IF B
GOTO DEPV2N
+13 IF 'B
QUIT ""
DEPV2N ;
+1 ;now check for active problem list or primary POV
+2 SET G=0
SET BGPISD=""
Begin DoDot:1
+3 SET C=$$PRIMPOV^APCLV(V,"I")
+4 IF $$ICD^BGP8UTL2(C,$ORDER(^ATXAX("B","BGP IPC MAJOR DEPRESSION DXS",0)),1)
SET G=1
SET BGPISD=Q
QUIT
+5 IF $$ICD^BGP8UTL2(C,$ORDER(^ATXAX("B","BGP IPC DYSTHYMIA DXS",0)),1)
SET G=1
SET BGPISD=Q
QUIT
+6 SET I=$$PRIMPOV^APCLV(V,5)
+7 SET C=$$VALI^XBDIQ1(9000010.07,I,1101)
+8 IF C]""
IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM BGP IPC MAJOR DEP",C))
SET G=1
SET BGPISD=Q
QUIT
+9 IF C]""
IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM BGP IPC DYSTHYMIA",C))
SET G=1
SET BGPISD=Q
QUIT
End DoDot:1
+10 QUIT BGPISD
CARESERV(P,BDATE,EDATE) ;
+1 NEW X,Y,Z,G,BGPV,D,A,B
+2 ;Let's check all Visits, looping through once
+3 ;return variable
SET G=""
+4 ;get all visits in date range in BGPV
+5 DO ALLV^APCLAPIU(P,BDATE,EDATE,"BGPV")
+6 ;now loop through and check Face to Face and .17 in visit and check v cpts attached to the visit
+7 SET X=0
FOR
SET X=$ORDER(BGPV(X))
IF X'=+X!(G)
QUIT
SET V=$PIECE(BGPV(X),U,5)
Begin DoDot:1
+8 ;no dependent entries
IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+9 ;deleted
IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+10 ;is .17 a cpt we want?
+11 SET Y=$$VALI^XBDIQ1(9000010,V,.17)
+12 IF Y
IF $$ICD^ATXAPI(Y,$ORDER(^ATXAX("B","BGP IPC LONG TERM CARE CPTS",0)),1)
SET G=1
+13 ;now check all V CPTs
+14 SET Z=0
FOR
SET Z=$ORDER(^AUPNVCPT("AD",V,Z))
IF Z'=+Z!(G)
QUIT
Begin DoDot:2
+15 SET Y=$PIECE($GET(^AUPNVCPT(Z,0)),U,1)
+16 IF Y
IF $$ICD^ATXAPI(Y,$ORDER(^ATXAX("B","BGP IPC LONG TERM CARE CPTS",0)),1)
SET G=1
End DoDot:2
End DoDot:1
+17 QUIT G
HASBPPD(P,BDATE,EDATE) ;
+1 NEW X,Y,Z,G
+2 IF $$PLTAXND^BGP8DU(P,"BGP IPC BIPOLAR DISORDER DXS",EDATE,1)
QUIT 1
+3 IF $$IPLSNOND^BGP8DU(P,"PXRM BGP IPC BIPOLAR DX",EDATE,1)
QUIT 1
+4 IF $$LASTDX^BGP8UTL1(P,"BGP IPC BIPOLAR DISORDER DXS",BDATE,EDATE)
QUIT 1
+5 IF $$PLTAXND^BGP8DU(P,"BGP IPC PERSONALITY DIS DXS",EDATE,1)
QUIT 1
+6 IF $$IPLSNOND^BGP8DU(P,"PXRM BGP IPC PERSONAL DIS",EDATE,1)
QUIT 1
+7 IF $$LASTDX^BGP8UTL1(P,"BGP IPC PERSONALITY DIS DXS",BDATE,EDATE)
QUIT 1
+8 ;NOW SNOMED USING ASNC
+9 SET T="PXRM BGP IPC BIPOLAR DX"
+10 SET S=0
SET G=""
FOR
SET S=$ORDER(^XTMP("BGPSNOMEDSUBSET",$JOB,T,S))
IF S=""!(G)
QUIT
Begin DoDot:1
+11 IF '$DATA(^AUPNVPOV("ASNC",P,S))
QUIT
+12 SET D=0
FOR
SET D=$ORDER(^AUPNVPOV("ASNC",P,S,D))
IF D=""!(G)
QUIT
Begin DoDot:2
+13 SET Y=9999999-D
+14 IF Y>EDATE
QUIT
+15 SET G=1
End DoDot:2
End DoDot:1
+16 ;
+17 SET T="PXRM BGP IPC PERSONAL DIS"
+18 SET S=0
FOR
SET S=$ORDER(^XTMP("BGPSNOMEDSUBSET",$JOB,T,S))
IF S=""!(G)
QUIT
Begin DoDot:1
+19 IF '$DATA(^AUPNVPOV("ASNC",P,S))
QUIT
+20 SET D=0
FOR
SET D=$ORDER(^AUPNVPOV("ASNC",P,S,D))
IF D=""!(G)
QUIT
Begin DoDot:2
+21 SET Y=9999999-D
+22 IF Y>EDATE
QUIT
+23 SET G=1
End DoDot:2
End DoDot:1
+24 IF G
QUIT G
+25 IF $$BHDX(P,BDATE,EDATE)
QUIT 1
+26 QUIT G
BHDX(P,BDATE,EDATE) ;has a bh dx in either taxonomy BDATE to EDATE?
+1 NEW X,Y,Z,C,I,G
+2 SET G=""
+3 SET X=0
FOR
SET X=$ORDER(^AMHRPRO("AC",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+4 ;DATE?
+5 SET Y=$$VALI^XBDIQ1(9002011.01,X,.01)
+6 IF 'Y
QUIT
+7 SET Y=$PIECE($PIECE($GET(^AMHREC(Y,0)),U,1),".")
+8 IF 'Y
QUIT
+9 IF Y<BDATE
QUIT
+10 IF Y>EDATE
QUIT
+11 SET C=$PIECE($GET(^AMHRPRO(X,0)),U,1)
+12 IF 'C
QUIT
+13 IF '$DATA(^AMHPROB(C,0))
QUIT
+14 SET I=$PIECE(^AMHPROB(C,0),U,5)
+15 IF I=""
SET I=$PIECE(^AMHPROB(C,0),U,17)
+16 IF I=""
QUIT
+17 SET Z=+$$CODEN^BGP8UTL2(I,80)
+18 IF 'Z
QUIT
+19 IF $$ICD^BGP8UTL2(Z,$ORDER(^ATXAX("B","BGP IPC BIPOLAR DISORDER DXS",0)),9)
SET G=1
QUIT
+20 IF $$ICD^BGP8UTL2(Z,$ORDER(^ATXAX("B","BGP IPC PERSONALITY DIS DXS",0)),9)
SET G=1
QUIT
+21 QUIT
End DoDot:1
+22 QUIT G
TESTPALL ;
+1 SET DFN=0
FOR
SET DFN=$ORDER(^AUPNPAT(DFN))
IF DFN'=+DFN
QUIT
SET X=$$PALLCARE(DFN,3160101,DT)
IF X
WRITE !,DFN," ",X
+2 QUIT
TESTCARE ;
+1 SET DFN=11700
FOR
SET DFN=$ORDER(^AUPNPAT(DFN))
IF DFN'=+DFN
QUIT
SET X=$$CARESERV(DFN,3110101,DT)
IF X
WRITE !,DFN," ",X
+2 QUIT
TESTBPPD ;
+1 SET DFN=0
FOR
SET DFN=$ORDER(^AUPNPAT(DFN))
IF DFN'=+DFN
QUIT
SET X=$$HASBPPD(DFN,3010101,DT)
IF X
WRITE !,DFN," ",X
+2 QUIT
