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

BGP5C1.m

Go to the documentation of this file.
  1. BGP5C1 ; IHS/CMI/LAB - calc CMS indicators 26 Sep 2004 11:28 AM 04 May 2005 2:38 PM ;
  1. ;;7.0;IHS CLINICAL REPORTING;;JAN 24, 2007
  1. ;
  1. PROC ;EP
  1. D ^APCDCHKJ
  1. S BGPBT=$H
  1. S BGPJ=$J,BGPH=$H
  1. K ^XTMP("BGP5C1",BGPJ,BGPH),BGPCOUNT
  1. S BGPSD=$$FMADD^XLFDT(BGPBD,-1),BGPSD=BGPSD_".9999"
  1. F S BGPSD=$O(^AUPNVINP("B",BGPSD)) Q:BGPSD=""!($P(BGPSD,".")>BGPED) D
  1. .S BGPVINP=0 F S BGPVINP=$O(^AUPNVINP("B",BGPSD,BGPVINP)) Q:BGPVINP'=+BGPVINP S BGPVSIT=$P($G(^AUPNVINP(BGPVINP,0)),U,3) I BGPVSIT D PROC1
  1. S BGPET=$H
  1. Q
  1. ;
  1. PROC1 ;current time period
  1. Q:'$D(^AUPNVSIT(BGPVSIT,0))
  1. S BGPVSIT0=^AUPNVSIT(BGPVSIT,0)
  1. Q:$P(BGPVSIT0,U,7)'="H"
  1. Q:$P(BGPVSIT0,U,11)
  1. Q:'$P(BGPVSIT0,U,9)
  1. Q:$P(BGPVSIT0,U,6)'=BGPHOSP
  1. Q:$P(BGPVSIT0,U,3)="C"
  1. S DFN=$P(BGPVSIT0,U,5)
  1. Q:$P($G(^DPT(DFN,0)),U)["DEMO,PATIENT"
  1. S BGPIND=0 F S BGPIND=$O(BGPIND(BGPIND)) Q:BGPIND'=+BGPIND D
  1. .S BGPORDER=BGPIND
  1. .X ^BGPCMSIF(BGPIND,1)
  1. Q
  1. AMI ;EP
  1. ;was there an AMI pov on this visit
  1. Q:'$$AMIDX(BGPVSIT)
  1. S BGPX=$P(^DPT(DFN,0),U)_U_$$HRN^AUPNPAT(DFN,DUZ(2))_U_$P(^DPT(DFN,0),U,2)_U_$$AGE^AUPNPAT(DFN,$P($P(BGPVSIT0,U),"."))
  1. S $P(BGPX,U,5)=$$DATE^BGP5UTL($P($P(BGPVSIT0,U),"."))_"-"_$$DATE^BGP5UTL($$DSCH(BGPVINP))
  1. S $P(BGPX,U,6)=$$PRIMPOV^APCLV(BGPVSIT,"C")_" "_$$PRIMPOV^APCLV(BGPVSIT,"N")
  1. S BGPSKIP=0 K BGPZ
  1. I $$AGE^AUPNPAT(DFN,$P($P(BGPVSIT0,U),"."))<18 S BGPX="*"_BGPX,BGPSKIP=1,BGPZ(1)="under 18 yrs of age"
  1. S Z=$$VAL^XBDIQ1(9000010.02,BGPVINP,.06)
  1. S $P(BGPX,U,7)=Z
  1. I $$TRANS(BGPVINP) S:'BGPSKIP BGPX="*"_BGPX S BGPSKIP=1,BGPZ(2)="transferred out"
  1. I $$DSCH(BGPVINP)=$P($P(BGPVSIT0,U),".")&('$$DEATHAMA(BGPVINP)) S:'BGPSKIP BGPX="*"_BGPX S BGPSKIP=1,BGPZ(3)="dsch day of arrival & not AMA or death"
  1. I $$EXPIRED(BGPVINP,$P($P(BGPVSIT0,U),".")) S:'BGPSKIP BGPX="*"_BGPX S BGPSKIP=1,BGPZ(4)="died on day other than arrival date" ;patient expired on any day other than day of arrival
  1. I $$AMA(BGPVINP,$P($P(BGPVSIT0,U),".")) S:'BGPSKIP BGPX="*"_BGPX S BGPSKIP=1,BGPZ(5)="left AMA on day other than arrival date"
  1. S Z=$$VAL^XBDIQ1(9000010.02,BGPVINP,.07)
  1. S $P(BGPX,U,8)=Z
  1. Q:$D(^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 1",$P(^DPT(DFN,0),U),DFN,BGPVSIT))
  1. S ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 1",$P(^DPT(DFN,0),U),DFN,BGPVSIT)=BGPX
  1. K BGPZ1 I $D(BGPZ) S X=0 F S X=$O(BGPZ(X)) Q:X'=+X S:$G(BGPZ1)]"" BGPZ1=BGPZ1_", " S BGPZ1=$G(BGPZ1)_BGPZ(X)
  1. I $D(BGPZ1) S BGPZ1="Exclusions: "_BGPZ1 S $P(^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 1",$P(^DPT(DFN,0),U),DFN,BGPVSIT),U,12)=BGPZ1
  1. S BGPCOUNT("L1",BGPIND)=$G(BGPCOUNT("L1",BGPIND))+1 ;a hit on list 1
  1. ;set up second list after applying exclusions
  1. Q:BGPSKIP ;SKIP THIS ONE
  1. S BGPX=$P(^DPT(DFN,0),U)_U_$$HRN^AUPNPAT(DFN,DUZ(2))_U_$P(^DPT(DFN,0),U,2)_U_$$AGE^AUPNPAT(DFN,$P($P(BGPVSIT0,U),"."))
  1. S $P(BGPX,U,5)=$$DATE^BGP5UTL($P($P(BGPVSIT0,U),"."))_"-"_$$DATE^BGP5UTL($$DSCH(BGPVINP))
  1. S $P(BGPX,U,6)=$$PRIMPOV^APCLV(BGPVSIT,"C")_" "_$$PRIMPOV^APCLV(BGPVSIT,"N")
  1. S $P(BGPX,U,7)=$$VAL^XBDIQ1(9000010.02,BGPVINP,.06)
  1. S $P(BGPX,U,8)=$$VAL^XBDIQ1(9000010.02,BGPVINP,.07)
  1. S ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT)=BGPX
  1. S BGPCOUNT("L2",BGPIND)=$G(BGPCOUNT("L2",BGPIND))+1
  1. ;get other povs
  1. S ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,1,"Other Discharge POVs:")=""
  1. S (X,C)=0 F S X=$O(^AUPNVPOV("AD",BGPVSIT,X)) Q:X'=+X D
  1. .Q:'$D(^AUPNVPOV(X,0))
  1. .Q:$P(^AUPNVPOV(X,0),U,12)="P"
  1. .S I=$P(^AUPNVPOV(X,0),U),I=$P($$ICDDX^ICDCODE(I),U,2)
  1. .S N=$$VAL^XBDIQ1(9000010.07,X,.04),N=$$UP^XLFSTR(N)
  1. .S C=C+1
  1. .S ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,1,"Other Discharge POVs:",C)=I,$E(^(C),9)=N
  1. .Q
  1. ASAALG ;
  1. S ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,2,"Aspirin Allergy?")=""
  1. K BGPASAAL
  1. D ASAALLEG(DFN,$$DSCH(BGPVINP),.BGPASAAL) ;return text of aspirin allergy if found
  1. I $D(BGPASAAL) S ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,2,"Aspirin Allergy?")=""
  1. S X=0 F S X=$O(BGPASAAL(X)) Q:X'=+X D
  1. .S ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,2,"Aspirin Allergy?",X)=BGPASAAL(X)
  1. ASACONT ;
  1. S ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,3,"Other Aspirin Exclusion:")=""
  1. K BGPASAAL
  1. D ASACONTR(DFN,$P($P(BGPVSIT0,U),"."),$$DSCH(BGPVINP),BGPVSIT,.BGPASAAL)
  1. I $D(BGPASAAL) S ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,3,"Other Aspirin Exclusion:")=""
  1. S X=0 F S X=$O(BGPASAAL(X)) Q:X'=+X D
  1. .S ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,3,"Other Aspirin Exclusion:",X)=BGPASAAL(X)
  1. ASARX ;
  1. S ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,4,"Aspirin Rx Status?")=""
  1. K BGPASAAL
  1. D ASARX1(DFN,$P($P(BGPVSIT0,U),"."),$$DSCH(BGPVINP),.BGPASAAL)
  1. S X=0 F S X=$O(BGPASAAL(X)) Q:X'=+X D
  1. .S ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,4,"Aspirin Rx Status?",X)=BGPASAAL(X)
  1. WARRX ;gather up warfarin meds
  1. S ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,5,"Warfarin/Coumadin Rx Status?")=""
  1. K BGPASAAL
  1. D WARRX1(DFN,$P($P(BGPVSIT0,U),"."),$$DSCH(BGPVINP),.BGPASAAL)
  1. S X=0 F S X=$O(BGPASAAL(X)) Q:X'=+X D
  1. .S ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,5,"Warfarin/Coumadin Rx Status?",X)=BGPASAAL(X)
  1. ANTIRX ;gather up warfarin meds
  1. S ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,6,"Other Anti-Platelet Rx Status?")=""
  1. K BGPASAAL
  1. D ANTIRX1(DFN,$P($P(BGPVSIT0,U),"."),$$DSCH(BGPVINP),.BGPASAAL)
  1. S X=0 F S X=$O(BGPASAAL(X)) Q:X'=+X D
  1. .S ^XTMP("BGP5C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,6,"Other Anti-Platelet Rx Status?",X)=BGPASAAL(X)
  1. D EN^BGP5C11 ;continue on with this indicator
  1. Q
  1. GETMEDS(P,BGPMBD,BGPMED,TAX1,TAX2,TAX3,EXP,ADM,BGPDNAME) ;EP
  1. K ^TMP($J,"MEDS")
  1. S BGPDNAME=$G(BGPDNAME)
  1. S BGPC1=0 K BGPZ
  1. S Y="^TMP($J,""MEDS"",",X=P_"^ALL MED;DURING "_$$FMTE^XLFDT(BGPMBD)_"-"_$$FMTE^XLFDT(BGPMED) S E=$$START1^APCLDF(X,Y)
  1. S T="" I TAX1]"" S T=$O(^ATXAX("B",TAX1,0))
  1. S T1="" I TAX2]"" S T1=$O(^ATXAX("B",TAX2,0))
  1. S T2="" I TAX3]"" S T2=$O(^ATXAX("B",TAX3,0))
  1. S X=0 F S X=$O(^TMP($J,"MEDS",X)) Q:X'=+X S Y=+$P(^TMP($J,"MEDS",X),U,4) D
  1. .Q:'$D(^AUPNVMED(Y,0))
  1. .S G=0
  1. .S D=$P(^AUPNVMED(Y,0),U)
  1. .S C=$P($G(^PSDRUG(D,0)),U,2)
  1. .I C]"",T2,$D(^ATXAX(T2,21,"B",C)) S G=1
  1. .S C=$P($G(^PSDRUG(D,2)),U,4)
  1. .I C]"",T1,$D(^ATXAX(T1,21,"B",C)) S G=1
  1. .I T,$D(^ATXAX(T,21,"B",D)) S G=1
  1. .I BGPDNAME]"",$P(^PSDRUG(D,0),U)[BGPDNAME S G=1
  1. .I $G(EXP) Q:$$EXP(Y,X,ADM)
  1. .I G=1 S BGPZ($P(^TMP($J,"MEDS",X),U,2),(9999999-$P(^TMP($J,"MEDS",X),U)))=$P(^TMP($J,"MEDS",X),U,2)_" "_$P(^AUPNVMED(Y,0),U,5)_" qty: "_$P(^AUPNVMED(Y,0),U,6)_" days: "_$P(^AUPNVMED(Y,0),U,7)_" "_$$DATE^BGP5UTL($P(^TMP($J,"MEDS",X),U))
  1. .Q
  1. S N="" F S N=$O(BGPZ(N)) Q:N="" D
  1. .S D=0,D=$O(BGPZ(N,D)) I '$D(BGPY("B",N,D)) S BGPC=BGPC+1,BGPY(BGPC)=BGPZ(N,D),BGPY("B",N,D)=""
  1. Q
  1. EXP(Y,Z,ADM) ;
  1. NEW G
  1. S G=0 ;not expired
  1. S N=$P($G(^AUPNVMED(Y,0)),U,7) ;DAYS SUPPLY
  1. S Z=$S($D(^PSRX("APCC",Y)):$O(^(Y,0)),1:0) I Z D
  1. .S E=$P($G(^PSRX(Z,2)),U,6)
  1. .I E<ADM S G=1 ;prescription expired prior to admission date
  1. I $$FMADD^XLFDT(^TMP($J,"MEDS",X),N)<ADM S G=0
  1. Q G
  1. ASARX1(P,BGPA,BGPD,BGPY) ;
  1. ;get last aspirin rx before date of adm
  1. NEW BGPG,BGPC,X,Y,Z,E,BD,ED,G,D
  1. S BGPC=0 K BGPY
  1. S ED=$$FMADD^XLFDT(BGPA,-1)
  1. S BD=$$FMADD^XLFDT(BGPA,-365)
  1. D GETMEDS(P,BD,ED,"DM AUDIT ASPIRIN DRUGS","BGP CMS ASPIRIN DRUGS NDC","BGP CMS ASPIRIN DRUGS CLASS")
  1. ;get ud/iv prior to admission
  1. S BD=BGPA
  1. S ED=$$FMADD^XLFDT(BGPD,30)
  1. D GETMEDS(P,BD,ED,"DM AUDIT ASPIRIN DRUGS","BGP CMS ASPIRIN DRUGS NDC","BGP CMS ASPIRIN DRUGS CLASS")
  1. K BGPG
  1. Q
  1. WARRX1(P,BGPA,BGPD,BGPY) ;
  1. ;get last aspirin rx before date of adm
  1. NEW BGPC,X,Y,Z,E,BD,ED
  1. S BGPC=0 K BGPY
  1. S ED=$$FMADD^XLFDT(BGPA,-1)
  1. S BD=$$FMADD^XLFDT(BGPA,-365)
  1. D GETMEDS(P,BD,ED,"BGP CMS WARFARIN MEDS","BGP CMS WARFARIN MEDS NDC","BGP CMS WARFARIN MEDS CLASS",,,"WARFARIN")
  1. S BD=BGPA
  1. S ED=$$FMADD^XLFDT(BGPD,30)
  1. D GETMEDS(P,BD,ED,"BGP CMS WARFARIN MEDS","BGP CMS WARFARIN MEDS NDC","BGP CMS WARFARIN MEDS CLASS",,,"WARFARIN")
  1. Q
  1. ANTIRX1(P,BGPA,BGPD,BGPY) ;
  1. ;get last aspirin rx before date of adm
  1. NEW BGPC,X,Y,Z,E,BD,ED
  1. S BGPC=0 K BGPY
  1. S ED=$$FMADD^XLFDT(BGPA,-1)
  1. S BD=$$FMADD^XLFDT(BGPA,-365)
  1. D GETMEDS(P,BD,ED,"DM AUDIT ANTI-PLATELET DRUGS","DM AUDIT ANTI-PLATELET NDC","DM AUDIT ANTI-PLATELET CLASS")
  1. S BD=BGPA
  1. S ED=$$FMADD^XLFDT(BGPD,30)
  1. D GETMEDS(P,BD,ED,"DM AUDIT ANTI-PLATELET DRUGS","DM AUDIT ANTI-PLATELET NDC","DM AUDIT ANTI-PLATELET CLASS")
  1. Q
  1. ASAALLEG(P,BGPD,BGPY) ;does patient have an aspirin allergy
  1. ;get all povs with 995.0-995.3 with ecode of e935.3 up to discharge date
  1. NEW ED,BD,BGPG,BGPC,X,Y,Z,N
  1. ;BGPD is discharge date
  1. S BGPC=0 K BGPY
  1. S ED=$$FMADD^XLFDT(BGPD,-365)
  1. ASAPOV ;
  1. K BGPG S Y="BGPG(",X=P_"^ALL DX [BGP ASA ALLERGY 995.0-995.3;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_$$FMTE^XLFDT(BGPD) S E=$$START1^APCLDF(X,Y)
  1. S X=0 F S X=$O(BGPG(X)) Q:X'=+X S Y=+$P(BGPG(X),U,4) D
  1. .S N=$$VAL^XBDIQ1(9000010.07,Y,.04),N=$$UP^XLFSTR(N)
  1. .I N["ASPIRIN"!(N["ASA") S BGPC=BGPC+1,BGPY(BGPC)="POV: "_$$DATE^BGP5UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_"] "_N
  1. .S Z=$P(^AUPNVPOV(Y,0),U,9) I Z]"",$P($$ICDDX^ICDCODE(Z),U,2)="E935.3" S BGPC=BGPC+1,BGPY(BGPC)="POV "_$$DATE^BGP5UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_" + E935.3] "_N
  1. .Q
  1. K BGPG S Y="BGPG(",X=P_"^ALL DX V14.8;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(DFN))_"-"_$$FMTE^XLFDT(BGPD) S E=$$START1^APCLDF(X,Y)
  1. S X=0 F S X=$O(BGPG(X)) Q:X'=+X S Y=+$P(BGPG(X),U,4) D
  1. .S N=$$VAL^XBDIQ1(9000010.07,Y,.04),N=$$UP^XLFSTR(N)
  1. .I N["ASPIRIN"!(N["ASA") S BGPC=BGPC+1,BGPY(BGPC)="POV: "_$$DATE^BGP5UTL($P(BGPG(X),U))_" ["_$P(BGPG(X),U,2)_"] "_N
  1. .Q
  1. ;now check problem list for these codes
  1. S T="",T=$O(^ATXAX("B","BGP ASA ALLERGY 995.0-995.3",0))
  1. S X=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X D
  1. .S I=$P($G(^AUPNPROB(X,0)),U),Y=$P($$ICDDX^ICDCODE(I),U,2)
  1. .S N=$$VAL^XBDIQ1(9000011,X,.05),N=$$UP^XLFSTR(N)
  1. .Q:$P(^AUPNPROB(X,0),U,8)>BGPD ;added after discharge date
  1. .I Y="V14.8"!($$ICD^ATXCHK(I,T,9)),N["ASPIRIN"!(N["ASA") S BGPC=BGPC+1,BGPY(BGPC)="PROBLEM LIST: "_$$DATE^BGP5UTL($P(^AUPNPROB(X,0),U,8))_" ["_Y_"] "_N
  1. .Q
  1. ;now check allergy tracking
  1. S X=0 F S X=$O(^GMR(120.8,"B",P,X)) Q:X'=+X D
  1. .Q:$P($G(^GMR(120.8,X,0)),U,26)>BGPD ;entered after discharge date
  1. .S N=$P($G(^GMR(120.8,X,0)),U,2),N=$$UP^XLFSTR(N)
  1. .I N["ASPIRIN" S BGPC=BGPC+1,BGPY(BGPC)="ALLERGY TRACKING: "_$$DATE^BGP5UTL($P(^GMR(120.8,X,0),U,4))_" "_N
  1. Q
  1. ASACONTR(P,BGPA,BGPDDT,BGPV,BGPY) ;does patient have an aspirin allergy
  1. ;get all MEDS and check if still good
  1. NEW ED,BD,BGPG,BGPC,X,Y,Z,N,E
  1. S BGPC=0 K BGPY
  1. S BD=$$FMADD^XLFDT(BGPA,-365)
  1. S ED=$$FMADD^XLFDT(BGPA,-1)
  1. ;
  1. D GETMEDS(P,BD,ED,"BGP CMS WARFARIN MEDS","BGP CMS WARFARIN MEDS NDC","BGP CMS WARFARIN MEDS CLASS",1,BGPA,"WARFARIN")
  1. ;
  1. D GETMEDS(P,BGPDDT,BGPDDT,"BGP CMS WARFARIN MEDS","BGP CMS WARFARIN MEDS NDC","BGP CMS WARFARIN MEDS CLASS",,,"WARFARIN")
  1. ;
  1. S X=0 F S X=$O(^AUPNVPOV("AD",BGPV,X)) Q:X'=+X D
  1. .S I=$P($G(^AUPNVPOV(X,0)),U) Q:'I
  1. .;S I=$P($G(^ICD9(I,0)),U)
  1. .S I=$P($$ICDDX^ICDCODE(I),U,2)
  1. .Q:I'="459.0"
  1. .S BGPC=BGPC+1,BGPY(BGPC)="Hemorrhage dx during admission: ["_I_"] "_$$VAL^XBDIQ1(9000010.07,X,.04)
  1. ;
  1. ;nmi in refusal file for aspirin
  1. S T=$O(^ATXAX("B","DM AUDIT ASPIRIN DRUGS",0))
  1. S Z=$$FMADD^XLFDT(BGPDDT,-365)
  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. ..S Y=9999999-D I Y<Z Q ;documented more than 1 year before discharge
  1. ..I Y>BGPDDT Q ;documented after discharge
  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 BGPC=BGPC+1,BGPY(BGPC)="NMI Aspirin: "_$$VAL^XBDIQ1(9000022,N,.04)_" "_$$DATE^BGP5UTL($P(^AUPNPREF(N,0),U,3))_" "_$$VAL^XBDIQ1(9000022,X,1101)
  1. ..Q
  1. .Q
  1. Q
  1. DEATHAMA(H) ;was discharge death or AMA?
  1. S X=$P(^AUPNVINP(H,0),U,6)
  1. I X="" Q 0
  1. S X=$P($G(^DG(405.1,X,"IHS")),U,1)
  1. I X=3 Q 1
  1. I X=4 Q 1
  1. I X=5 Q 1
  1. I X=6 Q 1
  1. I X=7 Q 1
  1. Q 0
  1. AMA(H,D) ;
  1. I $P($P($G(^AUPNVINP(H,0)),U),".")=D Q 0
  1. S X=$P(^AUPNVINP(H,0),U,6)
  1. I X="" Q 0
  1. S X=$P($G(^DG(405.1,X,"IHS")),U,1)
  1. I X=3 Q 1
  1. Q 0
  1. AMIDX(V) ;
  1. S C=$$PRIMPOV^APCLV(V,"I")
  1. I C="" Q 0 ;no primary dx
  1. S T=$O(^ATXAX("B","BGP CMS AMI DXS",0))
  1. I 'T Q
  1. Q $$ICD^ATXCHK(C,T,9)
  1. EXPIRED(H,D) ;
  1. I $P($P($G(^AUPNVINP(H,0)),U),".")=D Q 0
  1. S X=$P(^AUPNVINP(H,0),U,6)
  1. I X="" Q 0
  1. S X=$P($G(^DG(405.1,X,"IHS")),U,1)
  1. I X=4!(X=5)!(X=6)!(X=7) Q 1
  1. Q 0
  1. DSCH(H) ;
  1. Q $P($P(^AUPNVINP(H,0),U),".")
  1. TRANSIN(H) ;
  1. S X=$P(^AUPNVINP(H,0),U,7)
  1. I X="" Q 0
  1. S X=$P($G(^DG(405.1,X,"IHS")),U,1)
  1. I X=2!(X=3) Q 1
  1. Q 0
  1. TRANS(H) ;
  1. S X=$P(^AUPNVINP(H,0),U,6)
  1. I X="" Q 0
  1. S X=$P($G(^DG(405.1,X,"IHS")),U,1)
  1. I X=2 Q 1
  1. Q 0