BGP4D211 ; IHS/CMI/LAB - measure 6 ; 19 Sep 2013 8:12 AM
;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
;
DNKA(V) ;EP
NEW D,N
S D=$$PRIMPOV^APCLV(V,"C")
I D=".0860" Q 1
S N=$$PRIMPOV^APCLV(V,"N")
I $E(D)="V",N["DNKA" Q 1
I $E(D)="V",N["DID NOT KEEP APPOINTMENT" Q 1
I $E(D)="V",N["DID NOT KEEP APPT" Q 1
Q 0
GFR(P,BDATE,EDATE) ;EP
S BGPC=""
S T=$O(^LAB(60,"B","ESTIMATED GFR",0))
S T1=$O(^ATXLAB("B","BGP GPRA ESTIMATED GFR TAX",0))
S T2=$O(^ATXAX("B","BGP ESTIMATED GFR LOINC",0))
S B=9999999-BDATE,E=9999999-EDATE S D=E-1 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(D>B)!(BGPC]"") D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(BGPC]"") D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(BGPC]"") D
...Q:'$D(^AUPNVLAB(X,0))
...Q:$P(^AUPNVLAB(X,0),U,4)=""
...I T,$P(^AUPNVLAB(X,0),U)=T S BGPC=1_U_(9999999-D) Q
...I T1,$D(^ATXLAB(T1,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC=1_U_(9999999-D) Q
...Q:'T2
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,T2)
...S BGPC=1_U_(9999999-D)
...Q
Q BGPC
QUANTUP(P,BDATE,EDATE) ;EP
K BGPC,BGPX
S BGPC="",BGPLC=""
K BGPG S %=P_"^LAST LAB [BGP QUANT UACR TESTS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) S BGPLC=1_"^"_$P(BGPG(1),U,3)_"^"_$P(BGPG(1),U)
S T=$O(^ATXAX("B","BGP QUANT UACR LOINC",0))
S B=9999999-BDATE,E=9999999-EDATE S D=E-1 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(D>B)!(BGPC]"") D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!(BGPC]"") D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!(BGPC]"") D
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,T)
...S %=$$VAL^XBDIQ1(9000010.09,X,.01) ;$P(^AUPNVLAB(X,0),U,4)
...I $P(BGPLC,U,3)<(9999999-D) S BGPLC=1_U_%_U_(9999999-D)
S %="",E=+$$CODEN^ICPTCOD(82043),%=$$CPTI^BGP4DU(P,BDATE,EDATE,E)
I %]"",$P(BGPLC,U,3)<$P(%,U,2),$$OCPT($P(%,U,3)) S BGPLC="1^CPT 82043/82570^"_$P(%,U,2)
S %="",E=+$$CODEN^ICPTCOD(82043),%=$$TRANI^BGP4DU(P,BDATE,EDATE,E)
I %]"",$P(BGPLC,U,3)<$P(%,U,2),$$OCPT($P(%,U,3)) S BGPLC="1^CPT 84023/82570^"_$P(%,U,2)
Q BGPLC
OCPT(V) ;is there a 82570 on this visit?
NEW X,Y
S X=0,Y=0 F S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X D
.I $$VAL^XBDIQ1(9000010.18,X,.01)=82570 S Y=1 Q
I Y Q Y
;check tran codes
S X=0,Y=0 F S X=$O(^AUPNVTC("AD",V,X)) Q:X'=+X D
.I $$VAL^XBDIQ1(9000010.33,X,.07)=82570 S Y=1 Q
Q Y
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 ""
ESRD(P,BDATE,EDATE) ;EP
S X=$$LASTDX^BGP4UTL1(P,"BGP ESRD PMS DXS",BDATE,EDATE)
I X Q 1_U_"POV "_$P(X,U,2)_U_$P(X,U,3)
S T=$O(^ATXAX("B","BGP ESRD CPTS",0))
I T D I X]"" Q 1_U_"CPT "_$P(X,U,2)_U_$P(X,U,1)
.S X=$$CPT^BGP4DU(P,$$DOB^AUPNPAT(P),EDATE,T,5) I X]"" Q
.S X=$$TRAN^BGP4DU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
S X=$$LASTPRC^BGP4UTL1(P,"BGP ESRD PROCS",BDATE,EDATE)
I X Q 1_U_"PRC "_$P(X,U,2)_U_$P(X,U,3)
Q 0
IGOAL ;EP
I 'BGPACTUP S BGPSTOP=1 Q ;not user pop
S (BGPD1,BGPN1,BGPN2)=0
S BGPD1=1
;did patient have a goal set with a start date in report period
S BGPSET=$$SET(DFN,BGPBDATE,BGPEDATE)
I BGPSET S BGPN1=1
S BGPMET=$$MET(DFN,BGPBDATE,BGPEDATE)
I BGPMET S BGPN2=1
S BGPVALUE="UP|||"_$S(BGPSET:"GS: "_$$DATE^BGP4UTL(BGPSET),1:"")
I BGPMET D
.S BGPVALUE=BGPVALUE_$S(BGPSET:"; ",1:"")
.S BGPVALUE=BGPVALUE_"GM: "_$$DATE^BGP4UTL(BGPMET)
Q
;
MET(P,BDATE,EDATE) ;
NEW D,%,X,Y
S X=0,%=""
F S X=$O(^AUPNGOAL("AC",P,X)) Q:X'=+X!(%]"") D
.Q:'$D(^AUPNGOAL(X,0)) ;BAD XREF
.Q:$P(^AUPNGOAL(X,0),U,1)'="S" ;SET ONLY
.Q:$P(^AUPNGOAL(X,0),U,11)'="ME"
.;DURING REPORT PERIOD MODIFIED DATE)
.S G=0
.S D=$P($P(^AUPNGOAL(X,0),U,5),".")
.I D'<BDATE,D'>EDATE S G=1
.Q:'G
.S %=D
Q %
SET(P,BDATE,EDATE) ;
NEW X,Y,Z,%,D
S X=0,%=""
F S X=$O(^AUPNGOAL("AC",P,X)) Q:X'=+X!(%]"") D
.Q:'$D(^AUPNGOAL(X,0)) ;BAD XREF
.Q:$P(^AUPNGOAL(X,0),U,1)'="S" ;SET ONLY
.S D=$P($P(^AUPNGOAL(X,0),U,9),".")
.Q:D=""
.Q:D<BDATE
.Q:D>EDATE
.S %=D
Q %
AWV ;EP
S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPN1)=0
S BGPVALUE=""
I 'BGPACTCL S BGPSTOP=1 Q ;not active clinical
I BGPAGEB<65 S BGPSTOP=1 Q ;not over 65
S BGPD1=1
I $P(^DPT(DFN,0),U,2)="M" S BGPD2=1
I $P(^DPT(DFN,0),U,2)="F" S BGPD3=1
I BGPAGEB>64,BGPAGEB<75 S BGPD4=1
I BGPAGEB>74,BGPAGEB<85 S BGPD5=1
I BGPAGEB>84 S BGPD6=1
S BGPVAL=$$AWV1(DFN,$$FMADD^XLFDT(BGPEDATE,-456),BGPEDATE)
S BGPN1=$P(BGPVAL,U)
S BGPVALUE="AC|||" I BGPN1 S BGPVALUE=BGPVALUE_$$DATE^BGP4UTL($P(BGPVAL,U,2))_" CPT "_$P(BGPVAL,U,3)
K BGPVAL
Q
;
AWV1(P,BDATE,EDATE) ;EP
NEW T,X
S T=$O(^ATXAX("B","BGP ANNUAL WELLNESS CPTS",0))
I 'T Q ""
S X=$$CPT^BGP4DU(P,BDATE,EDATE,T,6)
I 'X S X=$$TRAN^BGP4DU(P,BDATE,EDATE,T,6)
Q X
BGP4D211 ; IHS/CMI/LAB - measure 6 ; 19 Sep 2013 8:12 AM
+1 ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
+2 ;
DNKA(V) ;EP
+1 NEW D,N
+2 SET D=$$PRIMPOV^APCLV(V,"C")
+3 IF D=".0860"
QUIT 1
+4 SET N=$$PRIMPOV^APCLV(V,"N")
+5 IF $EXTRACT(D)="V"
IF N["DNKA"
QUIT 1
+6 IF $EXTRACT(D)="V"
IF N["DID NOT KEEP APPOINTMENT"
QUIT 1
+7 IF $EXTRACT(D)="V"
IF N["DID NOT KEEP APPT"
QUIT 1
+8 QUIT 0
GFR(P,BDATE,EDATE) ;EP
+1 SET BGPC=""
+2 SET T=$ORDER(^LAB(60,"B","ESTIMATED GFR",0))
+3 SET T1=$ORDER(^ATXLAB("B","BGP GPRA ESTIMATED GFR TAX",0))
+4 SET T2=$ORDER(^ATXAX("B","BGP ESTIMATED GFR LOINC",0))
+5 SET B=9999999-BDATE
SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(D>B)!(BGPC]"")
QUIT
Begin DoDot:1
+6 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!(BGPC]"")
QUIT
Begin DoDot:2
+7 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!(BGPC]"")
QUIT
Begin DoDot:3
+8 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+9 IF $PIECE(^AUPNVLAB(X,0),U,4)=""
QUIT
+10 IF T
IF $PIECE(^AUPNVLAB(X,0),U)=T
SET BGPC=1_U_(9999999-D)
QUIT
+11 IF T1
IF $DATA(^ATXLAB(T1,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPC=1_U_(9999999-D)
QUIT
+12 IF 'T2
QUIT
+13 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+14 IF '$$LOINC(J,T2)
QUIT
+15 SET BGPC=1_U_(9999999-D)
+16 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+17 QUIT BGPC
QUANTUP(P,BDATE,EDATE) ;EP
+1 KILL BGPC,BGPX
+2 SET BGPC=""
SET BGPLC=""
+3 KILL BGPG
SET %=P_"^LAST LAB [BGP QUANT UACR TESTS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+4 IF $DATA(BGPG(1))
SET BGPLC=1_"^"_$PIECE(BGPG(1),U,3)_"^"_$PIECE(BGPG(1),U)
+5 SET T=$ORDER(^ATXAX("B","BGP QUANT UACR LOINC",0))
+6 SET B=9999999-BDATE
SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(D>B)!(BGPC]"")
QUIT
Begin DoDot:1
+7 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!(BGPC]"")
QUIT
Begin DoDot:2
+8 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!(BGPC]"")
QUIT
Begin DoDot:3
+9 IF 'T
QUIT
+10 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+11 IF '$$LOINC(J,T)
QUIT
+12 ;$P(^AUPNVLAB(X,0),U,4)
SET %=$$VAL^XBDIQ1(9000010.09,X,.01)
+13 IF $PIECE(BGPLC,U,3)<(9999999-D)
SET BGPLC=1_U_%_U_(9999999-D)
End DoDot:3
End DoDot:2
End DoDot:1
+14 SET %=""
SET E=+$$CODEN^ICPTCOD(82043)
SET %=$$CPTI^BGP4DU(P,BDATE,EDATE,E)
+15 IF %]""
IF $PIECE(BGPLC,U,3)<$PIECE(%,U,2)
IF $$OCPT($PIECE(%,U,3))
SET BGPLC="1^CPT 82043/82570^"_$PIECE(%,U,2)
+16 SET %=""
SET E=+$$CODEN^ICPTCOD(82043)
SET %=$$TRANI^BGP4DU(P,BDATE,EDATE,E)
+17 IF %]""
IF $PIECE(BGPLC,U,3)<$PIECE(%,U,2)
IF $$OCPT($PIECE(%,U,3))
SET BGPLC="1^CPT 84023/82570^"_$PIECE(%,U,2)
+18 QUIT BGPLC
OCPT(V) ;is there a 82570 on this visit?
+1 NEW X,Y
+2 SET X=0
SET Y=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:1
+3 IF $$VAL^XBDIQ1(9000010.18,X,.01)=82570
SET Y=1
QUIT
End DoDot:1
+4 IF Y
QUIT Y
+5 ;check tran codes
+6 SET X=0
SET Y=0
FOR
SET X=$ORDER(^AUPNVTC("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:1
+7 IF $$VAL^XBDIQ1(9000010.33,X,.07)=82570
SET Y=1
QUIT
End DoDot:1
+8 QUIT Y
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 ""
ESRD(P,BDATE,EDATE) ;EP
+1 SET X=$$LASTDX^BGP4UTL1(P,"BGP ESRD PMS DXS",BDATE,EDATE)
+2 IF X
QUIT 1_U_"POV "_$PIECE(X,U,2)_U_$PIECE(X,U,3)
+3 SET T=$ORDER(^ATXAX("B","BGP ESRD CPTS",0))
+4 IF T
Begin DoDot:1
+5 SET X=$$CPT^BGP4DU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
IF X]""
QUIT
+6 SET X=$$TRAN^BGP4DU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
End DoDot:1
IF X]""
QUIT 1_U_"CPT "_$PIECE(X,U,2)_U_$PIECE(X,U,1)
+7 SET X=$$LASTPRC^BGP4UTL1(P,"BGP ESRD PROCS",BDATE,EDATE)
+8 IF X
QUIT 1_U_"PRC "_$PIECE(X,U,2)_U_$PIECE(X,U,3)
+9 QUIT 0
IGOAL ;EP
+1 ;not user pop
IF 'BGPACTUP
SET BGPSTOP=1
QUIT
+2 SET (BGPD1,BGPN1,BGPN2)=0
+3 SET BGPD1=1
+4 ;did patient have a goal set with a start date in report period
+5 SET BGPSET=$$SET(DFN,BGPBDATE,BGPEDATE)
+6 IF BGPSET
SET BGPN1=1
+7 SET BGPMET=$$MET(DFN,BGPBDATE,BGPEDATE)
+8 IF BGPMET
SET BGPN2=1
+9 SET BGPVALUE="UP|||"_$SELECT(BGPSET:"GS: "_$$DATE^BGP4UTL(BGPSET),1:"")
+10 IF BGPMET
Begin DoDot:1
+11 SET BGPVALUE=BGPVALUE_$SELECT(BGPSET:"; ",1:"")
+12 SET BGPVALUE=BGPVALUE_"GM: "_$$DATE^BGP4UTL(BGPMET)
End DoDot:1
+13 QUIT
+14 ;
MET(P,BDATE,EDATE) ;
+1 NEW D,%,X,Y
+2 SET X=0
SET %=""
+3 FOR
SET X=$ORDER(^AUPNGOAL("AC",P,X))
IF X'=+X!(%]"")
QUIT
Begin DoDot:1
+4 ;BAD XREF
IF '$DATA(^AUPNGOAL(X,0))
QUIT
+5 ;SET ONLY
IF $PIECE(^AUPNGOAL(X,0),U,1)'="S"
QUIT
+6 IF $PIECE(^AUPNGOAL(X,0),U,11)'="ME"
QUIT
+7 ;DURING REPORT PERIOD MODIFIED DATE)
+8 SET G=0
+9 SET D=$PIECE($PIECE(^AUPNGOAL(X,0),U,5),".")
+10 IF D'<BDATE
IF D'>EDATE
SET G=1
+11 IF 'G
QUIT
+12 SET %=D
End DoDot:1
+13 QUIT %
SET(P,BDATE,EDATE) ;
+1 NEW X,Y,Z,%,D
+2 SET X=0
SET %=""
+3 FOR
SET X=$ORDER(^AUPNGOAL("AC",P,X))
IF X'=+X!(%]"")
QUIT
Begin DoDot:1
+4 ;BAD XREF
IF '$DATA(^AUPNGOAL(X,0))
QUIT
+5 ;SET ONLY
IF $PIECE(^AUPNGOAL(X,0),U,1)'="S"
QUIT
+6 SET D=$PIECE($PIECE(^AUPNGOAL(X,0),U,9),".")
+7 IF D=""
QUIT
+8 IF D<BDATE
QUIT
+9 IF D>EDATE
QUIT
+10 SET %=D
End DoDot:1
+11 QUIT %
AWV ;EP
+1 SET (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPN1)=0
+2 SET BGPVALUE=""
+3 ;not active clinical
IF 'BGPACTCL
SET BGPSTOP=1
QUIT
+4 ;not over 65
IF BGPAGEB<65
SET BGPSTOP=1
QUIT
+5 SET BGPD1=1
+6 IF $PIECE(^DPT(DFN,0),U,2)="M"
SET BGPD2=1
+7 IF $PIECE(^DPT(DFN,0),U,2)="F"
SET BGPD3=1
+8 IF BGPAGEB>64
IF BGPAGEB<75
SET BGPD4=1
+9 IF BGPAGEB>74
IF BGPAGEB<85
SET BGPD5=1
+10 IF BGPAGEB>84
SET BGPD6=1
+11 SET BGPVAL=$$AWV1(DFN,$$FMADD^XLFDT(BGPEDATE,-456),BGPEDATE)
+12 SET BGPN1=$PIECE(BGPVAL,U)
+13 SET BGPVALUE="AC|||"
IF BGPN1
SET BGPVALUE=BGPVALUE_$$DATE^BGP4UTL($PIECE(BGPVAL,U,2))_" CPT "_$PIECE(BGPVAL,U,3)
+14 KILL BGPVAL
+15 QUIT
+16 ;
AWV1(P,BDATE,EDATE) ;EP
+1 NEW T,X
+2 SET T=$ORDER(^ATXAX("B","BGP ANNUAL WELLNESS CPTS",0))
+3 IF 'T
QUIT ""
+4 SET X=$$CPT^BGP4DU(P,BDATE,EDATE,T,6)
+5 IF 'X
SET X=$$TRAN^BGP4DU(P,BDATE,EDATE,T,6)
+6 QUIT X
