BGP7D5.m

BGP7D5 ; IHS/CMI/LAB - measure calc ;

 ;;17.1;IHS CLINICAL REPORTING;;MAY 10, 2017;Build 29

 ;

I21 ;EP

 S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0

 S (BGPDVEX,BGPDVDX,BGPDVPED,BGPDVREF)=""

 I 'BGPACTUP S BGPSTOP=1 Q

 I BGPSEX'="F" S BGPSTOP=1 Q

 I BGPAGEB<13 S BGPSTOP=1 Q

 I BGPACTUP S BGPD3=1

 I BGPACTCL S BGPD1=1

 I BGPAGEB>14,BGPAGEB<41,BGPACTCL S BGPD2=1 ;gpra denominator 15-40

 I BGPAGEB>13,BGPAGEB<47,BGPACTUP S BGPD5=1

 I BGPAGEB>13,BGPAGEB<47,BGPACTCL S BGPD4=1

DV ;EP - called from elder care

 S BGPDVEX=$$DVEX(DFN,BGPBDATE,BGPEDATE) I $P(BGPDVEX,U)=1 S BGPN2=1  ;EXAM ONLY

 S BGPDVDX=$$DVDX(DFN,BGPBDATE,BGPEDATE) I $P(BGPDVDX,U)=1 S BGPN3=1  ;DX ONLY

 S BGPDVPED=$$DVPED(DFN,BGPBDATE,BGPEDATE) I $P(BGPDVPED,U)=1 S BGPN4=1,BGPN8=1  ;W/O V61.11

 S BGPDVCOU=$$DV61(DFN,BGPBDATE,BGPEDATE) I $P(BGPDVCOU,U)=1 S BGPN4=1  ;include in education for gpra

 I BGPN2 S BGPN1=1

 I BGPN3 S BGPN1=1

 I BGPN4 S BGPN1=1

 ;I 'BGPN1 S BGPDVREF=$$REFDV(DFN,BGP365,BGPEDATE) I $P(BGPDVREF,U)=1 S BGPN5=1

 ;I BGPN5 S BGPN1=1

 I BGPN1,'BGPN5 S BGPN6=1  ;

 I BGPN2!(BGPN3)!(BGPDVCOU) S BGPN7=1

 S BGPVALUE=$S(BGPD3:"UP",1:"")_$S(BGPD1:",AC",1:"")_"|||"

 I $P(BGPDVEX,U)=1 S BGPVALUE=BGPVALUE_"EXAM: "_$$DATE^BGP7UTL($P(BGPDVEX,U,2))_" "_$P(BGPDVEX,U,4)

 I $P(BGPDVDX,U)=1 S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":"; DX: ",1:"DX: ")_$$DATE^BGP7UTL($P(BGPDVDX,U,2))_" "_$P(BGPDVDX,U,4)

 I $P(BGPDVPED,U)=1 S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":"; PT ED: ",1:"PT ED: ")_$$DATE^BGP7UTL($P(BGPDVPED,U,2))_" "_$P(BGPDVPED,U,4)

 I $P(BGPDVCOU,U)=1 S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":"; COUNSEL ",1:"COUNSEL ")_$$DATE^BGP7UTL($P(BGPDVCOU,U,2))_" "_$P(BGPDVCOU,U,4)

 I BGPRTYPE'=1,$P(BGPDVREF,U)=1 S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":"; ",1:"")_$$DATE^BGP7UTL($P(BGPDVREF,U,2))_" "_$P(BGPDVREF,U,3)

 S BGPVALUD="" I BGPD4 S BGPVALUD="AC"_"|||" D

 .I $P(BGPDVEX,U)=1 S BGPVALUD=BGPVALUD_"EXAM: "_$$DATE^BGP7UTL($P(BGPDVEX,U,2))_" "_$P(BGPDVEX,U,4)

 .I $P(BGPDVDX,U)=1 S BGPVALUD=BGPVALUD_$S($P(BGPVALUD,"|||",2)]"":"; DX: ",1:"DX: ")_$$DATE^BGP7UTL($P(BGPDVDX,U,2))_" "_$P(BGPDVDX,U,4)

 .I $P(BGPDVPED,U)=1 S BGPVALUD=BGPVALUD_$S($P(BGPVALUD,"|||",2)]"":"; PT ED: ",1:"PT ED: ")_$$DATE^BGP7UTL($P(BGPDVPED,U,2))_" "_$P(BGPDVPED,U,4)

 .I $P(BGPDVCOU,U)=1 S BGPVALUD=BGPVALUD_$S($P(BGPVALUD,"|||",2)]"":"; COUNSEL ",1:"COUNSEL ")_$$DATE^BGP7UTL($P(BGPDVCOU,U,2))_" "_$P(BGPDVCOU,U,4)

 K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T

 Q

 ;

