BGP2D5A ; IHS/CMI/LAB - measure calc ;
;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
;
ALDX(P,BDATE,EDATE) ;EP
NEW BGPLAL,BGPG,X,Y,E,BGPC,BGPP,D,G
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_"POV "_$P(BGPG(1),U,2)_U_$$DATE^BGP2UTL($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 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 BGPP=10 S BGPC=1_U_"BH POV 10"_U_$$DATE^BGP2UTL((9999999-D))_U_(9999999-D) Q
..I BGPP=27 S BGPC=1_U_"BH POV 27"_U_$$DATE^BGP2UTL((9999999-D))_U_(9999999-D) Q
..I BGPP=29 S BGPC=1_U_"BH POV 29"_U_$$DATE^BGP2UTL((9999999-D))_U_(9999999-D) Q
..I $E(BGPP,1,3)=303 S BGPC=1_U_"BH POV "_BGPP_U_$$DATE^BGP2UTL((9999999-D))_U_(9999999-D) Q
..I $E(BGPP,1,5)=305.0 S BGPC=1_U_"BH POV "_BGPP_U_$$DATE^BGP2UTL((9999999-D))_U_(9999999-D) Q
..I $E(BGPP,1,3)=291 S BGPC=1_U_"BH POV "_BGPP_U_$$DATE^BGP2UTL((9999999-D))_U_(9999999-D) Q
..I $E(BGPP,1,5)=357.5 S BGPC=1_U_"BH POV "_BGPP_U_$$DATE^BGP2UTL((9999999-D))_U_(9999999-D) Q
..Q
I $P(BGPLAL,U,4)<$P(BGPC,U,4) S BGPLAL=BGPC
;now check pcc and bh problem lists
S T=$O(^ATXAX("B","BGP ALCOHOL DXS",0))
S (X,G)=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G) D
.Q:$P(^AUPNPROB(X,0),U,12)'="A"
.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^ATXCHK(Y,T,9)
.S D=$P(^AUPNPROB(X,0),U,3)
.S G=1_U_"PROB LIST "_$P($$ICDDX^ICDCODE(Y),U,2)_U_$$DATE^BGP2UTL((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)
.S Y=$P($G(^AMHPROB(Y,0)),U)
.I $E(Y,1,3)="303" S G=1_U_"BH PROB LIST "_Y_U_$$DATE^BGP2UTL($P(^AMHPPROB(X,0),U,3))_U_$P(^AMHPPROB(X,0),U,3) Q
.I $E(Y,1,5)="305.0" S G=1_U_"BH PROB LIST "_Y_U_$$DATE^BGP2UTL($P(^AMHPPROB(X,0),U,3))_U_$P(^AMHPPROB(X,0),U,3) Q
.I $E(Y,1,3)=291 S G=1_U_"BH PROB LIST "_Y_U_$$DATE^BGP2UTL($P(^AMHPPROB(X,0),U,3))_U_$P(^AMHPPROB(X,0),U,3) Q
.I $E(Y,1,5)=357.5 S G=1_U_"BH PROB LIST "_Y_U_$$DATE^BGP2UTL($P(^AMHPPROB(X,0),U,3))_U_$P(^AMHPPROB(X,0),U,3) Q
.I Y=10 S G=1_U_"BH PROB LIST "_Y_U_$$DATE^BGP2UTL($P(^AMHPPROB(X,0),U,3))_U_$P(^AMHPPROB(X,0),U,3) Q
.I Y=27 S G=1_U_"BH PROB LIST "_Y_U_$$DATE^BGP2UTL($P(^AMHPPROB(X,0),U,3))_U_$P(^AMHPPROB(X,0),U,3) Q
.I Y=29 S G=1_U_"BH PROB LIST "_Y_U_$$DATE^BGP2UTL($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
Q BGPLAL
BGP2D5A ; IHS/CMI/LAB - measure calc ;
+1 ;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
+2 ;
ALDX(P,BDATE,EDATE) ;EP
+1 NEW BGPLAL,BGPG,X,Y,E,BGPC,BGPP,D,G
+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_"POV "_$PIECE(BGPG(1),U,2)_U_$$DATE^BGP2UTL($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 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
+11 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
+12 IF 'BGPP
QUIT
+13 SET BGPP=$PIECE($GET(^AMHPROB(BGPP,0)),U)
+14 IF BGPP=10
SET BGPC=1_U_"BH POV 10"_U_$$DATE^BGP2UTL((9999999-D))_U_(9999999-D)
QUIT
+15 IF BGPP=27
SET BGPC=1_U_"BH POV 27"_U_$$DATE^BGP2UTL((9999999-D))_U_(9999999-D)
QUIT
+16 IF BGPP=29
SET BGPC=1_U_"BH POV 29"_U_$$DATE^BGP2UTL((9999999-D))_U_(9999999-D)
QUIT
+17 IF $EXTRACT(BGPP,1,3)=303
SET BGPC=1_U_"BH POV "_BGPP_U_$$DATE^BGP2UTL((9999999-D))_U_(9999999-D)
QUIT
+18 IF $EXTRACT(BGPP,1,5)=305.0
SET BGPC=1_U_"BH POV "_BGPP_U_$$DATE^BGP2UTL((9999999-D))_U_(9999999-D)
QUIT
+19 IF $EXTRACT(BGPP,1,3)=291
SET BGPC=1_U_"BH POV "_BGPP_U_$$DATE^BGP2UTL((9999999-D))_U_(9999999-D)
QUIT
+20 IF $EXTRACT(BGPP,1,5)=357.5
SET BGPC=1_U_"BH POV "_BGPP_U_$$DATE^BGP2UTL((9999999-D))_U_(9999999-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 T=$ORDER(^ATXAX("B","BGP ALCOHOL DXS",0))
+25 SET (X,G)=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+26 IF $PIECE(^AUPNPROB(X,0),U,12)'="A"
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^ATXCHK(Y,T,9)
QUIT
+31 SET D=$PIECE(^AUPNPROB(X,0),U,3)
+32 SET G=1_U_"PROB LIST "_$PIECE($$ICDDX^ICDCODE(Y),U,2)_U_$$DATE^BGP2UTL((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 SET Y=$PIECE($GET(^AMHPROB(Y,0)),U)
+41 IF $EXTRACT(Y,1,3)="303"
SET G=1_U_"BH PROB LIST "_Y_U_$$DATE^BGP2UTL($PIECE(^AMHPPROB(X,0),U,3))_U_$PIECE(^AMHPPROB(X,0),U,3)
QUIT
+42 IF $EXTRACT(Y,1,5)="305.0"
SET G=1_U_"BH PROB LIST "_Y_U_$$DATE^BGP2UTL($PIECE(^AMHPPROB(X,0),U,3))_U_$PIECE(^AMHPPROB(X,0),U,3)
QUIT
+43 IF $EXTRACT(Y,1,3)=291
SET G=1_U_"BH PROB LIST "_Y_U_$$DATE^BGP2UTL($PIECE(^AMHPPROB(X,0),U,3))_U_$PIECE(^AMHPPROB(X,0),U,3)
QUIT
+44 IF $EXTRACT(Y,1,5)=357.5
SET G=1_U_"BH PROB LIST "_Y_U_$$DATE^BGP2UTL($PIECE(^AMHPPROB(X,0),U,3))_U_$PIECE(^AMHPPROB(X,0),U,3)
QUIT
+45 IF Y=10
SET G=1_U_"BH PROB LIST "_Y_U_$$DATE^BGP2UTL($PIECE(^AMHPPROB(X,0),U,3))_U_$PIECE(^AMHPPROB(X,0),U,3)
QUIT
+46 IF Y=27
SET G=1_U_"BH PROB LIST "_Y_U_$$DATE^BGP2UTL($PIECE(^AMHPPROB(X,0),U,3))_U_$PIECE(^AMHPPROB(X,0),U,3)
QUIT
+47 IF Y=29
SET G=1_U_"BH PROB LIST "_Y_U_$$DATE^BGP2UTL($PIECE(^AMHPPROB(X,0),U,3))_U_$PIECE(^AMHPPROB(X,0),U,3)
QUIT
+48 QUIT
End DoDot:1
+49 IF $PIECE(BGPLAL,U,4)<$PIECE(G,U,4)
SET BGPLAL=G
+50 QUIT BGPLAL
