- 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