BGP0D211 ; IHS/CMI/LAB - measure 6 ;
;;10.0;IHS CLINICAL REPORTING;;JUN 18, 2010
;
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,BGP1
S BGPC="",BGPLC=""
K BGPG S %=P_"^LAST LAB [BGP QUANT URINE PROTEIN;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 URINE PROT 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 %=$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^BGP0DU(P,BDATE,EDATE,E)
I %]"",$P(BGPLC,U,3)<$P(%,U,2) S BGPLC="1^QUANT UP-CPT^"_$P(%,U,2)
S %="",E=+$$CODEN^ICPTCOD(82042),%=$$CPTI^BGP0DU(P,BDATE,EDATE,E)
I %]"",$P(BGPLC,U,3)<$P(%,U,2) S BGPLC="1^QUANT UP-CPT^"_$P(%,U,2)
S %="",E=+$$CODEN^ICPTCOD(84156),%=$$CPTI^BGP0DU(P,BDATE,EDATE,E)
I %]"",$P(BGPLC,U,3)<$P(%,U,2) S BGPLC="1^QUANT UP-CPT^"_$P(%,U,2)
S %="",E=+$$CODEN^ICPTCOD(82043),%=$$TRANI^BGP0DU(P,BDATE,EDATE,E)
I %]"",$P(BGPLC,U,3)<$P(%,U,2) S BGPLC="1^QUANT UP-CPT^"_$P(%,U,2)
S %="",E=+$$CODEN^ICPTCOD(82042),%=$$TRANI^BGP0DU(P,BDATE,EDATE,E)
I %]"",$P(BGPLC,U,3)<$P(%,U,2) S BGPLC="1^QUANT UP-CPT^"_$P(%,U,2)
S %="",E=+$$CODEN^ICPTCOD(84156),%=$$TRANI^BGP0DU(P,BDATE,EDATE,E)
I %]"",$P(BGPLC,U,3)<$P(%,U,2) S BGPLC="1^QUANT UP-CPT^"_$P(%,U,2)
Q BGPLC
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
;K BGPG S %=P_"^LAST DX 585.5;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
;I $D(BGPG(1)) Q "1^ESRD 585.5^"_$P(BGPG(1),U)
;K BGPG S %=P_"^LAST DX 585.6;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
;I $D(BGPG(1)) Q "1^ESRD 585.6^"_$P(BGPG(1),U)
;K BGPG S %=P_"^LAST DX V45.1;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
;I $D(BGPG(1)) Q "1^ESRD V45.1^"_$P(BGPG(1),U)
S X=$$LASTDX^BGP0UTL1(P,"BGP ESRD PMS DXS",BDATE,EDATE)
I X Q 1_U_"ESRD "_$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_"ESRD "_$P(X,U,2)_U_$P(X,U,1)
.S X=$$CPT^BGP0DU(P,$$DOB^AUPNPAT(P),EDATE,T,5) I X]"" Q
.S X=$$TRAN^BGP0DU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
S X=$$LASTPRC^BGP0UTL1(P,"BGP ESRD PROCS",BDATE,EDATE)
I X Q 1_U_"ESRD "_$P(X,U,2)_U_$P(X,U,3)
Q 0
BGP0D211 ; IHS/CMI/LAB - measure 6 ;
+1 ;;10.0;IHS CLINICAL REPORTING;;JUN 18, 2010
+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,BGP1
+2 SET BGPC=""
SET BGPLC=""
+3 KILL BGPG
SET %=P_"^LAST LAB [BGP QUANT URINE PROTEIN;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 URINE PROT 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 SET %=$PIECE(^AUPNVLAB(X,0),U,4)
+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^BGP0DU(P,BDATE,EDATE,E)
+15 IF %]""
IF $PIECE(BGPLC,U,3)<$PIECE(%,U,2)
SET BGPLC="1^QUANT UP-CPT^"_$PIECE(%,U,2)
+16 SET %=""
SET E=+$$CODEN^ICPTCOD(82042)
SET %=$$CPTI^BGP0DU(P,BDATE,EDATE,E)
+17 IF %]""
IF $PIECE(BGPLC,U,3)<$PIECE(%,U,2)
SET BGPLC="1^QUANT UP-CPT^"_$PIECE(%,U,2)
+18 SET %=""
SET E=+$$CODEN^ICPTCOD(84156)
SET %=$$CPTI^BGP0DU(P,BDATE,EDATE,E)
+19 IF %]""
IF $PIECE(BGPLC,U,3)<$PIECE(%,U,2)
SET BGPLC="1^QUANT UP-CPT^"_$PIECE(%,U,2)
+20 SET %=""
SET E=+$$CODEN^ICPTCOD(82043)
SET %=$$TRANI^BGP0DU(P,BDATE,EDATE,E)
+21 IF %]""
IF $PIECE(BGPLC,U,3)<$PIECE(%,U,2)
SET BGPLC="1^QUANT UP-CPT^"_$PIECE(%,U,2)
+22 SET %=""
SET E=+$$CODEN^ICPTCOD(82042)
SET %=$$TRANI^BGP0DU(P,BDATE,EDATE,E)
+23 IF %]""
IF $PIECE(BGPLC,U,3)<$PIECE(%,U,2)
SET BGPLC="1^QUANT UP-CPT^"_$PIECE(%,U,2)
+24 SET %=""
SET E=+$$CODEN^ICPTCOD(84156)
SET %=$$TRANI^BGP0DU(P,BDATE,EDATE,E)
+25 IF %]""
IF $PIECE(BGPLC,U,3)<$PIECE(%,U,2)
SET BGPLC="1^QUANT UP-CPT^"_$PIECE(%,U,2)
+26 QUIT BGPLC
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 ;K BGPG S %=P_"^LAST DX 585.5;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
+2 ;I $D(BGPG(1)) Q "1^ESRD 585.5^"_$P(BGPG(1),U)
+3 ;K BGPG S %=P_"^LAST DX 585.6;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
+4 ;I $D(BGPG(1)) Q "1^ESRD 585.6^"_$P(BGPG(1),U)
+5 ;K BGPG S %=P_"^LAST DX V45.1;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
+6 ;I $D(BGPG(1)) Q "1^ESRD V45.1^"_$P(BGPG(1),U)
+7 SET X=$$LASTDX^BGP0UTL1(P,"BGP ESRD PMS DXS",BDATE,EDATE)
+8 IF X
QUIT 1_U_"ESRD "_$PIECE(X,U,2)_U_$PIECE(X,U,3)
+9 SET T=$ORDER(^ATXAX("B","BGP ESRD CPTS",0))
+10 IF T
Begin DoDot:1
+11 SET X=$$CPT^BGP0DU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
IF X]""
QUIT
+12 SET X=$$TRAN^BGP0DU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
End DoDot:1
IF X]""
QUIT 1_U_"ESRD "_$PIECE(X,U,2)_U_$PIECE(X,U,1)
+13 SET X=$$LASTPRC^BGP0UTL1(P,"BGP ESRD PROCS",BDATE,EDATE)
+14 IF X
QUIT 1_U_"ESRD "_$PIECE(X,U,2)_U_$PIECE(X,U,3)
+15 QUIT 0
