BGP8D55.m

BGP8D55 ; IHS/CMI/LAB - measure calc ;

 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66

 ;

IASCRN ;EP

 S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11,BGPD12,BGPD13,BGPD14,BGPD15,BGPD16)=0

 I 'BGPACTUP S BGPSTOP=1 Q

 ;I 'BGPACTCB S BGPSTOP=1 Q

 I BGPAGEB<9 S BGPSTOP=1 Q

 I BGPAGEB>75 S BGPSTOP=1 Q

 I BGPACTCL,BGPAGEB>11 S BGPD1=1

 I BGPACTCL,BGPAGEB>8 S BGPD11=1

 I BGPACTUP,BGPAGEB>11 S BGPD9=1

 I BGPACTUP S BGPD10=1

 I BGPACTCB D

 .I BGPAGEB>11 S BGPD1=1

 .I BGPAGEB>11,BGPAGEB<20 S BGPD2=1

 .I BGPAGEB>19,BGPAGEB<25 S BGPD3=1

 .I BGPAGEB>24,BGPAGEB<35 S BGPD4=1

 .I BGPAGEB>34,BGPAGEB<45 S BGPD5=1

 .I BGPAGEB>44,BGPAGEB<55 S BGPD6=1

 .I BGPAGEB>54,BGPAGEB<76 S BGPD7=1

 .I BGPAGEB>8 S BGPD11=1

 .I BGPAGEB>8,BGPAGEB<12 S BGPD12=1

 I BGPSEX="F",BGPAGEB>13,BGPAGEB<47,BGPACTCL S BGPD8=1

 I '(BGPD1+BGPD2+BGPD3+BGPD4+BGPD5+BGPD6+BGPD7+BGPD8+BGPD9+BGPD10+BGPD11+BGPD12) S BGPSTOP=1 Q

 ;BGPN1 - had screen or dx

 ;BGPN2 - had educ

 ;BGPN3 - had screening

 ;BGPN4 - had positive screen

ALEP ;did they have screening?

 K BGPALL

 K ^TMP($J,"A")

 D ALSCRN(DFN,BGPBDATE,BGPEDATE,.BGPALL)

 I $D(BGPALL) S BGPN1=1,BGPN3=1

 ;if screened, is any screen positive

 S C=""

 S D=0 F  S D=$O(BGPALL(D)) Q:D'=+D!(C]"")  S Y=0 F  S Y=$O(BGPALL(D,Y)) Q:Y'=+Y!(C]"")  I $P(BGPALL(D,Y),U,5) S C=BGPALL(D,Y)

 I C]"" S BGPN4=1

 ;if no positive then take latest one

 I C="" S D=$O(BGPALL(0)) I D S Y=$O(BGPALL(D,0)) S C=BGPALL(D,Y)

 ;if didn't have screen then check dx/proc

 S BGPALDX="" I 'BGPN1 S BGPALDX=$$ALDX(DFN,BGPBDATE,BGPEDATE)

 I BGPALDX S BGPN1=1,BGPN6=1  ;BGPALDX

 ;set numerators

 S BGPN2=$$ALPED^BGP8D5(DFN,BGPBDATE,BGPEDATE)

 I BGPN1!(BGPN2) S BGPN5=1 ;HAD EITHER SCREENING OR EDUC G.B.7

 ;

 S BGPVALUE="UP"_$S(BGPD8:",AC",1:"")_$S(BGPD8&(BGPD1):",",1:"")_$S(BGPD1!(BGPD12):"AC+BH",1:"")_"|||"

 I $P(BGPN1,U)=1,BGPN3 S BGPVALUE=BGPVALUE_"SCREEN: "_$P(C,U,3)_" "_$P(C,U,2)_"-"_$S($P(C,U,6)]"":$P(C,U,6),1:"NO RESULT")

 I BGPN1,'BGPN3 S BGPVALUE=BGPVALUE_"DX/PROC: "_$P(BGPALDX,U,3)_" "_$P(BGPALDX,U,2)

 ;I $P(BGPN1,U)=1,BGPN3!(BGPN5) S BGPVALUE=BGPVALUE_"SCREEN: "_$P(C,U,3)_" "_$P(C,U,2)_"-"_$S($P(C,U,6)]"":$P(C,U,6),1:"NO RESULT")

 ;I $P(BGPN1,U)=1,'BGPN3!(BGPN5) S BGPVALUE=BGPVALUE_"DX/PROC: "_$P(BGPALDX,U,3)_" "_$P(BGPALDX,U,2)

 I $P(BGPN2,U)=1 S BGPVALUE=BGPVALUE_$S(BGPN1:"; ",1:""),BGPVALUE=BGPVALUE_"PT ED: "_$P(BGPN2,U,3)_" "_$P(BGPN2,U,2)

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

 Q

