BGP8PC16 ; IHS/CMI/LAB - measure I2 ; 02 Feb 2018 11:25 AM
;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
;
CBP ;EP
S (BGPN1,BGPD1)=0
K Y
S BGPDV=""
I BGPAGEE<18 S BGPSTOP=1 Q ;18 or greater during time period
I BGPAGEB>85 S BGPSTOP=1 Q ;85 or less during time period
;
S BGPDV=$$ENC16(DFN,BGPBDATE,BGPEDATE) I BGPDV="" S BGPSTOP=1 G CBPX ;no office visit
;hypertension?
I '$$HTN(DFN,$$DOB^AUPNPAT(DFN),$$FMADD^XLFDT(BGPBDATE,180)) S BGPSTOP=1 G CBPX ;no hypertension
;now what about exclusions?
I $$HOSPIND^BGP8PC2(DFN,BGPBDATE,BGPEDATE) S BGPSTOP=1 G CBPX ;no hospice pts
;?
I $$PREG(DFN,BGPBDATE,BGPEDATE) S BGPSTOP=1 G CBPX
I $$ESRD(DFN,BGPBDATE,BGPEDATE) S BGPSTOP=1 G CBPX
I $$CKD(DFN,BGPBDATE,BGPEDATE) S BGPSTOP=1 G CBPX
I $$CPT^BGP8DU(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE,$O(^ATXAX("B","BGP IPC VASCULAR ACC DIAL CPTS",0)),5) S BGPSTOP=1 G CBPX
I $$CPT^BGP8DU(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE,$O(^ATXAX("B","BGP IPC ESRD OPT SRV CPTS",0)),5) S BGPSTOP=1 G CBPX
I $$CPT^BGP8DU(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE,$O(^ATXAX("B","BGP IPC KIDNEY TRANSPLANT CPTS",0)),5) S BGPSTOP=1 G CBPX
I $$CPT^BGP8DU(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE,$O(^ATXAX("B","BGP IPC DIALYSIS SRV CPTS",0)),5) S BGPSTOP=1 G CBPX
;
S BGPD1=1
;
K BGPG,BGPF
S Y="BGPG("
S X=DFN_"^FIRST DX [BGP IPC ESSENTIAL HTN DXS" S E=$$START1^APCLDF(X,Y)
;I '$D(BGPG(1)) S BGPSTOP=1 G CBPX ;NO DX EVER????
S BGPF=$P($G(BGPG(1)),U,1)
I BGPF="" S BGPF=$P($$PLTAXND(DFN,"BGP IPC ESSENTIAL HTN DXS",$$FMADD^XLFDT(BGPBDATE,180),1),U,3)
I BGPF="" S BGPF=$P($$IPLSNOND(DFN,"PXRM BGP IPC HTN",$$FMADD^XLFDT(BGPBDATE,180),1),U,3)
S BGPVAL=$$LASTBP(DFN,BGPBDATE,BGPEDATE) ;RETURN DATE^SYSTOLIC^DIASTOLIC
I BGPVAL="" G CBPV
I $P(BGPVAL,U,1)<BGPF G CBPV
I $P(BGPVAL,U,2)<140,$P(BGPVAL,U,3)<90 S BGPN1=1
CBPV ;
S BGPVALUE=""
S BGPVALUE="ENC "_$P(BGPDV,U,2)_"|||" ;hit denominator
S BGPVALUE=BGPVALUE_$S(BGPN1:"*** ",1:"")
I BGPVAL]"" S BGPVALUE=BGPVALUE_$$DATE^BGP8UTL($P(BGPVAL,U,1))_" "_$P(BGPVAL,U,2)_"/"_$P(BGPVAL,U,3)
CBPX ;
K V,BGPDV,BGPVAL,BGPG,F,Y,X,E
Q
ENC16(P,BDATE,EDATE) ;EP - have encounter per CMS122v6
;HAS one of the following
NEW X,Y,Z,G,BGPV,D
;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
.S D=$$VD^APCLV(V)
.S Y=$$FTOF^BGP8PC2(V) I Y]"" S G=1_U_$$DATE^BGP8UTL(D)_" FTOF: "_Y Q
.;is .17 a cpt we want?
.S Y=$$VALI^XBDIQ1(9000010,V,.17)
.I Y,$$OFFCPT16(Y) S G=1_U_$$DATE^BGP8UTL(D)_" CPT: "_$P($$CPT^ICPTCOD(Y),U,2) Q
.;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,$$OFFCPT16(Y) S G=1_U_$$DATE^BGP8UTL(D)_" CPT: "_$P($$CPT^ICPTCOD(Y),U,2) Q
Q G
OFFCPT16(C) ;EP
I $$ICD^ATXAPI(C,$O(^ATXAX("B","BGP IPC OFFICE VISIT CPTS",0)),1) Q 1
I $$ICD^ATXAPI(C,$O(^ATXAX("B","BGP IPC PREVCARE EOV >=18 CPTS",0)),1) Q 1
I $$ICD^ATXAPI(C,$O(^ATXAX("B","BGP IPC PREVCARE IOV >=18 CPTS",0)),1) Q 1
I $$ICD^ATXAPI(C,$O(^ATXAX("B","BGP IPC HOMEHEALTH VISIT CPTS",0)),1) Q 1
I $$ICD^ATXAPI(C,$O(^ATXAX("B","BGP IPC ANNUAL WELLNESS CPTS",0)),1) Q 1
Q ""
HTN(P,BDATE,EDATE) ;
I $$PLTAXND^BGP8DU(P,"BGP IPC ESSENTIAL HTN DXS",EDATE,1) Q 1
I $$IPLSNOND^BGP8DU(P,"PXRM BGP IPC HTN",EDATE,1) Q 1
I $$LASTDX^BGP8UTL1(P,"BGP IPC ESSENTIAL HTN DXS",BDATE,EDATE) Q 1
Q ""
PREG(P,BDATE,EDATE) ;
NEW X,Y,Z,G,A
I $P(^DPT(P,0),U,2)'="F" Q ""
;check dx
S X=$$LASTDX^BGP8UTL1(P,"BGP IPC PREGNANCY DXS",BDATE,EDATE) I X Q 1
S T=$O(^ATXAX("B","BGP IPC PREGNANCY DXS",0))
S (X,G,A)=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G) D
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.S A=0
.S D=$P(^AUPNPROB(X,0),U,13)
.I D'<BDATE,D'>EDATE S A=1
.I A G PREGN
.;I D Q ;had a doo and it didn't match
.Q:$P(^AUPNPROB(X,0),U,8)>EDATE
.Q:$P(^AUPNPROB(X,0),U,8)<BDATE
PREGN .I $$ICD^ATXAPI($P(^AUPNPROB(X,0),U,1),T,9) S G=1 Q
.S S=$$VAL^XBDIQ1(9000011,X,80001)
.I S]"",$D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP IPC PREGNANCY",S)) S G=1 Q
Q G
ESRD(P,BDATE,EDATE) ;
I $$PLTAXND^BGP8DU(P,"BGP IPC ESRD DXS",EDATE,1) Q 1
I $$LASTDX^BGP8UTL1(P,"BGP IPC ESRD DXS",BDATE,EDATE) Q 1
NEW X,S,I
S I=""
S X=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(I) D
.Q:'$D(^AUPNPROB(X,0))
.I $P(^AUPNPROB(X,0),U,12)="D" Q
.I $P(^AUPNPROB(X,0),U,12)="I" Q
.I $P(^AUPNPROB(X,0),U,13),$P(^AUPNPROB(X,0),U,13)>EDATE Q ;if there is a doo and it is after report period skip
.I $P(^AUPNPROB(X,0),U,13)="",$P(^AUPNPROB(X,0),U,8)>EDATE Q ;entered after report period, skip
.S S=$$VAL^XBDIQ1(9000011,X,80001)
.I S=236434000 S I=1 Q
.I S=236435004 S I=1 Q
.I S=236436003 S I=1 Q
.I S=46177005 S I=1 Q
.Q
I I Q 1
;NOW V POV FOR SNOMED CODE
;NOW SNOMED USING ASNC
S G="",I=""
S S="" F S S=$O(^AUPNVPOV("ASNC",P,S)) Q:S=""!(G) D
.S I=0
.I S=236434000 S I=1
.I S=236435004 S I=1
.I S=236436003 S I=1
.I S=46177005 S I=1
.Q:'I
.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 1
Q ""
CKD(P,BDATE,EDATE) ;
I $$PLTAXND^BGP8DU(P,"BGP IPC CKD STG 5 DXS",EDATE,1) Q 1
I $$LASTDX^BGP8UTL1(P,"BGP IPC CKD STG 5 DXS",BDATE,EDATE) Q 1
NEW X,S,I
S I=""
S X=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(I) D
.Q:'$D(^AUPNPROB(X,0))
.I $P(^AUPNPROB(X,0),U,12)="D" Q
.I $P(^AUPNPROB(X,0),U,12)="I" Q
.I $P(^AUPNPROB(X,0),U,13),$P(^AUPNPROB(X,0),U,13)>EDATE Q ;if there is a doo and it is after report period skip
.I $P(^AUPNPROB(X,0),U,13)="",$P(^AUPNPROB(X,0),U,8)>EDATE Q ;entered after report period, skip
.S S=$$VAL^XBDIQ1(9000011,X,80001)
.I S=433146000 S I=1 Q
.Q
I I Q 1
;NOW V POV FOR SNOMED CODE
;NOW SNOMED USING ASNC
S G="",I=""
S S="" F S S=$O(^AUPNVPOV("ASNC",P,S)) Q:S=""!(G) D
.S I=0
.I S=433146000 S I=1
.Q:'I
.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 1
Q ""
LASTBP(P,BDATE,EDATE) ;
NEW A,B,C,G,X,Y,Z,SYS,DIA,D,BGPV,V,L,LV,R
;get all visits in time window
;eliminate all that are not outpatient adult visits
D ALLV^APCLAPIU(P,BDATE,EDATE,"BGPV")
I '$O(BGPV(0)) Q ""
;ELIMIATE NON ADULT OPT AND GET LAST ONE BY DATE/TIME, IF 2 AT SAME DATE/TIME TAKE HIGHEST IEN
K Z
S X=0,V="",G="" F S X=$O(BGPV(X)) Q:X'=+X D
.S V=$P(BGPV(X),U,5) ;VISIT IEN
.Q:'$P(^AUPNVSIT(V,0),U,9) ;no dependent entries
.Q:$P(^AUPNVSIT(V,0),U,11) ;deleted
.S D=$$VD^APCLV(V)
.S Y=$$FTOF^BGP8PC2(V) I Y]"" S Z(D,V)="" Q
.;is .17 a cpt we want?
.S C=$$VALI^XBDIQ1(9000010,V,.17) I C,$$ICD^ATXAPI(C,$O(^ATXAX("B","BGP IPC ADULT OPT CPTS",0)),1) S Z(D,V)="" Q
.;now check all V CPTs
.S B=0 F S B=$O(^AUPNVCPT("AD",V,B)) Q:B'=+B D
..S C=$P($G(^AUPNVCPT(B,0)),U,1)
..I C,$$ICD^ATXAPI(C,$O(^ATXAX("B","BGP IPC ADULT OPT CPTS",0)),1) S Z(D,V)="" Q
;NOW CHECK ARRAY Z AND GET VERY LAST ONE
I '$O(Z(0)) Q ""
S D=0,L="" F S D=$O(Z(D)) Q:D="" S L=D
S (SYS,DIA)=""
S V=0 F S V=$O(Z(L,V)) Q:V'=+V D
.;GET ALL BPS ON EACH ADULT VISIT ON THIS DAY
.S X=0 F S X=$O(^AUPNVMSR("AD",V,X)) Q:X'=+X D
..Q:'$D(^AUPNVMSR(X,0))
..Q:$$VAL^XBDIQ1(9000010.01,X,.01)'="BP"
..Q:$P($G(^AUPNVMSR(X,2)),U,1) ;entered in error
..S R=$$VAL^XBDIQ1(9000010.01,X,.04)
..S S=$P(R,"/"),D=$P(R,"/",2)
..I SYS="" S SYS=S
..I DIA="" S DIA=D
..I S<SYS S SYS=S
..I D<DIA S DIA=D
I SYS]"",DIA]"" Q L_U_SYS_U_DIA
Q ""
TESTBP ;
S DFN=0 F S DFN=$O(^AUPNPAT(DFN)) Q:DFN'=+DFN S A=$$LASTBP(DFN,3120101,DT) W !,DFN," ",A
Q
TESTESRD ;
S DFN=0 F S DFN=$O(^AUPNPAT(DFN)) Q:DFN'=+DFN S A=$$ESRD(DFN,$$DOB^AUPNPAT(DFN),DT) I A W !,DFN," ",A
Q
TESTPREG ;
S DFN=0 F S DFN=$O(^AUPNPAT(DFN)) Q:DFN'=+DFN S A=$$PREG(DFN,3120101,DT) I A W !,DFN," ",A
Q
TESTCKD ;
S DFN=0 F S DFN=$O(^AUPNPAT(DFN)) Q:DFN'=+DFN S A=$$CKD(DFN,$$DOB^AUPNPAT(DFN),DT) I A W !,DFN," ",A
Q
PLTAXND(P,A,E,Z) ;EP - is dx on problem list as NOT DELETED
;P is dfn
;a is taxonomy name
I $G(P)="" Q ""
I $G(A)="" Q ""
S E=$G(E)
S Z=$G(Z) ;skip inactive if =1
NEW T S T=$O(^ATXAX("B",A,0))
I 'T Q "" ;bad taxonomy??
NEW X,Y,I,D
S (X,Y,I)=0
F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(I) D
.Q:'$D(^AUPNPROB(X,0))
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.I Z Q:$P(^AUPNPROB(X,0),U,12)="I"
.S Y=$P(^AUPNPROB(X,0),U)
.I E,$P(^AUPNPROB(X,0),U,13)>E Q ;if there is a doo and it is after report period skip
.I $P(^AUPNPROB(X,0),U,13)="",E,$P(^AUPNPROB(X,0),U,8)>E Q ;entered after report period, skip
.Q:'$$ICD^BGP8UTL2(Y,T,9)
.S D=$P(^AUPNPROB(X,0),U,13)
.I 'D S D=$P(^AUPNPROB(X,0),U,8)
.S I=1_U_"Problem List: "_$$VAL^XBDIQ1(9000011,X,.01)_U_D
.Q
Q I
IPLSNOND(P,T,E,Z) ;EP - any problem list entry with a SNOMED in T
;LOOP PROBLEM LIST
NEW G,X,Y
S (X,G)=""
S E=$G(E)
S Z=$G(Z)
F S X=$O(^AUPNPROB("APCT",P,X)) Q:X=""!(G) D
.S Y=0 F S Y=$O(^AUPNPROB("APCT",P,X,Y)) Q:Y'=+Y!(G) D
..Q:'$D(^AUPNPROB(Y,0))
..Q:$P(^AUPNPROB(Y,0),U,12)="D" ;deleted
..I Z Q:$P(^AUPNPROB(Y,0),U,12)="I"
..Q:'$D(^XTMP("BGPSNOMEDSUBSET",$J,T,X))
..I E,$P(^AUPNPROB(Y,0),U,13)>E Q ;if there is a doo and it is after report period skip
..I $P(^AUPNPROB(Y,0),U,13)="",E,$P(^AUPNPROB(Y,0),U,8)>E Q ;entered after report period, skip
..S D=$P(^AUPNPROB(Y,0),U,13)
..I 'D S D=$P(^AUPNPROB(Y,0),U,8)
..S G=1_U_"Problem List: "_X_U_D ;$$CONCPT^AUPNVUTL(X)
Q G
BGP8PC16 ; IHS/CMI/LAB - measure I2 ; 02 Feb 2018 11:25 AM
+1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
+2 ;
CBP ;EP
+1 SET (BGPN1,BGPD1)=0
+2 KILL Y
+3 SET BGPDV=""
+4 ;18 or greater during time period
IF BGPAGEE<18
SET BGPSTOP=1
QUIT
+5 ;85 or less during time period
IF BGPAGEB>85
SET BGPSTOP=1
QUIT
+6 ;
+7 ;no office visit
SET BGPDV=$$ENC16(DFN,BGPBDATE,BGPEDATE)
IF BGPDV=""
SET BGPSTOP=1
GOTO CBPX
+8 ;hypertension?
+9 ;no hypertension
IF '$$HTN(DFN,$$DOB^AUPNPAT(DFN),$$FMADD^XLFDT(BGPBDATE,180))
SET BGPSTOP=1
GOTO CBPX
+10 ;now what about exclusions?
+11 ;no hospice pts
IF $$HOSPIND^BGP8PC2(DFN,BGPBDATE,BGPEDATE)
SET BGPSTOP=1
GOTO CBPX
+12 ;?
+13 IF $$PREG(DFN,BGPBDATE,BGPEDATE)
SET BGPSTOP=1
GOTO CBPX
+14 IF $$ESRD(DFN,BGPBDATE,BGPEDATE)
SET BGPSTOP=1
GOTO CBPX
+15 IF $$CKD(DFN,BGPBDATE,BGPEDATE)
SET BGPSTOP=1
GOTO CBPX
+16 IF $$CPT^BGP8DU(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE,$ORDER(^ATXAX("B","BGP IPC VASCULAR ACC DIAL CPTS",0)),5)
SET BGPSTOP=1
GOTO CBPX
+17 IF $$CPT^BGP8DU(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE,$ORDER(^ATXAX("B","BGP IPC ESRD OPT SRV CPTS",0)),5)
SET BGPSTOP=1
GOTO CBPX
+18 IF $$CPT^BGP8DU(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE,$ORDER(^ATXAX("B","BGP IPC KIDNEY TRANSPLANT CPTS",0)),5)
SET BGPSTOP=1
GOTO CBPX
+19 IF $$CPT^BGP8DU(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE,$ORDER(^ATXAX("B","BGP IPC DIALYSIS SRV CPTS",0)),5)
SET BGPSTOP=1
GOTO CBPX
+20 ;
+21 SET BGPD1=1
+22 ;
+23 KILL BGPG,BGPF
+24 SET Y="BGPG("
+25 SET X=DFN_"^FIRST DX [BGP IPC ESSENTIAL HTN DXS"
SET E=$$START1^APCLDF(X,Y)
+26 ;I '$D(BGPG(1)) S BGPSTOP=1 G CBPX ;NO DX EVER????
+27 SET BGPF=$PIECE($GET(BGPG(1)),U,1)
+28 IF BGPF=""
SET BGPF=$PIECE($$PLTAXND(DFN,"BGP IPC ESSENTIAL HTN DXS",$$FMADD^XLFDT(BGPBDATE,180),1),U,3)
+29 IF BGPF=""
SET BGPF=$PIECE($$IPLSNOND(DFN,"PXRM BGP IPC HTN",$$FMADD^XLFDT(BGPBDATE,180),1),U,3)
+30 ;RETURN DATE^SYSTOLIC^DIASTOLIC
SET BGPVAL=$$LASTBP(DFN,BGPBDATE,BGPEDATE)
+31 IF BGPVAL=""
GOTO CBPV
+32 IF $PIECE(BGPVAL,U,1)<BGPF
GOTO CBPV
+33 IF $PIECE(BGPVAL,U,2)<140
IF $PIECE(BGPVAL,U,3)<90
SET BGPN1=1
CBPV ;
+1 SET BGPVALUE=""
+2 ;hit denominator
SET BGPVALUE="ENC "_$PIECE(BGPDV,U,2)_"|||"
+3 SET BGPVALUE=BGPVALUE_$SELECT(BGPN1:"*** ",1:"")
+4 IF BGPVAL]""
SET BGPVALUE=BGPVALUE_$$DATE^BGP8UTL($PIECE(BGPVAL,U,1))_" "_$PIECE(BGPVAL,U,2)_"/"_$PIECE(BGPVAL,U,3)
CBPX ;
+1 KILL V,BGPDV,BGPVAL,BGPG,F,Y,X,E
+2 QUIT
ENC16(P,BDATE,EDATE) ;EP - have encounter per CMS122v6
+1 ;HAS one of the following
+2 NEW X,Y,Z,G,BGPV,D
+3 ;Let's check all Visits, looping through once
+4 ;return variable
SET G=""
+5 ;get all visits in date range in BGPV
+6 DO ALLV^APCLAPIU(P,BDATE,EDATE,"BGPV")
+7 ;now loop through and check Face to Face and .17 in visit and check v cpts attached to the visit
+8 SET X=0
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 D=$$VD^APCLV(V)
+12 SET Y=$$FTOF^BGP8PC2(V)
IF Y]""
SET G=1_U_$$DATE^BGP8UTL(D)_" FTOF: "_Y
QUIT
+13 ;is .17 a cpt we want?
+14 SET Y=$$VALI^XBDIQ1(9000010,V,.17)
+15 IF Y
IF $$OFFCPT16(Y)
SET G=1_U_$$DATE^BGP8UTL(D)_" CPT: "_$PIECE($$CPT^ICPTCOD(Y),U,2)
QUIT
+16 ;now check all V CPTs
+17 SET Z=0
FOR
SET Z=$ORDER(^AUPNVCPT("AD",V,Z))
IF Z'=+Z!(G)
QUIT
Begin DoDot:2
+18 SET Y=$PIECE($GET(^AUPNVCPT(Z,0)),U,1)
+19 IF Y
IF $$OFFCPT16(Y)
SET G=1_U_$$DATE^BGP8UTL(D)_" CPT: "_$PIECE($$CPT^ICPTCOD(Y),U,2)
QUIT
End DoDot:2
End DoDot:1
+20 QUIT G
OFFCPT16(C) ;EP
+1 IF $$ICD^ATXAPI(C,$ORDER(^ATXAX("B","BGP IPC OFFICE VISIT CPTS",0)),1)
QUIT 1
+2 IF $$ICD^ATXAPI(C,$ORDER(^ATXAX("B","BGP IPC PREVCARE EOV >=18 CPTS",0)),1)
QUIT 1
+3 IF $$ICD^ATXAPI(C,$ORDER(^ATXAX("B","BGP IPC PREVCARE IOV >=18 CPTS",0)),1)
QUIT 1
+4 IF $$ICD^ATXAPI(C,$ORDER(^ATXAX("B","BGP IPC HOMEHEALTH VISIT CPTS",0)),1)
QUIT 1
+5 IF $$ICD^ATXAPI(C,$ORDER(^ATXAX("B","BGP IPC ANNUAL WELLNESS CPTS",0)),1)
QUIT 1
+6 QUIT ""
HTN(P,BDATE,EDATE) ;
+1 IF $$PLTAXND^BGP8DU(P,"BGP IPC ESSENTIAL HTN DXS",EDATE,1)
QUIT 1
+2 IF $$IPLSNOND^BGP8DU(P,"PXRM BGP IPC HTN",EDATE,1)
QUIT 1
+3 IF $$LASTDX^BGP8UTL1(P,"BGP IPC ESSENTIAL HTN DXS",BDATE,EDATE)
QUIT 1
+4 QUIT ""
PREG(P,BDATE,EDATE) ;
+1 NEW X,Y,Z,G,A
+2 IF $PIECE(^DPT(P,0),U,2)'="F"
QUIT ""
+3 ;check dx
+4 SET X=$$LASTDX^BGP8UTL1(P,"BGP IPC PREGNANCY DXS",BDATE,EDATE)
IF X
QUIT 1
+5 SET T=$ORDER(^ATXAX("B","BGP IPC PREGNANCY DXS",0))
+6 SET (X,G,A)=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 SET A=0
+9 SET D=$PIECE(^AUPNPROB(X,0),U,13)
+10 IF D'<BDATE
IF D'>EDATE
SET A=1
+11 IF A
GOTO PREGN
+12 ;I D Q ;had a doo and it didn't match
+13 IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+14 IF $PIECE(^AUPNPROB(X,0),U,8)<BDATE
QUIT
PREGN IF $$ICD^ATXAPI($PIECE(^AUPNPROB(X,0),U,1),T,9)
SET G=1
QUIT
+1 SET S=$$VAL^XBDIQ1(9000011,X,80001)
+2 IF S]""
IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM BGP IPC PREGNANCY",S))
SET G=1
QUIT
End DoDot:1
+3 QUIT G
ESRD(P,BDATE,EDATE) ;
+1 IF $$PLTAXND^BGP8DU(P,"BGP IPC ESRD DXS",EDATE,1)
QUIT 1
+2 IF $$LASTDX^BGP8UTL1(P,"BGP IPC ESRD DXS",BDATE,EDATE)
QUIT 1
+3 NEW X,S,I
+4 SET I=""
+5 SET X=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(I)
QUIT
Begin DoDot:1
+6 IF '$DATA(^AUPNPROB(X,0))
QUIT
+7 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+8 IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+9 ;if there is a doo and it is after report period skip
IF $PIECE(^AUPNPROB(X,0),U,13)
IF $PIECE(^AUPNPROB(X,0),U,13)>EDATE
QUIT
+10 ;entered after report period, skip
IF $PIECE(^AUPNPROB(X,0),U,13)=""
IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+11 SET S=$$VAL^XBDIQ1(9000011,X,80001)
+12 IF S=236434000
SET I=1
QUIT
+13 IF S=236435004
SET I=1
QUIT
+14 IF S=236436003
SET I=1
QUIT
+15 IF S=46177005
SET I=1
QUIT
+16 QUIT
End DoDot:1
+17 IF I
QUIT 1
+18 ;NOW V POV FOR SNOMED CODE
+19 ;NOW SNOMED USING ASNC
+20 SET G=""
SET I=""
+21 SET S=""
FOR
SET S=$ORDER(^AUPNVPOV("ASNC",P,S))
IF S=""!(G)
QUIT
Begin DoDot:1
+22 SET I=0
+23 IF S=236434000
SET I=1
+24 IF S=236435004
SET I=1
+25 IF S=236436003
SET I=1
+26 IF S=46177005
SET I=1
+27 IF 'I
QUIT
+28 SET D=0
FOR
SET D=$ORDER(^AUPNVPOV("ASNC",P,S,D))
IF D=""!(G)
QUIT
Begin DoDot:2
+29 SET Y=9999999-D
+30 IF Y>EDATE
QUIT
+31 SET G=1
End DoDot:2
End DoDot:1
+32 IF G
QUIT 1
+33 QUIT ""
CKD(P,BDATE,EDATE) ;
+1 IF $$PLTAXND^BGP8DU(P,"BGP IPC CKD STG 5 DXS",EDATE,1)
QUIT 1
+2 IF $$LASTDX^BGP8UTL1(P,"BGP IPC CKD STG 5 DXS",BDATE,EDATE)
QUIT 1
+3 NEW X,S,I
+4 SET I=""
+5 SET X=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(I)
QUIT
Begin DoDot:1
+6 IF '$DATA(^AUPNPROB(X,0))
QUIT
+7 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+8 IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+9 ;if there is a doo and it is after report period skip
IF $PIECE(^AUPNPROB(X,0),U,13)
IF $PIECE(^AUPNPROB(X,0),U,13)>EDATE
QUIT
+10 ;entered after report period, skip
IF $PIECE(^AUPNPROB(X,0),U,13)=""
IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+11 SET S=$$VAL^XBDIQ1(9000011,X,80001)
+12 IF S=433146000
SET I=1
QUIT
+13 QUIT
End DoDot:1
+14 IF I
QUIT 1
+15 ;NOW V POV FOR SNOMED CODE
+16 ;NOW SNOMED USING ASNC
+17 SET G=""
SET I=""
+18 SET S=""
FOR
SET S=$ORDER(^AUPNVPOV("ASNC",P,S))
IF S=""!(G)
QUIT
Begin DoDot:1
+19 SET I=0
+20 IF S=433146000
SET I=1
+21 IF 'I
QUIT
+22 SET D=0
FOR
SET D=$ORDER(^AUPNVPOV("ASNC",P,S,D))
IF D=""!(G)
QUIT
Begin DoDot:2
+23 SET Y=9999999-D
+24 IF Y>EDATE
QUIT
+25 SET G=1
End DoDot:2
End DoDot:1
+26 IF G
QUIT 1
+27 QUIT ""
LASTBP(P,BDATE,EDATE) ;
+1 NEW A,B,C,G,X,Y,Z,SYS,DIA,D,BGPV,V,L,LV,R
+2 ;get all visits in time window
+3 ;eliminate all that are not outpatient adult visits
+4 DO ALLV^APCLAPIU(P,BDATE,EDATE,"BGPV")
+5 IF '$ORDER(BGPV(0))
QUIT ""
+6 ;ELIMIATE NON ADULT OPT AND GET LAST ONE BY DATE/TIME, IF 2 AT SAME DATE/TIME TAKE HIGHEST IEN
+7 KILL Z
+8 SET X=0
SET V=""
SET G=""
FOR
SET X=$ORDER(BGPV(X))
IF X'=+X
QUIT
Begin DoDot:1
+9 ;VISIT IEN
SET V=$PIECE(BGPV(X),U,5)
+10 ;no dependent entries
IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+11 ;deleted
IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+12 SET D=$$VD^APCLV(V)
+13 SET Y=$$FTOF^BGP8PC2(V)
IF Y]""
SET Z(D,V)=""
QUIT
+14 ;is .17 a cpt we want?
+15 SET C=$$VALI^XBDIQ1(9000010,V,.17)
IF C
IF $$ICD^ATXAPI(C,$ORDER(^ATXAX("B","BGP IPC ADULT OPT CPTS",0)),1)
SET Z(D,V)=""
QUIT
+16 ;now check all V CPTs
+17 SET B=0
FOR
SET B=$ORDER(^AUPNVCPT("AD",V,B))
IF B'=+B
QUIT
Begin DoDot:2
+18 SET C=$PIECE($GET(^AUPNVCPT(B,0)),U,1)
+19 IF C
IF $$ICD^ATXAPI(C,$ORDER(^ATXAX("B","BGP IPC ADULT OPT CPTS",0)),1)
SET Z(D,V)=""
QUIT
End DoDot:2
End DoDot:1
+20 ;NOW CHECK ARRAY Z AND GET VERY LAST ONE
+21 IF '$ORDER(Z(0))
QUIT ""
+22 SET D=0
SET L=""
FOR
SET D=$ORDER(Z(D))
IF D=""
QUIT
SET L=D
+23 SET (SYS,DIA)=""
+24 SET V=0
FOR
SET V=$ORDER(Z(L,V))
IF V'=+V
QUIT
Begin DoDot:1
+25 ;GET ALL BPS ON EACH ADULT VISIT ON THIS DAY
+26 SET X=0
FOR
SET X=$ORDER(^AUPNVMSR("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:2
+27 IF '$DATA(^AUPNVMSR(X,0))
QUIT
+28 IF $$VAL^XBDIQ1(9000010.01,X,.01)'="BP"
QUIT
+29 ;entered in error
IF $PIECE($GET(^AUPNVMSR(X,2)),U,1)
QUIT
+30 SET R=$$VAL^XBDIQ1(9000010.01,X,.04)
+31 SET S=$PIECE(R,"/")
SET D=$PIECE(R,"/",2)
+32 IF SYS=""
SET SYS=S
+33 IF DIA=""
SET DIA=D
+34 IF S<SYS
SET SYS=S
+35 IF D<DIA
SET DIA=D
End DoDot:2
End DoDot:1
+36 IF SYS]""
IF DIA]""
QUIT L_U_SYS_U_DIA
+37 QUIT ""
TESTBP ;
+1 SET DFN=0
FOR
SET DFN=$ORDER(^AUPNPAT(DFN))
IF DFN'=+DFN
QUIT
SET A=$$LASTBP(DFN,3120101,DT)
WRITE !,DFN," ",A
+2 QUIT
TESTESRD ;
+1 SET DFN=0
FOR
SET DFN=$ORDER(^AUPNPAT(DFN))
IF DFN'=+DFN
QUIT
SET A=$$ESRD(DFN,$$DOB^AUPNPAT(DFN),DT)
IF A
WRITE !,DFN," ",A
+2 QUIT
TESTPREG ;
+1 SET DFN=0
FOR
SET DFN=$ORDER(^AUPNPAT(DFN))
IF DFN'=+DFN
QUIT
SET A=$$PREG(DFN,3120101,DT)
IF A
WRITE !,DFN," ",A
+2 QUIT
TESTCKD ;
+1 SET DFN=0
FOR
SET DFN=$ORDER(^AUPNPAT(DFN))
IF DFN'=+DFN
QUIT
SET A=$$CKD(DFN,$$DOB^AUPNPAT(DFN),DT)
IF A
WRITE !,DFN," ",A
+2 QUIT
PLTAXND(P,A,E,Z) ;EP - is dx on problem list as NOT DELETED
+1 ;P is dfn
+2 ;a is taxonomy name
+3 IF $GET(P)=""
QUIT ""
+4 IF $GET(A)=""
QUIT ""
+5 SET E=$GET(E)
+6 ;skip inactive if =1
SET Z=$GET(Z)
+7 NEW T
SET T=$ORDER(^ATXAX("B",A,0))
+8 ;bad taxonomy??
IF 'T
QUIT ""
+9 NEW X,Y,I,D
+10 SET (X,Y,I)=0
+11 FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(I)
QUIT
Begin DoDot:1
+12 IF '$DATA(^AUPNPROB(X,0))
QUIT
+13 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+14 IF Z
IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+15 SET Y=$PIECE(^AUPNPROB(X,0),U)
+16 ;if there is a doo and it is after report period skip
IF E
IF $PIECE(^AUPNPROB(X,0),U,13)>E
QUIT
+17 ;entered after report period, skip
IF $PIECE(^AUPNPROB(X,0),U,13)=""
IF E
IF $PIECE(^AUPNPROB(X,0),U,8)>E
QUIT
+18 IF '$$ICD^BGP8UTL2(Y,T,9)
QUIT
+19 SET D=$PIECE(^AUPNPROB(X,0),U,13)
+20 IF 'D
SET D=$PIECE(^AUPNPROB(X,0),U,8)
+21 SET I=1_U_"Problem List: "_$$VAL^XBDIQ1(9000011,X,.01)_U_D
+22 QUIT
End DoDot:1
+23 QUIT I
IPLSNOND(P,T,E,Z) ;EP - any problem list entry with a SNOMED in T
+1 ;LOOP PROBLEM LIST
+2 NEW G,X,Y
+3 SET (X,G)=""
+4 SET E=$GET(E)
+5 SET Z=$GET(Z)
+6 FOR
SET X=$ORDER(^AUPNPROB("APCT",P,X))
IF X=""!(G)
QUIT
Begin DoDot:1
+7 SET Y=0
FOR
SET Y=$ORDER(^AUPNPROB("APCT",P,X,Y))
IF Y'=+Y!(G)
QUIT
Begin DoDot:2
+8 IF '$DATA(^AUPNPROB(Y,0))
QUIT
+9 ;deleted
IF $PIECE(^AUPNPROB(Y,0),U,12)="D"
QUIT
+10 IF Z
IF $PIECE(^AUPNPROB(Y,0),U,12)="I"
QUIT
+11 IF '$DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,T,X))
QUIT
+12 ;if there is a doo and it is after report period skip
IF E
IF $PIECE(^AUPNPROB(Y,0),U,13)>E
QUIT
+13 ;entered after report period, skip
IF $PIECE(^AUPNPROB(Y,0),U,13)=""
IF E
IF $PIECE(^AUPNPROB(Y,0),U,8)>E
QUIT
+14 SET D=$PIECE(^AUPNPROB(Y,0),U,13)
+15 IF 'D
SET D=$PIECE(^AUPNPROB(Y,0),U,8)
+16 ;$$CONCPT^AUPNVUTL(X)
SET G=1_U_"Problem List: "_X_U_D
End DoDot:2
End DoDot:1
+17 QUIT G