DVEX(P,BDATE,EDATE) ;EP

 S BGPLDV=""

 K BGPG S %=P_"^LAST EXAM 34;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")

 I $D(BGPG(1)) S BGPLDV=1_"^"_$P(BGPG(1),U)_"^IPV EXAM 34"_U_"Ex 34"_U_$$DATE^BGP7UTL($P(BGPG(1),U))

 S BGPC=0,BGPV=""

 S E=9999999-BDATE,D=9999999-EDATE-1_".99" F  S D=$O(^AMHREC("AE",P,D)) Q:D'=+D!($P(D,".")>E)!(BGPC)  S V=0 F  S V=$O(^AMHREC("AE",P,D,V)) Q:V'=+V!(BGPC)  D

 .S X=$P($G(^AMHREC(V,14)),U)

 .I X="" Q  ;no test

 .I $E(X)="U" Q  ;don't count Refusal here

 .I X="REF" Q

 .S BGPC=BGPC+1,BGPV="1^"_(9999999-D)_"^BH IPV EXAM"_U_" BH Ex 34"_U_$$DATE^BGP7UTL((9999999-D))

 I $P(BGPLDV,U,2)<$P(BGPC,U,2) S BGPLDV=BGPC

 Q BGPLDV

REFDV(P,BDATE,EDATE) ;EP

 ;add Refusal for exam 34

 S G=$$REFUSAL^BGP7UTL1(P,9999999.15,$O(^AUTTEXAM("C",34,0)),$$FMADD^XLFDT(EDATE,-365),EDATE)

 I $P(G,U)=1 Q 1_"^"_$P(G,U,2)_"^Refused Ex 34"

 S G=""

 S X=0 F  S X=$O(^AUPNPREF("AA",P,9999999.09,X)) Q:X'=+X!(G)  D

 .S H=""

 .I $P($P($G(^AUTTEDT(X,0)),U),"-")="DV"!($P($P($G(^AUTTEDT(X,0)),U),"-",2)="DV") S H=1

 .Q:H'=1

 .S D=0 F  S D=$O(^AUPNPREF("AA",P,9999999.09,X,D)) Q:D'=+D  D

 ..S Z=9999999-D

 ..Q:Z<BDATE

 ..Q:Z>EDATE

 ..S G=1_"^"_Z_"^Refused PtEd "_$P(^AUTTEDT(X,0),U)

 I $P(G,U,1)=1 Q G

 S BGPC=0 K BGPV

 S E=9999999-BDATE,D=9999999-EDATE-1_".99" F  S D=$O(^AMHREC("AE",P,D)) Q:D'=+D!($P(D,".")>E)!(BGPC)  S V=0 F  S V=$O(^AMHREC("AE",P,D,V)) Q:V'=+V!(BGPC)  D

 .S X=$P($G(^AMHREC(V,14)),U)

 .I X="" Q  ;no test

 .I X="U" S BGPC=1,BGPV=1_"^"_(9999999-D)_"^Refused BH UTS" Q

 .I X="REF" S BGPC=1,BGPV=1_"^"_(9999999-D)_"^Refused BH" Q

 .Q

 I BGPC Q BGPV

 Q ""

