- BGP3D5A ; IHS/CMI/LAB - measure calc ;
- ;;13.0;IHS CLINICAL REPORTING;;NOV 20, 2012;Build 81
- ;
- 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^BGP3UTL($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^BGP3UTL((9999999-D))_U_(9999999-D) Q
- ..I BGPP=27 S BGPC=1_U_"BH POV 27"_U_$$DATE^BGP3UTL((9999999-D))_U_(9999999-D) Q
- ..I BGPP=29 S BGPC=1_U_"BH POV 29"_U_$$DATE^BGP3UTL((9999999-D))_U_(9999999-D) Q
- ..I $E(BGPP,1,3)=303 S BGPC=1_U_"BH POV "_BGPP_U_$$DATE^BGP3UTL((9999999-D))_U_(9999999-D) Q
- ..I $E(BGPP,1,5)=305.0 S BGPC=1_U_"BH POV "_BGPP_U_$$DATE^BGP3UTL((9999999-D))_U_(9999999-D) Q
- ..I $E(BGPP,1,3)=291 S BGPC=1_U_"BH POV "_BGPP_U_$$DATE^BGP3UTL((9999999-D))_U_(9999999-D) Q
- ..I $E(BGPP,1,5)=357.5 S BGPC=1_U_"BH POV "_BGPP_U_$$DATE^BGP3UTL((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^BGP3UTL((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^BGP3UTL($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^BGP3UTL($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^BGP3UTL($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^BGP3UTL($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^BGP3UTL($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^BGP3UTL($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^BGP3UTL($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
- BGP3D5A ; IHS/CMI/LAB - measure calc ;
- +1 ;;13.0;IHS CLINICAL REPORTING;;NOV 20, 2012;Build 81
- +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^BGP3UTL($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^BGP3UTL((9999999-D))_U_(9999999-D)
- QUIT
- +15 IF BGPP=27
- SET BGPC=1_U_"BH POV 27"_U_$$DATE^BGP3UTL((9999999-D))_U_(9999999-D)
- QUIT
- +16 IF BGPP=29
- SET BGPC=1_U_"BH POV 29"_U_$$DATE^BGP3UTL((9999999-D))_U_(9999999-D)
- QUIT
- +17 IF $EXTRACT(BGPP,1,3)=303
- SET BGPC=1_U_"BH POV "_BGPP_U_$$DATE^BGP3UTL((9999999-D))_U_(9999999-D)
- QUIT
- +18 IF $EXTRACT(BGPP,1,5)=305.0
- SET BGPC=1_U_"BH POV "_BGPP_U_$$DATE^BGP3UTL((9999999-D))_U_(9999999-D)
- QUIT
- +19 IF $EXTRACT(BGPP,1,3)=291
- SET BGPC=1_U_"BH POV "_BGPP_U_$$DATE^BGP3UTL((9999999-D))_U_(9999999-D)
- QUIT
- +20 IF $EXTRACT(BGPP,1,5)=357.5
- SET BGPC=1_U_"BH POV "_BGPP_U_$$DATE^BGP3UTL((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^BGP3UTL((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^BGP3UTL($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^BGP3UTL($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^BGP3UTL($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^BGP3UTL($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^BGP3UTL($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^BGP3UTL($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^BGP3UTL($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