ALDX(P,BDATE,EDATE) ;EP

 NEW T,X,BGPC,E,Y,V,D,BGPLAL,BGPP,G,BGPG,BGPJ,BGPT

 S BGPLAL=""

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

 K BGPG

 S Y="BGPG("

 S X=P_"^LAST DX [BGP ALCOHOL DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)

 I $D(BGPG(1)) S BGPLAL=1_U_"DX "_$P(BGPG(1),U,2)_U_$$DATE^BGP8UTL($P(BGPG(1),U))_U_$P(BGPG(1),U)

 S BGPC=""

 ;go through BH record file and find up to 1 visits in date range

 S BGPT=$O(^ATXAX("B","BGP ALCOHOL DXS",0))

 I 'BGPT W !,BGPBOMB

 S BGPJ=$O(^ATXAX("B","BGP BH PC ALCOHOL DXS",0))

 I 'BGPJ W !,BGPBOMB

 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(^AMHRPRO("AD",V,X)) Q:X'=+X!(BGPC)  S BGPP=$P($G(^AMHRPRO(X,0)),U) D

 ..Q:'BGPP

 ..;S BGPP=$P($G(^AMHPROB(BGPP,0)),U)

 ..I $$ICD^BGP8UTL2(BGPP,BGPT,9) S BGPC=1_U_"BH POV "_$P(^AMHPROB(BGPP,0),U)_U_$$DATE^BGP8UTL((9999999-$P(D,".")))_U_(9999999-$P(D,".")) Q

 ..S BGPP=$P($G(^AMHPROB(BGPP,0)),U)

 ..Q:BGPP=""

 ..I $D(^ATXAX(BGPJ,21,"B",BGPP)) S BGPC=1_U_"BH POV "_BGPP_U_$$DATE^BGP8UTL((9999999-$P(D,".")))_U_(9999999-$P(D,".")) Q

 ..Q

 I $P(BGPLAL,U,4)<$P(BGPC,U,4) S BGPLAL=BGPC

 S G=""

 S Y=$$PLTAXID^BGP8DU(P,"BGP ALCOHOL DXS",BDATE,EDATE)

 I Y S G=1_U_$P(Y,U,2)_U_$$DATE^BGP8UTL($P(Y,U,3))_U_D

 I $P(BGPLAL,U,4)<$P(G,U,4) S BGPLAL=G

 S Y=$$IPLSNOID^BGP8DU(P,"PXRM BGP ETOH RELATED DX",BDATE,EDATE)

 I Y S G=1_U_$P(Y,U,2)_U_$$DATE^BGP8UTL($P(Y,U,3))_U_D

 I $P(BGPLAL,U,4)<$P(G,U,4) S BGPLAL=G

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

 .Q:$P(^AMHPPROB(X,0),U,12)'="A"

 .Q:$P(^AMHPPROB(X,0),U,3)>EDATE

 .Q:$P(^AMHPPROB(X,0),U,3)<BDATE

 .S Y=$P(^AMHPPROB(X,0),U)

 .I $$ICD^BGP8UTL2(Y,BGPT,9) S G=1_U_"BH PL "_Y_U_$$DATE^BGP8UTL($P(^AMHPPROB(X,0),U,3))_U_$P(^AMHPPROB(X,0),U,3) Q

 .S Y=$P($G(^AMHPROB(Y,0)),U)

 .I $D(^ATXAX(BGPJ,21,"B",Y)) S G=1_U_"BH PL "_Y_U_$$DATE^BGP8UTL($P(^AMHPPROB(X,0),U,3))_U_$P(^AMHPPROB(X,0),U,3) Q

 .Q

 I $P(BGPLAL,U,4)<$P(G,U,4) S BGPLAL=G

 ;

 K BGPG

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

 I $P(BGPLAL,U,4)<$P(BGPG,U,3) S BGPLAL=1_U_"Proc "_$P(BGPG,U,2)_U_$$DATE^BGP8UTL($P(BGPG,U,3))_U_$P(BGPG,U,3)

 Q BGPLAL

