- BGP9D211 ; IHS/CMI/LAB - measure 6 ;
- ;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009
- ;
- 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^BGP9DU(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^BGP9DU(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^BGP9DU(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^BGP9DU(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^BGP9DU(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^BGP9DU(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^BGP9UTL1(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^BGP9DU(P,$$DOB^AUPNPAT(P),EDATE,T,5) I X]"" Q
- .S X=$$TRAN^BGP9DU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
- S X=$$LASTPRC^BGP9UTL1(P,"BGP ESRD PROCS",BDATE,EDATE)
- I X Q 1_U_"ESRD "_$P(X,U,2)_U_$P(X,U,3)
- Q 0
- BGP9D211 ; IHS/CMI/LAB - measure 6 ;
- +1 ;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009
- +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^BGP9DU(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^BGP9DU(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^BGP9DU(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^BGP9DU(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^BGP9DU(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^BGP9DU(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^BGP9UTL1(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^BGP9DU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
- IF X]""
- QUIT
- +12 SET X=$$TRAN^BGP9DU(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^BGP9UTL1(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
