- 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