ALSCRN(P,BDATE,EDATE,BGPALL,SBI) ;EP - alcohol hf or screening pov IN REPORT PERIOD

 NEW BGPG,%,E,BGPSC,V,BGPC,T,F,D,R,BGPCT,BGPX,BGPV,BGPVD,BGPIVD

 K BGPALL

 S SBI=$G(SBI)

 S BGPSC=0

PCC ;check PCC first

 S BGPCT=$O(^ATXAX("B","BGP ALCOHOL SCREENING CPTS",0))

 K BGPG

 K ^TMP($J,"A")

 S R=$NA(^TMP($J,"A"))

 D ALLV^APCLAPIU(P,BDATE,EDATE,R)

 S BGPX=0 F  S BGPX=$O(^TMP($J,"A",BGPX)) Q:BGPX'=+BGPX  S BGPV=$P(^TMP($J,"A",BGPX),U,5) D

 .I SBI Q:$P(^AUPNVSIT(BGPV,0),U,7)'="A"  ;IF SBI ONLY AMBULATORY

 .S BGPVD=$$VD^APCLV(BGPV)

 .S BGPIVD=9999999-BGPVD

PCCEX .;

 .S E=0 F  S E=$O(^AUPNVXAM("AD",BGPV,E)) Q:E'=+E  D

 ..S I=$P($G(^AUPNVXAM(E,0)),U,1)

 ..Q:'I

 ..Q:$P($G(^AUTTEXAM(I,0)),U,2)'=35

 ..S BGPSC=BGPSC+1

 ..S R=$$VAL^XBDIQ1(9000010.13,E,.04)

 ..S BGPALL(BGPIVD,BGPSC)=1_"^Ex 35^"_$$DATE^BGP8UTL(BGPVD)_U_BGPVD_U_$S(R="POSITIVE":1,1:0)_U_R

PCCHF .;

 .S E=0 F  S E=$O(^AUPNVHF("AD",BGPV,E)) Q:E'=+E  D

 ..S I=$P($G(^AUPNVHF(E,0)),U,1)

 ..S I=$P($G(^AUTTHF(I,0)),U,1)

 ..I I'="CAGE 0/4",I'="CAGE 1/4",I'="CAGE 2/4",I'="CAGE 3/4",I'="CAGE 4/4" Q  ;cage only

 ..S R=$S(I["0":"NEGATIVE",1:"POSITIVE")

 ..S BGPSC=BGPSC+1,BGPALL(BGPIVD,BGPSC)=1_"^HF "_I_"^"_$$DATE^BGP8UTL(BGPVD)_U_BGPVD_U_$S(R="POSITIVE":1,1:0)_U_R

PCCDX .;

 .S E=0 F  S E=$O(^AUPNVPOV("AD",BGPV,E)) Q:E'=+E  D

 ..S I=$$VAL^XBDIQ1(9000010.07,E,.01)

 ..I '$$ICD^BGP8UTL2($$VALI^XBDIQ1(9000010.07,E,.01),$O(^ATXAX("B",$S('SBI:"BGP ALCOHOL SCREEN DXS",1:"BGP SCREEN FOR ALCOHOLISM DX"),0)),9) Q

 ..S BGPSC=BGPSC+1,BGPALL(BGPIVD,BGPSC)=1_U_"POV "_I_U_$$DATE^BGP8UTL(BGPVD)_U_BGPVD

