BGP8PC6 ; IHS/CMI/LAB - measure I2 ; 02 Feb 2018 11:25 AM
;;18.1;IHS CLINICAL REPORTING;**1**;MAY 25, 2018;Build 65
;
CIZ ;EP
K BGPSTOP
S (BGPN1,BGPD1)=0
;GET THE PATIENT'S 6 MONTH BIRTHDAY
S A=$$Y2BD(DFN) ;FIRST DAY THEY ARE 2 YEARS OLD
S B=$$Y3BD(DFN) ;FIRST DAY THEY ARE 3 YEARS OLD
S B=$$FMADD^XLFDT(B,-1) ;LAST DAY THEY ARE 2 YEARS OLD
I A>BGPEDATE S BGPSTOP=1 Q ;turned 2 YEARS after end date of report period
I B<BGPBDATE S BGPSTOP=1 Q ;last day they are 2 is before the report period
;
I $$HOSPIND^BGP8PC2(DFN,BGPBDATE,BGPEDATE) S BGPSTOP=1 Q ;no hospice pts
;
S BGPDV=$$ENC6(DFN,BGPBDATE,BGPEDATE) I BGPDV="" S BGPSTOP=1 G CIZE ;no visit
;
S BGPDV1=""
S (BGPDTAP,BGPIPV,BGPMMR,BGPHIB,BGPHEPB,BGPVAR,BGPPNEU,BGPHEPA,BGPROTA,BGPFLU)=""
S BGPD1=1
;
S BGPDTAP=$$DTAP(DFN)
S BGPIPV=$$IPV^BGP8PC61(DFN)
S BGPMMR=$$MMR^BGP8PC62(DFN)
S BGPHIB=$$HIB^BGP8PC63(DFN)
S BGPHEPB=$$HEPB^BGP8PC64(DFN)
S BGPVAR=$$VZV^BGP8PC65(DFN)
S BGPPNEU=$$PNEUMO^BGP8PC66(DFN)
S BGPHEPA=$$HEPA^BGP8PC67(DFN)
S BGPROTA=$$ROTA^BGP8PC68(DFN)
S BGPFLU=$$FLU^BGP8PC69(DFN)
;W !,DFN," ",$$DOB^AUPNPAT(DFN)," ",BGPDV," ",BGPDTAP," ",BGPIPV," ",BGPMMR," ",BGPHIB," ",BGPHEPB," ",BGPVAR," ",BGPPNEU," ",BGPHEPA," ",BGPROTA," ",BGPFLU
I BGPDTAP,BGPIPV,BGPMMR,BGPHIB,BGPHEPB,BGPVAR,BGPPNEU,BGPHEPA,BGPROTA,BGPFLU S BGPN1=1 ;HAD ALL
I BGPN1 S V="" F X="BGPDTAP","BGPIPV","BGPMMR","BGPHIB","BGPHEPB","BGPVAR","BGPPNEU","BGPHEPA","BGPROTA","BGPFLU" S:V]"" V=V_"; " S V=V_$P(@X,U,2)
I BGPN1 S V="*** "_V
I 'BGPN1 S V="" F X="BGPDTAP","BGPIPV","BGPMMR","BGPHIB","BGPHEPB","BGPVAR","BGPPNEU","BGPHEPA","BGPROTA","BGPFLU" I $P(@X,U,1) S:V]"" V=V_"; " S V=V_$P(@X,U,2)
I 'BGPN1,V]"" S V="HAS: "_V
I 'BGPN1 S N="" F X="BGPDTAP","BGPIPV","BGPMMR","BGPHIB","BGPHEPB","BGPVAR","BGPPNEU","BGPHEPA","BGPROTA","BGPFLU" I '$P(@X,U,1) S:N]"" N=N_"; " S N=N_$E(X,4,8)
I 'BGPN1 S V=V_" NEEDS: "_N
S BGPVALUE=""
S BGPVALUE="ENC "_$P(BGPDV,U,2)_"|||"_V ;hit denominator
CIZE ;
K BGPDV,BGPDTAP,BGPIPV,BGPMMR,BGPHIB,BGPHEPB,BGPVAR,BGPPNEU,BGPHEPA,BGPROTA,BGPFLU,V,N,BGPDV1
Q
DTAP(P) ;
NEW A42,A730,X,Y,Z,TCVX,TCPT,C,BGPIMMS,D,V,BGPZ
S TCVX=$O(^ATXAX("B","BGP IPC DTAP CVX CODES",0))
S TCPT=$O(^ATXAX("B","BGP IPC DTAP CPT CODES",0))
S A42=$$FMADD^XLFDT($$DOB^AUPNPAT(P),42)
S A730=$$FMADD^XLFDT($$DOB^AUPNPAT(P),730)
S X=0 F S X=$O(^AUPNVIMM("AC",P,X)) Q:X'=+X D
.Q:'$D(^AUPNVIMM(X,0)) ;happens
.S Y=$P(^AUPNVIMM(X,0),U)
.Q:'Y ;happens too
.S I=$P($G(^AUTTIMM(Y,0)),U,3) ;get HL7/CVX code
.Q:'$D(^ATXAX(TCVX,21,"B",I)) ;not a DTAP
.S D=$P($P($G(^AUPNVIMM(X,12)),U,1),".")
.I D="" S V=$P(^AUPNVIMM(X,0),U,3) I V S D=$P($P($G(^AUPNVSIT(V,0)),U),".")
.Q:D<A42
.Q:D>A730
.S BGPIMMS(D)=Y
.Q
;go through and set into array if 1 days apart
S X="",Y="",C=0 F S X=$O(BGPIMMS(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<1 K BGPIMMS(X) Q
.S Y=X
;see if there are 4 of them, if there are quit
S BGPIMMS=0,X=0 F S X=$O(BGPIMMS(X)) Q:X'=+X S BGPIMMS=BGPIMMS+1
I BGPIMMS>3 Q 1_U_"4 DTAP"
;now get cpts
S G="",X=0
F S X=$O(^AUPNVCPT("AC",P,X)) Q:X="" D
.Q:'$D(^AUPNVCPT(X,0))
.S Y=$P(^AUPNVCPT(X,0),U)
.Q:'$$ICD^BGP8UTL2(Y,TCPT,1) ;not a dtap cpt
.S V=$P(^AUPNVCPT(X,0),U,3) Q:'V
.S D=$$VD^APCLV(V)
.Q:D<A42
.Q:D>A730
.S BGPIMMS(D)=""
;get tran codes
S X=0 F S X=$O(^AUPNVTC("AC",P,X)) Q:X'=+X D
.Q:'$D(^AUPNVTC(X,0))
.S Y=$P(^AUPNVTC(X,0),U,7) Q:'Y
.Q:'$$ICD^BGP8UTL2(Y,TCPT,1)
.S V=$P(^AUPNVTC(X,0),U,3) Q:'V
.S D=$$VD^APCLV(V)
.Q:D<A42
.Q:D>A730
.S BGPIMMS(D)=""
;
;go through and set into array if 1 days apart
S X="",Y="",C=0 F S X=$O(BGPIMMS(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<1 K BGPIMMS(X) Q
.S Y=X
;see if there are 4 of them, if there are quit
S BGPIMMS=0,X=0 F S X=$O(BGPIMMS(X)) Q:X'=+X S BGPIMMS=BGPIMMS+1
I BGPIMMS>3 Q 1_U_"4 DTAP"
;NOW CHECK FOR CONTRAINDICATION
;IMM PKG ANAPHYLACTIS
S BGPZ=0
F S BGPZ=$O(^ATXAX(TCVX,21,"B",BGPZ)) Q:BGPZ=""!(X]"") D
.S X=$$ANCONT^BGP8D31(P,BGPZ,A730)
I X]"" Q 1_U_"DTAP CONTRA ANAPHYLACTIC REACTION"
S X=$$ENCEPH(P,A730) I X Q 1_U_"DTAP CONTRA ENCEPH"
S X=$$ANSNDTAP(P,A730) I X Q 1_U_"DTAP CONTRA ANAPHYLACTIC REACTION"
Q ""
ENCEPH(P,EDATE) ;
;V POV OR PROBLEM LIST
NEW X,Y,Z,G,T,S,D
I $$PLTAXND^BGP8DU(P,"BGP IPC IZ ENCEPHALOPATHY DXS",EDATE,0) Q 1
I $$IPLSNOND^BGP8DU(P,"PXRM BGP IPC IZ ENCEPHAL",EDATE,0) Q 1
I $$LASTDX^BGP8UTL1(P,"BGP IPC IZ ENCEPHALOPATHY DXS",$$DOB^AUPNPAT(P),EDATE) Q 1
;NOW V POV SNOMED
;NOW SNOMED USING ASNC
S T="PXRM BGP IPC IZ ENCEPHAL"
S G=""
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
Q G
ANSNDTAP(P,EDATE) ;
;V POV OR PROBLEM LIST
NEW X,Y,Z,G,T,S,D,I
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 $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=219084006 S I=1 Q
.I S=293108006 S I=1 Q
.I S=428281000124107 S I=1 Q
.I S=428291000124105 S I=1 Q
.Q
I I Q I
;NOW V POV SNOMED
;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=219084006 S I=1
.I S=293108006 S I=1
.I S=428281000124107 S I=1
.I S=428291000124105 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
Q G
Y2BD(P) ;
NEW B,M,D,Y
S B=$$DOB^AUPNPAT(P) ;DOB
S M=$E(B,4,5)
S D=$E(B,6,7)
S Y=$E(B,1,3),Y=Y+2
Q Y_M_D
Y3BD(P) ;
NEW B,M,D,Y
S B=$$DOB^AUPNPAT(P) ;DOB
S M=$E(B,4,5)
S D=$E(B,6,7)
S Y=$E(B,1,3),Y=Y+3
Q Y_M_D
ENC6(P,BDATE,EDATE) ;EP - have encounter per CMS117v6
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
.S D=$$VD^APCLV(V)
.S Y=$$FTOF^BGP8PC2(V) I Y]"" S G=1_U_$$DATE^BGP8UTL(D)_" FTOF: "_Y Q ;ITEM 18
.;is .17 a cpt we want?
.S Y=$$VALI^XBDIQ1(9000010,V,.17)
.I Y,$$OFFCPT6(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,$$OFFCPT6(Y) S G=1_U_$$DATE^BGP8UTL(D)_" CPT: "_$P($$CPT^ICPTCOD(Y),U,2) Q
Q G
OFFCPT6(C) ;EP
I $$ICD^ATXAPI(C,$O(^ATXAX("B","BGP IPC OFFICE VISIT CPTS",0)),1) Q 1 ;ITEM 1
I $$ICD^ATXAPI(C,$O(^ATXAX("B","BGP IPC HOMEHEALTH VISIT CPTS",0)),1) Q 1 ;ITEM 5
I $$ICD^ATXAPI(C,$O(^ATXAX("B","BGP IPC PREVCARE IOV 0-17 CPTS",0)),1) Q 1 ;ITEM 4
I $$ICD^ATXAPI(C,$O(^ATXAX("B","BGP IPC PREVCARE EOV 0-17 CPTS",0)),1) Q 1 ;ITEM 3
Q ""
BGP8PC6 ; IHS/CMI/LAB - measure I2 ; 02 Feb 2018 11:25 AM
+1 ;;18.1;IHS CLINICAL REPORTING;**1**;MAY 25, 2018;Build 65
+2 ;
CIZ ;EP
+1 KILL BGPSTOP
+2 SET (BGPN1,BGPD1)=0
+3 ;GET THE PATIENT'S 6 MONTH BIRTHDAY
+4 ;FIRST DAY THEY ARE 2 YEARS OLD
SET A=$$Y2BD(DFN)
+5 ;FIRST DAY THEY ARE 3 YEARS OLD
SET B=$$Y3BD(DFN)
+6 ;LAST DAY THEY ARE 2 YEARS OLD
SET B=$$FMADD^XLFDT(B,-1)
+7 ;turned 2 YEARS after end date of report period
IF A>BGPEDATE
SET BGPSTOP=1
QUIT
+8 ;last day they are 2 is before the report period
IF B<BGPBDATE
SET BGPSTOP=1
QUIT
+9 ;
+10 ;no hospice pts
IF $$HOSPIND^BGP8PC2(DFN,BGPBDATE,BGPEDATE)
SET BGPSTOP=1
QUIT
+11 ;
+12 ;no visit
SET BGPDV=$$ENC6(DFN,BGPBDATE,BGPEDATE)
IF BGPDV=""
SET BGPSTOP=1
GOTO CIZE
+13 ;
+14 SET BGPDV1=""
+15 SET (BGPDTAP,BGPIPV,BGPMMR,BGPHIB,BGPHEPB,BGPVAR,BGPPNEU,BGPHEPA,BGPROTA,BGPFLU)=""
+16 SET BGPD1=1
+17 ;
+18 SET BGPDTAP=$$DTAP(DFN)
+19 SET BGPIPV=$$IPV^BGP8PC61(DFN)
+20 SET BGPMMR=$$MMR^BGP8PC62(DFN)
+21 SET BGPHIB=$$HIB^BGP8PC63(DFN)
+22 SET BGPHEPB=$$HEPB^BGP8PC64(DFN)
+23 SET BGPVAR=$$VZV^BGP8PC65(DFN)
+24 SET BGPPNEU=$$PNEUMO^BGP8PC66(DFN)
+25 SET BGPHEPA=$$HEPA^BGP8PC67(DFN)
+26 SET BGPROTA=$$ROTA^BGP8PC68(DFN)
+27 SET BGPFLU=$$FLU^BGP8PC69(DFN)
+28 ;W !,DFN," ",$$DOB^AUPNPAT(DFN)," ",BGPDV," ",BGPDTAP," ",BGPIPV," ",BGPMMR," ",BGPHIB," ",BGPHEPB," ",BGPVAR," ",BGPPNEU," ",BGPHEPA," ",BGPROTA," ",BGPFLU
+29 ;HAD ALL
IF BGPDTAP
IF BGPIPV
IF BGPMMR
IF BGPHIB
IF BGPHEPB
IF BGPVAR
IF BGPPNEU
IF BGPHEPA
IF BGPROTA
IF BGPFLU
SET BGPN1=1
+30 IF BGPN1
SET V=""
FOR X="BGPDTAP","BGPIPV","BGPMMR","BGPHIB","BGPHEPB","BGPVAR","BGPPNEU","BGPHEPA","BGPROTA","BGPFLU"
IF V]""
SET V=V_"; "
SET V=V_$PIECE(@X,U,2)
+31 IF BGPN1
SET V="*** "_V
+32 IF 'BGPN1
SET V=""
FOR X="BGPDTAP","BGPIPV","BGPMMR","BGPHIB","BGPHEPB","BGPVAR","BGPPNEU","BGPHEPA","BGPROTA","BGPFLU"
IF $PIECE(@X,U,1)
IF V]""
SET V=V_"; "
SET V=V_$PIECE(@X,U,2)
+33 IF 'BGPN1
IF V]""
SET V="HAS: "_V
+34 IF 'BGPN1
SET N=""
FOR X="BGPDTAP","BGPIPV","BGPMMR","BGPHIB","BGPHEPB","BGPVAR","BGPPNEU","BGPHEPA","BGPROTA","BGPFLU"
IF '$PIECE(@X,U,1)
IF N]""
SET N=N_"; "
SET N=N_$EXTRACT(X,4,8)
+35 IF 'BGPN1
SET V=V_" NEEDS: "_N
+36 SET BGPVALUE=""
+37 ;hit denominator
SET BGPVALUE="ENC "_$PIECE(BGPDV,U,2)_"|||"_V
CIZE ;
+1 KILL BGPDV,BGPDTAP,BGPIPV,BGPMMR,BGPHIB,BGPHEPB,BGPVAR,BGPPNEU,BGPHEPA,BGPROTA,BGPFLU,V,N,BGPDV1
+2 QUIT
DTAP(P) ;
+1 NEW A42,A730,X,Y,Z,TCVX,TCPT,C,BGPIMMS,D,V,BGPZ
+2 SET TCVX=$ORDER(^ATXAX("B","BGP IPC DTAP CVX CODES",0))
+3 SET TCPT=$ORDER(^ATXAX("B","BGP IPC DTAP CPT CODES",0))
+4 SET A42=$$FMADD^XLFDT($$DOB^AUPNPAT(P),42)
+5 SET A730=$$FMADD^XLFDT($$DOB^AUPNPAT(P),730)
+6 SET X=0
FOR
SET X=$ORDER(^AUPNVIMM("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+7 ;happens
IF '$DATA(^AUPNVIMM(X,0))
QUIT
+8 SET Y=$PIECE(^AUPNVIMM(X,0),U)
+9 ;happens too
IF 'Y
QUIT
+10 ;get HL7/CVX code
SET I=$PIECE($GET(^AUTTIMM(Y,0)),U,3)
+11 ;not a DTAP
IF '$DATA(^ATXAX(TCVX,21,"B",I))
QUIT
+12 SET D=$PIECE($PIECE($GET(^AUPNVIMM(X,12)),U,1),".")
+13 IF D=""
SET V=$PIECE(^AUPNVIMM(X,0),U,3)
IF V
SET D=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+14 IF D<A42
QUIT
+15 IF D>A730
QUIT
+16 SET BGPIMMS(D)=Y
+17 QUIT
End DoDot:1
+18 ;go through and set into array if 1 days apart
+19 SET X=""
SET Y=""
SET C=0
FOR
SET X=$ORDER(BGPIMMS(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+20 IF C=1
SET Y=X
QUIT
+21 IF $$FMDIFF^XLFDT(X,Y)<1
KILL BGPIMMS(X)
QUIT
+22 SET Y=X
End DoDot:1
+23 ;see if there are 4 of them, if there are quit
+24 SET BGPIMMS=0
SET X=0
FOR
SET X=$ORDER(BGPIMMS(X))
IF X'=+X
QUIT
SET BGPIMMS=BGPIMMS+1
+25 IF BGPIMMS>3
QUIT 1_U_"4 DTAP"
+26 ;now get cpts
+27 SET G=""
SET X=0
+28 FOR
SET X=$ORDER(^AUPNVCPT("AC",P,X))
IF X=""
QUIT
Begin DoDot:1
+29 IF '$DATA(^AUPNVCPT(X,0))
QUIT
+30 SET Y=$PIECE(^AUPNVCPT(X,0),U)
+31 ;not a dtap cpt
IF '$$ICD^BGP8UTL2(Y,TCPT,1)
QUIT
+32 SET V=$PIECE(^AUPNVCPT(X,0),U,3)
IF 'V
QUIT
+33 SET D=$$VD^APCLV(V)
+34 IF D<A42
QUIT
+35 IF D>A730
QUIT
+36 SET BGPIMMS(D)=""
End DoDot:1
+37 ;get tran codes
+38 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+39 IF '$DATA(^AUPNVTC(X,0))
QUIT
+40 SET Y=$PIECE(^AUPNVTC(X,0),U,7)
IF 'Y
QUIT
+41 IF '$$ICD^BGP8UTL2(Y,TCPT,1)
QUIT
+42 SET V=$PIECE(^AUPNVTC(X,0),U,3)
IF 'V
QUIT
+43 SET D=$$VD^APCLV(V)
+44 IF D<A42
QUIT
+45 IF D>A730
QUIT
+46 SET BGPIMMS(D)=""
End DoDot:1
+47 ;
+48 ;go through and set into array if 1 days apart
+49 SET X=""
SET Y=""
SET C=0
FOR
SET X=$ORDER(BGPIMMS(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+50 IF C=1
SET Y=X
QUIT
+51 IF $$FMDIFF^XLFDT(X,Y)<1
KILL BGPIMMS(X)
QUIT
+52 SET Y=X
End DoDot:1
+53 ;see if there are 4 of them, if there are quit
+54 SET BGPIMMS=0
SET X=0
FOR
SET X=$ORDER(BGPIMMS(X))
IF X'=+X
QUIT
SET BGPIMMS=BGPIMMS+1
+55 IF BGPIMMS>3
QUIT 1_U_"4 DTAP"
+56 ;NOW CHECK FOR CONTRAINDICATION
+57 ;IMM PKG ANAPHYLACTIS
+58 SET BGPZ=0
+59 FOR
SET BGPZ=$ORDER(^ATXAX(TCVX,21,"B",BGPZ))
IF BGPZ=""!(X]"")
QUIT
Begin DoDot:1
+60 SET X=$$ANCONT^BGP8D31(P,BGPZ,A730)
End DoDot:1
+61 IF X]""
QUIT 1_U_"DTAP CONTRA ANAPHYLACTIC REACTION"
+62 SET X=$$ENCEPH(P,A730)
IF X
QUIT 1_U_"DTAP CONTRA ENCEPH"
+63 SET X=$$ANSNDTAP(P,A730)
IF X
QUIT 1_U_"DTAP CONTRA ANAPHYLACTIC REACTION"
+64 QUIT ""
ENCEPH(P,EDATE) ;
+1 ;V POV OR PROBLEM LIST
+2 NEW X,Y,Z,G,T,S,D
+3 IF $$PLTAXND^BGP8DU(P,"BGP IPC IZ ENCEPHALOPATHY DXS",EDATE,0)
QUIT 1
+4 IF $$IPLSNOND^BGP8DU(P,"PXRM BGP IPC IZ ENCEPHAL",EDATE,0)
QUIT 1
+5 IF $$LASTDX^BGP8UTL1(P,"BGP IPC IZ ENCEPHALOPATHY DXS",$$DOB^AUPNPAT(P),EDATE)
QUIT 1
+6 ;NOW V POV SNOMED
+7 ;NOW SNOMED USING ASNC
+8 SET T="PXRM BGP IPC IZ ENCEPHAL"
+9 SET G=""
+10 SET S=0
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 QUIT G
ANSNDTAP(P,EDATE) ;
+1 ;V POV OR PROBLEM LIST
+2 NEW X,Y,Z,G,T,S,D,I
+3 SET (X,Y,I)=0
+4 FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(I)
QUIT
Begin DoDot:1
+5 IF '$DATA(^AUPNPROB(X,0))
QUIT
+6 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+7 ;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
+8 ;entered after report period, skip
IF $PIECE(^AUPNPROB(X,0),U,13)=""
IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+9 SET S=$$VAL^XBDIQ1(9000011,X,80001)
+10 IF S=219084006
SET I=1
QUIT
+11 IF S=293108006
SET I=1
QUIT
+12 IF S=428281000124107
SET I=1
QUIT
+13 IF S=428291000124105
SET I=1
QUIT
+14 QUIT
End DoDot:1
+15 IF I
QUIT I
+16 ;NOW V POV SNOMED
+17 ;NOW SNOMED USING ASNC
+18 SET G=""
SET I=""
+19 SET S=""
FOR
SET S=$ORDER(^AUPNVPOV("ASNC",P,S))
IF S=""!(G)
QUIT
Begin DoDot:1
+20 SET I=0
+21 IF S=219084006
SET I=1
+22 IF S=293108006
SET I=1
+23 IF S=428281000124107
SET I=1
+24 IF S=428291000124105
SET I=1
+25 IF 'I
QUIT
+26 SET D=0
FOR
SET D=$ORDER(^AUPNVPOV("ASNC",P,S,D))
IF D=""!(G)
QUIT
Begin DoDot:2
+27 SET Y=9999999-D
+28 IF Y>EDATE
QUIT
+29 SET G=1
End DoDot:2
End DoDot:1
+30 QUIT G
Y2BD(P) ;
+1 NEW B,M,D,Y
+2 ;DOB
SET B=$$DOB^AUPNPAT(P)
+3 SET M=$EXTRACT(B,4,5)
+4 SET D=$EXTRACT(B,6,7)
+5 SET Y=$EXTRACT(B,1,3)
SET Y=Y+2
+6 QUIT Y_M_D
Y3BD(P) ;
+1 NEW B,M,D,Y
+2 ;DOB
SET B=$$DOB^AUPNPAT(P)
+3 SET M=$EXTRACT(B,4,5)
+4 SET D=$EXTRACT(B,6,7)
+5 SET Y=$EXTRACT(B,1,3)
SET Y=Y+3
+6 QUIT Y_M_D
ENC6(P,BDATE,EDATE) ;EP - have encounter per CMS117v6
+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 SET D=$$VD^APCLV(V)
+11 ;ITEM 18
SET Y=$$FTOF^BGP8PC2(V)
IF Y]""
SET G=1_U_$$DATE^BGP8UTL(D)_" FTOF: "_Y
QUIT
+12 ;is .17 a cpt we want?
+13 SET Y=$$VALI^XBDIQ1(9000010,V,.17)
+14 IF Y
IF $$OFFCPT6(Y)
SET G=1_U_$$DATE^BGP8UTL(D)_" CPT: "_$PIECE($$CPT^ICPTCOD(Y),U,2)
QUIT
+15 ;now check all V CPTs
+16 SET Z=0
FOR
SET Z=$ORDER(^AUPNVCPT("AD",V,Z))
IF Z'=+Z!(G)
QUIT
Begin DoDot:2
+17 SET Y=$PIECE($GET(^AUPNVCPT(Z,0)),U,1)
+18 IF Y
IF $$OFFCPT6(Y)
SET G=1_U_$$DATE^BGP8UTL(D)_" CPT: "_$PIECE($$CPT^ICPTCOD(Y),U,2)
QUIT
End DoDot:2
End DoDot:1
+19 QUIT G
OFFCPT6(C) ;EP
+1 ;ITEM 1
IF $$ICD^ATXAPI(C,$ORDER(^ATXAX("B","BGP IPC OFFICE VISIT CPTS",0)),1)
QUIT 1
+2 ;ITEM 5
IF $$ICD^ATXAPI(C,$ORDER(^ATXAX("B","BGP IPC HOMEHEALTH VISIT CPTS",0)),1)
QUIT 1
+3 ;ITEM 4
IF $$ICD^ATXAPI(C,$ORDER(^ATXAX("B","BGP IPC PREVCARE IOV 0-17 CPTS",0)),1)
QUIT 1
+4 ;ITEM 3
IF $$ICD^ATXAPI(C,$ORDER(^ATXAX("B","BGP IPC PREVCARE EOV 0-17 CPTS",0)),1)
QUIT 1
+5 QUIT ""
