BGP8PC15 ; IHS/CMI/LAB - measure I2 ; 02 Feb 2018 11:25 AM
;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
;
WAC ;EP
S (BGPN1,BGPN2,BGPN3,BGPD1)=0
S (BGPDV,BGPVITAL,BGPNC,BGPPA)=""
S BGPVALUE=""
K BGPV
;
I BGPAGEE<3 S BGPSTOP=1 G WACE ;18 or greater during time period
I BGPAGEB>17 S BGPSTOP=1 G WACE ;75 or less during time period
;
;S BGPDV=$$ENC15(DFN,BGPBDATE,BGPEDATE) I BGPDV="" S BGPSTOP=1 G WACE
;GET ALL OUTPATIENT ENCOUNTERS
;Let's check all Visits, looping through once
S G="" ;return variable
;get all visits in date range in BGPV
D ALLV^APCLAPIU(DFN,BGPBDATE,BGPEDATE,"BGPV")
;now loop through and check Face to Face and .17 in visit and check v cpts attached to the visit
K BGPOV
S X=0 F S X=$O(BGPV(X)) Q:X'=+X 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,BGPOV(V)="" Q
.;is .17 a cpt we want?
.S Y=$$VALI^XBDIQ1(9000010,V,.17)
.I Y,$$OFFCPT15(Y) S G=1_U_$$DATE^BGP8UTL(D)_" CPT: "_$P($$CPT^ICPTCOD(Y),U,2),BGPOV(V)="" 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,$$OFFCPT15(Y) S G=1_U_$$DATE^BGP8UTL(D)_" CPT: "_$P($$CPT^ICPTCOD(Y),U,2),BGPOV(V)="" Q
I G S BGPDV=G
I BGPDV="" S BGPSTOP=1 G WACE
;now what about exclusions?
I $$HOSPIND^BGP8PC2(DFN,BGPBDATE,BGPEDATE) S BGPSTOP=1 G WACE ;no hospice pts
;PREG?
I $$PREG^BGP8PC16(DFN,BGPBDATE,BGPEDATE) S BGPSTOP=1 G WACE
;
S BGPD1=1
;
S BGPVAL=""
S BGPVITAL=$$HWBMIP(DFN,BGPBDATE,BGPEDATE) I $P(BGPVITAL,U,1) S BGPN1=1
D NC
I $P(BGPNC,U,1) S BGPN2=1
D PA
I $P(BGPPA,U,1) S BGPN3=1
S BGPVALUE=""
;S BGPVALUE="ENC "_$P(BGPDV,U,2)_"|||" ;hit denominator
I BGPN1 S BGPVALUE=BGPVALUE_"***N1 "_$P(BGPVITAL,U,2)
I BGPN2 S:BGPVALUE]"" BGPVALUE=BGPVALUE_";" S BGPVALUE=BGPVALUE_"***N2 NUTR COUN: "_$P(BGPNC,U,2)
I BGPN3 S:BGPVALUE]"" BGPVALUE=BGPVALUE_";" S BGPVALUE=BGPVALUE_"***N3 PHYS ACT COUN: "_$P(BGPPA,U,2)
S BGPVALUE="ENC "_$P(BGPDV,U,2)_"|||"_BGPVALUE
;
WACE ;
K V,BGPDV,BGPVAL,BGPV,BGPOV,BGPVITAL,BGPNC,BGPPA
Q
ENC15(P,BDATE,EDATE) ;EP - have encounter per CMS122v6
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
.Q:"AORS"'[$P(^AUPNVSIT(V,0),U,7) ;outpatient only
.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,$$OFFCPT15(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,$$OFFCPT15(Y) S G=1_U_$$DATE^BGP8UTL(D)_" CPT: "_$P($$CPT^ICPTCOD(Y),U,2) Q
Q G
OFFCPT15(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 0-17 CPTS",0)),1) Q 1
I $$ICD^ATXAPI(C,$O(^ATXAX("B","BGP IPC PREVCARE IOV 0-17 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 PREVCARE IND COUN CPTS",0)),1) Q 1
I $$ICD^ATXAPI(C,$O(^ATXAX("B","BGP IPC PREVCARE GRP COUN 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 ""
HWBMIP(P,BDATE,EDATE) ;
;has ht, wt and bmip?
NEW X,Y,Z,H,W,B
S W=$$LASTITEM^BGP8DU(P,BDATE,EDATE,"MEASUREMENT","WT") I W="" Q ""
S H=$$LASTITEM^BGP8DU(P,BDATE,EDATE,"MEASUREMENT","HT") I H="" Q ""
S B=$$LASTITEM^BGP8DU(P,BDATE,EDATE,"MEASUREMENT","BMIP") I B="" Q ""
Q 1_U_$$DATE^BGP8UTL($P(H,U,2))_" HT "_$P(H,U,4)_" "_$$DATE^BGP8UTL($P(W,U,2))_" WT "_$P(W,U,4)_" "_$$DATE^BGP8UTL($P(B,U,2))_" BMIP "_$P(B,U,4)
NC ;
S BGPNC=""
NEW X,Y,Z,V,G
S G=""
S V=0 F S V=$O(BGPOV(V)) Q:V'=+V!(G) D
.;cpt
.S X=0 F S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X!(G) D
..S C=$P($G(^AUPNVCPT(X,0)),U,1)
..I 'C Q
..I $$ICD^BGP8UTL2(C,$O(^ATXAX("B","BGP IPC NUTR COUN CPTS",0)),1) S G=1_U_$$DATE^BGP8UTL($$VD^APCLV(V))_" CPT: "_$$VAL^XBDIQ1(9000010.18,X,.01)
.;NOW CHECK V POV FOR SNOMED
.S X=0 F S X=$O(^AUPNVPOV("AD",V,X)) Q:X'=+X!(G) D
..S C=$$VAL^XBDIQ1(9000010.07,X,1101) Q:C=""
..I $D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP IPC NUTRITION",C)) S G=1_U_$$DATE^BGP8UTL($$VD^APCLV(V))_" SNOMED: "_C
S BGPNC=G
Q
PA ;
S BGPPA=""
NEW X,Y,Z,V,G
S G=""
S V=0 F S V=$O(BGPOV(V)) Q:V'=+V!(G) D
.;NOW CHECK V POV FOR SNOMED
.S X=0 F S X=$O(^AUPNVPOV("AD",V,X)) Q:X'=+X!(G) D
..S C=$$VAL^XBDIQ1(9000010.07,X,1101) Q:C=""
..I $D(^XTMP("BGPSNOMEDSUBSET",$J,"PXRM BGP IPC PHYS ACT",C)) S G=1_U_$$DATE^BGP8UTL($$VD^APCLV(V))_" SNOMED: "_C
S BGPPA=G
Q
BGP8PC15 ; IHS/CMI/LAB - measure I2 ; 02 Feb 2018 11:25 AM
+1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
+2 ;
WAC ;EP
+1 SET (BGPN1,BGPN2,BGPN3,BGPD1)=0
+2 SET (BGPDV,BGPVITAL,BGPNC,BGPPA)=""
+3 SET BGPVALUE=""
+4 KILL BGPV
+5 ;
+6 ;18 or greater during time period
IF BGPAGEE<3
SET BGPSTOP=1
GOTO WACE
+7 ;75 or less during time period
IF BGPAGEB>17
SET BGPSTOP=1
GOTO WACE
+8 ;
+9 ;S BGPDV=$$ENC15(DFN,BGPBDATE,BGPEDATE) I BGPDV="" S BGPSTOP=1 G WACE
+10 ;GET ALL OUTPATIENT ENCOUNTERS
+11 ;Let's check all Visits, looping through once
+12 ;return variable
SET G=""
+13 ;get all visits in date range in BGPV
+14 DO ALLV^APCLAPIU(DFN,BGPBDATE,BGPEDATE,"BGPV")
+15 ;now loop through and check Face to Face and .17 in visit and check v cpts attached to the visit
+16 KILL BGPOV
+17 SET X=0
FOR
SET X=$ORDER(BGPV(X))
IF X'=+X
QUIT
SET V=$PIECE(BGPV(X),U,5)
Begin DoDot:1
+18 ;no dependent entries
IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+19 ;deleted
IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+20 SET D=$$VD^APCLV(V)
+21 SET Y=$$FTOF^BGP8PC2(V)
IF Y]""
SET G=1_U_$$DATE^BGP8UTL(D)_" FTOF: "_Y
SET BGPOV(V)=""
QUIT
+22 ;is .17 a cpt we want?
+23 SET Y=$$VALI^XBDIQ1(9000010,V,.17)
+24 IF Y
IF $$OFFCPT15(Y)
SET G=1_U_$$DATE^BGP8UTL(D)_" CPT: "_$PIECE($$CPT^ICPTCOD(Y),U,2)
SET BGPOV(V)=""
QUIT
+25 ;now check all V CPTs
+26 SET Z=0
FOR
SET Z=$ORDER(^AUPNVCPT("AD",V,Z))
IF Z'=+Z
QUIT
Begin DoDot:2
+27 SET Y=$PIECE($GET(^AUPNVCPT(Z,0)),U,1)
+28 IF Y
IF $$OFFCPT15(Y)
SET G=1_U_$$DATE^BGP8UTL(D)_" CPT: "_$PIECE($$CPT^ICPTCOD(Y),U,2)
SET BGPOV(V)=""
QUIT
End DoDot:2
End DoDot:1
+29 IF G
SET BGPDV=G
+30 IF BGPDV=""
SET BGPSTOP=1
GOTO WACE
+31 ;now what about exclusions?
+32 ;no hospice pts
IF $$HOSPIND^BGP8PC2(DFN,BGPBDATE,BGPEDATE)
SET BGPSTOP=1
GOTO WACE
+33 ;PREG?
+34 IF $$PREG^BGP8PC16(DFN,BGPBDATE,BGPEDATE)
SET BGPSTOP=1
GOTO WACE
+35 ;
+36 SET BGPD1=1
+37 ;
+38 SET BGPVAL=""
+39 SET BGPVITAL=$$HWBMIP(DFN,BGPBDATE,BGPEDATE)
IF $PIECE(BGPVITAL,U,1)
SET BGPN1=1
+40 DO NC
+41 IF $PIECE(BGPNC,U,1)
SET BGPN2=1
+42 DO PA
+43 IF $PIECE(BGPPA,U,1)
SET BGPN3=1
+44 SET BGPVALUE=""
+45 ;S BGPVALUE="ENC "_$P(BGPDV,U,2)_"|||" ;hit denominator
+46 IF BGPN1
SET BGPVALUE=BGPVALUE_"***N1 "_$PIECE(BGPVITAL,U,2)
+47 IF BGPN2
IF BGPVALUE]""
SET BGPVALUE=BGPVALUE_";"
SET BGPVALUE=BGPVALUE_"***N2 NUTR COUN: "_$PIECE(BGPNC,U,2)
+48 IF BGPN3
IF BGPVALUE]""
SET BGPVALUE=BGPVALUE_";"
SET BGPVALUE=BGPVALUE_"***N3 PHYS ACT COUN: "_$PIECE(BGPPA,U,2)
+49 SET BGPVALUE="ENC "_$PIECE(BGPDV,U,2)_"|||"_BGPVALUE
+50 ;
WACE ;
+1 KILL V,BGPDV,BGPVAL,BGPV,BGPOV,BGPVITAL,BGPNC,BGPPA
+2 QUIT
ENC15(P,BDATE,EDATE) ;EP - have encounter per CMS122v6
+1 NEW X,Y,Z,G,BGPV,D
+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 ;outpatient only
IF "AORS"'[$PIECE(^AUPNVSIT(V,0),U,7)
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 $$OFFCPT15(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 $$OFFCPT15(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
OFFCPT15(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 0-17 CPTS",0)),1)
QUIT 1
+3 IF $$ICD^ATXAPI(C,$ORDER(^ATXAX("B","BGP IPC PREVCARE IOV 0-17 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 PREVCARE IND COUN CPTS",0)),1)
QUIT 1
+6 IF $$ICD^ATXAPI(C,$ORDER(^ATXAX("B","BGP IPC PREVCARE GRP COUN CPTS",0)),1)
QUIT 1
+7 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 ""
HWBMIP(P,BDATE,EDATE) ;
+1 ;has ht, wt and bmip?
+2 NEW X,Y,Z,H,W,B
+3 SET W=$$LASTITEM^BGP8DU(P,BDATE,EDATE,"MEASUREMENT","WT")
IF W=""
QUIT ""
+4 SET H=$$LASTITEM^BGP8DU(P,BDATE,EDATE,"MEASUREMENT","HT")
IF H=""
QUIT ""
+5 SET B=$$LASTITEM^BGP8DU(P,BDATE,EDATE,"MEASUREMENT","BMIP")
IF B=""
QUIT ""
+6 QUIT 1_U_$$DATE^BGP8UTL($PIECE(H,U,2))_" HT "_$PIECE(H,U,4)_" "_$$DATE^BGP8UTL($PIECE(W,U,2))_" WT "_$PIECE(W,U,4)_" "_$$DATE^BGP8UTL($PIECE(B,U,2))_" BMIP "_$PIECE(B,U,4)
NC ;
+1 SET BGPNC=""
+2 NEW X,Y,Z,V,G
+3 SET G=""
+4 SET V=0
FOR
SET V=$ORDER(BGPOV(V))
IF V'=+V!(G)
QUIT
Begin DoDot:1
+5 ;cpt
+6 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",V,X))
IF X'=+X!(G)
QUIT
Begin DoDot:2
+7 SET C=$PIECE($GET(^AUPNVCPT(X,0)),U,1)
+8 IF 'C
QUIT
+9 IF $$ICD^BGP8UTL2(C,$ORDER(^ATXAX("B","BGP IPC NUTR COUN CPTS",0)),1)
SET G=1_U_$$DATE^BGP8UTL($$VD^APCLV(V))_" CPT: "_$$VAL^XBDIQ1(9000010.18,X,.01)
End DoDot:2
+10 ;NOW CHECK V POV FOR SNOMED
+11 SET X=0
FOR
SET X=$ORDER(^AUPNVPOV("AD",V,X))
IF X'=+X!(G)
QUIT
Begin DoDot:2
+12 SET C=$$VAL^XBDIQ1(9000010.07,X,1101)
IF C=""
QUIT
+13 IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM BGP IPC NUTRITION",C))
SET G=1_U_$$DATE^BGP8UTL($$VD^APCLV(V))_" SNOMED: "_C
End DoDot:2
End DoDot:1
+14 SET BGPNC=G
+15 QUIT
PA ;
+1 SET BGPPA=""
+2 NEW X,Y,Z,V,G
+3 SET G=""
+4 SET V=0
FOR
SET V=$ORDER(BGPOV(V))
IF V'=+V!(G)
QUIT
Begin DoDot:1
+5 ;NOW CHECK V POV FOR SNOMED
+6 SET X=0
FOR
SET X=$ORDER(^AUPNVPOV("AD",V,X))
IF X'=+X!(G)
QUIT
Begin DoDot:2
+7 SET C=$$VAL^XBDIQ1(9000010.07,X,1101)
IF C=""
QUIT
+8 IF $DATA(^XTMP("BGPSNOMEDSUBSET",$JOB,"PXRM BGP IPC PHYS ACT",C))
SET G=1_U_$$DATE^BGP8UTL($$VD^APCLV(V))_" SNOMED: "_C
End DoDot:2
End DoDot:1
+9 SET BGPPA=G
+10 QUIT