PCCCPT .;

 .S E=0 F  S E=$O(^AUPNVCPT("AD",BGPV,E)) Q:E'=+E  D

 ..S I=$P($G(^AUPNVCPT(E,0)),U,1)

 ..Q:'I

 ..Q:'$$ICD^BGP8UTL2(I,BGPCT,1)

 ..S J=$P(^ICPT(I,0),U,1)

 ..S R=$S($$ICD^BGP8UTL2(I,$O(^ATXAX("B","BGP ALCOHOL POSITIVE SCRN CPTS",0)),1):"POSITIVE",1:"")

 ..S BGPSC=BGPSC+1

 ..S BGPALL(BGPIVD,BGPSC)=1_"^CPT "_J_"^"_$$DATE^BGP8UTL(BGPVD)_U_BGPVD_U_$S(R="POSITIVE":1,1:0)_U_R

PCCMEAS .;now add in v measurements

 .S E=0 F  S E=$O(^AUPNVMSR("AD",BGPV,E)) Q:E'=+E  D

 ..S I=$$VAL^XBDIQ1(9000010.01,E,.01)

 ..I I'="AUDT",I'="AUDC",I'="CRFT" Q

 ..S BGPSC=BGPSC+1

 ..S R=$$VAL^XBDIQ1(9000010.01,E,.04)

 ..S T=""

 ..I I="AUDT",R>7 S T=1

 ..I I="AUDC",$P(^DPT(P,0),U,2)="M",R>3 S T=1

 ..I I="AUDC",$P(^DPT(P,0),U,2)="F",R>2 S T=1

 ..I I="CRFT",R>1,R<7 S T=1

 ..S BGPALL(BGPIVD,BGPSC)=1_"^Meas "_I_"^"_$$DATE^BGP8UTL(BGPVD)_U_BGPVD_U_T_U_$S(T:"POSITIVE: "_R,1:"NEGATIVE: "_R)

BH ;CHECK BH VISITS

 S BGPC="",T="",F=""

 S E=9999999-BDATE,D=9999999-EDATE-1_".99"

 F  S D=$O(^AMHREC("AE",P,D)) Q:D'=+D!($P(D,".")>E)  S V=0 F  S V=$O(^AMHREC("AE",P,D,V)) Q:V'=+V  D

BHEX .;

 .I $G(SBI) Q:$$VAL^XBDIQ1(9002011,V,.07)'="OUTPATIENT"

 .S BGPVD=9999999-$P(D,"."),BGPIVD=$P(D,".")

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

 .I X="P"!(X="N") D

 ..S R=$S(X="P":"POSITIVE",1:"NEGATIVE")

 ..S BGPSC=BGPSC+1

 ..S BGPALL(BGPIVD,BGPSC)=1_"^BH Ex^"_$$DATE^BGP8UTL(BGPVD)_U_BGPVD_U_$S(R="POSITIVE":1,1:0)_U_R

BHHF .;

 .S X=0 F  S X=$O(^AMHRHF("AD",V,X)) Q:X'=+X  D

 ..S I=$P($G(^AMHRHF(X,0)),U,1)

 ..Q:'I

 ..S I=$P($G(^AUTTHF(I,0)),U,1)

 ..I I'="CAGE 0/4",I'="CAGE 1/4",I'="CAGE 2/4",I'="CAGE 3/4",I'="CAGE 4/4" Q  ;cage only

 ..S R=$S(I["0":"NEGATIVE",1:"POSITIVE")

 ..S BGPSC=BGPSC+1,BGPALL(BGPIVD,BGPSC)=1_"^BH HF "_I_"^"_$$DATE^BGP8UTL(BGPVD)_U_BGPVD_U_$S(R="POSITIVE":1,1:0)_U_R

 ..Q

BHDX .;

 .S X=0 F  S X=$O(^AMHRPRO("AD",V,X)) Q:X'=+X  D

 ..S I=$$VAL^XBDIQ1(9002011.01,X,.01)

 ..I '$$ICD^BGP8UTL2($$VALI^XBDIQ1(9002011.01,X,.01),$O(^ATXAX("B",$S('SBI:"BGP ALCOHOL SCREEN DXS",1:"BGP SCREEN FOR ALCOHOLISM DX"),0)),9),I'="29.1" Q

 ..S BGPSC=BGPSC+1,BGPALL(BGPIVD,BGPSC)=1_U_"BH POV "_I_U_$$DATE^BGP8UTL(BGPVD)_U_BGPVD

 ..Q