DVDX(P,BDATE,EDATE) ;EP

 I $G(P)="" Q ""

 G DVDX^BGP7D54

 ;

DVPED(P,BDATE,EDATE) ;EP

 NEW BGPG,Y,X,BGPLDV,E,D,T,S,BGPV,SN

 K BGPG

 S Y="BGPG(",BGPLDV=""

 S SN=$O(^BGPSNOMG("B","IPV/DV PATIENT ED",0))

 S X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)

 I '$D(BGPG(1)) G BHPED

 K BGPV S (X,D,E)=0,%="",T="" F  S X=$O(BGPG(X)) Q:X'=+X  D

 .S T=$P(^AUPNVPED(+$P(BGPG(X),U,4),0),U)

 .Q:'T

 .Q:'$D(^AUTTEDT(T,0))

 .S T=$P(^AUTTEDT(T,0),U,2)

 .I $P(T,"-",1)="DV"!($P(T,"-",2)="DV") S BGPLDV=1_"^"_$P(BGPG(X),U)_"^PED "_T_U_"PED "_T_U_$$DATE^BGP7UTL($P(BGPG(X),U)) Q

 .S S=$P(T,"-",1)

 .S S=$$ICDDX^BGP7UTL2(S)

 .I $P(S,U,1)'="-1",$$ICD^BGP7UTL2($P(S,U,1),$O(^ATXAX("B","BGP IPV/DV EDUC DXS",0)),9) S BGPLDV=1_"^"_$P(BGPG(X),U)_"^PED "_T_U_"PED "_T_U_$$DATE^BGP7UTL($P(BGPG(X),U)) Q

 .I $P(T,"-",1)]"",$D(^BGPSNOMG(SN,11,"B",$P(T,"-",1))) S BGPLDV=1_"^"_$P(BGPG(X),U)_"^PED "_T_U_"PED "_T_U_$$DATE^BGP7UTL($P(BGPG(X),U)) Q

 ;

BHPED ;

 K BGPV S BGPC="",T="" S E=9999999-BDATE,D=9999999-EDATE-1_".99" F  S D=$O(^AMHREC("AE",P,D)) Q:D'=+D!($P(D,".")>E)!(BGPC)  S V=0 F  S V=$O(^AMHREC("AE",P,D,V)) Q:V'=+V!(BGPC)  D

 .S X=0 F  S X=$O(^AMHREDU("AD",V,X)) Q:X'=+X!(BGPC)  S T=$P($G(^AMHREDU(X,0)),U) D

 ..Q:'T

 ..Q:'$D(^AUTTEDT(T,0))

 ..S T=$P(^AUTTEDT(T,0),U,2)

 ..I $P(T,"-")="DV"!($P(T,"-",2)="DV"),$P(BGPLDV,U,2)<(9999999-$P(D,".")) D

 ...S BGPLDV=1_"^"_(9999999-$P(D,"."))_"^BH PED "_T_U_"BH PED "_T_U_$$DATE^BGP7UTL((9999999-$P(D,".")))

 ..S S=$P(T,"-",1)

 ..S S=$$ICDDX^BGP7UTL2(S)

 ..I $P(S,U,1)'="-1",$$ICD^BGP7UTL2($P(S,U,1),$O(^ATXAX("B","BGP IPV/DV EDUC DXS",0)),9),$P(BGPLDV,U,2)<(9999999-$P(D,".")) D

 ...S BGPLDV=1_"^"_(9999999-$P(D,"."))_"^BH PED "_T_U_"BH PED "_T_U_$$DATE^BGP7UTL((9999999-$P(D,".")))

 ..I $P(T,"-",1)]"",$D(^BGPSNOMG(SN,11,"B",$P(T,"-",1))) S BGPLDV=1_"^"_(9999999-$P(D,"."))_"^BH PED "_T_U_"BH PED "_T_U_$$DATE^BGP7UTL((9999999-$P(D,"."))) Q

 Q BGPLDV  ;I BGPC Q BGPV

