BGP8PC12 ; IHS/CMI/LAB - measure I2 ; 02 Feb 2018 11:25 AM
;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
;
DFU S (BGPN1,BGPD1)=0
S BGPFDV="" K BGPDEPV,BGPV,BGPDOV
;
I BGPAGEE<12 S BGPSTOP=1 Q ;12 or greater during time period
;
;GATHER UP ALL DEP SCRN VISITS
NEW X,V,D,Y
;Let's check all Visits, looping through once
S G="" ;return variable
K BGPV
;get all visits in date range in BGPV
D ALLV^APCLAPIU(DFN,BGPBDATE,BGPEDATE,"BGPV")
;I '$O(BGPV(0)) S BGPSTOP=1 G DFUE ;NO DEP VISITS
;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),X)=BGPV(X)
S D=0 F S D=$O(BGPDOV(D)) Q:D'=+D S X=0 F S X=$O(BGPDOV(D,X)) Q:X'=+X S V=$P(BGPDOV(D,X),U,5) D
.Q:'$P(^AUPNVSIT(V,0),U,9) ;no dependent entries
.Q:$P(^AUPNVSIT(V,0),U,11) ;deleted
.S Y=$$DEPV(V) I Y]"" S BGPDEPV(9999999-D,X)=""
.;is .17 a cpt we want?
.S Y=$$VALI^XBDIQ1(9000010,V,.17)
.I Y,$$OFFCPT12(Y) S BGPDEPV(9999999-D,X)="" Q
.;now check all V CPTs
.S Z=0 F S Z=$O(^AUPNVCPT("AD",V,Z)) Q:Z'=+Z D
..S Y=$P($G(^AUPNVCPT(Z,0)),U,1)
..I Y,$$OFFCPT12(Y) S BGPDEPV(9999999-D,X)="" Q
;NOW ADD IN ANY VISITS IN BH THAT DID NOT PASS TO PCC AND ARE NOT EHR CREATED
S D=0,E=9999999-BGPBDATE,D=9999999-BGPEDATE-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 Z=0 F S Z=$O(^AMHRPROC("AD",V,Z)) Q:Z'=+Z D
..S Y=$P($G(^AMHRPROC(Z,0)),U,1)
..I Y,$$OFFCPT12(Y) S BGPDEPV($P(D,"."),V)="" Q
;
I '$D(BGPDEPV) S BGPSTOP=1 G DFUE
;
S BGPFDV="",X="" F S X=$O(BGPDEPV(X)) Q:X'=+X S BGPFDV=X
S D=9999999-BGPFDV
;
;now what about exclusions?
I $$HASDX(DFN,$$DOB^AUPNPAT(DFN),$$FMADD^XLFDT(D,-1)) S BGPSTOP=1 G DFUE ;DX PRIOR TO 1ST DEP VISIT
;
;FIND LAST SCREEN ON A DATE OF A DEPRESSION VISIT
S D=0,G="" F S D=$O(BGPDEPV(D)) Q:D'=+D!(G]"") D
.S G=$$DEPSCR(DFN,(9999999-D),(9999999-D))
I G]"" S:G BGPN1=1 G DFU1
;any screening during entire report period?
S E=$$DEPSCR(DFN,BGPBDATE,BGPEDATE)
I E]"" G DFU1 ;HAS A SCREENING SO CAN'T EXCLUDE
;check refusal, etc
S X=$$REFUSAL(DFN,BGPBDATE,BGPEDATE,.BGPDEPV)
I X S BGPSTOP=1 G DFUE
DFU1 ;
S BGPD1=1
S BGPVALUE=""
S BGPVALUE="ENC "_$$DATE^BGP8UTL((9999999-BGPFDV))_"|||" ;hit denominator
I BGPN1 S BGPVALUE=BGPVALUE_"*** "_$$DATE^BGP8UTL($P(G,U,2))_" "_$P(G,U,4)_" "_$P(G,U,6)_" "_$P(G,U,7)
I 'BGPN1 S BGPVALUE=BGPVALUE_$$DATE^BGP8UTL($P(G,U,2))_" "_$P(G,U,4)_" "_$P(G,U,6)_" "_$P(G,U,7)
;
DFUE ;
K D,V,X,Y,BGPV,BGPDEPV,BGPFDV,BGPDOV,G
Q
DEPV(V) ;EP
NEW A,B,C
S A=0,B=""
F S A=$O(^AUPNVSIT(V,28,"B",A)) Q:A=""!(B]"") D
.I $D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP IPC DEP SCRN ENC",A)) S B=A
I B]"" Q B
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 DEP SCRN ENC",A)) S B=A
Q B
OFFCPT12(C) ;EP
I $$ICD^ATXAPI(C,$O(^ATXAX("B","BGP IPC DEP SCRN ENC CPTS",0)),1) Q 1
Q ""
LOINC(A,B) ;EP
NEW %
S %=$P($G(^LAB(95.3,A,9999999)),U,2)
I %]"",$D(^ATXAX(B,21,"B",%)) Q 1
S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)
I $D(^ATXAX(B,21,"B",%)) Q 1
Q ""
HASDX(P,BDATE,EDATE) ;
NEW X,Y,Z
I $$PLTAXND^BGP8DU(P,"BGP IPC DEPRESSION DIAG DXS",EDATE,1) Q 1
I $$IPLSNOND^BGP8DU(P,"PXRM BGP IPC DEPRESSION DX",EDATE,1) Q 1
I $$LASTDX^BGP8UTL1(P,"BGP IPC DEPRESSION DIAG DXS",BDATE,EDATE) Q 1
I $$PLTAXND^BGP8DU(P,"BGP IPC BIPOLAR DIAG 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 DIAG DXS",BDATE,EDATE) Q 1
I $$BHDX(P,BDATE,EDATE) Q 1
Q ""
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 DIAG DXS",0)),9) S G=1 Q
.I $$ICD^BGP8UTL2(Z,$O(^ATXAX("B","BGP IPC DEPRESSION DIAG DXS",0)),9) S G=1 Q
.Q
Q G
DEPSCR(P,BDATE,EDATE) ;
NEW X,Y,Z,BGPV,BGPS,V,D,E,S
S BGPS=""
D ALLV^APCLAPIU(P,BDATE,EDATE,"BGPV")
S X=0 F S X=$O(BGPV(X)) Q:X'=+X D
.S V=$P(BGPV(X),U,5)
.;get depression screenings exam 36
.S Y=0 F S Y=$O(^AUPNVXAM("AD",V,Y)) Q:Y'=+Y D
..S E=$$VAL^XBDIQ1(9000010.13,Y,.019)
..Q:E'=36
..Q:$P(^AUPNVXAM(Y,0),U,4)="" ;no result
..S R=$$VALI^XBDIQ1(9000010.13,Y,.04)
..I R'="N",R'="PO",R'="RF" Q ;these are the positive and negative values
..;S D=$P($G(^AUPNVXAM(Y,12)),U,1)
..S D=$$VDTM^APCLV(V)
..I D=$P(BGPS,U,1),Y>$P(BGPS,U,4) S BGPS=D_U_R_U_"Exam 36"_U_Y_U_$S(R="PO":"POS",R="RF":"POS",1:"NEG") Q
..I D>$P(BGPS,U,1) S BGPS=D_U_$$VAL^XBDIQ1(9000010.13,Y,.04)_U_"Exam 36"_U_Y_U_$S(R="PO":"POS",R="RF":"POS",1:"NEG") Q
.;GET PHQ's
.S Y=0 F S Y=$O(^AUPNVMSR("AD",V,Y)) Q:Y'=+Y D
..Q:$P($G(^AUPNVMSR(Y,2)),U,1) ;entered in error
..S E=$$VAL^XBDIQ1(9000010.01,Y,.01)
..I E'="PHQ2",E'="PHQ9",E'="PHQT" Q
..Q:$P(^AUPNVMSR(Y,0),U,4)="" ;no result
..S R=$$VAL^XBDIQ1(9000010.01,Y,.04)
..;S D=$P($G(^AUPNVMSR(Y,12)),U,1)
..S D=$$VDTM^APCLV(V)
..I D=$P(BGPS,U,1),Y>$P(BGPS,U,4) S BGPS=D_U_$$VAL^XBDIQ1(9000010.13,Y,.04)_U_"Meas "_E_U_Y_U_$$RES(E,R) Q
..I D>$P(BGPS,U,1) S BGPS=D_U_$$VAL^XBDIQ1(9000010.13,Y,.04)_U_"Meas "_E_U_Y_U_$$RES(E,R) Q
;ADD IN BH
S D=0,E=9999999-BDATE,D=9999999-EDATE-1_".99" F S D=$O(^AMHREC("AE",P,D)) Q:D'=+D!($P(D,".")>E) S V=0 F S V=$O(^AMHREC("AE",P,D,V)) Q:V'=+V D
.S S=$P($$VALI^XBDIQ1(9002011,V,.01),".")
.S R=$$VALI^XBDIQ1(9002011,V,1405)
.I R="" G BHM
.I R]"",R'="P",R'="N",R'="RF" Q
.I S>$P(BGPS,U,1) S BGPS=S_U_$$VAL^XBDIQ1(9002011,V,1405)_U_"BH Exam 36"_U_V_U_$S(R="P":"POS",R="RF":"POS",1:"NEG") Q
BHM .S X=0 F S X=$O(^AMHRMSR("AD",V,X)) Q:X'=+X S BGPP=$P($G(^AMHRMSR(X,0)),U) D
..S BGPP=$P($G(^AUTTMSR(BGPP,0)),U)
..S R=$$VAL^XBDIQ1(9002011.12,X,.04)
..I BGPP="PHQ2"!(BGPP="PHQ9")!(BGPP="PHQT") I S>$P(BGPS,U,1) S BGPS=S_U_$$VAL^XBDIQ1(9002011.12,X,.04)_U_"BH Meas "_BGPP_U_X_U_$$RES(BGPP,R) Q
I BGPS="" Q ""
S R=$P(BGPS,U,5)
I R="NEG" Q 1_U_BGPS
S Y=$$FUPLAN(P,$P($P(BGPS,U,1),"."),$P($P(BGPS,U,1),"."))
I 'Y Q 0_U_BGPS_U_"NO FU PLAN"
I Y Q 1_U_BGPS_U_$P(Y,U,2)
Q
FUPLAN(P,BDATE,EDATE) ;
;PROBLEM LIST SNOMED ENTERED ON BDATE
NEW X,G,S,BGPG,Y,I,V,W,Z,TAX,BGPMEDS1,TAX1,M,R,B,O
S X=0,G="" F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G) D
.Q:'$D(^AUPNPROB(X,0))
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.Q:$P(^AUPNPROB(X,0),U,8)'=BDATE
.S S=$$VAL^XBDIQ1(9000011,X,80001)
.Q:S=""
.I '$D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP IPC DEP INTER",S)) Q
.S G=1_U_"F/U PL "_S
I G Q G
;now vpov using asnc
S Y="BGPG("
S X=P_"^ALL DX;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,Y)
S X=0 F S X=$O(BGPG(X)) Q:X'=+X!(G) D
.S I=+$P(BGPG(X),U,4)
.S V=$P(BGPG(X),U,5)
.S S=$$VAL^XBDIQ1(9000010.07,I,1101)
.I S="" Q
.I '$D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP IPC DEP INTER",S)) Q
.S G=1_U_"F/U POV "_S
I G Q G
;REFERRALS? ANY V REFERRAL ON DATE WITH A SNOMED AS .01 FIELD
S Z=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 DEP INTER",S))
.S G=1_U_"F/U Referral: "_S Q
I G Q G
S G=""
;V PATIENT EDUCATION
K BGPG
S X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
S X=0 F S X=$O(BGPG(X)) Q:X'=+X!(G) D
.S I=+$P(BGPG(X),U,4)
.S T=$$VALI^XBDIQ1(9000010.16,I,.01)
.Q:'T
.Q:'$D(^AUTTEDT(T,0))
.S T=$P(^AUTTEDT(T,0),U,2)
.I $P(T,"-",2)'="FU" Q ;must be followup
.S S=$P(T,"-",1)
.S C=$$ICDDX^BGP8UTL2(S)
.I $P(C,U,1)'="-1",$$ICD^BGP8UTL2($P(C,U,1),$O(^ATXAX("B","BGP IPC DEPRESSION DIAG DXS",0)),9) S G=1_U_"F/U Pt Ed "_T Q
.I $P(C,U,1)'="-1",$$ICD^BGP8UTL2($P(C,U,1),$O(^ATXAX("B","BGP IPC BIPOLAR DISORDER DXS",0)),9) S G=1_U_"F/U Pt Ed "_T Q
.;is it a snomed?
.I $D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP IPC DEP INTER",S)) S G=1_U_"F/U Pt Ed "_T Q
.I $D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP IPC DEPRESSION DX",S)) S G=1_U_"F/U Pt Ed "_T Q
.I $D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP IPC BIPOLAR DX",S)) S G=1_U_"F/U Pt Ed "_T Q
I G Q G
;v med first
D GETMEDS^BGP8UTL2(P,BDATE,EDATE,"BGP IPC DEPRESSION MEDS","",,,.BGPMEDS1,"BGP IPC DEPRESSION RXNORM")
S X=0,T=0,W="" F S X=$O(BGPMEDS1(X)) Q:X'=+X!(G) D
.S Y=$P(BGPMEDS1(X),U,4) ;vmed ien
.Q:'$D(^AUPNVMED(Y,0))
.Q:$$UP^XLFSTR($P($G(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"
.S D=$P(^AUPNVMED(Y,0),U,1) ;drug ien
.;DAYS SUPPLY MUST BE >0
.S E=$P(^AUPNVMED(Y,0),U,8) ;date discontinued
.S S=$P(^AUPNVMED(Y,0),U,7) ;DAYS SUPPLY
.Q:'S
.I E,E'>$P(BGPMEDS1(X),U,1) Q ;at least one day
.S G=1_U_"F/U Med "_$$VAL^XBDIQ1(9000010.14,Y,.01)
I G Q G
;how about orders
;go through all 52 for one ordered on BDATE
S TAX=$O(^ATXAX("B","BGP IPC DEPRESSION MEDS",0))
S TAX1=$O(^BGPSNOMR("B","BGP IPC DEPRESSION RXNORM",0))
S Z=0,G="" F S Z=$O(^PS(55,P,"P",Z)) Q:Z'=+Z!(G) D
.S R=$P(^PS(55,P,"P",Z,0),U,1)
.Q:'$D(^PSRX(R,0)) ;bad xref
.S D=$P(^PSRX(R,0),U,6)
.Q:'D ;no drug??
.S M=0
.I $D(^ATXAX(TAX,21,"B",D)) S M=1
.S B=$$VAL^XBDIQ1(9000010.14,R,9999999.27)
.I B]"",$D(^BGPSNOMR(TAX1,11,"B",B)) S M=1
.Q:'M
.;ORDER
.S O=$P($G(^PSRX(R,"OR1")),U,2) ;order number
.Q:'O
.Q:'$D(^OR(100,O))
.S A=0 F S A=$O(^OR(100,O,8,A)) Q:A'=+A!(G) D
..S D=$P($G(^OR(100,O,8,A,0)),U,1)
..I $P(D,".")=BDATE S G=1_U_"F/U PSRX Order"
I G Q G
Q ""
RES(T,R) ;
I T="PHQ2",R<3 Q "NEG"
I T="PHQ2" Q "POS"
I T="PHQ9",R<10 Q "NEG"
I T="PHQ9" Q "POS"
I T="PHQT",R<10 Q "NEG"
I T="PHQT" Q "POS"
Q ""
REFUSAL(P,BDATE,EDATE,BGPDEPV) ;
;CHECK REFUSAL FILE FIRST FOR FLU CVX OR FLU CPT AND MEDICAL REASON NOT DONE SNOMED OR PATIENT REASON NOT DONE SNOMED OR SYSTEM REASON NOT DONE SNOMED
;ITEM 1-2, 1-3, 1-4
NEW F,G,I,C,ID,X
S F=0,G="" F F=9999999.07,9999999.15 D
.S I="" F S I=$O(^AUPNPREF("AA",P,F,I)) Q:I=""!(G) D
..;check all file vs item combos
..I F=9999999.15,$$VAL^XBDIQ1(9999999.15,I,.02)'=36 Q
..I F=9999999.07 S C=$P($G(^AUTTMSR(I,0)),U,1) I C'="PHQ2",C'="PHQ9",C'="PHQT" Q
..S ID=0 F S ID=$O(^AUPNPREF("AA",P,F,I,ID)) Q:ID=""!(G) D
...Q:'$D(BGPDEPV(ID))
...S X=0 F S X=$O(^AUPNPREF("AA",P,F,I,ID,X)) Q:X'=+X!(G) D
....;get snomed reason not done and it must be in one of the subsets
....S R=$$VALI^XBDIQ1(9000022,X,1.01) ;SNOMED REASON NOT DONE
....I R]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP IPC NOT DONE MED",R)) S G=1 Q
....I R]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP IPC NOT DONE PAT",R)) S G=1 Q
....I $$VALI^XBDIQ1(9000022,X,.07)="R" S G=1 Q
....I $$VALI^XBDIQ1(9000022,X,.07)="N" S G=1 Q
Q G
BGP8PC12 ; IHS/CMI/LAB - measure I2 ; 02 Feb 2018 11:25 AM
+1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
+2 ;
DFU SET (BGPN1,BGPD1)=0
+1 SET BGPFDV=""
KILL BGPDEPV,BGPV,BGPDOV
+2 ;
+3 ;12 or greater during time period
IF BGPAGEE<12
SET BGPSTOP=1
QUIT
+4 ;
+5 ;GATHER UP ALL DEP SCRN VISITS
+6 NEW X,V,D,Y
+7 ;Let's check all Visits, looping through once
+8 ;return variable
SET G=""
+9 KILL BGPV
+10 ;get all visits in date range in BGPV
+11 DO ALLV^APCLAPIU(DFN,BGPBDATE,BGPEDATE,"BGPV")
+12 ;I '$O(BGPV(0)) S BGPSTOP=1 G DFUE ;NO DEP VISITS
+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),X)=BGPV(X)
+16 SET D=0
FOR
SET D=$ORDER(BGPDOV(D))
IF D'=+D
QUIT
SET X=0
FOR
SET X=$ORDER(BGPDOV(D,X))
IF X'=+X
QUIT
SET V=$PIECE(BGPDOV(D,X),U,5)
Begin DoDot:1
+17 ;no dependent entries
IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+18 ;deleted
IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+19 SET Y=$$DEPV(V)
IF Y]""
SET BGPDEPV(9999999-D,X)=""
+20 ;is .17 a cpt we want?
+21 SET Y=$$VALI^XBDIQ1(9000010,V,.17)
+22 IF Y
IF $$OFFCPT12(Y)
SET BGPDEPV(9999999-D,X)=""
QUIT
+23 ;now check all V CPTs
+24 SET Z=0
FOR
SET Z=$ORDER(^AUPNVCPT("AD",V,Z))
IF Z'=+Z
QUIT
Begin DoDot:2
+25 SET Y=$PIECE($GET(^AUPNVCPT(Z,0)),U,1)
+26 IF Y
IF $$OFFCPT12(Y)
SET BGPDEPV(9999999-D,X)=""
QUIT
End DoDot:2
End DoDot:1
+27 ;NOW ADD IN ANY VISITS IN BH THAT DID NOT PASS TO PCC AND ARE NOT EHR CREATED
+28 SET D=0
SET E=9999999-BGPBDATE
SET D=9999999-BGPEDATE-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
+29 ;ALREADY IN PCC SO WOULD HAVE GOT IT ALREADY
IF $PIECE(^AMHREC(V,0),U,16)
QUIT
+30 SET S=$PIECE($$VALI^XBDIQ1(9002011,V,.01),".")
+31 SET Z=0
FOR
SET Z=$ORDER(^AMHRPROC("AD",V,Z))
IF Z'=+Z
QUIT
Begin DoDot:2
+32 SET Y=$PIECE($GET(^AMHRPROC(Z,0)),U,1)
+33 IF Y
IF $$OFFCPT12(Y)
SET BGPDEPV($PIECE(D,"."),V)=""
QUIT
End DoDot:2
End DoDot:1
+34 ;
+35 IF '$DATA(BGPDEPV)
SET BGPSTOP=1
GOTO DFUE
+36 ;
+37 SET BGPFDV=""
SET X=""
FOR
SET X=$ORDER(BGPDEPV(X))
IF X'=+X
QUIT
SET BGPFDV=X
+38 SET D=9999999-BGPFDV
+39 ;
+40 ;now what about exclusions?
+41 ;DX PRIOR TO 1ST DEP VISIT
IF $$HASDX(DFN,$$DOB^AUPNPAT(DFN),$$FMADD^XLFDT(D,-1))
SET BGPSTOP=1
GOTO DFUE
+42 ;
+43 ;FIND LAST SCREEN ON A DATE OF A DEPRESSION VISIT
+44 SET D=0
SET G=""
FOR
SET D=$ORDER(BGPDEPV(D))
IF D'=+D!(G]"")
QUIT
Begin DoDot:1
+45 SET G=$$DEPSCR(DFN,(9999999-D),(9999999-D))
End DoDot:1
+46 IF G]""
IF G
SET BGPN1=1
GOTO DFU1
+47 ;any screening during entire report period?
+48 SET E=$$DEPSCR(DFN,BGPBDATE,BGPEDATE)
+49 ;HAS A SCREENING SO CAN'T EXCLUDE
IF E]""
GOTO DFU1
+50 ;check refusal, etc
+51 SET X=$$REFUSAL(DFN,BGPBDATE,BGPEDATE,.BGPDEPV)
+52 IF X
SET BGPSTOP=1
GOTO DFUE
DFU1 ;
+1 SET BGPD1=1
+2 SET BGPVALUE=""
+3 ;hit denominator
SET BGPVALUE="ENC "_$$DATE^BGP8UTL((9999999-BGPFDV))_"|||"
+4 IF BGPN1
SET BGPVALUE=BGPVALUE_"*** "_$$DATE^BGP8UTL($PIECE(G,U,2))_" "_$PIECE(G,U,4)_" "_$PIECE(G,U,6)_" "_$PIECE(G,U,7)
+5 IF 'BGPN1
SET BGPVALUE=BGPVALUE_$$DATE^BGP8UTL($PIECE(G,U,2))_" "_$PIECE(G,U,4)_" "_$PIECE(G,U,6)_" "_$PIECE(G,U,7)
+6 ;
DFUE ;
+1 KILL D,V,X,Y,BGPV,BGPDEPV,BGPFDV,BGPDOV,G
+2 QUIT
DEPV(V) ;EP
+1 NEW A,B,C
+2 SET A=0
SET B=""
+3 FOR
SET A=$ORDER(^AUPNVSIT(V,28,"B",A))
IF A=""!(B]"")
QUIT
Begin DoDot:1
+4 IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM BGP IPC DEP SCRN ENC",A))
SET B=A
End DoDot:1
+5 IF B]""
QUIT B
+6 SET A=0
SET B=""
+7 FOR
SET A=$ORDER(^AUPNVSIT(V,26,"B",A))
IF A=""!(B]"")
QUIT
Begin DoDot:1
+8 IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM BGP IPC DEP SCRN ENC",A))
SET B=A
End DoDot:1
+9 QUIT B
OFFCPT12(C) ;EP
+1 IF $$ICD^ATXAPI(C,$ORDER(^ATXAX("B","BGP IPC DEP SCRN ENC CPTS",0)),1)
QUIT 1
+2 QUIT ""
LOINC(A,B) ;EP
+1 NEW %
+2 SET %=$PIECE($GET(^LAB(95.3,A,9999999)),U,2)
+3 IF %]""
IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+4 SET %=$PIECE($GET(^LAB(95.3,A,0)),U)_"-"_$PIECE($GET(^LAB(95.3,A,0)),U,15)
+5 IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+6 QUIT ""
HASDX(P,BDATE,EDATE) ;
+1 NEW X,Y,Z
+2 IF $$PLTAXND^BGP8DU(P,"BGP IPC DEPRESSION DIAG DXS",EDATE,1)
QUIT 1
+3 IF $$IPLSNOND^BGP8DU(P,"PXRM BGP IPC DEPRESSION DX",EDATE,1)
QUIT 1
+4 IF $$LASTDX^BGP8UTL1(P,"BGP IPC DEPRESSION DIAG DXS",BDATE,EDATE)
QUIT 1
+5 IF $$PLTAXND^BGP8DU(P,"BGP IPC BIPOLAR DIAG DXS",EDATE,1)
QUIT 1
+6 IF $$IPLSNOND^BGP8DU(P,"PXRM BGP IPC BIPOLAR DX",EDATE,1)
QUIT 1
+7 IF $$LASTDX^BGP8UTL1(P,"BGP IPC BIPOLAR DIAG DXS",BDATE,EDATE)
QUIT 1
+8 IF $$BHDX(P,BDATE,EDATE)
QUIT 1
+9 QUIT ""
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 DIAG DXS",0)),9)
SET G=1
QUIT
+20 IF $$ICD^BGP8UTL2(Z,$ORDER(^ATXAX("B","BGP IPC DEPRESSION DIAG DXS",0)),9)
SET G=1
QUIT
+21 QUIT
End DoDot:1
+22 QUIT G
DEPSCR(P,BDATE,EDATE) ;
+1 NEW X,Y,Z,BGPV,BGPS,V,D,E,S
+2 SET BGPS=""
+3 DO ALLV^APCLAPIU(P,BDATE,EDATE,"BGPV")
+4 SET X=0
FOR
SET X=$ORDER(BGPV(X))
IF X'=+X
QUIT
Begin DoDot:1
+5 SET V=$PIECE(BGPV(X),U,5)
+6 ;get depression screenings exam 36
+7 SET Y=0
FOR
SET Y=$ORDER(^AUPNVXAM("AD",V,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+8 SET E=$$VAL^XBDIQ1(9000010.13,Y,.019)
+9 IF E'=36
QUIT
+10 ;no result
IF $PIECE(^AUPNVXAM(Y,0),U,4)=""
QUIT
+11 SET R=$$VALI^XBDIQ1(9000010.13,Y,.04)
+12 ;these are the positive and negative values
IF R'="N"
IF R'="PO"
IF R'="RF"
QUIT
+13 ;S D=$P($G(^AUPNVXAM(Y,12)),U,1)
+14 SET D=$$VDTM^APCLV(V)
+15 IF D=$PIECE(BGPS,U,1)
IF Y>$PIECE(BGPS,U,4)
SET BGPS=D_U_R_U_"Exam 36"_U_Y_U_$SELECT(R="PO":"POS",R="RF":"POS",1:"NEG")
QUIT
+16 IF D>$PIECE(BGPS,U,1)
SET BGPS=D_U_$$VAL^XBDIQ1(9000010.13,Y,.04)_U_"Exam 36"_U_Y_U_$SELECT(R="PO":"POS",R="RF":"POS",1:"NEG")
QUIT
End DoDot:2
+17 ;GET PHQ's
+18 SET Y=0
FOR
SET Y=$ORDER(^AUPNVMSR("AD",V,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+19 ;entered in error
IF $PIECE($GET(^AUPNVMSR(Y,2)),U,1)
QUIT
+20 SET E=$$VAL^XBDIQ1(9000010.01,Y,.01)
+21 IF E'="PHQ2"
IF E'="PHQ9"
IF E'="PHQT"
QUIT
+22 ;no result
IF $PIECE(^AUPNVMSR(Y,0),U,4)=""
QUIT
+23 SET R=$$VAL^XBDIQ1(9000010.01,Y,.04)
+24 ;S D=$P($G(^AUPNVMSR(Y,12)),U,1)
+25 SET D=$$VDTM^APCLV(V)
+26 IF D=$PIECE(BGPS,U,1)
IF Y>$PIECE(BGPS,U,4)
SET BGPS=D_U_$$VAL^XBDIQ1(9000010.13,Y,.04)_U_"Meas "_E_U_Y_U_$$RES(E,R)
QUIT
+27 IF D>$PIECE(BGPS,U,1)
SET BGPS=D_U_$$VAL^XBDIQ1(9000010.13,Y,.04)_U_"Meas "_E_U_Y_U_$$RES(E,R)
QUIT
End DoDot:2
End DoDot:1
+28 ;ADD IN BH
+29 SET D=0
SET E=9999999-BDATE
SET D=9999999-EDATE-1_".99"
FOR
SET D=$ORDER(^AMHREC("AE",P,D))
IF D'=+D!($PIECE(D,".")>E)
QUIT
SET V=0
FOR
SET V=$ORDER(^AMHREC("AE",P,D,V))
IF V'=+V
QUIT
Begin DoDot:1
+30 SET S=$PIECE($$VALI^XBDIQ1(9002011,V,.01),".")
+31 SET R=$$VALI^XBDIQ1(9002011,V,1405)
+32 IF R=""
GOTO BHM
+33 IF R]""
IF R'="P"
IF R'="N"
IF R'="RF"
QUIT
+34 IF S>$PIECE(BGPS,U,1)
SET BGPS=S_U_$$VAL^XBDIQ1(9002011,V,1405)_U_"BH Exam 36"_U_V_U_$SELECT(R="P":"POS",R="RF":"POS",1:"NEG")
QUIT
BHM SET X=0
FOR
SET X=$ORDER(^AMHRMSR("AD",V,X))
IF X'=+X
QUIT
SET BGPP=$PIECE($GET(^AMHRMSR(X,0)),U)
Begin DoDot:2
+1 SET BGPP=$PIECE($GET(^AUTTMSR(BGPP,0)),U)
+2 SET R=$$VAL^XBDIQ1(9002011.12,X,.04)
+3 IF BGPP="PHQ2"!(BGPP="PHQ9")!(BGPP="PHQT")
IF S>$PIECE(BGPS,U,1)
SET BGPS=S_U_$$VAL^XBDIQ1(9002011.12,X,.04)_U_"BH Meas "_BGPP_U_X_U_$$RES(BGPP,R)
QUIT
End DoDot:2
End DoDot:1
+4 IF BGPS=""
QUIT ""
+5 SET R=$PIECE(BGPS,U,5)
+6 IF R="NEG"
QUIT 1_U_BGPS
+7 SET Y=$$FUPLAN(P,$PIECE($PIECE(BGPS,U,1),"."),$PIECE($PIECE(BGPS,U,1),"."))
+8 IF 'Y
QUIT 0_U_BGPS_U_"NO FU PLAN"
+9 IF Y
QUIT 1_U_BGPS_U_$PIECE(Y,U,2)
+10 QUIT
FUPLAN(P,BDATE,EDATE) ;
+1 ;PROBLEM LIST SNOMED ENTERED ON BDATE
+2 NEW X,G,S,BGPG,Y,I,V,W,Z,TAX,BGPMEDS1,TAX1,M,R,B,O
+3 SET X=0
SET G=""
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+4 IF '$DATA(^AUPNPROB(X,0))
QUIT
+5 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+6 IF $PIECE(^AUPNPROB(X,0),U,8)'=BDATE
QUIT
+7 SET S=$$VAL^XBDIQ1(9000011,X,80001)
+8 IF S=""
QUIT
+9 IF '$DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM BGP IPC DEP INTER",S))
QUIT
+10 SET G=1_U_"F/U PL "_S
End DoDot:1
+11 IF G
QUIT G
+12 ;now vpov using asnc
+13 SET Y="BGPG("
+14 SET X=P_"^ALL DX;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,Y)
+15 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+16 SET I=+$PIECE(BGPG(X),U,4)
+17 SET V=$PIECE(BGPG(X),U,5)
+18 SET S=$$VAL^XBDIQ1(9000010.07,I,1101)
+19 IF S=""
QUIT
+20 IF '$DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM BGP IPC DEP INTER",S))
QUIT
+21 SET G=1_U_"F/U POV "_S
End DoDot:1
+22 IF G
QUIT G
+23 ;REFERRALS? ANY V REFERRAL ON DATE WITH A SNOMED AS .01 FIELD
+24 SET Z=0
FOR
SET Z=$ORDER(^AUPNVREF("AC",P,Z))
IF Z'=+Z!(G)
QUIT
Begin DoDot:1
+25 SET V=$PIECE($GET(^AUPNVREF(Z,0)),U,3)
+26 SET D=$$VD^APCLV(V)
+27 IF D<BDATE
QUIT
+28 IF D>EDATE
QUIT
+29 SET S=$PIECE($GET(^AUPNVREF(Z,0)),U,1)
IF S=""
QUIT
+30 IF '$DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM BGP IPC DEP INTER",S))
QUIT
+31 SET G=1_U_"F/U Referral: "_S
QUIT
End DoDot:1
+32 IF G
QUIT G
+33 SET G=""
+34 ;V PATIENT EDUCATION
+35 KILL BGPG
+36 SET X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+37 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+38 SET I=+$PIECE(BGPG(X),U,4)
+39 SET T=$$VALI^XBDIQ1(9000010.16,I,.01)
+40 IF 'T
QUIT
+41 IF '$DATA(^AUTTEDT(T,0))
QUIT
+42 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+43 ;must be followup
IF $PIECE(T,"-",2)'="FU"
QUIT
+44 SET S=$PIECE(T,"-",1)
+45 SET C=$$ICDDX^BGP8UTL2(S)
+46 IF $PIECE(C,U,1)'="-1"
IF $$ICD^BGP8UTL2($PIECE(C,U,1),$ORDER(^ATXAX("B","BGP IPC DEPRESSION DIAG DXS",0)),9)
SET G=1_U_"F/U Pt Ed "_T
QUIT
+47 IF $PIECE(C,U,1)'="-1"
IF $$ICD^BGP8UTL2($PIECE(C,U,1),$ORDER(^ATXAX("B","BGP IPC BIPOLAR DISORDER DXS",0)),9)
SET G=1_U_"F/U Pt Ed "_T
QUIT
+48 ;is it a snomed?
+49 IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM BGP IPC DEP INTER",S))
SET G=1_U_"F/U Pt Ed "_T
QUIT
+50 IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM BGP IPC DEPRESSION DX",S))
SET G=1_U_"F/U Pt Ed "_T
QUIT
+51 IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM BGP IPC BIPOLAR DX",S))
SET G=1_U_"F/U Pt Ed "_T
QUIT
End DoDot:1
+52 IF G
QUIT G
+53 ;v med first
+54 DO GETMEDS^BGP8UTL2(P,BDATE,EDATE,"BGP IPC DEPRESSION MEDS","",,,.BGPMEDS1,"BGP IPC DEPRESSION RXNORM")
+55 SET X=0
SET T=0
SET W=""
FOR
SET X=$ORDER(BGPMEDS1(X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+56 ;vmed ien
SET Y=$PIECE(BGPMEDS1(X),U,4)
+57 IF '$DATA(^AUPNVMED(Y,0))
QUIT
+58 IF $$UP^XLFSTR($PIECE($GET(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"
QUIT
+59 ;drug ien
SET D=$PIECE(^AUPNVMED(Y,0),U,1)
+60 ;DAYS SUPPLY MUST BE >0
+61 ;date discontinued
SET E=$PIECE(^AUPNVMED(Y,0),U,8)
+62 ;DAYS SUPPLY
SET S=$PIECE(^AUPNVMED(Y,0),U,7)
+63 IF 'S
QUIT
+64 ;at least one day
IF E
IF E'>$PIECE(BGPMEDS1(X),U,1)
QUIT
+65 SET G=1_U_"F/U Med "_$$VAL^XBDIQ1(9000010.14,Y,.01)
End DoDot:1
+66 IF G
QUIT G
+67 ;how about orders
+68 ;go through all 52 for one ordered on BDATE
+69 SET TAX=$ORDER(^ATXAX("B","BGP IPC DEPRESSION MEDS",0))
+70 SET TAX1=$ORDER(^BGPSNOMR("B","BGP IPC DEPRESSION RXNORM",0))
+71 SET Z=0
SET G=""
FOR
SET Z=$ORDER(^PS(55,P,"P",Z))
IF Z'=+Z!(G)
QUIT
Begin DoDot:1
+72 SET R=$PIECE(^PS(55,P,"P",Z,0),U,1)
+73 ;bad xref
IF '$DATA(^PSRX(R,0))
QUIT
+74 SET D=$PIECE(^PSRX(R,0),U,6)
+75 ;no drug??
IF 'D
QUIT
+76 SET M=0
+77 IF $DATA(^ATXAX(TAX,21,"B",D))
SET M=1
+78 SET B=$$VAL^XBDIQ1(9000010.14,R,9999999.27)
+79 IF B]""
IF $DATA(^BGPSNOMR(TAX1,11,"B",B))
SET M=1
+80 IF 'M
QUIT
+81 ;ORDER
+82 ;order number
SET O=$PIECE($GET(^PSRX(R,"OR1")),U,2)
+83 IF 'O
QUIT
+84 IF '$DATA(^OR(100,O))
QUIT
+85 SET A=0
FOR
SET A=$ORDER(^OR(100,O,8,A))
IF A'=+A!(G)
QUIT
Begin DoDot:2
+86 SET D=$PIECE($GET(^OR(100,O,8,A,0)),U,1)
+87 IF $PIECE(D,".")=BDATE
SET G=1_U_"F/U PSRX Order"
End DoDot:2
End DoDot:1
+88 IF G
QUIT G
+89 QUIT ""
RES(T,R) ;
+1 IF T="PHQ2"
IF R<3
QUIT "NEG"
+2 IF T="PHQ2"
QUIT "POS"
+3 IF T="PHQ9"
IF R<10
QUIT "NEG"
+4 IF T="PHQ9"
QUIT "POS"
+5 IF T="PHQT"
IF R<10
QUIT "NEG"
+6 IF T="PHQT"
QUIT "POS"
+7 QUIT ""
REFUSAL(P,BDATE,EDATE,BGPDEPV) ;
+1 ;CHECK REFUSAL FILE FIRST FOR FLU CVX OR FLU CPT AND MEDICAL REASON NOT DONE SNOMED OR PATIENT REASON NOT DONE SNOMED OR SYSTEM REASON NOT DONE SNOMED
+2 ;ITEM 1-2, 1-3, 1-4
+3 NEW F,G,I,C,ID,X
+4 SET F=0
SET G=""
FOR F=9999999.07,9999999.15
Begin DoDot:1
+5 SET I=""
FOR
SET I=$ORDER(^AUPNPREF("AA",P,F,I))
IF I=""!(G)
QUIT
Begin DoDot:2
+6 ;check all file vs item combos
+7 IF F=9999999.15
IF $$VAL^XBDIQ1(9999999.15,I,.02)'=36
QUIT
+8 IF F=9999999.07
SET C=$PIECE($GET(^AUTTMSR(I,0)),U,1)
IF C'="PHQ2"
IF C'="PHQ9"
IF C'="PHQT"
QUIT
+9 SET ID=0
FOR
SET ID=$ORDER(^AUPNPREF("AA",P,F,I,ID))
IF ID=""!(G)
QUIT
Begin DoDot:3
+10 IF '$DATA(BGPDEPV(ID))
QUIT
+11 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,F,I,ID,X))
IF X'=+X!(G)
QUIT
Begin DoDot:4
+12 ;get snomed reason not done and it must be in one of the subsets
+13 ;SNOMED REASON NOT DONE
SET R=$$VALI^XBDIQ1(9000022,X,1.01)
+14 IF R]""
IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM BGP IPC NOT DONE MED",R))
SET G=1
QUIT
+15 IF R]""
IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM BGP IPC NOT DONE PAT",R))
SET G=1
QUIT
+16 IF $$VALI^XBDIQ1(9000022,X,.07)="R"
SET G=1
QUIT
+17 IF $$VALI^XBDIQ1(9000022,X,.07)="N"
SET G=1
QUIT
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+18 QUIT G
