BGP7D729 ; IHS/CMI/LAB - measure AHR.A ;
;;17.1;IHS CLINICAL REPORTING;;MAY 10, 2017;Build 29
;
;
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^BGP7D1(P,BDATE,EDATE) Q "" ;not 2 visits during report period
K ^TMP($J)
I '$$CHDV(P,$$DOB^AUPNPAT(P),$$FMADD^XLFDT(BDATE,-1),0,0) Q "" ;first dx not prior to report period
;GET CHD DIAGNOSES AND SET BY VISIT
I '$$CHDV(P,$$DOB^AUPNPAT(P),EDATE,1,1) Q "" ;not two ever
Q 1
CHDV(P,BDATE,EDATE,MIN,MINPROC) ;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))
I 'T G CHDP
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)=""
.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^BGP7UTL2(%,T,9) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
I BGPCNT>MIN Q 1
CHDP ;NOW CHECK FOR MINPROC
;S BGPCNT=0
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)=""
.S T1=$O(^ATXAX("B","BGP PCI DXS",0))
.S T2=$O(^ATXAX("B","BGP CABG DXS",0))
.S (D,Y)=0 F S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(BGPCNT>MINPROC) I $D(^AUPNVPOV(Y,0)) D
..S %=$P(^AUPNVPOV(Y,0),U)
..;I $$ICD^BGP7UTL2(%,T,9) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
..I $$ICD^BGP7UTL2(%,T1,9) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
..I $$ICD^BGP7UTL2(%,T2,9) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
.;check for procedure in BGP CABG PROCS
.S E=$O(^ATXAX("B","BGP CABG PROCS",0))
.S F=$O(^ATXAX("B","BGP PCI CM PROCS",0))
.S Y=0 F S Y=$O(^AUPNVPRC("AD",V,Y)) Q:Y'=+Y!(BGPCNT>MINPROC) D
..Q:'$D(^AUPNVPRC(Y,0))
..I $$ICD^BGP7UTL2($P(^AUPNVPRC(Y,0),U,1),E,0) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
..I $$ICD^BGP7UTL2($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 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>MINPROC) D
..Q:'$D(^AUPNVCPT(Y,0))
..I $$ICD^BGP7UTL2($P(^AUPNVCPT(Y,0),U,1),E,1) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
..I $$ICD^BGP7UTL2($P(^AUPNVCPT(Y,0),U,1),F,1) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
..;I $$ICD^BGP7UTL2($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 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>MINPROC) D
..Q:'$D(^AUPNVTC(Y,0))
..S I=$P(^AUPNVTC(Y,0),U,7)
..Q:I=""
..I $$ICD^BGP7UTL2(I,E,1) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
..I $$ICD^BGP7UTL2(I,F,1) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
..;I $$ICD^BGP7UTL2(I,G,1) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
.Q
I BGPCNT>MIN Q 1
Q ""
BGP7D729 ; IHS/CMI/LAB - measure AHR.A ;
+1 ;;17.1;IHS CLINICAL REPORTING;;MAY 10, 2017;Build 29
+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^BGP7D1(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,0)
QUIT ""
+7 ;GET CHD DIAGNOSES AND SET BY VISIT
+8 ;not two ever
IF '$$CHDV(P,$$DOB^AUPNPAT(P),EDATE,1,1)
QUIT ""
+9 QUIT 1
CHDV(P,BDATE,EDATE,MIN,MINPROC) ;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 IF 'T
GOTO CHDP
+9 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
+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 ;Q:"V"[$P(^AUPNVSIT(V,0),U,3)
+15 IF $PIECE(^AUPNVSIT(V,0),U,6)=""
QUIT
+16 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
+17 SET %=$PIECE(^AUPNVPOV(Y,0),U)
+18 IF $$ICD^BGP7UTL2(%,T,9)
IF '$DATA(BGPALL(V))
SET BGPALL(V)=""
SET BGPCNT=BGPCNT+1
QUIT
End DoDot:2
End DoDot:1
+19 IF BGPCNT>MIN
QUIT 1
CHDP ;NOW CHECK FOR MINPROC
+1 ;S BGPCNT=0
+2 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
+3 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+4 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+5 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+6 ;Q:"SAHO"'[$P(^AUPNVSIT(V,0),U,7)
+7 ;Q:"V"[$P(^AUPNVSIT(V,0),U,3)
+8 IF $PIECE(^AUPNVSIT(V,0),U,6)=""
QUIT
+9 SET T1=$ORDER(^ATXAX("B","BGP PCI DXS",0))
+10 SET T2=$ORDER(^ATXAX("B","BGP CABG DXS",0))
+11 SET (D,Y)=0
FOR
SET Y=$ORDER(^AUPNVPOV("AD",V,Y))
IF Y'=+Y!(BGPCNT>MINPROC)
QUIT
IF $DATA(^AUPNVPOV(Y,0))
Begin DoDot:2
+12 SET %=$PIECE(^AUPNVPOV(Y,0),U)
+13 ;I $$ICD^BGP7UTL2(%,T,9) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
+14 IF $$ICD^BGP7UTL2(%,T1,9)
IF '$DATA(BGPALL(V))
SET BGPALL(V)=""
SET BGPCNT=BGPCNT+1
QUIT
+15 IF $$ICD^BGP7UTL2(%,T2,9)
IF '$DATA(BGPALL(V))
SET BGPALL(V)=""
SET BGPCNT=BGPCNT+1
QUIT
End DoDot:2
+16 ;check for procedure in BGP CABG PROCS
+17 SET E=$ORDER(^ATXAX("B","BGP CABG PROCS",0))
+18 SET F=$ORDER(^ATXAX("B","BGP PCI CM PROCS",0))
+19 SET Y=0
FOR
SET Y=$ORDER(^AUPNVPRC("AD",V,Y))
IF Y'=+Y!(BGPCNT>MINPROC)
QUIT
Begin DoDot:2
+20 IF '$DATA(^AUPNVPRC(Y,0))
QUIT
+21 IF $$ICD^BGP7UTL2($PIECE(^AUPNVPRC(Y,0),U,1),E,0)
IF '$DATA(BGPALL(V))
SET BGPALL(V)=""
SET BGPCNT=BGPCNT+1
QUIT
+22 IF $$ICD^BGP7UTL2($PIECE(^AUPNVPRC(Y,0),U,1),F,0)
IF '$DATA(BGPALL(V))
SET BGPALL(V)=""
SET BGPCNT=BGPCNT+1
End DoDot:2
+23 ;now check cpts
+24 SET E=$ORDER(^ATXAX("B","BGP CABG CPTS",0))
+25 SET F=$ORDER(^ATXAX("B","BGP PCI CPTS",0))
+26 ;S G=$O(^ATXAX("B","BGP PTCA CPTS",0))
+27 SET Y=0
FOR
SET Y=$ORDER(^AUPNVCPT("AD",V,Y))
IF Y'=+Y!(BGPCNT>MINPROC)
QUIT
Begin DoDot:2
+28 IF '$DATA(^AUPNVCPT(Y,0))
QUIT
+29 IF $$ICD^BGP7UTL2($PIECE(^AUPNVCPT(Y,0),U,1),E,1)
IF '$DATA(BGPALL(V))
SET BGPALL(V)=""
SET BGPCNT=BGPCNT+1
QUIT
+30 IF $$ICD^BGP7UTL2($PIECE(^AUPNVCPT(Y,0),U,1),F,1)
IF '$DATA(BGPALL(V))
SET BGPALL(V)=""
SET BGPCNT=BGPCNT+1
QUIT
+31 ;I $$ICD^BGP7UTL2($P(^AUPNVCPT(Y,0),U,1),G,1) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
End DoDot:2
+32 ;now check TRANS
+33 SET E=$ORDER(^ATXAX("B","BGP CABG CPTS",0))
+34 SET F=$ORDER(^ATXAX("B","BGP PCI CPTS",0))
+35 ;S G=$O(^ATXAX("B","BGP PTCA CPTS",0))
+36 SET Y=0
FOR
SET Y=$ORDER(^AUPNVTC("AD",V,Y))
IF Y'=+Y!(BGPCNT>MINPROC)
QUIT
Begin DoDot:2
+37 IF '$DATA(^AUPNVTC(Y,0))
QUIT
+38 SET I=$PIECE(^AUPNVTC(Y,0),U,7)
+39 IF I=""
QUIT
+40 IF $$ICD^BGP7UTL2(I,E,1)
IF '$DATA(BGPALL(V))
SET BGPALL(V)=""
SET BGPCNT=BGPCNT+1
QUIT
+41 IF $$ICD^BGP7UTL2(I,F,1)
IF '$DATA(BGPALL(V))
SET BGPALL(V)=""
SET BGPCNT=BGPCNT+1
QUIT
+42 ;I $$ICD^BGP7UTL2(I,G,1) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
End DoDot:2
+43 QUIT
End DoDot:1
+44 IF BGPCNT>MIN
QUIT 1
+45 QUIT ""
