BGP4D55 ; IHS/CMI/LAB - measure calc ;
;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
;
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<12 S BGPSTOP=1 Q
I BGPAGEB>75 S BGPSTOP=1 Q
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 BGPSEX="F",BGPAGEB>14,BGPAGEB<45 S BGPD8=1
;BGPN1 - had screen or dx
;BGPN2 - had educ
;BGPN3 - had screening
;BGPN4 - had positive screen
;did they have screening?
K BGPALL
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 ;BGPALDX
;set numerators
S BGPN2=$$ALPED^BGP4D5(DFN,BGPBDATE,BGPEDATE)
;
S BGPVALUE=$S(BGPD1:"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 $P(BGPN1,U)=1,'BGPN3 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)
;I $P(BGPN5,U)=1 S BGPVALUE=BGPVALUE_$P(BGPN5,U,2)_" "_$P(BGPN5,U,3)
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^BGP4UTL($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^BGP4UTL2(BGPP,BGPT,9) S BGPC=1_U_"BH POV "_$P(^AMHPROB(BGPP,0),U)_U_$$DATE^BGP4UTL((9999999-$P(D,".")))_U_(9999999-$P(D,".")) Q
..S BGPP=$P($G(^AMHPROB(BGPP,0)),U)
..I $D(^ATXAX(BGPJ,21,"B",BGPP)) S BGPC=1_U_"BH POV "_BGPP_U_$$DATE^BGP4UTL((9999999-$P(D,".")))_U_(9999999-$P(D,".")) Q
..Q
I $P(BGPLAL,U,4)<$P(BGPC,U,4) S BGPLAL=BGPC
;now check pcc and bh problem lists
S (X,G)=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G) D
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.Q:$P(^AUPNPROB(X,0),U,12)="I"
.Q:$P(^AUPNPROB(X,0),U,3)>EDATE
.Q:$P(^AUPNPROB(X,0),U,3)<BDATE
.S Y=$P(^AUPNPROB(X,0),U)
.Q:'$$ICD^BGP4UTL2(Y,BGPT,9)
.S D=$P(^AUPNPROB(X,0),U,3)
.S G=1_U_"PROB LIST "_$P($$ICDDX^BGP4UTL2(Y),U,2)_U_$$DATE^BGP4UTL((D))_U_(D)
.Q
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^BGP4UTL2(Y,BGPT,9) S G=1_U_"BH PL "_Y_U_$$DATE^BGP4UTL($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^BGP4UTL($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^BGP4UTL1(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^BGP4UTL($P(BGPG,U,3))_U_$P(BGPG,U,3)
Q BGPLAL
ALSCRN(P,BDATE,EDATE,BGPALL) ;EP - alcohol hf or screening pov
NEW BGPG,%,E,BGPSC,V,BGPC,T,F,D,R,BGPCT,BGPX,BGPV,BGPVD,BGPIVD
K BGPALL
S BGPSC=0
PCC ;check PCC first
S BGPCT=$O(^ATXAX("B","BGP ALCOHOL SCREENING CPTS",0))
K BGPG
D ALLV^APCLAPIU(P,BDATE,EDATE,"BGPG")
S BGPX=0 F S BGPX=$O(BGPG(BGPX)) Q:BGPX'=+BGPX S BGPV=$P(BGPG(BGPX),U,5) D
.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^BGP4UTL(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^BGP4UTL(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^BGP4UTL2($$VALI^XBDIQ1(9000010.07,E,.01),$O(^ATXAX("B","BGP ALCOHOL SCREEN DXS",0)),9) Q
..S BGPSC=BGPSC+1,BGPALL(BGPIVD,BGPSC)=1_U_"POV "_I_U_$$DATE^BGP4UTL(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^BGP4UTL2(I,BGPCT,1)
..S J=$P(^ICPT(I,0),U,1)
..S R=$S($$ICD^BGP4UTL2(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^BGP4UTL(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(^AUPNVCPT("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(BGPVD,BGPSC)=1_"^Meas "_I_"^"_$$DATE^BGP4UTL(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 .;
.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^BGP4UTL(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^BGP4UTL(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^BGP4UTL2($$VALI^XBDIQ1(9002011.01,X,.01),$O(^ATXAX("B","BGP ALCOHOL SCREEN DXS",0)),9),I'="29.1" Q
..S BGPSC=BGPSC+1,BGPALL(BGPIVD,BGPSC)=1_U_"BH POV "_I_U_$$DATE^BGP4UTL(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^BGP4UTL(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(^AUPNVCPT(X,0)),U,1)
..Q:'I
..Q:'$$ICD^BGP4UTL2(I,BGPCT,1)
..S J=$P(^ICPT(I,0),U,1)
..S R=$S($$ICD^BGP4UTL2(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^BGP4UTL(BGPVD)_U_BGPVD_U_$S(R="POSITIVE":1,1:0)_U_R
..Q
.Q
Q
BGP4D55 ; IHS/CMI/LAB - measure calc ;
+1 ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
+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 IF 'BGPACTCB
SET BGPSTOP=1
QUIT
+4 IF BGPAGEB<12
SET BGPSTOP=1
QUIT
+5 IF BGPAGEB>75
SET BGPSTOP=1
QUIT
+6 SET BGPD1=1
+7 IF BGPAGEB>11
IF BGPAGEB<20
SET BGPD2=1
+8 IF BGPAGEB>19
IF BGPAGEB<25
SET BGPD3=1
+9 IF BGPAGEB>24
IF BGPAGEB<35
SET BGPD4=1
+10 IF BGPAGEB>34
IF BGPAGEB<45
SET BGPD5=1
+11 IF BGPAGEB>44
IF BGPAGEB<55
SET BGPD6=1
+12 IF BGPAGEB>54
IF BGPAGEB<76
SET BGPD7=1
+13 IF BGPSEX="F"
IF BGPAGEB>14
IF BGPAGEB<45
SET BGPD8=1
+14 ;BGPN1 - had screen or dx
+15 ;BGPN2 - had educ
+16 ;BGPN3 - had screening
+17 ;BGPN4 - had positive screen
+18 ;did they have screening?
+19 KILL BGPALL
+20 DO ALSCRN(DFN,BGPBDATE,BGPEDATE,.BGPALL)
+21 IF $DATA(BGPALL)
SET BGPN1=1
SET BGPN3=1
+22 ;if screened, is any screen positive
+23 SET C=""
+24 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)
+25 IF C]""
SET BGPN4=1
+26 ;if no positive then take latest one
+27 IF C=""
SET D=$ORDER(BGPALL(0))
IF D
SET Y=$ORDER(BGPALL(D,0))
SET C=BGPALL(D,Y)
+28 ;if didn't have screen then check dx/proc
+29 SET BGPALDX=""
IF 'BGPN1
SET BGPALDX=$$ALDX(DFN,BGPBDATE,BGPEDATE)
+30 ;BGPALDX
IF BGPALDX
SET BGPN1=1
+31 ;set numerators
+32 SET BGPN2=$$ALPED^BGP4D5(DFN,BGPBDATE,BGPEDATE)
+33 ;
+34 SET BGPVALUE=$SELECT(BGPD1:"AC+BH",1:"")_"|||"
+35 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")
+36 IF $PIECE(BGPN1,U)=1
IF 'BGPN3
SET BGPVALUE=BGPVALUE_"DX/PROC: "_$PIECE(BGPALDX,U,3)_" "_$PIECE(BGPALDX,U,2)
+37 IF $PIECE(BGPN2,U)=1
SET BGPVALUE=BGPVALUE_$SELECT(BGPN1:"; ",1:"")
SET BGPVALUE=BGPVALUE_"PT ED: "_$PIECE(BGPN2,U,3)_" "_$PIECE(BGPN2,U,2)
+38 ;I $P(BGPN5,U)=1 S BGPVALUE=BGPVALUE_$P(BGPN5,U,2)_" "_$P(BGPN5,U,3)
+39 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T,BGPALL
+40 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^BGP4UTL($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^BGP4UTL2(BGPP,BGPT,9)
SET BGPC=1_U_"BH POV "_$PIECE(^AMHPROB(BGPP,0),U)_U_$$DATE^BGP4UTL((9999999-$PIECE(D,".")))_U_(9999999-$PIECE(D,"."))
QUIT
+19 SET BGPP=$PIECE($GET(^AMHPROB(BGPP,0)),U)
+20 IF $DATA(^ATXAX(BGPJ,21,"B",BGPP))
SET BGPC=1_U_"BH POV "_BGPP_U_$$DATE^BGP4UTL((9999999-$PIECE(D,".")))_U_(9999999-$PIECE(D,"."))
QUIT
+21 QUIT
End DoDot:2
End DoDot:1
+22 IF $PIECE(BGPLAL,U,4)<$PIECE(BGPC,U,4)
SET BGPLAL=BGPC
+23 ;now check pcc and bh problem lists
+24 SET (X,G)=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+25 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+26 IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+27 IF $PIECE(^AUPNPROB(X,0),U,3)>EDATE
QUIT
+28 IF $PIECE(^AUPNPROB(X,0),U,3)<BDATE
QUIT
+29 SET Y=$PIECE(^AUPNPROB(X,0),U)
+30 IF '$$ICD^BGP4UTL2(Y,BGPT,9)
QUIT
+31 SET D=$PIECE(^AUPNPROB(X,0),U,3)
+32 SET G=1_U_"PROB LIST "_$PIECE($$ICDDX^BGP4UTL2(Y),U,2)_U_$$DATE^BGP4UTL((D))_U_(D)
+33 QUIT
End DoDot:1
+34 IF $PIECE(BGPLAL,U,4)<$PIECE(G,U,4)
SET BGPLAL=G
+35 SET (X,G)=0
FOR
SET X=$ORDER(^AMHPPROB("AC",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+36 IF $PIECE(^AMHPPROB(X,0),U,12)'="A"
QUIT
+37 IF $PIECE(^AMHPPROB(X,0),U,3)>EDATE
QUIT
+38 IF $PIECE(^AMHPPROB(X,0),U,3)<BDATE
QUIT
+39 SET Y=$PIECE(^AMHPPROB(X,0),U)
+40 IF $$ICD^BGP4UTL2(Y,BGPT,9)
SET G=1_U_"BH PL "_Y_U_$$DATE^BGP4UTL($PIECE(^AMHPPROB(X,0),U,3))_U_$PIECE(^AMHPPROB(X,0),U,3)
QUIT
+41 SET Y=$PIECE($GET(^AMHPROB(Y,0)),U)
+42 IF $DATA(^ATXAX(BGPJ,21,"B",Y))
SET G=1_U_"BH PL "_Y_U_$$DATE^BGP4UTL($PIECE(^AMHPPROB(X,0),U,3))_U_$PIECE(^AMHPPROB(X,0),U,3)
QUIT
+43 QUIT
End DoDot:1
+44 IF $PIECE(BGPLAL,U,4)<$PIECE(G,U,4)
SET BGPLAL=G
+45 ;
+46 KILL BGPG
+47 SET BGPG=$$LASTPRC^BGP4UTL1(P,"BGP ALCOHOL PROCEDURES",BDATE,EDATE)
+48 IF $PIECE(BGPLAL,U,4)<$PIECE(BGPG,U,3)
SET BGPLAL=1_U_"Proc "_$PIECE(BGPG,U,2)_U_$$DATE^BGP4UTL($PIECE(BGPG,U,3))_U_$PIECE(BGPG,U,3)
+49 QUIT BGPLAL
ALSCRN(P,BDATE,EDATE,BGPALL) ;EP - alcohol hf or screening pov
+1 NEW BGPG,%,E,BGPSC,V,BGPC,T,F,D,R,BGPCT,BGPX,BGPV,BGPVD,BGPIVD
+2 KILL BGPALL
+3 SET BGPSC=0
PCC ;check PCC first
+1 SET BGPCT=$ORDER(^ATXAX("B","BGP ALCOHOL SCREENING CPTS",0))
+2 KILL BGPG
+3 DO ALLV^APCLAPIU(P,BDATE,EDATE,"BGPG")
+4 SET BGPX=0
FOR
SET BGPX=$ORDER(BGPG(BGPX))
IF BGPX'=+BGPX
QUIT
SET BGPV=$PIECE(BGPG(BGPX),U,5)
Begin DoDot:1
+5 SET BGPVD=$$VD^APCLV(BGPV)
+6 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^BGP4UTL(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
SET BGPALL(BGPIVD,BGPSC)=1_"^HF "_I_"^"_$$DATE^BGP4UTL(BGPVD)_U_BGPVD_U_$SELECT(R="POSITIVE":1,1:0)_U_R
End DoDot:2
PCCDX ;
+1 SET E=0
FOR
SET E=$ORDER(^AUPNVPOV("AD",BGPV,E))
IF E'=+E
QUIT
Begin DoDot:2
+2 SET I=$$VAL^XBDIQ1(9000010.07,E,.01)
+3 IF '$$ICD^BGP4UTL2($$VALI^XBDIQ1(9000010.07,E,.01),$ORDER(^ATXAX("B","BGP ALCOHOL SCREEN DXS",0)),9)
QUIT
+4 SET BGPSC=BGPSC+1
SET BGPALL(BGPIVD,BGPSC)=1_U_"POV "_I_U_$$DATE^BGP4UTL(BGPVD)_U_BGPVD
End DoDot:2
PCCCPT ;
+1 SET E=0
FOR
SET E=$ORDER(^AUPNVCPT("AD",BGPV,E))
IF E'=+E
QUIT
Begin DoDot:2
+2 SET I=$PIECE($GET(^AUPNVCPT(E,0)),U,1)
+3 IF 'I
QUIT
+4 IF '$$ICD^BGP4UTL2(I,BGPCT,1)
QUIT
+5 SET J=$PIECE(^ICPT(I,0),U,1)
+6 SET R=$SELECT($$ICD^BGP4UTL2(I,$ORDER(^ATXAX("B","BGP ALCOHOL POSITIVE SCRN CPTS",0)),1):"POSITIVE",1:"")
+7 SET BGPSC=BGPSC+1
+8 SET BGPALL(BGPIVD,BGPSC)=1_"^CPT "_J_"^"_$$DATE^BGP4UTL(BGPVD)_U_BGPVD_U_$SELECT(R="POSITIVE":1,1:0)_U_R
End DoDot:2
PCCMEAS ;now add in v measurements
+1 SET E=0
FOR
SET E=$ORDER(^AUPNVCPT("AD",BGPV,E))
IF E'=+E
QUIT
Begin DoDot:2
+2 SET I=$$VAL^XBDIQ1(9000010.01,E,.01)
+3 IF I'="AUDT"
IF I'="AUDC"
IF I'="CRFT"
QUIT
+4 SET BGPSC=BGPSC+1
+5 SET R=$$VAL^XBDIQ1(9000010.01,E,.04)
+6 SET T=""
+7 IF I="AUDT"
IF R>7
SET T=1
+8 IF I="AUDC"
IF $PIECE(^DPT(P,0),U,2)="M"
IF R>3
SET T=1
+9 IF I="AUDC"
IF $PIECE(^DPT(P,0),U,2)="F"
IF R>2
SET T=1
+10 IF I="CRFT"
IF R>1
IF R<7
SET T=1
+11 SET BGPALL(BGPVD,BGPSC)=1_"^Meas "_I_"^"_$$DATE^BGP4UTL(BGPVD)_U_BGPVD_U_T_U_$SELECT(T:"POSITIVE: "_R,1:"NEGATIVE: "_R)
End DoDot:2
End DoDot:1
BH ;CHECK BH VISITS
+1 SET BGPC=""
SET T=""
SET F=""
+2 SET E=9999999-BDATE
SET D=9999999-EDATE-1_".99"
+3 FOR
SET D=$ORDER(^AMHREC("AE",P,D))
IF D'=+D!($PIECE(D,".")>E)
QUIT
SET V=0
FOR
SET V=$ORDER(^AMHREC("AE",P,D,V))
IF V'=+V
QUIT
Begin DoDot:1
BHEX ;
+1 SET BGPVD=9999999-$PIECE(D,".")
SET BGPIVD=$PIECE(D,".")
+2 SET X=$PIECE($GET(^AMHREC(V,14)),U,3)
+3 IF X="P"!(X="N")
Begin DoDot:2
+4 SET R=$SELECT(X="P":"POSITIVE",1:"NEGATIVE")
+5 SET BGPSC=BGPSC+1
+6 SET BGPALL(BGPIVD,BGPSC)=1_"^BH Ex^"_$$DATE^BGP4UTL(BGPVD)_U_BGPVD_U_$SELECT(R="POSITIVE":1,1:0)_U_R
End DoDot:2
BHHF ;
+1 SET X=0
FOR
SET X=$ORDER(^AMHRHF("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:2
+2 SET I=$PIECE($GET(^AMHRHF(X,0)),U,1)
+3 IF 'I
QUIT
+4 SET I=$PIECE($GET(^AUTTHF(I,0)),U,1)
+5 ;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
+6 SET R=$SELECT(I["0":"NEGATIVE",1:"POSITIVE")
+7 SET BGPSC=BGPSC+1
SET BGPALL(BGPIVD,BGPSC)=1_"^BH HF "_I_"^"_$$DATE^BGP4UTL(BGPVD)_U_BGPVD_U_$SELECT(R="POSITIVE":1,1:0)_U_R
+8 QUIT
End DoDot:2
BHDX ;
+1 SET X=0
FOR
SET X=$ORDER(^AMHRPRO("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:2
+2 SET I=$$VAL^XBDIQ1(9002011.01,X,.01)
+3 IF '$$ICD^BGP4UTL2($$VALI^XBDIQ1(9002011.01,X,.01),$ORDER(^ATXAX("B","BGP ALCOHOL SCREEN DXS",0)),9)
IF I'="29.1"
QUIT
+4 SET BGPSC=BGPSC+1
SET BGPALL(BGPIVD,BGPSC)=1_U_"BH POV "_I_U_$$DATE^BGP4UTL(BGPVD)_U_BGPVD
+5 QUIT
End DoDot:2
BHMEAS ;
+1 SET X=0
FOR
SET X=$ORDER(^AMHRMSR("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:2
+2 SET I=$$VAL^XBDIQ1(9002011.12,X,.01)
+3 IF I'="AUDT"
IF I'="AUDC"
IF I'="CRFT"
QUIT
+4 SET BGPSC=BGPSC+1
+5 SET R=$$VAL^XBDIQ1(9002011.12,X,.04)
+6 SET T=""
+7 IF I="AUDT"
IF R>7
SET T=1
+8 IF I="AUDC"
IF $PIECE(^DPT(P,0),U,2)="M"
IF R>3
SET T=1
+9 IF I="AUDC"
IF $PIECE(^DPT(P,0),U,2)="F"
IF R>2
SET T=1
+10 IF I="CRFT"
IF R>1
IF R<7
SET T=1
+11 SET BGPALL(BGPIVD,BGPSC)=1_"^BH Meas "_I_"^"_$$DATE^BGP4UTL(BGPVD)_U_BGPVD_U_T_U_$SELECT(T=1:"POSITIVE: "_R,1:"NEGATIVE")
End DoDot:2
BHCPT ;now add in CPT codes
+1 SET X=0
FOR
SET X=$ORDER(^AMHRPROC("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:2
+2 SET I=$PIECE($GET(^AUPNVCPT(X,0)),U,1)
+3 IF 'I
QUIT
+4 IF '$$ICD^BGP4UTL2(I,BGPCT,1)
QUIT
+5 SET J=$PIECE(^ICPT(I,0),U,1)
+6 SET R=$SELECT($$ICD^BGP4UTL2(I,$ORDER(^ATXAX("B","BGP ALCOHOL POSITIVE SCRN CPTS",0)),1):"POSITIVE",1:"")
+7 SET BGPSC=BGPSC+1
+8 SET BGPALL(BGPIVD,BGPSC)=1_"^BH CPT "_J_"^"_$$DATE^BGP4UTL(BGPVD)_U_BGPVD_U_$SELECT(R="POSITIVE":1,1:0)_U_R
+9 QUIT
End DoDot:2
+10 QUIT
End DoDot:1
+11 QUIT