BHMEAS .;

 .S X=0 F  S X=$O(^AMHRMSR("AD",V,X)) Q:X'=+X  D

 ..S I=$$VAL^XBDIQ1(9002011.12,X,.01)

 ..I I'="AUDT",I'="AUDC",I'="CRFT" Q

 ..S BGPSC=BGPSC+1

 ..S R=$$VAL^XBDIQ1(9002011.12,X,.04)

 ..S T=""

 ..I I="AUDT",R>7 S T=1

 ..I I="AUDC",$P(^DPT(P,0),U,2)="M",R>3 S T=1

 ..I I="AUDC",$P(^DPT(P,0),U,2)="F",R>2 S T=1

 ..I I="CRFT",R>1,R<7 S T=1

 ..S BGPALL(BGPIVD,BGPSC)=1_"^BH Meas "_I_"^"_$$DATE^BGP8UTL(BGPVD)_U_BGPVD_U_T_U_$S(T=1:"POSITIVE: "_R,1:"NEGATIVE")

BHCPT .;now add in CPT codes

 .S X=0 F  S X=$O(^AMHRPROC("AD",V,X)) Q:X'=+X  D

 ..S I=$P($G(^AMHRPROC(X,0)),U,1)

 ..Q:'I

 ..Q:'$$ICD^BGP8UTL2(I,BGPCT,1)

 ..S J=$P(^ICPT(I,0),U,1)

 ..S R=$S($$ICD^BGP8UTL2(I,$O(^ATXAX("B","BGP ALCOHOL POSITIVE SCRN CPTS",0)),1):"POSITIVE",1:"")

 ..S BGPSC=BGPSC+1

 ..S BGPALL(BGPIVD,BGPSC)=1_"^BH CPT "_J_"^"_$$DATE^BGP8UTL(BGPVD)_U_BGPVD_U_$S(R="POSITIVE":1,1:0)_U_R

 ..Q

 .Q

 Q

BGP8D55   ; IHS/CMI/LAB - measure calc ;

 +1       ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66

 +2       ;

IASCRN    ;EP

 +1        SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11,BGPD12,BGPD13,BGPD14,BGPD15,BGPD16)=0

 +2        IF 'BGPACTUP

               SET BGPSTOP=1

               QUIT 

 +3       ;I 'BGPACTCB S BGPSTOP=1 Q

 +4        IF BGPAGEB<9

               SET BGPSTOP=1

               QUIT 

 +5        IF BGPAGEB>75

               SET BGPSTOP=1

               QUIT 

 +6        IF BGPACTCL

               IF BGPAGEB>11

                   SET BGPD1=1

 +7        IF BGPACTCL

               IF BGPAGEB>8

                   SET BGPD11=1

 +8        IF BGPACTUP

               IF BGPAGEB>11

                   SET BGPD9=1

 +9        IF BGPACTUP

               SET BGPD10=1

 +10       IF BGPACTCB

               Begin DoDot:1

 +11               IF BGPAGEB>11

                       SET BGPD1=1

 +12               IF BGPAGEB>11

                       IF BGPAGEB<20

                           SET BGPD2=1

 +13               IF BGPAGEB>19

                       IF BGPAGEB<25

                           SET BGPD3=1

 +14               IF BGPAGEB>24

                       IF BGPAGEB<35

                           SET BGPD4=1

 +15               IF BGPAGEB>34

                       IF BGPAGEB<45

                           SET BGPD5=1

 +16               IF BGPAGEB>44

                       IF BGPAGEB<55

                           SET BGPD6=1

 +17               IF BGPAGEB>54

                       IF BGPAGEB<76

                           SET BGPD7=1

 +18               IF BGPAGEB>8

                       SET BGPD11=1

 +19               IF BGPAGEB>8

                       IF BGPAGEB<12

                           SET BGPD12=1

               End DoDot:1

 +20       IF BGPSEX="F"

               IF BGPAGEB>13

                   IF BGPAGEB<47

                       IF BGPACTCL

                           SET BGPD8=1

 +21       IF '(BGPD1+BGPD2+BGPD3+BGPD4+BGPD5+BGPD6+BGPD7+BGPD8+BGPD9+BGPD10+BGPD11+BGPD12)

               SET BGPSTOP=1

               QUIT 

 +22      ;BGPN1 - had screen or dx

 +23      ;BGPN2 - had educ

 +24      ;BGPN3 - had screening

 +25      ;BGPN4 - had positive screen

