BGP0D729 ; IHS/CMI/LAB - measure AHR.A ;
;;10.0;IHS CLINICAL REPORTING;;JUN 18, 2010
;
;
CHD(P,BDATE,EDATE) ;EP
;first dx prior to report period
;at least 2 visits during report period
;at least 2 Chd dxs ever
I '$$V2^BGP0D1(P,BDATE,EDATE) Q "" ;not 2 visits during report period
K ^TMP($J)
I '$$CHDV(P,$$DOB^AUPNPAT(P),$$FMADD^XLFDT(BDATE,-1),0) Q "" ;first dx not prior to report period
;GET CHD DIAGNOSES AND SET BY VISIT
I '$$CHDV(P,$$DOB^AUPNPAT(P),EDATE,1) Q "" ;not two during report period
Q 1
CHDV(P,BDATE,EDATE,MIN) ;EP
NEW A,B,E,T,X,G,V,Y,%,G,F,BGPG,BGPCNT,T1,BGPALL
K BGPALL
S BGPCNT=0
K ^TMP($J,"A")
S A="^TMP($J,""A"",",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
I '$D(^TMP($J,"A",1)) Q ""
S T=$O(^ATXAX("B","BGP CHD DXS",0))
S T1=$O(^ATXAX("B","BGP PCI DXS",0))
I 'T Q ""
S (X,G)=0 F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(BGPCNT>MIN) S V=$P(^TMP($J,"A",X),U,5) D
.Q:'$D(^AUPNVSIT(V,0))
.Q:'$P(^AUPNVSIT(V,0),U,9)
.Q:$P(^AUPNVSIT(V,0),U,11)
.Q:"SAHO"'[$P(^AUPNVSIT(V,0),U,7)
.Q:"V"[$P(^AUPNVSIT(V,0),U,3)
.Q:$P(^AUPNVSIT(V,0),U,6)=""
.I $G(BGPMFITI),'$D(^ATXAX(BGPMFITI,21,"B",$P(^AUPNVSIT(V,0),U,6))) Q
.S (D,Y)=0 F S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(BGPCNT>MIN) I $D(^AUPNVPOV(Y,0)) D
..S %=$P(^AUPNVPOV(Y,0),U)
..I $$ICD^ATXCHK(%,T,9) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
..I $$ICD^ATXCHK(%,T1,9) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
.;NOW CHECK
.;check for procedure in BGP CABG PROCS
.S E=$O(^ATXAX("B","BGP CABG PROCS",0))
.S F=$O(^ATXAX("B","BGP PCI PROCS",0))
.S Y=0 F S Y=$O(^AUPNVPRC("AD",V,Y)) Q:Y'=+Y!(BGPCNT>MIN) D
..Q:'$D(^AUPNVPRC(Y,0))
..I $$ICD^ATXCHK($P(^AUPNVPRC(Y,0),U,1),E,0) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
..I $$ICD^ATXCHK($P(^AUPNVPRC(Y,0),U,1),F,0) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1
.;now check cpts
.S E=$O(^ATXAX("B","BGP CABG CHD CPTS",0))
.S F=$O(^ATXAX("B","BGP PCI CPTS",0))
.S G=$O(^ATXAX("B","BGP PTCA CPTS",0))
.S Y=0 F S Y=$O(^AUPNVCPT("AD",V,Y)) Q:Y'=+Y!(BGPCNT>MIN) D
..Q:'$D(^AUPNVCPT(Y,0))
..I $$ICD^ATXCHK($P(^AUPNVCPT(Y,0),U,1),E,1) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
..I $$ICD^ATXCHK($P(^AUPNVCPT(Y,0),U,1),F,1) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
..I $$ICD^ATXCHK($P(^AUPNVCPT(Y,0),U,1),G,1) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
.;now check TRANS
.S E=$O(^ATXAX("B","BGP CABG CHD CPTS",0))
.S F=$O(^ATXAX("B","BGP PCI CPTS",0))
.S G=$O(^ATXAX("B","BGP PTCA CPTS",0))
.S Y=0 F S Y=$O(^AUPNVTC("AD",V,Y)) Q:Y'=+Y!(BGPCNT>MIN) D
..Q:'$D(^AUPNVTC(Y,0))
..S I=$P(^AUPNVTC(Y,0),U,7)
..Q:I=""
..I $$ICD^ATXCHK(I,E,1) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
..I $$ICD^ATXCHK(I,F,1) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
..I $$ICD^ATXCHK(I,G,1) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
.Q
I BGPCNT>MIN Q 1
Q ""
BGP0D729 ; IHS/CMI/LAB - measure AHR.A ;
+1 ;;10.0;IHS CLINICAL REPORTING;;JUN 18, 2010
+2 ;
+3 ;
CHD(P,BDATE,EDATE) ;EP
+1 ;first dx prior to report period
+2 ;at least 2 visits during report period
+3 ;at least 2 Chd dxs ever
+4 ;not 2 visits during report period
IF '$$V2^BGP0D1(P,BDATE,EDATE)
QUIT ""
+5 KILL ^TMP($JOB)
+6 ;first dx not prior to report period
IF '$$CHDV(P,$$DOB^AUPNPAT(P),$$FMADD^XLFDT(BDATE,-1),0)
QUIT ""
+7 ;GET CHD DIAGNOSES AND SET BY VISIT
+8 ;not two during report period
IF '$$CHDV(P,$$DOB^AUPNPAT(P),EDATE,1)
QUIT ""
+9 QUIT 1
CHDV(P,BDATE,EDATE,MIN) ;EP
+1 NEW A,B,E,T,X,G,V,Y,%,G,F,BGPG,BGPCNT,T1,BGPALL
+2 KILL BGPALL
+3 SET BGPCNT=0
+4 KILL ^TMP($JOB,"A")
+5 SET A="^TMP($J,""A"","
SET B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(B,A)
+6 IF '$DATA(^TMP($JOB,"A",1))
QUIT ""
+7 SET T=$ORDER(^ATXAX("B","BGP CHD DXS",0))
+8 SET T1=$ORDER(^ATXAX("B","BGP PCI DXS",0))
+9 IF 'T
QUIT ""
+10 SET (X,G)=0
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X!(BGPCNT>MIN)
QUIT
SET V=$PIECE(^TMP($JOB,"A",X),U,5)
Begin DoDot:1
+11 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+12 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+13 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+14 IF "SAHO"'[$PIECE(^AUPNVSIT(V,0),U,7)
QUIT
+15 IF "V"[$PIECE(^AUPNVSIT(V,0),U,3)
QUIT
+16 IF $PIECE(^AUPNVSIT(V,0),U,6)=""
QUIT
+17 IF $GET(BGPMFITI)
IF '$DATA(^ATXAX(BGPMFITI,21,"B",$PIECE(^AUPNVSIT(V,0),U,6)))
QUIT
+18 SET (D,Y)=0
FOR
SET Y=$ORDER(^AUPNVPOV("AD",V,Y))
IF Y'=+Y!(BGPCNT>MIN)
QUIT
IF $DATA(^AUPNVPOV(Y,0))
Begin DoDot:2
+19 SET %=$PIECE(^AUPNVPOV(Y,0),U)
+20 IF $$ICD^ATXCHK(%,T,9)
IF '$DATA(BGPALL(V))
SET BGPALL(V)=""
SET BGPCNT=BGPCNT+1
QUIT
+21 IF $$ICD^ATXCHK(%,T1,9)
IF '$DATA(BGPALL(V))
SET BGPALL(V)=""
SET BGPCNT=BGPCNT+1
QUIT
End DoDot:2
+22 ;NOW CHECK
+23 ;check for procedure in BGP CABG PROCS
+24 SET E=$ORDER(^ATXAX("B","BGP CABG PROCS",0))
+25 SET F=$ORDER(^ATXAX("B","BGP PCI PROCS",0))
+26 SET Y=0
FOR
SET Y=$ORDER(^AUPNVPRC("AD",V,Y))
IF Y'=+Y!(BGPCNT>MIN)
QUIT
Begin DoDot:2
+27 IF '$DATA(^AUPNVPRC(Y,0))
QUIT
+28 IF $$ICD^ATXCHK($PIECE(^AUPNVPRC(Y,0),U,1),E,0)
IF '$DATA(BGPALL(V))
SET BGPALL(V)=""
SET BGPCNT=BGPCNT+1
QUIT
+29 IF $$ICD^ATXCHK($PIECE(^AUPNVPRC(Y,0),U,1),F,0)
IF '$DATA(BGPALL(V))
SET BGPALL(V)=""
SET BGPCNT=BGPCNT+1
End DoDot:2
+30 ;now check cpts
+31 SET E=$ORDER(^ATXAX("B","BGP CABG CHD CPTS",0))
+32 SET F=$ORDER(^ATXAX("B","BGP PCI CPTS",0))
+33 SET G=$ORDER(^ATXAX("B","BGP PTCA CPTS",0))
+34 SET Y=0
FOR
SET Y=$ORDER(^AUPNVCPT("AD",V,Y))
IF Y'=+Y!(BGPCNT>MIN)
QUIT
Begin DoDot:2
+35 IF '$DATA(^AUPNVCPT(Y,0))
QUIT
+36 IF $$ICD^ATXCHK($PIECE(^AUPNVCPT(Y,0),U,1),E,1)
IF '$DATA(BGPALL(V))
SET BGPALL(V)=""
SET BGPCNT=BGPCNT+1
QUIT
+37 IF $$ICD^ATXCHK($PIECE(^AUPNVCPT(Y,0),U,1),F,1)
IF '$DATA(BGPALL(V))
SET BGPALL(V)=""
SET BGPCNT=BGPCNT+1
QUIT
+38 IF $$ICD^ATXCHK($PIECE(^AUPNVCPT(Y,0),U,1),G,1)
IF '$DATA(BGPALL(V))
SET BGPALL(V)=""
SET BGPCNT=BGPCNT+1
QUIT
End DoDot:2
+39 ;now check TRANS
+40 SET E=$ORDER(^ATXAX("B","BGP CABG CHD CPTS",0))
+41 SET F=$ORDER(^ATXAX("B","BGP PCI CPTS",0))
+42 SET G=$ORDER(^ATXAX("B","BGP PTCA CPTS",0))
+43 SET Y=0
FOR
SET Y=$ORDER(^AUPNVTC("AD",V,Y))
IF Y'=+Y!(BGPCNT>MIN)
QUIT
Begin DoDot:2
+44 IF '$DATA(^AUPNVTC(Y,0))
QUIT
+45 SET I=$PIECE(^AUPNVTC(Y,0),U,7)
+46 IF I=""
QUIT
+47 IF $$ICD^ATXCHK(I,E,1)
IF '$DATA(BGPALL(V))
SET BGPALL(V)=""
SET BGPCNT=BGPCNT+1
QUIT
+48 IF $$ICD^ATXCHK(I,F,1)
IF '$DATA(BGPALL(V))
SET BGPALL(V)=""
SET BGPCNT=BGPCNT+1
QUIT
+49 IF $$ICD^ATXCHK(I,G,1)
IF '$DATA(BGPALL(V))
SET BGPALL(V)=""
SET BGPCNT=BGPCNT+1
QUIT
End DoDot:2
+50 QUIT
End DoDot:1
+51 IF BGPCNT>MIN
QUIT 1
+52 QUIT ""
