Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BGP4D729

BGP4D729.m

Go to the documentation of this file. 
  1. BGP4D729 ; IHS/CMI/LAB - measure AHR.A ;
  1.  ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
  1.  ;
  1.  ;
  1. CHD(P,BDATE,EDATE) ;EP
  1.  ;first dx prior to report period
  1.  ;at least 2 visits during report period
  1.  ;at least 2 Chd dxs ever
  1.  I '$$V2^BGP4D1(P,BDATE,EDATE) Q ""  ;not 2 visits during report period
  1.  K ^TMP($J)
  1.  I '$$CHDV(P,$$DOB^AUPNPAT(P),$$FMADD^XLFDT(BDATE,-1),0,0) Q ""  ;first dx not prior to report period
  1.  ;GET CHD DIAGNOSES AND SET BY VISIT
  1.  I '$$CHDV(P,$$DOB^AUPNPAT(P),EDATE,1,1) Q ""  ;not two ever
  1.  Q 1
  1. CHDV(P,BDATE,EDATE,MIN,MINPROC) ;EP
  1.  NEW A,B,E,T,X,G,V,Y,%,G,F,BGPG,BGPCNT,T1,BGPALL
  1.  K BGPALL
  1.  S BGPCNT=0
  1.  K ^TMP($J,"A")
  1.  S A="^TMP($J,""A"",",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
  1.  I '$D(^TMP($J,"A",1)) Q ""
  1.  S T=$O(^ATXAX("B","BGP CHD DXS",0))
  1.  I 'T G CHDP
  1.  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
  1.  .Q:'$D(^AUPNVSIT(V,0))
  1.  .Q:'$P(^AUPNVSIT(V,0),U,9)
  1.  .Q:$P(^AUPNVSIT(V,0),U,11)
  1.  .Q:"SAHO"'[$P(^AUPNVSIT(V,0),U,7)
  1.  .Q:"V"[$P(^AUPNVSIT(V,0),U,3)
  1.  .Q:$P(^AUPNVSIT(V,0),U,6)=""
  1.  .I $G(BGPMFITI),'$D(^ATXAX(BGPMFITI,21,"B",$P(^AUPNVSIT(V,0),U,6))) Q
  1.  .S (D,Y)=0 F  S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(BGPCNT>MIN)  I $D(^AUPNVPOV(Y,0)) D
  1.  ..S %=$P(^AUPNVPOV(Y,0),U)
  1.  ..I $$ICD^BGP4UTL2(%,T,9) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
  1.  ..;I $$ICD^BGP4UTL2(%,T1,9) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
  1.  ..;I $$ICD^BGP4UTL2(%,T2,9) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
  1.  I BGPCNT>MIN Q 1
  1. CHDP ;NOW CHECK FOR MINPROC
  1.  ;S BGPCNT=0
  1.  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
  1.  .Q:'$D(^AUPNVSIT(V,0))
  1.  .Q:'$P(^AUPNVSIT(V,0),U,9)
  1.  .Q:$P(^AUPNVSIT(V,0),U,11)
  1.  .Q:"SAHO"'[$P(^AUPNVSIT(V,0),U,7)
  1.  .Q:"V"[$P(^AUPNVSIT(V,0),U,3)
  1.  .Q:$P(^AUPNVSIT(V,0),U,6)=""
  1.  .I $G(BGPMFITI),'$D(^ATXAX(BGPMFITI,21,"B",$P(^AUPNVSIT(V,0),U,6))) Q
  1.  .S T1=$O(^ATXAX("B","BGP PCI DXS",0))
  1.  .S T2=$O(^ATXAX("B","BGP CABG DXS",0))
  1.  .S (D,Y)=0 F  S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(BGPCNT>MINPROC)  I $D(^AUPNVPOV(Y,0)) D
  1.  ..S %=$P(^AUPNVPOV(Y,0),U)
  1.  ..;I $$ICD^BGP4UTL2(%,T,9) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
  1.  ..I $$ICD^BGP4UTL2(%,T1,9) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
  1.  ..I $$ICD^BGP4UTL2(%,T2,9) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
  1.  .;check for procedure in BGP CABG PROCS
  1.  .S E=$O(^ATXAX("B","BGP CABG PROCS",0))
  1.  .S F=$O(^ATXAX("B","BGP PCI CM PROCS",0))
  1.  .S Y=0 F  S Y=$O(^AUPNVPRC("AD",V,Y)) Q:Y'=+Y!(BGPCNT>MINPROC)  D
  1.  ..Q:'$D(^AUPNVPRC(Y,0))
  1.  ..I $$ICD^BGP4UTL2($P(^AUPNVPRC(Y,0),U,1),E,0) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
  1.  ..I $$ICD^BGP4UTL2($P(^AUPNVPRC(Y,0),U,1),F,0) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1
  1.  .;now check cpts
  1.  .S E=$O(^ATXAX("B","BGP CABG CPTS",0))
  1.  .S F=$O(^ATXAX("B","BGP PCI CPTS",0))
  1.  .;S G=$O(^ATXAX("B","BGP PTCA CPTS",0))
  1.  .S Y=0 F  S Y=$O(^AUPNVCPT("AD",V,Y)) Q:Y'=+Y!(BGPCNT>MINPROC)  D
  1.  ..Q:'$D(^AUPNVCPT(Y,0))
  1.  ..I $$ICD^BGP4UTL2($P(^AUPNVCPT(Y,0),U,1),E,1) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
  1.  ..I $$ICD^BGP4UTL2($P(^AUPNVCPT(Y,0),U,1),F,1) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
  1.  ..;I $$ICD^BGP4UTL2($P(^AUPNVCPT(Y,0),U,1),G,1) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
  1.  .;now check TRANS
  1.  .S E=$O(^ATXAX("B","BGP CABG CPTS",0))
  1.  .S F=$O(^ATXAX("B","BGP PCI CPTS",0))
  1.  .;S G=$O(^ATXAX("B","BGP PTCA CPTS",0))
  1.  .S Y=0 F  S Y=$O(^AUPNVTC("AD",V,Y)) Q:Y'=+Y!(BGPCNT>MINPROC)  D
  1.  ..Q:'$D(^AUPNVTC(Y,0))
  1.  ..S I=$P(^AUPNVTC(Y,0),U,7)
  1.  ..Q:I=""
  1.  ..I $$ICD^BGP4UTL2(I,E,1) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
  1.  ..I $$ICD^BGP4UTL2(I,F,1) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
  1.  ..;I $$ICD^BGP4UTL2(I,G,1) I '$D(BGPALL(V)) S BGPALL(V)="",BGPCNT=BGPCNT+1 Q
  1.  .Q
  1.  I BGPCNT>MIN Q 1
  1.  Q ""
  1. IHDCCVD(P,BDATE,EDATE) ;EP
  1.  ;first dx prior to report period
  1.  ;at least 2 visits during report period
  1.  ;at least 2 ihd dxs ever
  1.  I '$$V2^BGP4D1(P,BDATE,EDATE) Q ""  ;not 2 visits during report period
  1.  K ^TMP($J)
  1.  I '$$FIRSTIHD(P,EDATE) Q ""  ;first dx not prior to report period
  1.  I '$$V2IHD(P,$$DOB^AUPNPAT(P),EDATE) Q ""  ;at least 2 IHD dxs ever
  1.  Q 1
  1. FIRSTIHD(P,EDATE) ;EP
  1.  I $G(P)="" Q ""
  1.  NEW BGPG,Y,X,E
  1.  K BGPG
  1.  S Y="BGPG("
  1.  S X=P_"^FIRST DX [BGP IHD DXS (GPRA)" S E=$$START1^APCLDF(X,Y)
  1.  I '$D(BGPG(1)) Q ""
  1.  S X=$$FMDIFF^XLFDT(EDATE,$P(BGPG(1),U))
  1.  Q $S(X>365:1,1:"")
  1.  ;
  1. V2IHD(P,BDATE,EDATE) ;EP
  1.  I '$G(P) Q ""
  1.  I '$D(^AUPNVSIT("AC",P)) Q ""
  1.  NEW A,B,E,T,X,G,V,Y,%,G
  1.  K ^TMP($J,"A")
  1.  S A="^TMP($J,""A"",",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
  1.  I '$D(^TMP($J,"A",1)) Q ""
  1.  S T=$O(^ATXAX("B","BGP IHD DXS (GPRA)",0))
  1.  I 'T Q ""
  1.  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
  1.  .Q:'$D(^AUPNVSIT(V,0))
  1.  .Q:'$P(^AUPNVSIT(V,0),U,9)
  1.  .Q:$P(^AUPNVSIT(V,0),U,11)
  1.  .Q:"SAHO"'[$P(^AUPNVSIT(V,0),U,7)
  1.  .Q:"V"[$P(^AUPNVSIT(V,0),U,3)
  1.  .Q:$P(^AUPNVSIT(V,0),U,6)=""
  1.  .I $G(BGPMFITI),'$D(^ATXAX(BGPMFITI,21,"B",$P(^AUPNVSIT(V,0),U,6))) Q
  1.  .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^BGP4UTL2(%,T,9) S D=1
  1.  .Q:'D
  1.  .S G=G+1
  1.  .Q
  1.  K ^TMP($J,"A")
  1.  Q $S(G<2:"",1:1)
  1.  ;