BGP1D729 ; IHS/CMI/LAB - measure AHR.A ;
;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
;
;
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^BGP1D1(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 ""
IHDCCVD(P,BDATE,EDATE) ;EP
;first dx prior to report period
;at least 2 visits during report period
;at least 2 ihd dxs ever
I '$$V2^BGP1D1(P,BDATE,EDATE) Q "" ;not 2 visits during report period
K ^TMP($J)
I '$$FIRSTIHD(P,EDATE) Q "" ;first dx not prior to report period
I '$$V2IHD(P,$$DOB^AUPNPAT(P),EDATE) Q "" ;at least 2 IHD dxs ever
Q 1
FIRSTIHD(P,EDATE) ;EP
I $G(P)="" Q ""
NEW BGPG,Y,X,E
K BGPG
S Y="BGPG("
S X=P_"^FIRST DX [BGP IHD DXS (GPRA)" S E=$$START1^APCLDF(X,Y)
I '$D(BGPG(1)) Q ""
S X=$$FMDIFF^XLFDT(EDATE,$P(BGPG(1),U))
Q $S(X>365:1,1:"")
;
V2IHD(P,BDATE,EDATE) ;EP
I '$G(P) Q ""
I '$D(^AUPNVSIT("AC",P)) Q ""
NEW A,B,E,T,X,G,V,Y,%,G
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 IHD DXS (GPRA)",0))
I 'T Q ""
S (X,G)=0 F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(G>2) 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!(D) I $D(^AUPNVPOV(Y,0)) S %=$P(^AUPNVPOV(Y,0),U) I $$ICD^ATXCHK(%,T,9) S D=1
.Q:'D
.S G=G+1
.Q
K ^TMP($J,"A")
Q $S(G<2:"",1:1)
;
BGP1D729 ; IHS/CMI/LAB - measure AHR.A ;
+1 ;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
+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^BGP1D1(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 ;S G=$O(^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 ;I $$ICD^ATXCHK($P(^AUPNVCPT(Y,0),U,1),G,1) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
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 ;S G=$O(^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 ;I $$ICD^ATXCHK(I,G,1) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
End DoDot:2
+50 QUIT
End DoDot:1
+51 IF BGPCNT>MIN
QUIT 1
+52 QUIT ""
IHDCCVD(P,BDATE,EDATE) ;EP
+1 ;first dx prior to report period
+2 ;at least 2 visits during report period
+3 ;at least 2 ihd dxs ever
+4 ;not 2 visits during report period
IF '$$V2^BGP1D1(P,BDATE,EDATE)
QUIT ""
+5 KILL ^TMP($JOB)
+6 ;first dx not prior to report period
IF '$$FIRSTIHD(P,EDATE)
QUIT ""
+7 ;at least 2 IHD dxs ever
IF '$$V2IHD(P,$$DOB^AUPNPAT(P),EDATE)
QUIT ""
+8 QUIT 1
FIRSTIHD(P,EDATE) ;EP
+1 IF $GET(P)=""
QUIT ""
+2 NEW BGPG,Y,X,E
+3 KILL BGPG
+4 SET Y="BGPG("
+5 SET X=P_"^FIRST DX [BGP IHD DXS (GPRA)"
SET E=$$START1^APCLDF(X,Y)
+6 IF '$DATA(BGPG(1))
QUIT ""
+7 SET X=$$FMDIFF^XLFDT(EDATE,$PIECE(BGPG(1),U))
+8 QUIT $SELECT(X>365:1,1:"")
+9 ;
V2IHD(P,BDATE,EDATE) ;EP
+1 IF '$GET(P)
QUIT ""
+2 IF '$DATA(^AUPNVSIT("AC",P))
QUIT ""
+3 NEW A,B,E,T,X,G,V,Y,%,G
+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 IHD DXS (GPRA)",0))
+8 IF 'T
QUIT ""
+9 SET (X,G)=0
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X!(G>2)
QUIT
SET V=$PIECE(^TMP($JOB,"A",X),U,5)
Begin DoDot:1
+10 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+11 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+12 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+13 IF "SAHO"'[$PIECE(^AUPNVSIT(V,0),U,7)
QUIT
+14 IF "V"[$PIECE(^AUPNVSIT(V,0),U,3)
QUIT
+15 IF $PIECE(^AUPNVSIT(V,0),U,6)=""
QUIT
+16 IF $GET(BGPMFITI)
IF '$DATA(^ATXAX(BGPMFITI,21,"B",$PIECE(^AUPNVSIT(V,0),U,6)))
QUIT
+17 SET (D,Y)=0
FOR
SET Y=$ORDER(^AUPNVPOV("AD",V,Y))
IF Y'=+Y!(D)
QUIT
IF $DATA(^AUPNVPOV(Y,0))
SET %=$PIECE(^AUPNVPOV(Y,0),U)
IF $$ICD^ATXCHK(%,T,9)
SET D=1
+18 IF 'D
QUIT
+19 SET G=G+1
+20 QUIT
End DoDot:1
+21 KILL ^TMP($JOB,"A")
+22 QUIT $SELECT(G<2:"",1:1)
+23 ;