ALEP      ;did they have screening?

 +1        KILL BGPALL

 +2        KILL ^TMP($JOB,"A")

 +3        DO ALSCRN(DFN,BGPBDATE,BGPEDATE,.BGPALL)

 +4        IF $DATA(BGPALL)

               SET BGPN1=1

               SET BGPN3=1

 +5       ;if screened, is any screen positive

 +6        SET C=""

 +7        SET D=0

           FOR 

               SET D=$ORDER(BGPALL(D))

               IF D'=+D!(C]"")

                   QUIT 

               SET Y=0

               FOR 

                   SET Y=$ORDER(BGPALL(D,Y))

                   IF Y'=+Y!(C]"")

                       QUIT 

                   IF $PIECE(BGPALL(D,Y),U,5)

                       SET C=BGPALL(D,Y)

 +8        IF C]""

               SET BGPN4=1

 +9       ;if no positive then take latest one

 +10       IF C=""

               SET D=$ORDER(BGPALL(0))

               IF D

                   SET Y=$ORDER(BGPALL(D,0))

                   SET C=BGPALL(D,Y)

 +11      ;if didn't have screen then check dx/proc

 +12       SET BGPALDX=""

           IF 'BGPN1

               SET BGPALDX=$$ALDX(DFN,BGPBDATE,BGPEDATE)

 +13      ;BGPALDX

           IF BGPALDX

               SET BGPN1=1

               SET BGPN6=1

 +14      ;set numerators

 +15       SET BGPN2=$$ALPED^BGP8D5(DFN,BGPBDATE,BGPEDATE)

 +16      ;HAD EITHER SCREENING OR EDUC G.B.7

           IF BGPN1!(BGPN2)

               SET BGPN5=1

 +17      ;

 +18       SET BGPVALUE="UP"_$SELECT(BGPD8:",AC",1:"")_$SELECT(BGPD8&(BGPD1):",",1:"")_$SELECT(BGPD1!(BGPD12):"AC+BH",1:"")_"|||"

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

               IF BGPN3

                   SET BGPVALUE=BGPVALUE_"SCREEN: "_$PIECE(C,U,3)_" "_$PIECE(C,U,2)_"-"_$SELECT($PIECE(C,U,6)]"":$PIECE(C,U,6),1:"NO RESULT")

 +20       IF BGPN1

               IF 'BGPN3

                   SET BGPVALUE=BGPVALUE_"DX/PROC: "_$PIECE(BGPALDX,U,3)_" "_$PIECE(BGPALDX,U,2)

 +21      ;I $P(BGPN1,U)=1,BGPN3!(BGPN5) S BGPVALUE=BGPVALUE_"SCREEN: "_$P(C,U,3)_" "_$P(C,U,2)_"-"_$S($P(C,U,6)]"":$P(C,U,6),1:"NO RESULT")

 +22      ;I $P(BGPN1,U)=1,'BGPN3!(BGPN5) S BGPVALUE=BGPVALUE_"DX/PROC: "_$P(BGPALDX,U,3)_" "_$P(BGPALDX,U,2)

 +23       IF $PIECE(BGPN2,U)=1

               SET BGPVALUE=BGPVALUE_$SELECT(BGPN1:"; ",1:"")

               SET BGPVALUE=BGPVALUE_"PT ED: "_$PIECE(BGPN2,U,3)_" "_$PIECE(BGPN2,U,2)

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

 +25       QUIT 

