BGP6D211 ; IHS/CMI/LAB - measure 6 19 Sep 2014 8:12 AM ;
;;16.1;IHS CLINICAL REPORTING;;MAR 22, 2016;Build 170
;
JVN ;EP
NEW BGPVAL,A,E,%,Y,X,R,D,V
S BGPVAL=""
K ^TMP($J,"A")
S R=$NA(^TMP($J,"A"))
D ALLV^APCLAPIU(P,BDATE,EDATE,R)
S X=0,Y=0 F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(Y) S R=$$CLINIC^APCLV($P(^TMP($J,"A",X),U,5),"C") I R="A2",'$$DNKA($P(^TMP($J,"A",X),U,5)) S Y=1,D=$P(^TMP($J,"A",X),U)
I Y S $P(BGPVAL,U,1)="JVN: "_$$DATE^BGP6UTL(D)_" Cl "_R
;OPHTHALMOLOGY
S X=0,Y=0 F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(Y) D
.S V=$P(^TMP($J,"A",X),U,5)
.Q:$P($G(^AUPNVSIT(V,0)),U,7)="C"
.Q:$P($G(^AUPNVSIT(V,0)),U,7)="T"
.S R=$$CLINIC^APCLV($P(^TMP($J,"A",X),U,5),"C")
.Q:R'=17
.Q:$$DNKA($P(^TMP($J,"A",X),U,5))
.S J=$$PRIMPROV^APCLV($P(^TMP($J,"A",X),U,5),"D")
.Q:J'=79
.S Y=1,D=$P(^TMP($J,"A",X),U)
I Y S $P(BGPVAL,U,2)="Ophth: "_$$DATE^BGP6UTL(D)_" Cl/Prv "_R_"/"_J
;I 'Y D
;.S (X,Y)=0,D="" F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(Y) S R=$$PRIMPROV^APCLV($P(^TMP($J,"A",X),U,5),"D") I R=79,'$$DNKA($P(^TMP($J,"A",X),U,5)) S Y=1,D=$P(^TMP($J,"A",X),U)
;.I Y S $P(BGPVAL,U,2)="Ophth: "_$$DATE^BGP6UTL(D)_" Prv "_R
;S X=0,Y=0 F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(Y) S R=$$CLINIC^APCLV($P(^TMP($J,"A",X),U,5),"C") I R=18,'$$DNKA($P(^TMP($J,"A",X),U,5)) S Y=1,D=$P(^TMP($J,"A",X),U)
;I Y S $P(BGPVAL,U,3)="Optom: "_$$DATE^BGP6UTL(D)_" Cl "_R
;I 'Y D
;.S (X,Y)=0,D="" F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(Y) S R=$$PRIMPROV^APCLV($P(^TMP($J,"A",X),U,5),"D") I R="08"!(R=24),'$$DNKA($P(^TMP($J,"A",X),U,5)) S Y=1,D=$P(^TMP($J,"A",X),U)
;OPTOMETRY
S X=0,Y=0 F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(Y) D
.S V=$P(^TMP($J,"A",X),U,5)
.Q:$P($G(^AUPNVSIT(V,0)),U,7)="C"
.Q:$P($G(^AUPNVSIT(V,0)),U,7)="T"
.S R=$$CLINIC^APCLV($P(^TMP($J,"A",X),U,5),"C")
.Q:R'=18
.Q:$$DNKA($P(^TMP($J,"A",X),U,5))
.S J=$$PRIMPROV^APCLV($P(^TMP($J,"A",X),U,5),"D")
.I J'="08",J'=24 Q
.S Y=1,D=$P(^TMP($J,"A",X),U)
I Y S $P(BGPVAL,U,3)="Optom: "_$$DATE^BGP6UTL(D)_" Cl/Prv "_R_"/"_J
Q BGPVAL
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^BGP6DU(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^BGP6DU(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,D,E,%
S D=$$VD^APCLV(V) ;date of visit
S E=+$$CODEN^ICPTCOD("82570"),%=$$CPTI^BGP6DU(P,D,D,E)
;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 % Q 1
;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
S E=+$$CODEN^ICPTCOD("82570"),%=$$TRANI^BGP6DU(P,D,D,E)
I % Q 1
Q ""
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^BGP6UTL1(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^BGP6DU(P,$$DOB^AUPNPAT(P),EDATE,T,5) I X]"" Q
.S X=$$TRAN^BGP6DU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
S X=$$LASTPRC^BGP6UTL1(P,"BGP ESRD PROCS",BDATE,EDATE)
I X Q 1_U_"PRC "_$P(X,U,2)_U_$P(X,U,3)
Q 0
S ;
S BGPSET($P(^APCDTPGT(X,0),U,1))=0,BGPMET($P(^APCDTPGT(X,0),U,1))=0
Q
IGOAL ;EP
NEW BGPSET,BGPMET
;
I 'BGPACTUP S BGPSTOP=1 Q ;not user pop
F X=1:1:23 S @("BGPN"_X)=0
S BGPD1=1 ;USER POP
S BGPD2=0 ;# goals set
S BGPD3=0 ;# goals met
S X=0 F S X=$O(^APCDTPGT(X)) Q:X'=+X D
.S Y=$P(^APCDTPGT(X,0),U,1)
.I Y="PHYSICAL ACTIVITY" D S
.I Y="NUTRITION" D S
.I Y="MEDICATIONS" D S
.I Y="WELLNESS AND SAFETY" D S
.I Y="TOBACCO" D S
.I Y="ALCOHOL OR OTHER DRUGS" D S
.I Y="STRESS AND COPING" D S
.I Y="MONITORING" D S
.I Y="DIABETES CURRICULUM" D S
.I Y="OTHER" D S
;did patient have a goal set with a start date in report period
D SET
I BGPD2 S BGPN1=1
S C=2,X=0
F S X=$O(BGPSET(X)) Q:X="" S C=C+1 S @("BGPN"_C)=@("BGPN"_C)+BGPSET(X)
D MET
I BGPD3 S BGPN2=1
S C=12,X=0
F S X=$O(BGPMET(X)) Q:X="" S C=C+1 S @("BGPN"_C)=@("BGPN"_C)+BGPMET(X)
S BGPVALUE="UP|||"
S X="",Y="" F S X=$O(BGPSET(X)) Q:X="" I $P(BGPSET(X),U,1) D
.F J=2:1 S D=$P(BGPSET(X),U,J) Q:D="" D
..I Y]"" S Y=Y_", "
..S Y=Y_$$DATE^BGP6UTL(D)_" - "_X
I Y]"" S Y="GS: "_Y,BGPVALUE=BGPVALUE_Y
S Y=""
S X="",Y="" F S X=$O(BGPMET(X)) Q:X="" I $P(BGPMET(X),U,1) D
.F J=2:1 S D=$P(BGPMET(X),U,J) Q:D="" D
..I Y]"" S Y=Y_", "
..S Y=Y_$$DATE^BGP6UTL(D)_" - "_X
I Y]"" S Y="; GM: "_Y,BGPVALUE=BGPVALUE_Y
K BGPSET,BGPMET
Q
;
MET ;
NEW D,%,X,Y
S X=0,%=""
F S X=$O(^AUPNGOAL("AC",DFN,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'<BGPBDATE,D'>BGPEDATE S G=1
.Q:'G
.S Y=0 F S Y=$O(^AUPNGOAL(X,10,Y)) Q:Y'=+Y D
..S Z=$P($G(^AUPNGOAL(X,10,Y,0)),U,1)
..Q:'Z
..S BGPD3=BGPD3+1
..S Z=$P($G(^APCDTPGT(Z,0)),U,1)
..Q:Z=""
..S $P(BGPMET(Z),U,1)=$P(BGPMET(Z),U,1)+1,J=$P(BGPMET(Z),U,1),J=J+1,$P(BGPMET(Z),U,J)=D
Q
SET ;
NEW X,Y,Z,%,D
S X=0,%=""
F S X=$O(^AUPNGOAL("AC",DFN,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<BGPBDATE
.Q:D>BGPEDATE
.S Y=0 F S Y=$O(^AUPNGOAL(X,10,Y)) Q:Y'=+Y D
..S Z=$P($G(^AUPNGOAL(X,10,Y,0)),U,1)
..Q:'Z
..S BGPD2=BGPD2+1
..S Z=$P($G(^APCDTPGT(Z,0)),U,1)
..Q:Z=""
..S $P(BGPSET(Z),U,1)=$P(BGPSET(Z),U,1)+1,J=$P(BGPSET(Z),U,1),J=J+1,$P(BGPSET(Z),U,J)=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^BGP6UTL($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^BGP6DU(P,BDATE,EDATE,T,6)
I 'X S X=$$TRAN^BGP6DU(P,BDATE,EDATE,T,6)
Q X
BGP6D211 ; IHS/CMI/LAB - measure 6 19 Sep 2014 8:12 AM ;
+1 ;;16.1;IHS CLINICAL REPORTING;;MAR 22, 2016;Build 170
+2 ;
JVN ;EP
+1 NEW BGPVAL,A,E,%,Y,X,R,D,V
+2 SET BGPVAL=""
+3 KILL ^TMP($JOB,"A")
+4 SET R=$NAME(^TMP($JOB,"A"))
+5 DO ALLV^APCLAPIU(P,BDATE,EDATE,R)
+6 SET X=0
SET Y=0
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X!(Y)
QUIT
SET R=$$CLINIC^APCLV($PIECE(^TMP($JOB,"A",X),U,5),"C")
IF R="A2"
IF '$$DNKA($PIECE(^TMP($JOB,"A",X),U,5))
SET Y=1
SET D=$PIECE(^TMP($JOB,"A",X),U)
+7 IF Y
SET $PIECE(BGPVAL,U,1)="JVN: "_$$DATE^BGP6UTL(D)_" Cl "_R
+8 ;OPHTHALMOLOGY
+9 SET X=0
SET Y=0
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X!(Y)
QUIT
Begin DoDot:1
+10 SET V=$PIECE(^TMP($JOB,"A",X),U,5)
+11 IF $PIECE($GET(^AUPNVSIT(V,0)),U,7)="C"
QUIT
+12 IF $PIECE($GET(^AUPNVSIT(V,0)),U,7)="T"
QUIT
+13 SET R=$$CLINIC^APCLV($PIECE(^TMP($JOB,"A",X),U,5),"C")
+14 IF R'=17
QUIT
+15 IF $$DNKA($PIECE(^TMP($JOB,"A",X),U,5))
QUIT
+16 SET J=$$PRIMPROV^APCLV($PIECE(^TMP($JOB,"A",X),U,5),"D")
+17 IF J'=79
QUIT
+18 SET Y=1
SET D=$PIECE(^TMP($JOB,"A",X),U)
End DoDot:1
+19 IF Y
SET $PIECE(BGPVAL,U,2)="Ophth: "_$$DATE^BGP6UTL(D)_" Cl/Prv "_R_"/"_J
+20 ;I 'Y D
+21 ;.S (X,Y)=0,D="" F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(Y) S R=$$PRIMPROV^APCLV($P(^TMP($J,"A",X),U,5),"D") I R=79,'$$DNKA($P(^TMP($J,"A",X),U,5)) S Y=1,D=$P(^TMP($J,"A",X),U)
+22 ;.I Y S $P(BGPVAL,U,2)="Ophth: "_$$DATE^BGP6UTL(D)_" Prv "_R
+23 ;S X=0,Y=0 F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(Y) S R=$$CLINIC^APCLV($P(^TMP($J,"A",X),U,5),"C") I R=18,'$$DNKA($P(^TMP($J,"A",X),U,5)) S Y=1,D=$P(^TMP($J,"A",X),U)
+24 ;I Y S $P(BGPVAL,U,3)="Optom: "_$$DATE^BGP6UTL(D)_" Cl "_R
+25 ;I 'Y D
+26 ;.S (X,Y)=0,D="" F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(Y) S R=$$PRIMPROV^APCLV($P(^TMP($J,"A",X),U,5),"D") I R="08"!(R=24),'$$DNKA($P(^TMP($J,"A",X),U,5)) S Y=1,D=$P(^TMP($J,"A",X),U)
+27 ;OPTOMETRY
+28 SET X=0
SET Y=0
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X!(Y)
QUIT
Begin DoDot:1
+29 SET V=$PIECE(^TMP($JOB,"A",X),U,5)
+30 IF $PIECE($GET(^AUPNVSIT(V,0)),U,7)="C"
QUIT
+31 IF $PIECE($GET(^AUPNVSIT(V,0)),U,7)="T"
QUIT
+32 SET R=$$CLINIC^APCLV($PIECE(^TMP($JOB,"A",X),U,5),"C")
+33 IF R'=18
QUIT
+34 IF $$DNKA($PIECE(^TMP($JOB,"A",X),U,5))
QUIT
+35 SET J=$$PRIMPROV^APCLV($PIECE(^TMP($JOB,"A",X),U,5),"D")
+36 IF J'="08"
IF J'=24
QUIT
+37 SET Y=1
SET D=$PIECE(^TMP($JOB,"A",X),U)
End DoDot:1
+38 IF Y
SET $PIECE(BGPVAL,U,3)="Optom: "_$$DATE^BGP6UTL(D)_" Cl/Prv "_R_"/"_J
+39 QUIT BGPVAL
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^BGP6DU(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^BGP6DU(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,D,E,%
+2 ;date of visit
SET D=$$VD^APCLV(V)
+3 SET E=+$$CODEN^ICPTCOD("82570")
SET %=$$CPTI^BGP6DU(P,D,D,E)
+4 ;S X=0,Y=0 F S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X D
+5 ;.I $$VAL^XBDIQ1(9000010.18,X,.01)=82570 S Y=1 Q
+6 IF %
QUIT 1
+7 ;check tran codes
+8 ;S X=0,Y=0 F S X=$O(^AUPNVTC("AD",V,X)) Q:X'=+X D
+9 ;.I $$VAL^XBDIQ1(9000010.33,X,.07)=82570 S Y=1 Q
+10 SET E=+$$CODEN^ICPTCOD("82570")
SET %=$$TRANI^BGP6DU(P,D,D,E)
+11 IF %
QUIT 1
+12 QUIT ""
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^BGP6UTL1(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^BGP6DU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
IF X]""
QUIT
+6 SET X=$$TRAN^BGP6DU(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^BGP6UTL1(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
S ;
+1 SET BGPSET($PIECE(^APCDTPGT(X,0),U,1))=0
SET BGPMET($PIECE(^APCDTPGT(X,0),U,1))=0
+2 QUIT
IGOAL ;EP
+1 NEW BGPSET,BGPMET
+2 ;
+3 ;not user pop
IF 'BGPACTUP
SET BGPSTOP=1
QUIT
+4 FOR X=1:1:23
SET @("BGPN"_X)=0
+5 ;USER POP
SET BGPD1=1
+6 ;# goals set
SET BGPD2=0
+7 ;# goals met
SET BGPD3=0
+8 SET X=0
FOR
SET X=$ORDER(^APCDTPGT(X))
IF X'=+X
QUIT
Begin DoDot:1
+9 SET Y=$PIECE(^APCDTPGT(X,0),U,1)
+10 IF Y="PHYSICAL ACTIVITY"
DO S
+11 IF Y="NUTRITION"
DO S
+12 IF Y="MEDICATIONS"
DO S
+13 IF Y="WELLNESS AND SAFETY"
DO S
+14 IF Y="TOBACCO"
DO S
+15 IF Y="ALCOHOL OR OTHER DRUGS"
DO S
+16 IF Y="STRESS AND COPING"
DO S
+17 IF Y="MONITORING"
DO S
+18 IF Y="DIABETES CURRICULUM"
DO S
+19 IF Y="OTHER"
DO S
End DoDot:1
+20 ;did patient have a goal set with a start date in report period
+21 DO SET
+22 IF BGPD2
SET BGPN1=1
+23 SET C=2
SET X=0
+24 FOR
SET X=$ORDER(BGPSET(X))
IF X=""
QUIT
SET C=C+1
SET @("BGPN"_C)=@("BGPN"_C)+BGPSET(X)
+25 DO MET
+26 IF BGPD3
SET BGPN2=1
+27 SET C=12
SET X=0
+28 FOR
SET X=$ORDER(BGPMET(X))
IF X=""
QUIT
SET C=C+1
SET @("BGPN"_C)=@("BGPN"_C)+BGPMET(X)
+29 SET BGPVALUE="UP|||"
+30 SET X=""
SET Y=""
FOR
SET X=$ORDER(BGPSET(X))
IF X=""
QUIT
IF $PIECE(BGPSET(X),U,1)
Begin DoDot:1
+31 FOR J=2:1
SET D=$PIECE(BGPSET(X),U,J)
IF D=""
QUIT
Begin DoDot:2
+32 IF Y]""
SET Y=Y_", "
+33 SET Y=Y_$$DATE^BGP6UTL(D)_" - "_X
End DoDot:2
End DoDot:1
+34 IF Y]""
SET Y="GS: "_Y
SET BGPVALUE=BGPVALUE_Y
+35 SET Y=""
+36 SET X=""
SET Y=""
FOR
SET X=$ORDER(BGPMET(X))
IF X=""
QUIT
IF $PIECE(BGPMET(X),U,1)
Begin DoDot:1
+37 FOR J=2:1
SET D=$PIECE(BGPMET(X),U,J)
IF D=""
QUIT
Begin DoDot:2
+38 IF Y]""
SET Y=Y_", "
+39 SET Y=Y_$$DATE^BGP6UTL(D)_" - "_X
End DoDot:2
End DoDot:1
+40 IF Y]""
SET Y="; GM: "_Y
SET BGPVALUE=BGPVALUE_Y
+41 KILL BGPSET,BGPMET
+42 QUIT
+43 ;
MET ;
+1 NEW D,%,X,Y
+2 SET X=0
SET %=""
+3 FOR
SET X=$ORDER(^AUPNGOAL("AC",DFN,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'<BGPBDATE
IF D'>BGPEDATE
SET G=1
+11 IF 'G
QUIT
+12 SET Y=0
FOR
SET Y=$ORDER(^AUPNGOAL(X,10,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+13 SET Z=$PIECE($GET(^AUPNGOAL(X,10,Y,0)),U,1)
+14 IF 'Z
QUIT
+15 SET BGPD3=BGPD3+1
+16 SET Z=$PIECE($GET(^APCDTPGT(Z,0)),U,1)
+17 IF Z=""
QUIT
+18 SET $PIECE(BGPMET(Z),U,1)=$PIECE(BGPMET(Z),U,1)+1
SET J=$PIECE(BGPMET(Z),U,1)
SET J=J+1
SET $PIECE(BGPMET(Z),U,J)=D
End DoDot:2
End DoDot:1
+19 QUIT
SET ;
+1 NEW X,Y,Z,%,D
+2 SET X=0
SET %=""
+3 FOR
SET X=$ORDER(^AUPNGOAL("AC",DFN,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<BGPBDATE
QUIT
+9 IF D>BGPEDATE
QUIT
+10 SET Y=0
FOR
SET Y=$ORDER(^AUPNGOAL(X,10,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+11 SET Z=$PIECE($GET(^AUPNGOAL(X,10,Y,0)),U,1)
+12 IF 'Z
QUIT
+13 SET BGPD2=BGPD2+1
+14 SET Z=$PIECE($GET(^APCDTPGT(Z,0)),U,1)
+15 IF Z=""
QUIT
+16 SET $PIECE(BGPSET(Z),U,1)=$PIECE(BGPSET(Z),U,1)+1
SET J=$PIECE(BGPSET(Z),U,1)
SET J=J+1
SET $PIECE(BGPSET(Z),U,J)=D
End DoDot:2
End DoDot:1
+17 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^BGP6UTL($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^BGP6DU(P,BDATE,EDATE,T,6)
+5 IF 'X
SET X=$$TRAN^BGP6DU(P,BDATE,EDATE,T,6)
+6 QUIT X