DV61(P,BDATE,EDATE) ;EP

 NEW BGPLDV,BGPG,Y,X,E

 S BGPLDV=""

 K BGPG S Y="BGPG(" S X=P_"^LAST DX [BGP IPV/DV COUNSELING ICDS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)

 I $D(BGPG(1)) S BGPLDV=1_"^"_$P(BGPG(1),U)_"^"_$P(BGPG(1),U,2)_U_"POV "_$P(BGPG(1),U,2)_U_$$DATE^BGP7UTL($P(BGPG(1),U))

 Q BGPLDV

ALPRC(P,BDATE,EDATE) ;EP

 S BGPG=$$LASTPRC^BGP7UTL1(P,"BGP ALCOHOL PROCEDURES",BDATE,EDATE)

 I BGPG Q 1_U_"Proc "_$P(BGPG,U,2)_U_$$DATE^BGP7UTL($P(BGPG,U,3))_U_$P(BGPG,U,3)

 Q ""

ALPED(P,BDATE,EDATE) ;EP

 NEW BGPG

 NEW X,Y,D,E,T,%,S,BGPLPED,SN

 S Y="BGPG(",BGPLPED=""

 S SN=$O(^BGPSNOMG("B","ALCOHOL SCREEN PATIENT ED",0))

 S X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)

 S (X,D,E)=0,%="",T="" F  S X=$O(BGPG(X)) Q:X'=+X  D

 .S T=$P(^AUPNVPED(+$P(BGPG(X),U,4),0),U)

 .Q:'T

 .Q:'$D(^AUTTEDT(T,0))

 .S T=$P(^AUTTEDT(T,0),U,2)

 .I $P(T,"-",1)="CD"!($P(T,"-",2)="CD")!($P(T,"-",1)="AOD")!($P(T,"-",2)="AOD"),$P(BGPLPED,U,4)<$P(BGPG(X),U) S BGPLPED=1_U_T_U_$$DATE^BGP7UTL($P(BGPG(X),U))_U_$P(BGPG(X),U)

 .S S=$P(T,"-",1)

 .S S=$$ICDDX^BGP7UTL2(S)

 .I $P(S,U,1)'="-1",$$ICD^BGP7UTL2($P(S,U,1),$O(^ATXAX("B","BGP ALCOHOL EDUC DXS",0)),9),$P(BGPLPED,U,4)<$P(BGPG(X),U,1) S BGPLPED=1_U_""_T_U_$$DATE^BGP7UTL($P(BGPG(X),U))_U_$P(BGPG(X),U)

 .I $P(T,"-",1)="99408"!($P(T,"-",1)="99409")!($P(T,"-",1)["G0396")!($P(T,"-",1)["G0397")!($P(T,"-")["H0049")!($P(T,"-")["H0050")!($P(T,"-")["3016F"),$P(BGPLPED,U,4)<$P(BGPG(X),U) D

 ..S BGPLPED=1_U_T_U_$$DATE^BGP7UTL($P(BGPG(X),U))_U_$P(BGPG(X),U)

 .I $P(T,"-")]"",$D(^BGPSNOMG(SN,11,"B",$P(T,"-"))),$P(BGPLPED,U,4)<$P(BGPG(X),U) D

 ..S BGPLPED=1_U_T_U_$$DATE^BGP7UTL($P(BGPG(X),U))_U_$P(BGPG(X),U)

ALMH S BGPC="",T="" S E=9999999-BDATE,D=9999999-EDATE-1_".99" F  S D=$O(^AMHREC("AE",P,D)) Q:D'=+D!($P(D,".")>E)!(BGPC)  S V=0 F  S V=$O(^AMHREC("AE",P,D,V)) Q:V'=+V!(BGPC)  D

 .S X=0 F  S X=$O(^AMHREDU("AD",V,X)) Q:X'=+X  S T=$P($G(^AMHREDU(X,0)),U) D

 ..Q:'T

 ..Q:'$D(^AUTTEDT(T,0))

 ..S T=$P(^AUTTEDT(T,0),U,2)

 ..I $P(T,"-",1)="CD"!($P(T,"-",2)="CD")!($P(T,"-",1)="AOD")!($P(T,"-",2)="AOD"),$P(BGPLPED,U,4)<(9999999-D) S BGPLPED=1_U_T_U_$$DATE^BGP7UTL((9999999-D))_U_(9999999-D)

 ..S S=$P(T,"-",1)

 ..S S=$$ICDDX^BGP7UTL2(S)

 ..I $P(S,U,1)'="-1",$$ICD^BGP7UTL2($P(S,U,1),$O(^ATXAX("B","BGP ALCOHOL EDUC DXS",0)),9),$P(BGPLPED,U,4)<(9999999-D) D

 ...S BGPLPED=1_U_T_U_$$DATE^BGP7UTL((9999999-D))_U_(9999999-D)

 ..I $P(T,"-",1)="99408"!($P(T,"-",1)="99409")!($P(T,"-",1)["G0396")!($P(T,"-",1)["G0397")!($P(T,"-")["H0049")!($P(T,"-")["H0050"),$P(BGPLPED,U,4)<(9999999-D) D

 ...S BGPLPED=1_U_T_U_$$DATE^BGP7UTL((9999999-D))_U_(9999999-D)

 ..I $P(T,"-")]"",$D(^BGPSNOMG(SN,11,"B",$P(T,"-"))),$P(BGPLPED,U,4)<(9999999-D) D

 ...S BGPLPED=1_U_T_U_$$DATE^BGP7UTL((9999999-D))_U_(9999999-D)

 Q BGPLPED

 ;

LASTHF(P,C,BDATE,EDATE) ;EP - get last factor in category C for patient P

 S C=$O(^AUTTHF("B",C,0))

 I '$G(C) Q ""

 S (H,D)=0 K O

 F  S H=$O(^AUTTHF("AC",C,H))  Q:'+H  D

 .Q:'$D(^AUPNVHF("AA",P,H))

 .S D="" F  S D=$O(^AUPNVHF("AA",P,H,D)) Q:D'=+D  D

 ..Q:(9999999-D)>EDATE  ;after time frame

 ..Q:(9999999-D)<BDATE  ;before time frame

 ..S O(D)=$O(^AUPNVHF("AA",P,H,D,""))

 .Q

 S D=$O(O(0))

 I D="" Q D

 Q $$VAL^XBDIQ1(9000010.23,O(D),.01)_"^"_$$DATE^BGP7UTL(9999999-D)_U_(9999999-D)

 ;

ALREF(P,BDATE,EDATE) ;EP

 ;add Refusal for exam 35

 S G=$$REFUSAL^BGP7UTL1(P,9999999.15,$O(^AUTTEXAM("C",35,0)),$$FMADD^XLFDT(EDATE,-365),EDATE)

 I $P(G,U)=1 Q 1_"^Refused Ex 35^"_$$DATE^BGP7UTL($P(G,U,2))_U_$P(G,U,2)

 Q ""

LOINC(A,B) ;

 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 ""

BGP7D5    ; IHS/CMI/LAB - measure calc ;

 +1       ;;17.1;IHS CLINICAL REPORTING;;MAY 10, 2017;Build 29

 +2       ;

I21       ;EP

 +1        SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0

 +2        SET (BGPDVEX,BGPDVDX,BGPDVPED,BGPDVREF)=""

 +3        IF 'BGPACTUP

               SET BGPSTOP=1

               QUIT 

 +4        IF BGPSEX'="F"

               SET BGPSTOP=1

               QUIT 

 +5        IF BGPAGEB<13

               SET BGPSTOP=1

               QUIT 

 +6        IF BGPACTUP

               SET BGPD3=1

 +7        IF BGPACTCL

               SET BGPD1=1

 +8       ;gpra denominator 15-40

           IF BGPAGEB>14

               IF BGPAGEB<41

                   IF BGPACTCL

                       SET BGPD2=1

 +9        IF BGPAGEB>13

               IF BGPAGEB<47

                   IF BGPACTUP

                       SET BGPD5=1

 +10       IF BGPAGEB>13

               IF BGPAGEB<47

                   IF BGPACTCL

                       SET BGPD4=1

DV        ;EP - called from elder care

 +1       ;EXAM ONLY

           SET BGPDVEX=$$DVEX(DFN,BGPBDATE,BGPEDATE)

           IF $PIECE(BGPDVEX,U)=1

               SET BGPN2=1

 +2       ;DX ONLY

           SET BGPDVDX=$$DVDX(DFN,BGPBDATE,BGPEDATE)

           IF $PIECE(BGPDVDX,U)=1

               SET BGPN3=1

 +3       ;W/O V61.11

           SET BGPDVPED=$$DVPED(DFN,BGPBDATE,BGPEDATE)

           IF $PIECE(BGPDVPED,U)=1

               SET BGPN4=1

               SET BGPN8=1

 +4       ;include in education for gpra

           SET BGPDVCOU=$$DV61(DFN,BGPBDATE,BGPEDATE)

           IF $PIECE(BGPDVCOU,U)=1

               SET BGPN4=1

 +5        IF BGPN2

               SET BGPN1=1

 +6        IF BGPN3

               SET BGPN1=1

 +7        IF BGPN4

               SET BGPN1=1

 +8       ;I 'BGPN1 S BGPDVREF=$$REFDV(DFN,BGP365,BGPEDATE) I $P(BGPDVREF,U)=1 S BGPN5=1

 +9       ;I BGPN5 S BGPN1=1

 +10      ;

           IF BGPN1

               IF 'BGPN5

                   SET BGPN6=1

 +11       IF BGPN2!(BGPN3)!(BGPDVCOU)

               SET BGPN7=1

 +12       SET BGPVALUE=$SELECT(BGPD3:"UP",1:"")_$SELECT(BGPD1:",AC",1:"")_"|||"

 +13       IF $PIECE(BGPDVEX,U)=1

               SET BGPVALUE=BGPVALUE_"EXAM: "_$$DATE^BGP7UTL($PIECE(BGPDVEX,U,2))_" "_$PIECE(BGPDVEX,U,4)

 +14       IF $PIECE(BGPDVDX,U)=1

               SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":"; DX: ",1:"DX: ")_$$DATE^BGP7UTL($PIECE(BGPDVDX,U,2))_" "_$PIECE(BGPDVDX,U,4)

 +15       IF $PIECE(BGPDVPED,U)=1

               SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":"; PT ED: ",1:"PT ED: ")_$$DATE^BGP7UTL($PIECE(BGPDVPED,U,2))_" "_$PIECE(BGPDVPED,U,4)

 +16       IF $PIECE(BGPDVCOU,U)=1

               SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":"; COUNSEL ",1:"COUNSEL ")_$$DATE^BGP7UTL($PIECE(BGPDVCOU,U,2))_" "_$PIECE(BGPDVCOU,U,4)

 +17       IF BGPRTYPE'=1

               IF $PIECE(BGPDVREF,U)=1

                   SET BGPVALUE=BGPVALUE_$SELECT($PIECE(BGPVALUE,"|||",2)]"":"; ",1:"")_$$DATE^BGP7UTL($PIECE(BGPDVREF,U,2))_" "_$PIECE(BGPDVREF,U,3)

 +18       SET BGPVALUD=""

           IF BGPD4

               SET BGPVALUD="AC"_"|||"

               Begin DoDot:1

 +19               IF $PIECE(BGPDVEX,U)=1

                       SET BGPVALUD=BGPVALUD_"EXAM: "_$$DATE^BGP7UTL($PIECE(BGPDVEX,U,2))_" "_$PIECE(BGPDVEX,U,4)

 +20               IF $PIECE(BGPDVDX,U)=1

                       SET BGPVALUD=BGPVALUD_$SELECT($PIECE(BGPVALUD,"|||",2)]"":"; DX: ",1:"DX: ")_$$DATE^BGP7UTL($PIECE(BGPDVDX,U,2))_" "_$PIECE(BGPDVDX,U,4)

 +21               IF $PIECE(BGPDVPED,U)=1

                       SET BGPVALUD=BGPVALUD_$SELECT($PIECE(BGPVALUD,"|||",2)]"":"; PT ED: ",1:"PT ED: ")_$$DATE^BGP7UTL($PIECE(BGPDVPED,U,2))_" "_$PIECE(BGPDVPED,U,4)

 +22               IF $PIECE(BGPDVCOU,U)=1

                       SET BGPVALUD=BGPVALUD_$SELECT($PIECE(BGPVALUD,"|||",2)]"":"; COUNSEL ",1:"COUNSEL ")_$$DATE^BGP7UTL($PIECE(BGPDVCOU,U,2))_" "_$PIECE(BGPDVCOU,U,4)

               End DoDot:1

 +23       KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T

 +24       QUIT 

 +25      ;

DVEX(P,BDATE,EDATE) ;EP

 +1        SET BGPLDV=""

 +2        KILL BGPG

           SET %=P_"^LAST EXAM 34;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)

           SET E=$$START1^APCLDF(%,"BGPG(")

 +3        IF $DATA(BGPG(1))

               SET BGPLDV=1_"^"_$PIECE(BGPG(1),U)_"^IPV EXAM 34"_U_"Ex 34"_U_$$DATE^BGP7UTL($PIECE(BGPG(1),U))

 +4        SET BGPC=0

           SET BGPV=""

 +5        SET E=9999999-BDATE

           SET D=9999999-EDATE-1_".99"

           FOR 

               SET D=$ORDER(^AMHREC("AE",P,D))

               IF D'=+D!($PIECE(D,".")>E)!(BGPC)

                   QUIT 

               SET V=0

               FOR 

                   SET V=$ORDER(^AMHREC("AE",P,D,V))

                   IF V'=+V!(BGPC)

                       QUIT 

                   Begin DoDot:1

 +6                    SET X=$PIECE($GET(^AMHREC(V,14)),U)

 +7       ;no test

                       IF X=""

                           QUIT 

 +8       ;don't count Refusal here

                       IF $EXTRACT(X)="U"

                           QUIT 

 +9                    IF X="REF"

                           QUIT 

 +10                   SET BGPC=BGPC+1

                       SET BGPV="1^"_(9999999-D)_"^BH IPV EXAM"_U_" BH Ex 34"_U_$$DATE^BGP7UTL((9999999-D))

                   End DoDot:1

 +11       IF $PIECE(BGPLDV,U,2)<$PIECE(BGPC,U,2)

               SET BGPLDV=BGPC

 +12       QUIT BGPLDV

REFDV(P,BDATE,EDATE) ;EP

 +1       ;add Refusal for exam 34

 +2        SET G=$$REFUSAL^BGP7UTL1(P,9999999.15,$ORDER(^AUTTEXAM("C",34,0)),$$FMADD^XLFDT(EDATE,-365),EDATE)

 +3        IF $PIECE(G,U)=1

               QUIT 1_"^"_$PIECE(G,U,2)_"^Refused Ex 34"

 +4        SET G=""

 +5        SET X=0

           FOR 

               SET X=$ORDER(^AUPNPREF("AA",P,9999999.09,X))

               IF X'=+X!(G)

                   QUIT 

               Begin DoDot:1

 +6                SET H=""

 +7                IF $PIECE($PIECE($GET(^AUTTEDT(X,0)),U),"-")="DV"!($PIECE($PIECE($GET(^AUTTEDT(X,0)),U),"-",2)="DV")

                       SET H=1

 +8                IF H'=1

                       QUIT 

 +9                SET D=0

                   FOR 

                       SET D=$ORDER(^AUPNPREF("AA",P,9999999.09,X,D))

                       IF D'=+D

                           QUIT 

                       Begin DoDot:2

 +10                       SET Z=9999999-D

 +11                       IF Z<BDATE

                               QUIT 

 +12                       IF Z>EDATE

                               QUIT 

 +13                       SET G=1_"^"_Z_"^Refused PtEd "_$PIECE(^AUTTEDT(X,0),U)

                       End DoDot:2

               End DoDot:1

 +14       IF $PIECE(G,U,1)=1

               QUIT G

 +15       SET BGPC=0

           KILL BGPV

 +16       SET E=9999999-BDATE

           SET D=9999999-EDATE-1_".99"

           FOR 

               SET D=$ORDER(^AMHREC("AE",P,D))

               IF D'=+D!($PIECE(D,".")>E)!(BGPC)

                   QUIT 

               SET V=0

               FOR 

                   SET V=$ORDER(^AMHREC("AE",P,D,V))

                   IF V'=+V!(BGPC)

                       QUIT 

                   Begin DoDot:1

 +17                   SET X=$PIECE($GET(^AMHREC(V,14)),U)

 +18      ;no test

                       IF X=""

                           QUIT 

 +19                   IF X="U"

                           SET BGPC=1

                           SET BGPV=1_"^"_(9999999-D)_"^Refused BH UTS"

                           QUIT 

 +20                   IF X="REF"

                           SET BGPC=1

                           SET BGPV=1_"^"_(9999999-D)_"^Refused BH"

                           QUIT 

 +21                   QUIT 

                   End DoDot:1

 +22       IF BGPC

               QUIT BGPV

 +23       QUIT ""

DVDX(P,BDATE,EDATE) ;EP

 +1        IF $GET(P)=""

               QUIT ""

 +2        GOTO DVDX^BGP7D54

 +3       ;

DVPED(P,BDATE,EDATE) ;EP

 +1        NEW BGPG,Y,X,BGPLDV,E,D,T,S,BGPV,SN

 +2        KILL BGPG

 +3        SET Y="BGPG("

           SET BGPLDV=""

 +4        SET SN=$ORDER(^BGPSNOMG("B","IPV/DV PATIENT ED",0))

 +5        SET X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)

           SET E=$$START1^APCLDF(X,Y)

 +6        IF '$DATA(BGPG(1))

               GOTO BHPED

 +7        KILL BGPV

           SET (X,D,E)=0

           SET %=""

           SET T=""

           FOR 

               SET X=$ORDER(BGPG(X))

               IF X'=+X

                   QUIT 

               Begin DoDot:1

 +8                SET T=$PIECE(^AUPNVPED(+$PIECE(BGPG(X),U,4),0),U)

 +9                IF 'T

                       QUIT 

 +10               IF '$DATA(^AUTTEDT(T,0))

                       QUIT 

 +11               SET T=$PIECE(^AUTTEDT(T,0),U,2)

 +12               IF $PIECE(T,"-",1)="DV"!($PIECE(T,"-",2)="DV")

                       SET BGPLDV=1_"^"_$PIECE(BGPG(X),U)_"^PED "_T_U_"PED "_T_U_$$DATE^BGP7UTL($PIECE(BGPG(X),U))

                       QUIT 

 +13               SET S=$PIECE(T,"-",1)

 +14               SET S=$$ICDDX^BGP7UTL2(S)

 +15               IF $PIECE(S,U,1)'="-1"

                       IF $$ICD^BGP7UTL2($PIECE(S,U,1),$ORDER(^ATXAX("B","BGP IPV/DV EDUC DXS",0)),9)

                           SET BGPLDV=1_"^"_$PIECE(BGPG(X),U)_"^PED "_T_U_"PED "_T_U_$$DATE^BGP7UTL($PIECE(BGPG(X),U))

                           QUIT 

 +16               IF $PIECE(T,"-",1)]""

                       IF $DATA(^BGPSNOMG(SN,11,"B",$PIECE(T,"-",1)))