ALDX(P,BDATE,EDATE) ;EP

 +1        NEW T,X,BGPC,E,Y,V,D,BGPLAL,BGPP,G,BGPG,BGPJ,BGPT

 +2        SET BGPLAL=""

 +3        IF $GET(P)=""

               QUIT ""

 +4        KILL BGPG

 +5        SET Y="BGPG("

 +6        SET X=P_"^LAST DX [BGP ALCOHOL DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)

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

 +7        IF $DATA(BGPG(1))

               SET BGPLAL=1_U_"DX "_$PIECE(BGPG(1),U,2)_U_$$DATE^BGP8UTL($PIECE(BGPG(1),U))_U_$PIECE(BGPG(1),U)

 +8        SET BGPC=""

 +9       ;go through BH record file and find up to 1 visits in date range

 +10       SET BGPT=$ORDER(^ATXAX("B","BGP ALCOHOL DXS",0))

 +11       IF 'BGPT

               WRITE !,BGPBOMB

 +12       SET BGPJ=$ORDER(^ATXAX("B","BGP BH PC ALCOHOL DXS",0))

 +13       IF 'BGPJ

               WRITE !,BGPBOMB

 +14       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

 +15                   SET X=0

                       FOR 

                           SET X=$ORDER(^AMHRPRO("AD",V,X))

                           IF X'=+X!(BGPC)

                               QUIT 

                           SET BGPP=$PIECE($GET(^AMHRPRO(X,0)),U)

                           Begin DoDot:2

 +16                           IF 'BGPP

                                   QUIT 

 +17      ;S BGPP=$P($G(^AMHPROB(BGPP,0)),U)

 +18                           IF $$ICD^BGP8UTL2(BGPP,BGPT,9)

                                   SET BGPC=1_U_"BH POV "_$PIECE(^AMHPROB(BGPP,0),U)_U_$$DATE^BGP8UTL((9999999-$PIECE(D,".")))_U_(9999999-$PIECE(D,"."))

                                   QUIT 

 +19                           SET BGPP=$PIECE($GET(^AMHPROB(BGPP,0)),U)

 +20                           IF BGPP=""

                                   QUIT 

 +21                           IF $DATA(^ATXAX(BGPJ,21,"B",BGPP))

                                   SET BGPC=1_U_"BH POV "_BGPP_U_$$DATE^BGP8UTL((9999999-$PIECE(D,".")))_U_(9999999-$PIECE(D,"."))

                                   QUIT 

 +22                           QUIT 

                           End DoDot:2

                   End DoDot:1

 +23       IF $PIECE(BGPLAL,U,4)<$PIECE(BGPC,U,4)

               SET BGPLAL=BGPC

 +24       SET G=""

 +25       SET Y=$$PLTAXID^BGP8DU(P,"BGP ALCOHOL DXS",BDATE,EDATE)

 +26       IF Y

               SET G=1_U_$PIECE(Y,U,2)_U_$$DATE^BGP8UTL($PIECE(Y,U,3))_U_D

 +27       IF $PIECE(BGPLAL,U,4)<$PIECE(G,U,4)

               SET BGPLAL=G

 +28       SET Y=$$IPLSNOID^BGP8DU(P,"PXRM BGP ETOH RELATED DX",BDATE,EDATE)

 +29       IF Y

               SET G=1_U_$PIECE(Y,U,2)_U_$$DATE^BGP8UTL($PIECE(Y,U,3))_U_D

 +30       IF $PIECE(BGPLAL,U,4)<$PIECE(G,U,4)

               SET BGPLAL=G

 +31       SET (X,G)=0

           FOR 

               SET X=$ORDER(^AMHPPROB("AC",P,X))

               IF X'=+X!(G)

                   QUIT 

               Begin DoDot:1

 +32               IF $PIECE(^AMHPPROB(X,0),U,12)'="A"

                       QUIT 

 +33               IF $PIECE(^AMHPPROB(X,0),U,3)>EDATE

                       QUIT 

 +34               IF $PIECE(^AMHPPROB(X,0),U,3)<BDATE

                       QUIT 

 +35               SET Y=$PIECE(^AMHPPROB(X,0),U)

 +36               IF $$ICD^BGP8UTL2(Y,BGPT,9)

                       SET G=1_U_"BH PL "_Y_U_$$DATE^BGP8UTL($PIECE(^AMHPPROB(X,0),U,3))_U_$PIECE(^AMHPPROB(X,0),U,3)

                       QUIT 

 +37               SET Y=$PIECE($GET(^AMHPROB(Y,0)),U)

 +38               IF $DATA(^ATXAX(BGPJ,21,"B",Y))

                       SET G=1_U_"BH PL "_Y_U_$$DATE^BGP8UTL($PIECE(^AMHPPROB(X,0),U,3))_U_$PIECE(^AMHPPROB(X,0),U,3)

                       QUIT 

 +39               QUIT 

               End DoDot:1

 +40       IF $PIECE(BGPLAL,U,4)<$PIECE(G,U,4)

               SET BGPLAL=G

 +41      ;

 +42       KILL BGPG

 +43       SET BGPG=$$LASTPRC^BGP8UTL1(P,"BGP ALCOHOL PROCEDURES",BDATE,EDATE)

 +44       IF $PIECE(BGPLAL,U,4)<$PIECE(BGPG,U,3)

               SET BGPLAL=1_U_"Proc "_$PIECE(BGPG,U,2)_U_$$DATE^BGP8UTL($PIECE(BGPG,U,3))_U_$PIECE(BGPG,U,3)

 +45       QUIT BGPLAL

