BGP0EL4 ; IHS/CMI/LAB - measure 1,2,3,4 05 Apr 2009 1:44 PM ;
;;10.0;IHS CLINICAL REPORTING;;JUN 18, 2010
;
I18 ;EP
S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7)=0
I BGPAGEB<55 S BGPSTOP=1 Q
I 'BGPACTCL S BGPSTOP=1 Q
S BGPD1=1
I BGPAGEB>54,BGPAGEB<65 S BGPD2=1
I BGPAGEB>64,BGPAGEB<75 S BGPD3=1
I BGPAGEB>74,BGPAGEB<85 S BGPD4=1
I BGPAGEB>84 S BGPD5=1
D CHEL^BGP0D73
S BGPVALUE="AC|||"_$P(BGPVALUE,"|||",2)
K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T,BGPLDL
Q
;
PALLCARE ;EP
S (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7)=0
I BGPAGEB<55 S BGPSTOP=1 Q
I 'BGPACTCL S BGPSTOP=1 Q
S BGPD1=1
I BGPAGEB>54,BGPAGEB<65 S BGPD2=1
I BGPAGEB>64,BGPAGEB<75 S BGPD3=1
I BGPAGEB>74,BGPAGEB<85 S BGPD4=1
I BGPAGEB>84 S BGPD5=1
S BGPVAL=$$PCV^BGP0D24(DFN,BGPBDATE,BGPEDATE) ;return #visits^list string
S BGPN1=$P(BGPVAL,U)
S BGPVALUE="AC|||"_BGPN1_$S(BGPN1'=1:" visits: ",1:" visit: ")_$P(BGPVAL,U,2)
K BGPVAL
Q
;
FUNCTION(P,BDATE,EDATE) ;EP
S BD=(9999999-BDATE)
S ED=(9999999-EDATE)-1
K BGPG
S (BGP1,BGP2)=0
F S ED=$O(^AUPNVELD("AA",P,ED)) Q:ED=""!(ED>BD) D
.S BGPX=0 F S BGPX=$O(^AUPNVELD("AA",P,ED,BGPX)) Q:BGPX'=+BGPX D
..S Y=^AUPNVELD(BGPX,0)
..I $P(Y,U,4)]"" S:'$O(BGPG("TLT",0)) BGPG("TLT",ED)="",BGP1=1
..I $P(Y,U,5)]"" S:'$O(BGPG("BATH",0)) BGPG("BATH",ED)="",BGP1=1
..I $P(Y,U,6)]"" S:'$O(BGPG("DRES",0)) BGPG("DRES",ED)="",BGP1=1
..I $P(Y,U,7)]"" S:'$O(BGPG("XFER",0)) BGPG("XFER",ED)="",BGP1=1
..I $P(Y,U,8)]"" S:'$O(BGPG("FEED",0)) BGPG("FEED",ED)="",BGP1=1
..I $P(Y,U,9)]"" S:'$O(BGPG("CONT",0)) BGPG("CONT",ED)="",BGP1=1
..I $P(Y,U,11)]"" S:'$O(BGPG("FIN",0)) BGPG("FIN",ED)="",BGP2=1
..I $P(Y,U,12)]"" S:'$O(BGPG("COOK",0)) BGPG("COOK",ED)="",BGP2=1
..I $P(Y,U,13)]"" S:'$O(BGPG("SHOP",0)) BGPG("SHOP",ED)="",BGP2=1
..I $P(Y,U,14)]"" S:'$O(BGPG("HSWK",0)) BGPG("HSWK",ED)="",BGP2=1
..I $P(Y,U,15)]"" S:'$O(BGPG("MEDS",0)) BGPG("MEDS",ED)="",BGP2=1
..I $P(Y,U,16)]"" S:'$O(BGPG("TRNS",0)) BGPG("TRNS",ED)="",BGP2=1
K BGPV
S X="" F S X=$O(BGPG(X)) Q:X="" S ED=$O(BGPG(X,0)) S:$D(BGPV(ED)) BGPV(ED)=BGPV(ED)_";" S BGPV(ED)=$G(BGPV(ED))_X
S BGPQ=""
S BGPQ=$S((BGP1+BGP2)=2:1,1:0)_U
S Y=0 F S Y=$O(BGPV(Y)) Q:Y'=+Y D
.S $P(BGPQ,U,2)=$P(BGPQ,U,2)_$$DATE^BGP0UTL((9999999-Y))_": "_BGPV(Y)_" "
K BGPV,BGPG
Q BGPQ
;
PHNV(P,BDATE,EDATE,HOMELOC) ;EP
S HOMELOC=$G(HOMELOC)
K ^TMP($J,"A") S A="^TMP($J,""A"","
S B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
I '$D(^TMP($J,"A",1)) Q "0^0^0^0^0^0^0^0^0^0^0^0"
S (X,Y)=0,C="0^0^0^0^0^0^0^0^0^0^0^0" F S X=$O(^TMP($J,"A",X)) Q:X'=+X S V=$P(^TMP($J,"A",X),U,5) D
.;S Y=0 I $$CLINIC^APCLV(V,"C")=45 S Y=1 Q
.S (D,Y,Z)=0
.F S D=$O(^AUPNVPRV("AD",V,D)) Q:D'=+D S Q=$P(^AUPNVPRV(D,0),U) D
..Q:Q=""
..S %=$$VALI^XBDIQ1($S($P(^DD(9000010.06,.01,0),U,2)["200":200,1:6),Q,$S($P(^DD(9000010.06,.01,0),U,2)["200":53.5,1:2))
..I % S %=$P($G(^DIC(7,+%,9999999)),U)
..I %'=13,%'=91 Q ;not a phn or driver
..S $P(C,U,1)=$P(C,U,1)+1
..I %=91 S $P(C,U,6)=$P(C,U,6)+1
..D HOME
..D AGE
Q C
;
HOME ;
S HV=0
I $$CLINIC^APCLV(V,"C")=11 S $P(C,U,7)=$P(C,U,7)+1,HV=1 S:%=91 $P(C,U,12)=$P(C,U,12)+1 Q
Q:HOMELOC=""
I HOMELOC=$P(^AUPNVSIT(V,0),U,6) S $P(C,U,7)=$P(C,U,7)+1,HV=1 S:%=91 $P(C,U,12)=$P(C,U,12)+1 Q
Q
AGE ;
I BGPD2 S $P(C,U,2)=$P(C,U,2)+1 S:HV=1 $P(C,U,8)=$P(C,U,8)+1 Q
I BGPD3 S $P(C,U,3)=$P(C,U,3)+1 S:HV=1 $P(C,U,9)=$P(C,U,9)+1 Q
I BGPD4 S $P(C,U,4)=$P(C,U,4)+1 S:HV=1 $P(C,U,10)=$P(C,U,10)+1 Q
I BGPD5 S $P(C,U,5)=$P(C,U,5)+1 S:HV=1 $P(C,U,11)=$P(C,U,11)+1 Q
W BGPBOMB
Q
TXBMD(P,BDATE,EDATE,HOSP) ;EP
;first see if there are any procedures in this date range
S HOSP=$G(HOSP)
K BGPG
S BGPG=$$LASTPRC^BGP0UTL1(P,"BGP BMD PROCEDURES",BDATE,EDATE)
I $P(BGPG,U)=1 Q 1_U_"bmd proc "_$P(BGPG,U,2)_" "_$$DATE^BGP0UTL($P(BGPG,U,3))
;now check dx
S BGPG=$$LASTDX^BGP0UTL1(P,"BGP BMD DXS",BDATE,EDATE)
I $P(BGPG,U)=1 Q 1_U_"bmd DX "_$P(BGPG,U,2)_" "_$$DATE^BGP0UTL($P(BGPG,U,3))
;now check cpts
S T=$O(^ATXAX("B","BGP BMD CPTS",0))
S BGPG=$$CPT^BGP0DU(P,BDATE,EDATE,T,5)
I BGPG]"" Q 1_U_$P(BGPG,U,2)_" "_$$DATE^BGP0UTL($P(BGPG,U,1)) ;had a cpt
S T=$O(^ATXAX("B","BGP BMD CPTS",0))
S BGPG=$$TRAN^BGP0DU(P,BDATE,EDATE,T,5)
I BGPG]"" Q 1_U_$P(BGPG,U,2)_" "_$$DATE^BGP0UTL($P(BGPG,U,1)) ;had a TRAN
;now check RAD
S T=$O(^ATXAX("B","BGP BMD CPTS",0))
S BGPG=$$RAD^BGP0DU(P,BDATE,EDATE,T,5)
I BGPG]"" Q 1_U_$P(BGPG,U,2)_" "_$$DATE^BGP0UTL($P(BGPG,U,1)) ;had a cpt
I HOSP Q ""
;now check all meds
K ^TMP($J,"MEDS")
S G=0 K BGPZ
S Y="^TMP($J,""MEDS"",",X=P_"^ALL MED;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
S T=$O(^ATXAX("B","BGP HEDIS OSTEOPOROSIS DRUGS",0))
S T1=$O(^ATXAX("B","BGP HEDIS OSTEOPOROSIS NDC",0))
;S T2="" I TAX3]"" S T2=$O(^ATXAX("B",TAX3,0))
S X=0 F S X=$O(^TMP($J,"MEDS",X)) Q:X'=+X!(G) S Y=+$P(^TMP($J,"MEDS",X),U,4) D
.Q:'$D(^AUPNVMED(Y,0))
.S G=0
.S D=$P(^AUPNVMED(Y,0),U)
.S C=$P($G(^PSDRUG(D,0)),U,2)
.;I C]"",T2,$D(^ATXAX(T2,21,"B",C)) S G=X
.S C=$P($G(^PSDRUG(D,2)),U,4)
.I C]"",T1,$D(^ATXAX(T1,21,"B",C)) S G=$P(^TMP($J,"MEDS",X),U)
.I T,$D(^ATXAX(T,21,"B",D)) S G=$P(^TMP($J,"MEDS",X),U)
.Q
K ^TMP($J,"MEDS")
I G Q 1_U_"osteo med: "_$$DATE^BGP0UTL(G)
Q ""
BGP0EL4 ; IHS/CMI/LAB - measure 1,2,3,4 05 Apr 2009 1:44 PM ;
+1 ;;10.0;IHS CLINICAL REPORTING;;JUN 18, 2010
+2 ;
I18 ;EP
+1 SET (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0
+2 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7)=0
+3 IF BGPAGEB<55
SET BGPSTOP=1
QUIT
+4 IF 'BGPACTCL
SET BGPSTOP=1
QUIT
+5 SET BGPD1=1
+6 IF BGPAGEB>54
IF BGPAGEB<65
SET BGPD2=1
+7 IF BGPAGEB>64
IF BGPAGEB<75
SET BGPD3=1
+8 IF BGPAGEB>74
IF BGPAGEB<85
SET BGPD4=1
+9 IF BGPAGEB>84
SET BGPD5=1
+10 DO CHEL^BGP0D73
+11 SET BGPVALUE="AC|||"_$PIECE(BGPVALUE,"|||",2)
+12 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T,BGPLDL
+13 QUIT
+14 ;
PALLCARE ;EP
+1 SET (BGPD1,BGPD2,BGPD3,BGPD4,BGPD5)=0
+2 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7)=0
+3 IF BGPAGEB<55
SET BGPSTOP=1
QUIT
+4 IF 'BGPACTCL
SET BGPSTOP=1
QUIT
+5 SET BGPD1=1
+6 IF BGPAGEB>54
IF BGPAGEB<65
SET BGPD2=1
+7 IF BGPAGEB>64
IF BGPAGEB<75
SET BGPD3=1
+8 IF BGPAGEB>74
IF BGPAGEB<85
SET BGPD4=1
+9 IF BGPAGEB>84
SET BGPD5=1
+10 ;return #visits^list string
SET BGPVAL=$$PCV^BGP0D24(DFN,BGPBDATE,BGPEDATE)
+11 SET BGPN1=$PIECE(BGPVAL,U)
+12 SET BGPVALUE="AC|||"_BGPN1_$SELECT(BGPN1'=1:" visits: ",1:" visit: ")_$PIECE(BGPVAL,U,2)
+13 KILL BGPVAL
+14 QUIT
+15 ;
FUNCTION(P,BDATE,EDATE) ;EP
+1 SET BD=(9999999-BDATE)
+2 SET ED=(9999999-EDATE)-1
+3 KILL BGPG
+4 SET (BGP1,BGP2)=0
+5 FOR
SET ED=$ORDER(^AUPNVELD("AA",P,ED))
IF ED=""!(ED>BD)
QUIT
Begin DoDot:1
+6 SET BGPX=0
FOR
SET BGPX=$ORDER(^AUPNVELD("AA",P,ED,BGPX))
IF BGPX'=+BGPX
QUIT
Begin DoDot:2
+7 SET Y=^AUPNVELD(BGPX,0)
+8 IF $PIECE(Y,U,4)]""
IF '$ORDER(BGPG("TLT",0))
SET BGPG("TLT",ED)=""
SET BGP1=1
+9 IF $PIECE(Y,U,5)]""
IF '$ORDER(BGPG("BATH",0))
SET BGPG("BATH",ED)=""
SET BGP1=1
+10 IF $PIECE(Y,U,6)]""
IF '$ORDER(BGPG("DRES",0))
SET BGPG("DRES",ED)=""
SET BGP1=1
+11 IF $PIECE(Y,U,7)]""
IF '$ORDER(BGPG("XFER",0))
SET BGPG("XFER",ED)=""
SET BGP1=1
+12 IF $PIECE(Y,U,8)]""
IF '$ORDER(BGPG("FEED",0))
SET BGPG("FEED",ED)=""
SET BGP1=1
+13 IF $PIECE(Y,U,9)]""
IF '$ORDER(BGPG("CONT",0))
SET BGPG("CONT",ED)=""
SET BGP1=1
+14 IF $PIECE(Y,U,11)]""
IF '$ORDER(BGPG("FIN",0))
SET BGPG("FIN",ED)=""
SET BGP2=1
+15 IF $PIECE(Y,U,12)]""
IF '$ORDER(BGPG("COOK",0))
SET BGPG("COOK",ED)=""
SET BGP2=1
+16 IF $PIECE(Y,U,13)]""
IF '$ORDER(BGPG("SHOP",0))
SET BGPG("SHOP",ED)=""
SET BGP2=1
+17 IF $PIECE(Y,U,14)]""
IF '$ORDER(BGPG("HSWK",0))
SET BGPG("HSWK",ED)=""
SET BGP2=1
+18 IF $PIECE(Y,U,15)]""
IF '$ORDER(BGPG("MEDS",0))
SET BGPG("MEDS",ED)=""
SET BGP2=1
+19 IF $PIECE(Y,U,16)]""
IF '$ORDER(BGPG("TRNS",0))
SET BGPG("TRNS",ED)=""
SET BGP2=1
End DoDot:2
End DoDot:1
+20 KILL BGPV
+21 SET X=""
FOR
SET X=$ORDER(BGPG(X))
IF X=""
QUIT
SET ED=$ORDER(BGPG(X,0))
IF $DATA(BGPV(ED))
SET BGPV(ED)=BGPV(ED)_";"
SET BGPV(ED)=$GET(BGPV(ED))_X
+22 SET BGPQ=""
+23 SET BGPQ=$SELECT((BGP1+BGP2)=2:1,1:0)_U
+24 SET Y=0
FOR
SET Y=$ORDER(BGPV(Y))
IF Y'=+Y
QUIT
Begin DoDot:1
+25 SET $PIECE(BGPQ,U,2)=$PIECE(BGPQ,U,2)_$$DATE^BGP0UTL((9999999-Y))_": "_BGPV(Y)_" "
End DoDot:1
+26 KILL BGPV,BGPG
+27 QUIT BGPQ
+28 ;
PHNV(P,BDATE,EDATE,HOMELOC) ;EP
+1 SET HOMELOC=$GET(HOMELOC)
+2 KILL ^TMP($JOB,"A")
SET A="^TMP($J,""A"","
+3 SET B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(B,A)
+4 IF '$DATA(^TMP($JOB,"A",1))
QUIT "0^0^0^0^0^0^0^0^0^0^0^0"
+5 SET (X,Y)=0
SET C="0^0^0^0^0^0^0^0^0^0^0^0"
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X
QUIT
SET V=$PIECE(^TMP($JOB,"A",X),U,5)
Begin DoDot:1
+6 ;S Y=0 I $$CLINIC^APCLV(V,"C")=45 S Y=1 Q
+7 SET (D,Y,Z)=0
+8 FOR
SET D=$ORDER(^AUPNVPRV("AD",V,D))
IF D'=+D
QUIT
SET Q=$PIECE(^AUPNVPRV(D,0),U)
Begin DoDot:2
+9 IF Q=""
QUIT
+10 SET %=$$VALI^XBDIQ1($SELECT($PIECE(^DD(9000010.06,.01,0),U,2)["200":200,1:6),Q,$SELECT($PIECE(^DD(9000010.06,.01,0),U,2)["200":53.5,1:2))
+11 IF %
SET %=$PIECE($GET(^DIC(7,+%,9999999)),U)
+12 ;not a phn or driver
IF %'=13
IF %'=91
QUIT
+13 SET $PIECE(C,U,1)=$PIECE(C,U,1)+1
+14 IF %=91
SET $PIECE(C,U,6)=$PIECE(C,U,6)+1
+15 DO HOME
+16 DO AGE
End DoDot:2
End DoDot:1
+17 QUIT C
+18 ;
HOME ;
+1 SET HV=0
+2 IF $$CLINIC^APCLV(V,"C")=11
SET $PIECE(C,U,7)=$PIECE(C,U,7)+1
SET HV=1
IF %=91
SET $PIECE(C,U,12)=$PIECE(C,U,12)+1
QUIT
+3 IF HOMELOC=""
QUIT
+4 IF HOMELOC=$PIECE(^AUPNVSIT(V,0),U,6)
SET $PIECE(C,U,7)=$PIECE(C,U,7)+1
SET HV=1
IF %=91
SET $PIECE(C,U,12)=$PIECE(C,U,12)+1
QUIT
+5 QUIT
AGE ;
+1 IF BGPD2
SET $PIECE(C,U,2)=$PIECE(C,U,2)+1
IF HV=1
SET $PIECE(C,U,8)=$PIECE(C,U,8)+1
QUIT
+2 IF BGPD3
SET $PIECE(C,U,3)=$PIECE(C,U,3)+1
IF HV=1
SET $PIECE(C,U,9)=$PIECE(C,U,9)+1
QUIT
+3 IF BGPD4
SET $PIECE(C,U,4)=$PIECE(C,U,4)+1
IF HV=1
SET $PIECE(C,U,10)=$PIECE(C,U,10)+1
QUIT
+4 IF BGPD5
SET $PIECE(C,U,5)=$PIECE(C,U,5)+1
IF HV=1
SET $PIECE(C,U,11)=$PIECE(C,U,11)+1
QUIT
+5 WRITE BGPBOMB
+6 QUIT
TXBMD(P,BDATE,EDATE,HOSP) ;EP
+1 ;first see if there are any procedures in this date range
+2 SET HOSP=$GET(HOSP)
+3 KILL BGPG
+4 SET BGPG=$$LASTPRC^BGP0UTL1(P,"BGP BMD PROCEDURES",BDATE,EDATE)
+5 IF $PIECE(BGPG,U)=1
QUIT 1_U_"bmd proc "_$PIECE(BGPG,U,2)_" "_$$DATE^BGP0UTL($PIECE(BGPG,U,3))
+6 ;now check dx
+7 SET BGPG=$$LASTDX^BGP0UTL1(P,"BGP BMD DXS",BDATE,EDATE)
+8 IF $PIECE(BGPG,U)=1
QUIT 1_U_"bmd DX "_$PIECE(BGPG,U,2)_" "_$$DATE^BGP0UTL($PIECE(BGPG,U,3))
+9 ;now check cpts
+10 SET T=$ORDER(^ATXAX("B","BGP BMD CPTS",0))
+11 SET BGPG=$$CPT^BGP0DU(P,BDATE,EDATE,T,5)
+12 ;had a cpt
IF BGPG]""
QUIT 1_U_$PIECE(BGPG,U,2)_" "_$$DATE^BGP0UTL($PIECE(BGPG,U,1))
+13 SET T=$ORDER(^ATXAX("B","BGP BMD CPTS",0))
+14 SET BGPG=$$TRAN^BGP0DU(P,BDATE,EDATE,T,5)
+15 ;had a TRAN
IF BGPG]""
QUIT 1_U_$PIECE(BGPG,U,2)_" "_$$DATE^BGP0UTL($PIECE(BGPG,U,1))
+16 ;now check RAD
+17 SET T=$ORDER(^ATXAX("B","BGP BMD CPTS",0))
+18 SET BGPG=$$RAD^BGP0DU(P,BDATE,EDATE,T,5)
+19 ;had a cpt
IF BGPG]""
QUIT 1_U_$PIECE(BGPG,U,2)_" "_$$DATE^BGP0UTL($PIECE(BGPG,U,1))
+20 IF HOSP
QUIT ""
+21 ;now check all meds
+22 KILL ^TMP($JOB,"MEDS")
+23 SET G=0
KILL BGPZ
+24 SET Y="^TMP($J,""MEDS"","
SET X=P_"^ALL MED;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+25 SET T=$ORDER(^ATXAX("B","BGP HEDIS OSTEOPOROSIS DRUGS",0))
+26 SET T1=$ORDER(^ATXAX("B","BGP HEDIS OSTEOPOROSIS NDC",0))
+27 ;S T2="" I TAX3]"" S T2=$O(^ATXAX("B",TAX3,0))
+28 SET X=0
FOR
SET X=$ORDER(^TMP($JOB,"MEDS",X))
IF X'=+X!(G)
QUIT
SET Y=+$PIECE(^TMP($JOB,"MEDS",X),U,4)
Begin DoDot:1
+29 IF '$DATA(^AUPNVMED(Y,0))
QUIT
+30 SET G=0
+31 SET D=$PIECE(^AUPNVMED(Y,0),U)
+32 SET C=$PIECE($GET(^PSDRUG(D,0)),U,2)
+33 ;I C]"",T2,$D(^ATXAX(T2,21,"B",C)) S G=X
+34 SET C=$PIECE($GET(^PSDRUG(D,2)),U,4)
+35 IF C]""
IF T1
IF $DATA(^ATXAX(T1,21,"B",C))
SET G=$PIECE(^TMP($JOB,"MEDS",X),U)
+36 IF T
IF $DATA(^ATXAX(T,21,"B",D))
SET G=$PIECE(^TMP($JOB,"MEDS",X),U)
+37 QUIT
End DoDot:1
+38 KILL ^TMP($JOB,"MEDS")
+39 IF G
QUIT 1_U_"osteo med: "_$$DATE^BGP0UTL(G)
+40 QUIT ""
