BGP5D211 ; IHS/CMI/LAB - measure 6 ; 19 Sep 2014 8:12 AM
;;15.1;IHS CLINICAL REPORTING;;MAY 06, 2015;Build 143
;
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^BGP5DU(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^BGP5DU(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^BGP5UTL1(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^BGP5DU(P,$$DOB^AUPNPAT(P),EDATE,T,5) I X]"" Q
.S X=$$TRAN^BGP5DU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
S X=$$LASTPRC^BGP5UTL1(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
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 S BGPSET($P(^APCDTPGT(X,0),U,1))=0,BGPMET($P(^APCDTPGT(X,0),U,1))=0
;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^BGP5UTL(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^BGP5UTL(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^BGP5UTL($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^BGP5DU(P,BDATE,EDATE,T,6)
I 'X S X=$$TRAN^BGP5DU(P,BDATE,EDATE,T,6)
Q X
BGP5D211 ; IHS/CMI/LAB - measure 6 ; 19 Sep 2014 8:12 AM
+1 ;;15.1;IHS CLINICAL REPORTING;;MAY 06, 2015;Build 143
+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^BGP5DU(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^BGP5DU(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^BGP5UTL1(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^BGP5DU(P,$$DOB^AUPNPAT(P),EDATE,T,5)
IF X]""
QUIT
+6 SET X=$$TRAN^BGP5DU(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^BGP5UTL1(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 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
SET BGPSET($PIECE(^APCDTPGT(X,0),U,1))=0
SET BGPMET($PIECE(^APCDTPGT(X,0),U,1))=0
+9 ;did patient have a goal set with a start date in report period
+10 DO SET
+11 IF BGPD2
SET BGPN1=1
+12 SET C=2
SET X=0
+13 FOR
SET X=$ORDER(BGPSET(X))
IF X=""
QUIT
SET C=C+1
SET @("BGPN"_C)=@("BGPN"_C)+BGPSET(X)
+14 DO MET
+15 IF BGPD3
SET BGPN2=1
+16 SET C=12
SET X=0
+17 FOR
SET X=$ORDER(BGPMET(X))
IF X=""
QUIT
SET C=C+1
SET @("BGPN"_C)=@("BGPN"_C)+BGPMET(X)
+18 SET BGPVALUE="UP|||"
+19 SET X=""
SET Y=""
FOR
SET X=$ORDER(BGPSET(X))
IF X=""
QUIT
IF $PIECE(BGPSET(X),U,1)
Begin DoDot:1
+20 FOR J=2:1
SET D=$PIECE(BGPSET(X),U,J)
IF D=""
QUIT
Begin DoDot:2
+21 IF Y]""
SET Y=Y_", "
+22 SET Y=Y_$$DATE^BGP5UTL(D)_" - "_X
End DoDot:2
End DoDot:1
+23 IF Y]""
SET Y="GS: "_Y
SET BGPVALUE=BGPVALUE_Y
+24 SET Y=""
+25 SET X=""
SET Y=""
FOR
SET X=$ORDER(BGPMET(X))
IF X=""
QUIT
IF $PIECE(BGPMET(X),U,1)
Begin DoDot:1
+26 FOR J=2:1
SET D=$PIECE(BGPMET(X),U,J)
IF D=""
QUIT
Begin DoDot:2
+27 IF Y]""
SET Y=Y_", "
+28 SET Y=Y_$$DATE^BGP5UTL(D)_" - "_X
End DoDot:2
End DoDot:1
+29 IF Y]""
SET Y="; GM: "_Y
SET BGPVALUE=BGPVALUE_Y
+30 KILL BGPSET,BGPMET
+31 QUIT
+32 ;
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^BGP5UTL($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^BGP5DU(P,BDATE,EDATE,T,6)
+5 IF 'X
SET X=$$TRAN^BGP5DU(P,BDATE,EDATE,T,6)
+6 QUIT X
