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

BGP4D731.m

Go to the documentation of this file. 
  1. BGP4D731 ; IHS/CMI/LAB - measure AHR.A ;
  1.  ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
  1.  ;
  1.  ;
  1. IPAMT ;EP
  1.  S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPN11,BGPN12,BGPN13,BGPN14,BGPN15,BGPN16,BGPN17,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
  1.  S BGPVALUE=""
  1.  I BGPAGEB<35 S BGPSTOP=1 Q
  1.  I 'BGPACTCL S BGPSTOP=1 Q  ;must be active clinical
  1.  S BGPAMI=$$AMI(DFN,$$FMADD^XLFDT(BGPBDATE,-182),$$FMADD^XLFDT(BGPBDATE,182))
  1.  I '$P(BGPAMI,U) S BGPSTOP=1 Q  ;no ami
  1.  S BGPD1=1
  1.  I $P(^DPT(DFN,0),U,2)="M" S BGPD2=1
  1.  I $P(^DPT(DFN,0),U,2)="F" S BGPD3=1
  1.  S BGPADDAT=$S($P(BGPAMI,U,4)]"":$P(BGPAMI,U,4),1:$P(BGPAMI,U,2))  ;discharge date
  1.  K BGPBETA
  1.  S BGPBETA("RX")=$$BETA^BGP4D721(DFN,BGPADDAT,$$FMADD^XLFDT(BGPADDAT,180),134)
  1.  I BGPBETA("RX") S BGPN2=1  ;pt has 135 days of beta blocker
  1.  ;I 'BGPN2 S BGPBETA("REF")=$$BETAREF^BGP4D721(DFN,$P(BGPAMI,U,2),$$FMADD^XLFDT(BGPADDAT,180)) I BGPBETA("REF") S BGPN3=1
  1.  I 'BGPN2 S BGPBETA("CONTRA")=$$BETACONT^BGP4D721(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE,$P(BGPAMI,U,2),$$FMADD^XLFDT(BGPADDAT,180)) I BGPBETA("CONTRA") S BGPN4=1 ;beta Contraindication
  1.  I 'BGPN2 S BGPBETA("ADR")=$$BETAALG1^BGP4D72(DFN,$$FMADD^XLFDT(BGPADDAT,180)) I BGPBETA("ADR") S BGPN4=1
  1.  I (BGPN2+BGPN4) S BGPN1=1
  1.  K BGPASA
  1.  S BGPASA("RX")=$$ASA^BGP4D721(DFN,BGPADDAT,$$FMADD^XLFDT(BGPADDAT,180),134)  ;get 1_U_# days
  1.  I BGPASA("RX") S BGPN6=1  ;pt has 135 days of beta blocker
  1.  ;I 'BGPN6 S BGPASA("REF")=$$ASAREF^BGP4D721(DFN,$P(BGPAMI,U,2),$$FMADD^XLFDT(BGPADDAT,180)) I BGPASA("REF") S BGPN7=1
  1.  I 'BGPN6 S BGPASA("CONTRA")=$$ASACONTR(DFN,$P(BGPAMI,U,2),$$FMADD^XLFDT(BGPADDAT,180),$$DOB^AUPNPAT(DFN),BGPEDATE) I BGPASA("CONTRA") S BGPN8=1 ;beta Contraindication
  1.  I 'BGPN6 S BGPASA("ADR")=$$ASAALLEG^BGP4D721(DFN,$$FMADD^XLFDT(BGPADDAT,180)) I BGPASA("ADR") S BGPN8=1
  1.  I (BGPN6+BGPN8) S BGPN5=1
  1.  K BGPACE
  1.  S BGPACE("RX")=$$ACERX^BGP4D722(DFN,BGPADDAT,$$FMADD^XLFDT(BGPADDAT,180),134)  ;get 1_U_# days
  1.  I BGPACE("RX") S BGPN10=1  ;pt has 135 days of ACE
  1.  ;I 'BGPN10 S BGPACE("REF")=$$ACEREF^BGP4D722(DFN,$P(BGPAMI,U,2),$$FMADD^XLFDT(BGPADDAT,180)) I BGPACE("REF") S BGPN11=1
  1.  I 'BGPN10 S BGPACE("CONTRA")=$$ACECONT^BGP4D722(DFN,$$DOB^AUPNPAT(DFN),BGPEDATE,$P(BGPAMI,U,2),$$FMADD^XLFDT(BGPADDAT,180),BGPBDATE) I BGPACE("CONTRA") S BGPN12=1 ;beta Contraindication
  1.  I 'BGPN10 S BGPACE("ADR")=$$ACEALG^BGP4D722(DFN,BGPBDATE,$$FMADD^XLFDT(BGPADDAT,180)) I BGPACE("ADR") S BGPN12=1
  1.  I (BGPN10+BGPN12) S BGPN9=1
  1.  K BGPSTAT
  1.  S BGPSTAT("RX")=$$STATRX^BGP4D722(DFN,BGPADDAT,$$FMADD^XLFDT(BGPADDAT,180),134)  ;get 1_U_# days
  1.  I BGPSTAT("RX") S BGPN14=1  ;pt has 135 days of STAT
  1.  ;I 'BGPN14 S BGPSTAT("REF")=$$STATREF^BGP4D722(DFN,$P(BGPAMI,U,2),$$FMADD^XLFDT(BGPADDAT,180)) I BGPSTAT("REF") S BGPN15=1
  1.  I 'BGPN14 S BGPSTAT("CONTRA")=$$STATCON^BGP4D722(DFN,BGPADDAT,$$FMADD^XLFDT(BGPADDAT,180),BGPADDAT,$$FMADD^XLFDT(BGPADDAT,180)) I BGPSTAT("CONTRA") S BGPN16=1 ;beta Contraindication
  1.  I 'BGPN14 S BGPSTAT("ADR")=$$STATALG^BGP4D722(DFN,$$DOB^AUPNPAT(DFN),$$FMADD^XLFDT(BGPADDAT,180),BGPADDAT,$$FMADD^XLFDT(BGPADDAT,180)) I BGPSTAT("ADR") S BGPN16=1
  1.  I (BGPN14+BGPN16) S BGPN13=1
  1.  I BGPN1,BGPN5,BGPN9,BGPN13 S BGPN17=1
  1.  S BGPVALUE="AC|||"
  1.  S BGPVALUE=BGPVALUE_$S(BGPN17:"ALL MEDS:",1:"")
  1.  I BGPN2!(BGPN3)!(BGPN4) S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":" ",1:"") S BGPVALUE=BGPVALUE_"BETA: " F X="RX","REF","CONTRA","ADR" I $P($G(BGPBETA(X)),U,1),$P($G(BGPBETA(X)),U,2)]"" D
  1.  .S BGPVALUE=BGPVALUE_$P(BGPBETA(X),U,2)_$S($P(BGPBETA(X),U,3)]"":" "_$P(BGPBETA(X),U,3),1:"")
  1.  I BGPN6!(BGPN7)!(BGPN8) S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":"; ",1:"") S BGPVALUE=BGPVALUE_"ASA: " F X="RX","REF","CONTRA","ADR" I $P($G(BGPASA(X)),U,1),$P($G(BGPASA(X)),U,2)]"" D
  1.  .S BGPVALUE=BGPVALUE_$P(BGPASA(X),U,2)_$S($P(BGPASA(X),U,3)]"":" "_$P(BGPASA(X),U,3),1:"")
  1.  I BGPN10!(BGPN11)!(BGPN12) S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":"; ",1:"") S BGPVALUE=BGPVALUE_"ACEI/ARB: " F X="RX","REF","CONTRA","ADR" I $P($G(BGPACE(X)),U,1),$P($G(BGPACE(X)),U,2)]"" D
  1.  .S BGPVALUE=BGPVALUE_$P(BGPACE(X),U,2)_$S($P(BGPACE(X),U,3)]"":" "_$P(BGPACE(X),U,3),1:"")
  1.  I BGPN14!(BGPN15)!(BGPN16) S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":"; ",1:"") S BGPVALUE=BGPVALUE_"STATIN: " F X="RX","REF","CONTRA","ADR" I $P($G(BGPSTAT(X)),U,1),$P($G(BGPSTAT(X)),U,2)]"" D
  1.  .S BGPVALUE=BGPVALUE_$P(BGPSTAT(X),U,2)_$S($P(BGPSTAT(X),U,3)]"":" "_$P(BGPSTAT(X),U,3),1:"")
  1.  K ^TMP($J)
  1.  Q  ;old stuff below
  1.  I BGPN2!(BGPN3)!(BGPN4) S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":" ",1:"") S BGPVALUE=BGPVALUE_"BETA: " F X="RX","REF","CONTRA","ADR" I $P($G(BGPBETA(X)),U,1),$P($G(BGPBETA(X)),U,2)]"" S BGPVALUE=BGPVALUE_$P(BGPBETA(X),U,2)_" DAYS"
  1.  I BGPN6!(BGPN7)!(BGPN8) S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":"; ",1:"") S BGPVALUE=BGPVALUE_"ASA: " F X="RX","REF","CONTRA","ADR" I $P($G(BGPASA(X)),U,1),$P($G(BGPASA(X)),U,2)]"" S BGPVALUE=BGPVALUE_$P(BGPASA(X),U,2)
  1.  I BGPN10!(BGPN11)!(BGPN12) S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":"; ",1:"") S BGPVALUE=BGPVALUE_"ACEI/ARB: " F X="RX","REF","CONTRA","ADR" I $P($G(BGPACE(X)),U,1),$P($G(BGPACE(X)),U,2)]"" S BGPVALUE=BGPVALUE_$P(BGPACE(X),U,2)
  1.  I BGPN14!(BGPN15)!(BGPN16) S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,"|||",2)]"":"; ",1:"") S BGPVALUE=BGPVALUE_"STATIN: " F X="RX","REF","CONTRA","ADR" I $P($G(BGPSTAT(X)),U,1),$P($G(BGPSTAT(X)),U,2)]"" S BGPVALUE=BGPVALUE_$P(BGPSTAT(X),U,2)
  1.  K BGPIHD,BGPBETA,BGPMEDS1,BGPASA,BGPACE,BGPSTAT
  1.  K ^TMP($J)
  1.  Q
  1. AMI(P,BDATE,EDATE) ;
  1.  ;look for any H with AMI discharge dx
  1.  K ^TMP($J,"A"),G
  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 0
  1.  S T=$O(^ATXAX("B","BGP AMI DXS PAMT",0))
  1.  S (BGPX,G,M,D,E)=0 F  S BGPX=$O(^TMP($J,"A",BGPX)) Q:BGPX'=+BGPX  S V=$P(^TMP($J,"A",BGPX),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:"AOSH"'[$P(^AUPNVSIT(V,0),U,7)
  1.  .S H=0
  1.  .I $P(^AUPNVSIT(V,0),U,7)="H" S H=$O(^AUPNVINP("AD",V,0)) D  Q:'B
  1.  ..S B=0
  1.  ..I 'H Q
  1.  ..Q:$$AMA^BGP4D72(H)  ;ama
  1.  ..Q:$$TRANS^BGP4D72(H)  ;transferred
  1.  ..Q:$$EXPIRED^BGP4D72(H)  ;died
  1.  ..S B=1
  1.  .S (D,Y)=0 F  S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(D)  I $D(^AUPNVPOV(Y,0))  D
  1.  ..S %=$P(^AUPNVPOV(Y,0),U) Q:'$$ICD^BGP4UTL2(%,T,9)
  1.  ..I $P(^AUPNVPOV(Y,0),U,6)]"",$P(^AUPNVPOV(Y,0),U,6)'="F" Q  ;modifier
  1.  ..S N=$$VAL^XBDIQ1(9000010.07,Y,.04)
  1.  ..S N=$$UP^XLFSTR(N)
  1.  ..I $E(N,1,8)="CONSIDER" Q
  1.  ..I $E(N,1,8)="DOUBTFUL" Q
  1.  ..I $E(N,1,5)="MAYBE" Q
  1.  ..I $E(N,1,8)="POSSIBLE" Q
  1.  ..I $E(N,1,7)="PERHAPS" Q
  1.  ..I $E(N,1,8)="RULE OUT" Q
  1.  ..I $E(N,1,3)="R/O" Q
  1.  ..I $E(N,1,8)="PROBABLE" Q
  1.  ..I $E(N,1,8)="RESOLVED" Q
  1.  ..I $E(N,1,7)="SUSPECT" Q
  1.  ..I $E(N,1,10)="SUSPICIOUS" Q
  1.  ..I $E(N,1,11)="STATUS POST" Q
  1.  ..S D=1
  1.  .I D S G=G+1,G($P($P(^AUPNVSIT(V,0),U),"."))=V ;got one visit
  1.  I 'G Q G
  1.  S D=$O(G(0)),V=G(D),H=$O(^AUPNVINP("AD",V,0))
  1.  Q 1_U_$O(G(0))_U_V_U_$S(H:$P($P(^AUPNVINP(H,0),U),"."),1:"")_U_H
  1. ASACONTR(P,BGPADM,BGPDD,BDATE,EDATE) ;does patient have an aspirin allergy
  1.  K BGPMEDS1
  1.  S K=0,R="",BGPG=""
  1.  D GETMEDS^BGP4UTL2(P,$$FMADD^XLFDT(BGPADM,-90),BGPDD,,,,,.BGPMEDS1)
  1.  I '$D(BGPMEDS1) Q ""
  1.  S T=$O(^ATXAX("B","BGP CMS WARFARIN MEDS",0))
  1.  S X=0 F  S X=$O(BGPMEDS1(X)) Q:X'=+X  S Y=+$P(BGPMEDS1(X),U,4) D
  1.  .Q:'$D(^AUPNVMED(Y,0))
  1.  .S G=0
  1.  .S D=$P(^AUPNVMED(Y,0),U)
  1.  .I T,$D(^ATXAX(T,21,"B",D)) S G=1 G WAR71
  1.  .S N=$P($G(^PSDRUG(D,0)),U,1)
  1.  .I N["WARFARIN" S G=1 G WAR71
  1.  .I $$VAPI^BGP4D81(D,$O(^ATXAX("B","BGP CMS WARFARIN VAPI",0))) S G=1 G WAR71
  1.  .Q:'G
  1. WAR71 .;
  1.  .S J=$P(^AUPNVMED(Y,0),U,8)
  1.  .S V=$P(^AUPNVMED(Y,0),U,3)
  1.  .Q:'V
  1.  .Q:'$D(^AUPNVSIT(V,0))
  1.  .;S IS DAYS SUPPLY, J IS DATE DISCONTINUED
  1.  .I J]"" Q:J<BGPADM  ;discontinued before admission
  1.  .S E=$P($P(^AUPNVSIT(V,0),U),".")
  1.  .I E'<BGPADM,E'>BGPDD S BGPG=1_U_$$DATE^BGP4UTL(E)_U_$P(^PSDRUG(D,0),U)
  1.  .S S=$P(^AUPNVMED(Y,0),U,7)
  1.  .S Z=$$FMDIFF^XLFDT(BGPADM,$P($P(^AUPNVSIT(V,0),U),"."))
  1.  .I S>Z S BGPG=1_U_$$DATE^BGP4UTL($P($P(^AUPNVSIT(V,0),U),"."))_U_" Contra "_$P(^PSDRUG(D,0),U)
  1.  .Q
  1.  I BGPG Q BGPG
  1.  ;now check for dx 459
  1.  K BGPG S BGPG=$$LASTDX^BGP4UTL1(P,"BGP HEMORRHAGE DXS",$$DOB^AUPNPAT(P),EDATE)
  1.  I BGPG Q 1_U_"asa Contra "_$P(BGPG,U,2)_" "_$$DATE^BGP4UTL($P(BGPG,U,3))
  1.  ;
  1.  ;nmi in Refusal file for aspirin
  1.  S BGPG=""
  1.  S T=$O(^ATXAX("B","DM AUDIT ASPIRIN DRUGS",0))
  1.  S X=0 F  S X=$O(^AUPNPREF("AA",P,50,X)) Q:X'=+X  D
  1.  .Q:'$D(^ATXAX(T,21,"B",X))  ;not an aspirin
  1.  .S D=0 F  S D=$O(^AUPNPREF("AA",P,50,X,D)) Q:D'=+D  D
  1.  ..I Y>EDATE Q  ;documented EDATE OF REPORT PERIOD
  1.  ..S N=0 F  S N=$O(^AUPNPREF("AA",P,50,X,D,N)) Q:N'=+N  D
  1.  ...Q:$P($G(^AUPNPREF(N,0)),U,7)'="N"
  1.  ...S BGPG=1_U_$$DATE^BGP4UTL($P(^AUPNPREF(N,0),U,3))_" Contra NMI "_$$VAL^XBDIQ1(9000022,N,.04)  ;_" "_" "_$$VAL^XBDIQ1(9000022,X,1101)
  1.  ..Q
  1.  .Q
  1.  I BGPG Q BGPG
  1.  ;now check for CPT code G8008
  1.  S X=$$CPTI^BGP4DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G8008"))
  1.  I X Q 1_U_$$DATE^BGP4UTL($P(X,U,2))_U_" Contra CPT G8008"
  1.  S X=$$TRANI^BGP4DU(P,BDATE,EDATE,+$$CODEN^ICPTCOD("G8008"))
  1.  I X Q 1_U_$$DATE^BGP4UTL($P(X,U,2))_U_" Contra CPT/TRAN G8008"
  1.  Q ""