ALSCRN(P,BDATE,EDATE,BGPALL,SBI) ;EP - alcohol hf or screening pov IN REPORT PERIOD

 +1        NEW BGPG,%,E,BGPSC,V,BGPC,T,F,D,R,BGPCT,BGPX,BGPV,BGPVD,BGPIVD

 +2        KILL BGPALL

 +3        SET SBI=$GET(SBI)

 +4        SET BGPSC=0

PCC       ;check PCC first

 +1        SET BGPCT=$ORDER(^ATXAX("B","BGP ALCOHOL SCREENING CPTS",0))

 +2        KILL BGPG

 +3        KILL ^TMP($JOB,"A")

 +4        SET R=$NAME(^TMP($JOB,"A"))

 +5        DO ALLV^APCLAPIU(P,BDATE,EDATE,R)

 +6        SET BGPX=0

           FOR 

               SET BGPX=$ORDER(^TMP($JOB,"A",BGPX))

               IF BGPX'=+BGPX

                   QUIT 

               SET BGPV=$PIECE(^TMP($JOB,"A",BGPX),U,5)

               Begin DoDot:1

 +7       ;IF SBI ONLY AMBULATORY

                   IF SBI

                       IF $PIECE(^AUPNVSIT(BGPV,0),U,7)'="A"

                           QUIT 

 +8                SET BGPVD=$$VD^APCLV(BGPV)

 +9                SET BGPIVD=9999999-BGPVD

PCCEX     ;

 +1                SET E=0

                   FOR 

                       SET E=$ORDER(^AUPNVXAM("AD",BGPV,E))

                       IF E'=+E

                           QUIT 

                       Begin DoDot:2

 +2                        SET I=$PIECE($GET(^AUPNVXAM(E,0)),U,1)

 +3                        IF 'I

                               QUIT 

 +4                        IF $PIECE($GET(^AUTTEXAM(I,0)),U,2)'=35

                               QUIT 

 +5                        SET BGPSC=BGPSC+1

 +6                        SET R=$$VAL^XBDIQ1(9000010.13,E,.04)

 +7                        SET BGPALL(BGPIVD,BGPSC)=1_"^Ex 35^"_$$DATE^BGP8UTL(BGPVD)_U_BGPVD_U_$SELECT(R="POSITIVE":1,1:0)_U_R

                       End DoDot:2

PCCHF     ;

 +1                SET E=0

                   FOR 

                       SET E=$ORDER(^AUPNVHF("AD",BGPV,E))

                       IF E'=+E

                           QUIT 

                       Begin DoDot:2

 +2                        SET I=$PIECE($GET(^AUPNVHF(E,0)),U,1)

 +3                        SET I=$PIECE($GET(^AUTTHF(I,0)),U,1)

 +4       ;cage only

                           IF I'="CAGE 0/4"

                               IF I'="CAGE 1/4"

                                   IF I'="CAGE 2/4"

                                       IF I'="CAGE 3/4"

                                           IF I'="CAGE 4/4"

                                               QUIT 

 +5                        SET R=$SELECT(I["0":"NEGATIVE",1:"POSITIVE")

 +6                        SET BGPSC=BGPSC+1