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