BGP8C3X ; IHS/CMI/LAB - calc CMS measures 26 Sep 2004 11:28 AM ;
;;8.0;IHS CLINICAL REPORTING;**2**;MAR 12, 2008
;
PNEU ;
;
I '$$PNEUDX(BGPVSIT) Q
;
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^BGP8UTL($P($P(BGPVSIT0,U),"."))_"-"_$$DATE^BGP8UTL($$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 $$TRANSIN(BGPVINP) S:'BGPSKIP BGPX="*"_BGPX S BGPSKIP=1,BGPZ(2)="transferred in from another hospital"
S Z=$$VAL^XBDIQ1(9000010.02,BGPVINP,.07)
S $P(BGPX,U,8)=Z
Q:$D(^XTMP("BGP8C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 1",$P(^DPT(DFN,0),U),DFN,BGPVSIT))
S ^XTMP("BGP8C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 1",$P(^DPT(DFN,0),U),DFN,BGPVSIT)=BGPX ;a hit on list 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)
I $D(BGPZ1) S BGPZ1="Exclusions: "_BGPZ1 S $P(^XTMP("BGP8C1",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
;set up second list after applying exclusions
Q:BGPSKIP
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^BGP8UTL($P($P(BGPVSIT0,U),"."))_"-"_$$DATE^BGP8UTL($$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("BGP8C1",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("BGP8C1",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("BGP8C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,1,"Other Discharge POVs:",C)=I,$E(^(C),9)=N
.Q
ABIRX ;
S ^XTMP("BGP8C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,2,"Recent Antibiotic Rx Status?")=""
K BGPDATA
D ABRX1(DFN,$P($P(BGPVSIT0,U),"."),$$DSCH(BGPVINP),.BGPDATA)
S X=0 F S X=$O(BGPDATA(X)) Q:X'=+X D
.S ^XTMP("BGP8C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,2,"Recent Antibiotic Rx Status?",X)=BGPDATA(X)
PNEUVAX ;
S ^XTMP("BGP8C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,3,"Pneumovax Status?")=""
K BGPDATA
D PNEUVAX1(DFN,.BGPDATA)
S X=0 F S X=$O(BGPDATA(X)) Q:X'=+X D
.S ^XTMP("BGP8C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,3,"Pneumovax Status?",X)=BGPDATA(X)
ABGPO ;
S ^XTMP("BGP8C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,4,"ABG/PO Status?")=""
K BGPDATA
D ABGPO1^BGP8C31(DFN,$P($P(BGPVSIT0,U),"."),$$DSCH(BGPVINP),.BGPDATA)
S X=0 F S X=$O(BGPDATA(X)) Q:X'=+X D
.S ^XTMP("BGP8C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,4,"ABG/PO Status?",X)=BGPDATA(X)
ERBC ;
S ^XTMP("BGP8C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,5,"ER Visit with Blood Culture Status?")=""
K BGPDATA
D ERBC1(DFN,$$FMADD^XLFDT($P($P(BGPVSIT0,U),"."),-1),$P($P(BGPVSIT0,U),"."),.BGPDATA)
S X=0 F S X=$O(BGPDATA(X)) Q:X'=+X D
.S ^XTMP("BGP8C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,5,"ER Visit with Blood Culture Status?",X)=BGPDATA(X)
SMOKER ;EP
S ^XTMP("BGP8C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,6,"Smoker?")=""
K BGPASAAL
D SMOKER1^BGP8C12(DFN,$P($P(BGPVSIT0,U),"."),$$DSCH(BGPVINP),.BGPASAAL)
S X=0 F S X=$O(BGPASAAL(X)) Q:X'=+X D
.S ^XTMP("BGP8C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,6,"Smoker?",X)=BGPASAAL(X)
CESS ;
S ^XTMP("BGP8C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,7,"Smoking Cessation Advice/Counseling Status?")=""
K BGPASAAL
D CESS1^BGP8C12(DFN,$P($P(BGPVSIT0,U),"."),$$DSCH(BGPVINP),.BGPASAAL)
S X=0 F S X=$O(BGPASAAL(X)) Q:X'=+X D
.S ^XTMP("BGP8C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$P(^DPT(DFN,0),U),DFN,BGPVSIT,7,"Smoking Cessation Advice/Counseling Status?",X)=BGPASAAL(X)
D EN^BGP8C12
Q
ABRX1(P,BGPA,BGPD,BGPY) ;EP
NEW BGPG,BGPC,X,Y,Z,E,BD,ED
S BGPC=0
S ED=$$FMADD^XLFDT(BGPA,-1)
S BD=$$FMADD^XLFDT(BGPA,-365)
D GETMEDS^BGP8CU(P,BD,ED,"BGP CMS ANTIBIOTIC MEDS","BGP CMS ANTIBIOTIC MEDS NDC","BGP CMS ANTIBIOTICS MEDS CLASS")
S X=$$CPTI^BGP8DU(P,BD,ED,+$$CODEN^ICPTCOD("G8012"))
I X S BGPC=BGPC+1,BGPY(BGPC)="CPT code G8012: "_$$DATE^BGP8UTL($P(X,U,2))
S X=$$TRANI^BGP8DU(P,BD,ED,+$$CODEN^ICPTCOD("G8012"))
I X S BGPC=BGPC+1,BGPY(BGPC)="TRAN CODE CPT code G8012: "_$$DATE^BGP8UTL($P(X,U,2))
;now see if any procedures
S X=0 F S X=$O(^AUPNVPRC("AC",P,X)) Q:X'=+X D
.Q:'$D(^AUPNVPRC(X,0))
.S I=$P($G(^AUPNVPRC(X,0)),U) Q:'I
.S Y=$P($$ICDOP^ICDCODE(I),U,2)
.I Y=99.21 D
..S V=$P(^AUPNVPRC(X,0),U,3)
..S V=$P($P($G(^AUPNVSIT(V,0)),U),".")
..I V>ED Q
..I V<BD Q
..S BGPC=BGPC+1,BGPY(BGPC)="ANTIBIOTIC PROCEDURE: "_$$DATE^BGP8UTL(V)_" ["_Y_"] "_$$VAL^XBDIQ1(9000010.08,X,.04)
S BD=BGPA
S ED=$$FMADD^XLFDT(BGPD,30)
D GETMEDS^BGP8CU(P,BD,ED,"BGP CMS ANTIBIOTIC MEDS","BGP CMS ANTIBIOTIC MEDS NDC","BGP CMS ANTIBIOTICS MEDS CLASS")
S X=$$CPTI^BGP8DU(P,BD,ED,+$$CODEN^ICPTCOD("G8012"))
I X S BGPC=BGPC+1,BGPY(BGPC)="CPT code G8012: "_$$DATE^BGP8UTL($P(X,U,2))
S X=$$TRANI^BGP8DU(P,BD,ED,+$$CODEN^ICPTCOD("G8012"))
I X S BGPC=BGPC+1,BGPY(BGPC)="TRAN CODE CPT code G8012: "_$$DATE^BGP8UTL($P(X,U,2))
;now see if any procedures
S X=0 F S X=$O(^AUPNVPRC("AC",P,X)) Q:X'=+X D
.Q:'$D(^AUPNVPRC(X,0))
.S I=$P($G(^AUPNVPRC(X,0)),U) Q:'I
.S Y=$P($$ICDOP^ICDCODE(I),U,2)
.I Y=99.21 D
..S V=$P(^AUPNVPRC(X,0),U,3)
..S V=$P($P($G(^AUPNVSIT(V,0)),U),".")
..I V>ED Q
..I V<BD Q
..S BGPC=BGPC+1,BGPY(BGPC)="ANTIBIOTIC PROCEDURE: "_$$DATE^BGP8UTL(V)_" ["_Y_"] "_$$VAL^XBDIQ1(9000010.08,X,.04)
Q
SET ;
S BGPX(D)=C1_" "_C_" "_$$DATE^BGP8UTL(D)
Q
PNEUVAX1(P,BGPY) ;
K BGPG,BGPX
S BGPC=0
S X=P_"^ALL IMM 33" S E=$$START1^APCLDF(X,"BGPG(")
S X=0 F S X=$O(BGPG(X)) Q:X'=+X S Y=+$P(BGPG(X),U,4) D
.Q:'$D(^AUPNVIMM(Y,0))
.S Y=$P(^AUPNVIMM(Y,0),U,1)
.Q:'Y
.S C=$P($G(^AUTTIMM(Y,0)),U)
.Q:C=""
.S D=$P(BGPG(X),U),C1=$P(^AUTTIMM(Y,0),U,3)
.D SET
.Q
K BGPG S X=P_"^ALL IMM 100" S E=$$START1^APCLDF(X,"BGPG(")
S X=0 F S X=$O(BGPG(X)) Q:X'=+X S Y=+$P(BGPG(X),U,4) D
.Q:'$D(^AUPNVIMM(Y,0))
.S Y=$P(^AUPNVIMM(Y,0),U,1)
.Q:'Y
.S C=$P($G(^AUTTIMM(Y,0)),U)
.Q:C=""
.S D=$P(BGPG(X),U),C1=$P(^AUTTIMM(Y,0),U,3)
.D SET
.Q
K BGPG S X=P_"^ALL IMM 109" S E=$$START1^APCLDF(X,"BGPG(")
S X=0 F S X=$O(BGPG(X)) Q:X'=+X S Y=+$P(BGPG(X),U,4) D
.Q:'$D(^AUPNVIMM(Y,0))
.S Y=$P(^AUPNVIMM(Y,0),U,1)
.Q:'Y
.S C=$P($G(^AUTTIMM(Y,0)),U)
.Q:C=""
.S D=$P(BGPG(X),U),C1=$P(^AUTTIMM(Y,0),U,3)
.D SET
.Q
K BGPG S %=P_"^ALL PROCEDURE 99.55",E=$$START1^APCLDF(%,"BGPG(")
S X=0 F S X=$O(BGPG(X)) Q:X'=+X S Y=+$P(BGPG(X),U,4) D
.Q:'$D(^AUPNVPRC(Y,0))
.S Y=$P(^AUPNVPRC(Y,0),U,1)
.Q:'Y
.S D=$P(BGPG(X),U)
.S C=$P($$ICDOP^ICDCODE(Y,D),U,5)
.Q:C=""
.S C1=$P($$ICDOP^ICDCODE(Y,D),U,2)
.D SET
.Q
K BGPG S %=P_"^ALL DX V03.82",E=$$START1^APCLDF(%,"BGPG(")
S X=0 F S X=$O(BGPG(X)) Q:X'=+X S Y=+$P(BGPG(X),U,4) D
.Q:'$D(^AUPNVPOV(Y,0))
.S Y=$P(^AUPNVPOV(Y,0),U,1)
.Q:'Y
.S D=$P(BGPG(X),U)
.S C=$P($$ICDDX^ICDCODE(Y,D),U,4)
.Q:C=""
.S C1=$P($$ICDDX^ICDCODE(Y,D),U,2)
.D SET
.Q
K BGPG S %=P_"^ALL DX V03.89",E=$$START1^APCLDF(%,"BGPG(")
S X=0 F S X=$O(BGPG(X)) Q:X'=+X S Y=+$P(BGPG(X),U,4) D
.Q:'$D(^AUPNVPOV(Y,0))
.S Y=$P(^AUPNVPOV(Y,0),U,1)
.Q:'Y
.S D=$P(BGPG(X),U)
.S C=$P($$ICDDX^ICDCODE(Y,D),U,4)
.Q:C=""
.S C1=$P($$ICDDX^ICDCODE(Y,D),U,2)
.D SET
.Q
K BGPG S %=P_"^ALL DX V06.6",E=$$START1^APCLDF(%,"BGPG(")
S X=0 F S X=$O(BGPG(X)) Q:X'=+X S Y=+$P(BGPG(X),U,4) D
.Q:'$D(^AUPNVPOV(Y,0))
.S Y=$P(^AUPNVPOV(Y,0),U,1)
.Q:'Y
.S D=$P(BGPG(X),U)
.S C=$P($$ICDDX^ICDCODE(Y,D),U,4)
.Q:C=""
.S C1=$P($$ICDDX^ICDCODE(Y,D),U,2)
.D SET
.Q
;now check for cpts
S X=0 F S X=$O(^AUPNVCPT("AC",P,X)) Q:X'=+X D
.Q:'$D(^AUPNVCPT(X,0))
.S C1=$$VAL^XBDIQ1(9000010.18,X,.01)
.I C1'=90732,C1'=90669 Q
.S C=$$VAL^XBDIQ1(9000010.18,X,.019)
.S D=$P(^AUPNVCPT(X,0),U,3)
.S D=$P($P($G(^AUPNVSIT(D,0)),U),".")
.D SET
.Q
;tran codes
S X=0 F S X=$O(^AUPNVTC("AC",P,X)) Q:X'=+X D
.Q:'$D(^AUPNVTC(X,0))
.S C1=$$VAL^XBDIQ1(9000010.33,X,.07)
.I C1'=90732,C1'=90669 Q
.S C=$$VALI^XBDIQ1(9000010.33,X,.07)
.I C="" Q
.S C=$P($$CPT^ICPTCOD(C),U,3)
.S D=$P(^AUPNVTC(X,0),U,3)
.S D=$P($P($G(^AUPNVSIT(D,0)),U),".")
.D SET
.Q
;refusals?
K BGPI F X=33,100,109 S Y=$O(^AUTTIMM("C",X,0)) I Y S BGPI(Y)=""
S X=0 F S X=$O(^AUPNPREF("AA",P,9999999.14,X)) Q:X'=+X D
.Q:'$D(BGPI(X)) ;not an ACEI
.S D=0 F S D=$O(^AUPNPREF("AA",P,50,X,D)) Q:D'=+D D
..S Y=9999999-D
..Q:$D(BGPX(Y)) S BGPX(Y)="REFUSAL: "_$$VAL^XBDIQ1(9000022,N,.04)_" "_$$DATE^BGP8UTL($P(^AUPNPREF(N,0),U,3))_" "_$$VAL^XBDIQ1(9000022,X,1101)
..Q
.Q
S (X,G)=0,Y=$O(^AUTTIMM("C",33,0)) F S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X D
.S R=$P(^BIPC(X,0),U,3)
.Q:R=""
.Q:'$D(^BICONT(R,0))
.Q:$P(^BICONT(R,0),U,1)'["Refusal"
.S D=$P(^BIPC(X,0),U,4)
.Q:D=""
.Q:$D(BGPX(D)) S BGPX(D)="REFUSAL: Immunization Package "_$$DATE^BGP8UTL(D)
S (X,G)=0,Y=$O(^AUTTIMM("C",100,0)) I Y F S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X D
.S R=$P(^BIPC(X,0),U,3)
.Q:R=""
.Q:'$D(^BICONT(R,0))
.Q:$P(^BICONT(R,0),U,1)'["Refusal"
.S D=$P(^BIPC(X,0),U,4)
.Q:D=""
.Q:$D(BGPX(D)) S BGPX(D)="REFUSAL: Immunization Package "_$$DATE^BGP8UTL(D)
S (X,G)=0,Y=$O(^AUTTIMM("C",109,0)) I Y F S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X D
.S R=$P(^BIPC(X,0),U,3)
.Q:R=""
.Q:'$D(^BICONT(R,0))
.Q:$P(^BICONT(R,0),U,1)'["Refusal"
.S D=$P(^BIPC(X,0),U,4)
.Q:D=""
.Q:$D(BGPX(D)) S BGPX(D)="REFUSAL: Immunization Package "_$$DATE^BGP8UTL(D)
S D=0 F S D=$O(BGPX(D)) Q:D'=+D S BGPC=BGPC+1,BGPY(BGPC)=BGPX(D)
K BGPX,BGPC,BGPI,X,Y,D
Q
ERBC1(P,BD,ED,BGPY) ;
K BGPG,BGPY
S BPGC=0
S A="BGPG(",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BD)_"-"_$$FMTE^XLFDT(ED),E=$$START1^APCLDF(B,A)
I '$D(BGPG(1)) Q
S (X,G)=0 F S X=$O(BGPG(X)) Q:X'=+X S V=$P(BGPG(X),U,5) D
.Q:'$D(^AUPNVSIT(V,0))
.Q:'$P(^AUPNVSIT(V,0),U,9)
.Q:$P(^AUPNVSIT(V,0),U,11)
.Q:$$CLINIC^APCLV(V,"C")'=30
.S BGPC=BGPC+1,BGPY(BGPC)="ER Visit: "_$$DATE^BGP8UTL($P($P(^AUPNVSIT(V,0),U),"."))
.S BGPC=BGPC+1,BGPY(BGPC)="ER Diagnoses: "
.S A=0 F S A=$O(^AUPNVPOV("AD",V,A)) Q:A'=+A D
..S BGPC=BGPC+1,BGPY(BGPC)=" "_$$VAL^XBDIQ1(9000010.07,A,.01)_" "_$$VAL^XBDIQ1(9000010.07,A,.04)
.S BGPC=BGPC+1,BGPY(BGPC)="Blood Culture: "
.;now check cpts/tran codes for 87040, 87103
.S Z=0 F S Z=$O(^AUPNVCPT("AD",V,Z)) Q:Z'=+Z D
..Q:'$D(^AUPNVCPT(Z,0))
..S C1=$$VAL^XBDIQ1(9000010.18,Z,.01)
..I C1'=87040,C1'=87103 Q
..S BGPC=BGPC+1,BGPY(BGPC)="CPT code: "_C1
..Q
.;tran codes
.S Z=0 F S Z=$O(^AUPNVTC("AD",V,Z)) Q:Z'=+Z D
..Q:'$D(^AUPNVTC(Z,0))
..S C1=$$VAL^XBDIQ1(9000010.33,Z,.07)
..I C1'=87040,C1'=87103 Q
..S BGPC=BGPC+1,BGPY(BGPC)="TRAN CODE CPT code: "_C1
..Q
.S T=$O(^ATXAX("B","BGP BLOOD CULTURE LOINC",0))
.S BGPLT=$O(^ATXLAB("B","BGP CMS BLOOD CULTURE",0))
.S B=9999999-$P($P(^AUPNVSIT(V,0),U),"."),E=9999999-$P($P(^AUPNVSIT(V,0),U),".") S D=E-1 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(D>B) D
..S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L D
...S A=0 F S A=$O(^AUPNVLAB("AE",P,D,L,A)) Q:A'=+A D
....Q:'$D(^AUPNVLAB(A,0))
....I $$VAL^XBDIQ1(9000010.09,A,.01)="BLOOD CULTURE" D Q
.....S BGPC=BGPC+1,BGPY(BGPC)=" LAB: "_$$VAL^XBDIQ1(9000010.09,A,.01)_" "_$$DATE^BGP8UTL($P(BGPG(X),U))_" value: "_$P(^AUPNVLAB(A,0),U,4) Q
....I BGPLT,$P(^AUPNVLAB(A,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(A,0),U))) S BGPC=BGPC+1,BGPY(BGPC)=" LAB: "_$$VAL^XBDIQ1(9000010.09,A,.01)_" "_$$DATE^BGP8UTL($P(BGPG(X),U))_" value: "_$P(^AUPNVLAB(A,0),U,4) Q
....Q:'T
....S J=$P($G(^AUPNVLAB(A,11)),U,13) Q:J=""
....Q:'$$LOINC^BGP8D21(J,T)
....S BGPC=BGPC+1,BGPY(BGPC)=" LAB: "_$$VAL^XBDIQ1(9000010.09,A,.01)_" "_$$DATE^BGP8UTL($P(BGPG(X),U))_" value: "_$P(^AUPNVLAB(A,0),U,4)
....Q
.S B=9999999-$P($P(^AUPNVSIT(V,0),U),"."),E=9999999-$P($P(^AUPNVSIT(V,0),U),".") S D=E-1 F S D=$O(^AUPNVMIC("AE",P,D)) Q:D'=+D!(D>B) D
..S L=0 F S L=$O(^AUPNVMIC("AE",P,D,L)) Q:L'=+L D
...S A=0 F S A=$O(^AUPNVMIC("AE",P,D,L,A)) Q:A'=+A D
....Q:'$D(^AUPNVMIC(A,0))
....I $$VAL^XBDIQ1(9000010.25,A,.01)="BLOOD CULTURE" D Q
.....S BGPC=BGPC+1,BGPY(BGPC)=" MICRO: "_$$VAL^XBDIQ1(9000010.25,A,.01)_" "_$$DATE^BGP8UTL($P(BGPG(X),U))_" value: "_$$VAL^XBDIQ1(9000010.25,A,.04)_" "_$P(^AUPNVMIC(A,0),U,7) Q
....I BGPLT,$P(^AUPNVMIC(A,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVMIC(A,0),U))) D
.....S BGPC=BGPC+1,BGPY(BGPC)=" MICRO: "_$$VAL^XBDIQ1(9000010.25,A,.01)_" "_$$DATE^BGP8UTL($P(BGPG(X),U))_" value: "_$$VAL^XBDIQ1(9000010.25,A,.04)_" "_$P(^AUPNVMIC(A,0),U,7) Q
....Q:'T
....S J=$P($G(^AUPNVMIC(A,11)),U,13) Q:J=""
....Q:'$$LOINC^BGP8D21(J,T)
....S BGPC=BGPC+1,BGPY(BGPC)=" MICRO: "_$$VAL^XBDIQ1(9000010.25,A,.01)_" "_$$DATE^BGP8UTL($P(BGPG(X),U))_" value: "_$$VAL^XBDIQ1(9000010.25,A,.04)_" "_$P(^AUPNVMIC(A,0),U,7)
....Q
Q
AMA(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=3 Q 1
Q 0
PNEUDX(V) ;
S C=$$PRIMPOV^APCLV(V,"I")
I C="" Q 0 ;no primary dx
S T=$O(^ATXAX("B","BGP CMS PNEUMONIA DXS",0))
I $$ICD^ATXCHK(C,T,9) Q 1 ;primary dx of pneumonia
;PRIMARY of resp failure and seconday of pneumonia
S T=$O(^ATXAX("B","BGP CMS SEPTI/RESP FAIL DXS",0))
I '$$ICD^ATXCHK(C,T,9) Q 0 ;resp failure not primary pov
S T=$O(^ATXAX("B","BGP CMS PNEUMONIA DXS",0))
S (X,G)=0 F S X=$O(^AUPNVPOV("AD",V,X)) Q:X'=+X!(G) D
.Q:'$D(^AUPNVPOV(X,0))
.Q:$P(^AUPNVPOV(X,0),U,12)="P"
.S I=$P(^AUPNVPOV(X,0),U)
.Q:'$$ICD^ATXCHK(I,T,9)
.S G=1
.Q
Q G
EXPIRED(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=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
BGP8C3X ; IHS/CMI/LAB - calc CMS measures 26 Sep 2004 11:28 AM ;
+1 ;;8.0;IHS CLINICAL REPORTING;**2**;MAR 12, 2008
+2 ;
PNEU ;
+1 ;
+2 IF '$$PNEUDX(BGPVSIT)
QUIT
+3 ;
+4 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),"."))
+5 SET $PIECE(BGPX,U,5)=$$DATE^BGP8UTL($PIECE($PIECE(BGPVSIT0,U),"."))_"-"_$$DATE^BGP8UTL($$DSCH(BGPVINP))
+6 SET $PIECE(BGPX,U,6)=$$PRIMPOV^APCLV(BGPVSIT,"C")_" "_$$PRIMPOV^APCLV(BGPVSIT,"N")
+7 SET BGPSKIP=0
KILL BGPZ
+8 IF $$AGE^AUPNPAT(DFN,$PIECE($PIECE(BGPVSIT0,U),"."))<18
SET BGPX="*"_BGPX
SET BGPSKIP=1
SET BGPZ(1)="under 18 yrs of age"
+9 SET Z=$$VAL^XBDIQ1(9000010.02,BGPVINP,.06)
+10 SET $PIECE(BGPX,U,7)=Z
+11 ;I $$TRANSIN(BGPVINP) S:'BGPSKIP BGPX="*"_BGPX S BGPSKIP=1,BGPZ(2)="transferred in from another hospital"
+12 SET Z=$$VAL^XBDIQ1(9000010.02,BGPVINP,.07)
+13 SET $PIECE(BGPX,U,8)=Z
+14 IF $DATA(^XTMP("BGP8C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 1",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT))
QUIT
+15 ;a hit on list 1
SET ^XTMP("BGP8C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 1",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT)=BGPX
+16 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)
+17 IF $DATA(BGPZ1)
SET BGPZ1="Exclusions: "_BGPZ1
SET $PIECE(^XTMP("BGP8C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 1",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT),U,12)=BGPZ1
+18 SET BGPCOUNT("L1",BGPIND)=$GET(BGPCOUNT("L1",BGPIND))+1
+19 ;set up second list after applying exclusions
+20 IF BGPSKIP
QUIT
+21 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),"."))
+22 SET $PIECE(BGPX,U,5)=$$DATE^BGP8UTL($PIECE($PIECE(BGPVSIT0,U),"."))_"-"_$$DATE^BGP8UTL($$DSCH(BGPVINP))
+23 SET $PIECE(BGPX,U,6)=$$PRIMPOV^APCLV(BGPVSIT,"C")_" "_$$PRIMPOV^APCLV(BGPVSIT,"N")
+24 SET $PIECE(BGPX,U,7)=$$VAL^XBDIQ1(9000010.02,BGPVINP,.06)
+25 SET $PIECE(BGPX,U,8)=$$VAL^XBDIQ1(9000010.02,BGPVINP,.07)
+26 SET ^XTMP("BGP8C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT)=BGPX
+27 SET BGPCOUNT("L2",BGPIND)=$GET(BGPCOUNT("L2",BGPIND))+1
+28 ;get other povs
+29 SET ^XTMP("BGP8C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,1,"Other Discharge POVs:")=""
+30 SET (X,C)=0
FOR
SET X=$ORDER(^AUPNVPOV("AD",BGPVSIT,X))
IF X'=+X
QUIT
Begin DoDot:1
+31 IF '$DATA(^AUPNVPOV(X,0))
QUIT
+32 IF $PIECE(^AUPNVPOV(X,0),U,12)="P"
QUIT
+33 SET I=$PIECE(^AUPNVPOV(X,0),U)
SET I=$PIECE($$ICDDX^ICDCODE(I),U,2)
+34 SET N=$$VAL^XBDIQ1(9000010.07,X,.04)
SET N=$$UP^XLFSTR(N)
+35 SET C=C+1
+36 SET ^XTMP("BGP8C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,1,"Other Discharge POVs:",C)=I
SET $EXTRACT(^(C),9)=N
+37 QUIT
End DoDot:1
ABIRX ;
+1 SET ^XTMP("BGP8C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,2,"Recent Antibiotic Rx Status?")=""
+2 KILL BGPDATA
+3 DO ABRX1(DFN,$PIECE($PIECE(BGPVSIT0,U),"."),$$DSCH(BGPVINP),.BGPDATA)
+4 SET X=0
FOR
SET X=$ORDER(BGPDATA(X))
IF X'=+X
QUIT
Begin DoDot:1
+5 SET ^XTMP("BGP8C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,2,"Recent Antibiotic Rx Status?",X)=BGPDATA(X)
End DoDot:1
PNEUVAX ;
+1 SET ^XTMP("BGP8C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,3,"Pneumovax Status?")=""
+2 KILL BGPDATA
+3 DO PNEUVAX1(DFN,.BGPDATA)
+4 SET X=0
FOR
SET X=$ORDER(BGPDATA(X))
IF X'=+X
QUIT
Begin DoDot:1
+5 SET ^XTMP("BGP8C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,3,"Pneumovax Status?",X)=BGPDATA(X)
End DoDot:1
ABGPO ;
+1 SET ^XTMP("BGP8C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,4,"ABG/PO Status?")=""
+2 KILL BGPDATA
+3 DO ABGPO1^BGP8C31(DFN,$PIECE($PIECE(BGPVSIT0,U),"."),$$DSCH(BGPVINP),.BGPDATA)
+4 SET X=0
FOR
SET X=$ORDER(BGPDATA(X))
IF X'=+X
QUIT
Begin DoDot:1
+5 SET ^XTMP("BGP8C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,4,"ABG/PO Status?",X)=BGPDATA(X)
End DoDot:1
ERBC ;
+1 SET ^XTMP("BGP8C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,5,"ER Visit with Blood Culture Status?")=""
+2 KILL BGPDATA
+3 DO ERBC1(DFN,$$FMADD^XLFDT($PIECE($PIECE(BGPVSIT0,U),"."),-1),$PIECE($PIECE(BGPVSIT0,U),"."),.BGPDATA)
+4 SET X=0
FOR
SET X=$ORDER(BGPDATA(X))
IF X'=+X
QUIT
Begin DoDot:1
+5 SET ^XTMP("BGP8C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,5,"ER Visit with Blood Culture Status?",X)=BGPDATA(X)
End DoDot:1
SMOKER ;EP
+1 SET ^XTMP("BGP8C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,6,"Smoker?")=""
+2 KILL BGPASAAL
+3 DO SMOKER1^BGP8C12(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("BGP8C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,6,"Smoker?",X)=BGPASAAL(X)
End DoDot:1
CESS ;
+1 SET ^XTMP("BGP8C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,7,"Smoking Cessation Advice/Counseling Status?")=""
+2 KILL BGPASAAL
+3 DO CESS1^BGP8C12(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("BGP8C1",BGPJ,BGPH,BGPORDER,BGPIND,"LIST 2",$PIECE(^DPT(DFN,0),U),DFN,BGPVSIT,7,"Smoking Cessation Advice/Counseling Status?",X)=BGPASAAL(X)
End DoDot:1
+6 DO EN^BGP8C12
+7 QUIT
ABRX1(P,BGPA,BGPD,BGPY) ;EP
+1 NEW BGPG,BGPC,X,Y,Z,E,BD,ED
+2 SET BGPC=0
+3 SET ED=$$FMADD^XLFDT(BGPA,-1)
+4 SET BD=$$FMADD^XLFDT(BGPA,-365)
+5 DO GETMEDS^BGP8CU(P,BD,ED,"BGP CMS ANTIBIOTIC MEDS","BGP CMS ANTIBIOTIC MEDS NDC","BGP CMS ANTIBIOTICS MEDS CLASS")
+6 SET X=$$CPTI^BGP8DU(P,BD,ED,+$$CODEN^ICPTCOD("G8012"))
+7 IF X
SET BGPC=BGPC+1
SET BGPY(BGPC)="CPT code G8012: "_$$DATE^BGP8UTL($PIECE(X,U,2))
+8 SET X=$$TRANI^BGP8DU(P,BD,ED,+$$CODEN^ICPTCOD("G8012"))
+9 IF X
SET BGPC=BGPC+1
SET BGPY(BGPC)="TRAN CODE CPT code G8012: "_$$DATE^BGP8UTL($PIECE(X,U,2))
+10 ;now see if any procedures
+11 SET X=0
FOR
SET X=$ORDER(^AUPNVPRC("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+12 IF '$DATA(^AUPNVPRC(X,0))
QUIT
+13 SET I=$PIECE($GET(^AUPNVPRC(X,0)),U)
IF 'I
QUIT
+14 SET Y=$PIECE($$ICDOP^ICDCODE(I),U,2)
+15 IF Y=99.21
Begin DoDot:2
+16 SET V=$PIECE(^AUPNVPRC(X,0),U,3)
+17 SET V=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+18 IF V>ED
QUIT
+19 IF V<BD
QUIT
+20 SET BGPC=BGPC+1
SET BGPY(BGPC)="ANTIBIOTIC PROCEDURE: "_$$DATE^BGP8UTL(V)_" ["_Y_"] "_$$VAL^XBDIQ1(9000010.08,X,.04)
End DoDot:2
End DoDot:1
+21 SET BD=BGPA
+22 SET ED=$$FMADD^XLFDT(BGPD,30)
+23 DO GETMEDS^BGP8CU(P,BD,ED,"BGP CMS ANTIBIOTIC MEDS","BGP CMS ANTIBIOTIC MEDS NDC","BGP CMS ANTIBIOTICS MEDS CLASS")
+24 SET X=$$CPTI^BGP8DU(P,BD,ED,+$$CODEN^ICPTCOD("G8012"))
+25 IF X
SET BGPC=BGPC+1
SET BGPY(BGPC)="CPT code G8012: "_$$DATE^BGP8UTL($PIECE(X,U,2))
+26 SET X=$$TRANI^BGP8DU(P,BD,ED,+$$CODEN^ICPTCOD("G8012"))
+27 IF X
SET BGPC=BGPC+1
SET BGPY(BGPC)="TRAN CODE CPT code G8012: "_$$DATE^BGP8UTL($PIECE(X,U,2))
+28 ;now see if any procedures
+29 SET X=0
FOR
SET X=$ORDER(^AUPNVPRC("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+30 IF '$DATA(^AUPNVPRC(X,0))
QUIT
+31 SET I=$PIECE($GET(^AUPNVPRC(X,0)),U)
IF 'I
QUIT
+32 SET Y=$PIECE($$ICDOP^ICDCODE(I),U,2)
+33 IF Y=99.21
Begin DoDot:2
+34 SET V=$PIECE(^AUPNVPRC(X,0),U,3)
+35 SET V=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+36 IF V>ED
QUIT
+37 IF V<BD
QUIT
+38 SET BGPC=BGPC+1
SET BGPY(BGPC)="ANTIBIOTIC PROCEDURE: "_$$DATE^BGP8UTL(V)_" ["_Y_"] "_$$VAL^XBDIQ1(9000010.08,X,.04)
End DoDot:2
End DoDot:1
+39 QUIT
SET ;
+1 SET BGPX(D)=C1_" "_C_" "_$$DATE^BGP8UTL(D)
+2 QUIT
PNEUVAX1(P,BGPY) ;
+1 KILL BGPG,BGPX
+2 SET BGPC=0
+3 SET X=P_"^ALL IMM 33"
SET E=$$START1^APCLDF(X,"BGPG(")
+4 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BGPG(X),U,4)
Begin DoDot:1
+5 IF '$DATA(^AUPNVIMM(Y,0))
QUIT
+6 SET Y=$PIECE(^AUPNVIMM(Y,0),U,1)
+7 IF 'Y
QUIT
+8 SET C=$PIECE($GET(^AUTTIMM(Y,0)),U)
+9 IF C=""
QUIT
+10 SET D=$PIECE(BGPG(X),U)
SET C1=$PIECE(^AUTTIMM(Y,0),U,3)
+11 DO SET
+12 QUIT
End DoDot:1
+13 KILL BGPG
SET X=P_"^ALL IMM 100"
SET E=$$START1^APCLDF(X,"BGPG(")
+14 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BGPG(X),U,4)
Begin DoDot:1
+15 IF '$DATA(^AUPNVIMM(Y,0))
QUIT
+16 SET Y=$PIECE(^AUPNVIMM(Y,0),U,1)
+17 IF 'Y
QUIT
+18 SET C=$PIECE($GET(^AUTTIMM(Y,0)),U)
+19 IF C=""
QUIT
+20 SET D=$PIECE(BGPG(X),U)
SET C1=$PIECE(^AUTTIMM(Y,0),U,3)
+21 DO SET
+22 QUIT
End DoDot:1
+23 KILL BGPG
SET X=P_"^ALL IMM 109"
SET E=$$START1^APCLDF(X,"BGPG(")
+24 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BGPG(X),U,4)
Begin DoDot:1
+25 IF '$DATA(^AUPNVIMM(Y,0))
QUIT
+26 SET Y=$PIECE(^AUPNVIMM(Y,0),U,1)
+27 IF 'Y
QUIT
+28 SET C=$PIECE($GET(^AUTTIMM(Y,0)),U)
+29 IF C=""
QUIT
+30 SET D=$PIECE(BGPG(X),U)
SET C1=$PIECE(^AUTTIMM(Y,0),U,3)
+31 DO SET
+32 QUIT
End DoDot:1
+33 KILL BGPG
SET %=P_"^ALL PROCEDURE 99.55"
SET E=$$START1^APCLDF(%,"BGPG(")
+34 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BGPG(X),U,4)
Begin DoDot:1
+35 IF '$DATA(^AUPNVPRC(Y,0))
QUIT
+36 SET Y=$PIECE(^AUPNVPRC(Y,0),U,1)
+37 IF 'Y
QUIT
+38 SET D=$PIECE(BGPG(X),U)
+39 SET C=$PIECE($$ICDOP^ICDCODE(Y,D),U,5)
+40 IF C=""
QUIT
+41 SET C1=$PIECE($$ICDOP^ICDCODE(Y,D),U,2)
+42 DO SET
+43 QUIT
End DoDot:1
+44 KILL BGPG
SET %=P_"^ALL DX V03.82"
SET E=$$START1^APCLDF(%,"BGPG(")
+45 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BGPG(X),U,4)
Begin DoDot:1
+46 IF '$DATA(^AUPNVPOV(Y,0))
QUIT
+47 SET Y=$PIECE(^AUPNVPOV(Y,0),U,1)
+48 IF 'Y
QUIT
+49 SET D=$PIECE(BGPG(X),U)
+50 SET C=$PIECE($$ICDDX^ICDCODE(Y,D),U,4)
+51 IF C=""
QUIT
+52 SET C1=$PIECE($$ICDDX^ICDCODE(Y,D),U,2)
+53 DO SET
+54 QUIT
End DoDot:1
+55 KILL BGPG
SET %=P_"^ALL DX V03.89"
SET E=$$START1^APCLDF(%,"BGPG(")
+56 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BGPG(X),U,4)
Begin DoDot:1
+57 IF '$DATA(^AUPNVPOV(Y,0))
QUIT
+58 SET Y=$PIECE(^AUPNVPOV(Y,0),U,1)
+59 IF 'Y
QUIT
+60 SET D=$PIECE(BGPG(X),U)
+61 SET C=$PIECE($$ICDDX^ICDCODE(Y,D),U,4)
+62 IF C=""
QUIT
+63 SET C1=$PIECE($$ICDDX^ICDCODE(Y,D),U,2)
+64 DO SET
+65 QUIT
End DoDot:1
+66 KILL BGPG
SET %=P_"^ALL DX V06.6"
SET E=$$START1^APCLDF(%,"BGPG(")
+67 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BGPG(X),U,4)
Begin DoDot:1
+68 IF '$DATA(^AUPNVPOV(Y,0))
QUIT
+69 SET Y=$PIECE(^AUPNVPOV(Y,0),U,1)
+70 IF 'Y
QUIT
+71 SET D=$PIECE(BGPG(X),U)
+72 SET C=$PIECE($$ICDDX^ICDCODE(Y,D),U,4)
+73 IF C=""
QUIT
+74 SET C1=$PIECE($$ICDDX^ICDCODE(Y,D),U,2)
+75 DO SET
+76 QUIT
End DoDot:1
+77 ;now check for cpts
+78 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+79 IF '$DATA(^AUPNVCPT(X,0))
QUIT
+80 SET C1=$$VAL^XBDIQ1(9000010.18,X,.01)
+81 IF C1'=90732
IF C1'=90669
QUIT
+82 SET C=$$VAL^XBDIQ1(9000010.18,X,.019)
+83 SET D=$PIECE(^AUPNVCPT(X,0),U,3)
+84 SET D=$PIECE($PIECE($GET(^AUPNVSIT(D,0)),U),".")
+85 DO SET
+86 QUIT
End DoDot:1
+87 ;tran codes
+88 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+89 IF '$DATA(^AUPNVTC(X,0))
QUIT
+90 SET C1=$$VAL^XBDIQ1(9000010.33,X,.07)
+91 IF C1'=90732
IF C1'=90669
QUIT
+92 SET C=$$VALI^XBDIQ1(9000010.33,X,.07)
+93 IF C=""
QUIT
+94 SET C=$PIECE($$CPT^ICPTCOD(C),U,3)
+95 SET D=$PIECE(^AUPNVTC(X,0),U,3)
+96 SET D=$PIECE($PIECE($GET(^AUPNVSIT(D,0)),U),".")
+97 DO SET
+98 QUIT
End DoDot:1
+99 ;refusals?
+100 KILL BGPI
FOR X=33,100,109
SET Y=$ORDER(^AUTTIMM("C",X,0))
IF Y
SET BGPI(Y)=""
+101 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,9999999.14,X))
IF X'=+X
QUIT
Begin DoDot:1
+102 ;not an ACEI
IF '$DATA(BGPI(X))
QUIT
+103 SET D=0
FOR
SET D=$ORDER(^AUPNPREF("AA",P,50,X,D))
IF D'=+D
QUIT
Begin DoDot:2
+104 SET Y=9999999-D
+105 IF $DATA(BGPX(Y))
QUIT
SET BGPX(Y)="REFUSAL: "_$$VAL^XBDIQ1(9000022,N,.04)_" "_$$DATE^BGP8UTL($PIECE(^AUPNPREF(N,0),U,3))_" "_$$VAL^XBDIQ1(9000022,X,1101)
+106 QUIT
End DoDot:2
+107 QUIT
End DoDot:1
+108 SET (X,G)=0
SET Y=$ORDER(^AUTTIMM("C",33,0))
FOR
SET X=$ORDER(^BIPC("AC",P,Y,X))
IF X'=+X
QUIT
Begin DoDot:1
+109 SET R=$PIECE(^BIPC(X,0),U,3)
+110 IF R=""
QUIT
+111 IF '$DATA(^BICONT(R,0))
QUIT
+112 IF $PIECE(^BICONT(R,0),U,1)'["Refusal"
QUIT
+113 SET D=$PIECE(^BIPC(X,0),U,4)
+114 IF D=""
QUIT
+115 IF $DATA(BGPX(D))
QUIT
SET BGPX(D)="REFUSAL: Immunization Package "_$$DATE^BGP8UTL(D)
End DoDot:1
+116 SET (X,G)=0
SET Y=$ORDER(^AUTTIMM("C",100,0))
IF Y
FOR
SET X=$ORDER(^BIPC("AC",P,Y,X))
IF X'=+X
QUIT
Begin DoDot:1
+117 SET R=$PIECE(^BIPC(X,0),U,3)
+118 IF R=""
QUIT
+119 IF '$DATA(^BICONT(R,0))
QUIT
+120 IF $PIECE(^BICONT(R,0),U,1)'["Refusal"
QUIT
+121 SET D=$PIECE(^BIPC(X,0),U,4)
+122 IF D=""
QUIT
+123 IF $DATA(BGPX(D))
QUIT
SET BGPX(D)="REFUSAL: Immunization Package "_$$DATE^BGP8UTL(D)
End DoDot:1
+124 SET (X,G)=0
SET Y=$ORDER(^AUTTIMM("C",109,0))
IF Y
FOR
SET X=$ORDER(^BIPC("AC",P,Y,X))
IF X'=+X
QUIT
Begin DoDot:1
+125 SET R=$PIECE(^BIPC(X,0),U,3)
+126 IF R=""
QUIT
+127 IF '$DATA(^BICONT(R,0))
QUIT
+128 IF $PIECE(^BICONT(R,0),U,1)'["Refusal"
QUIT
+129 SET D=$PIECE(^BIPC(X,0),U,4)
+130 IF D=""
QUIT
+131 IF $DATA(BGPX(D))
QUIT
SET BGPX(D)="REFUSAL: Immunization Package "_$$DATE^BGP8UTL(D)
End DoDot:1
+132 SET D=0
FOR
SET D=$ORDER(BGPX(D))
IF D'=+D
QUIT
SET BGPC=BGPC+1
SET BGPY(BGPC)=BGPX(D)
+133 KILL BGPX,BGPC,BGPI,X,Y,D
+134 QUIT
ERBC1(P,BD,ED,BGPY) ;
+1 KILL BGPG,BGPY
+2 SET BPGC=0
+3 SET A="BGPG("
SET B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BD)_"-"_$$FMTE^XLFDT(ED)
SET E=$$START1^APCLDF(B,A)
+4 IF '$DATA(BGPG(1))
QUIT
+5 SET (X,G)=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET V=$PIECE(BGPG(X),U,5)
Begin DoDot:1
+6 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+7 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+8 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+9 IF $$CLINIC^APCLV(V,"C")'=30
QUIT
+10 SET BGPC=BGPC+1
SET BGPY(BGPC)="ER Visit: "_$$DATE^BGP8UTL($PIECE($PIECE(^AUPNVSIT(V,0),U),"."))
+11 SET BGPC=BGPC+1
SET BGPY(BGPC)="ER Diagnoses: "
+12 SET A=0
FOR
SET A=$ORDER(^AUPNVPOV("AD",V,A))
IF A'=+A
QUIT
Begin DoDot:2
+13 SET BGPC=BGPC+1
SET BGPY(BGPC)=" "_$$VAL^XBDIQ1(9000010.07,A,.01)_" "_$$VAL^XBDIQ1(9000010.07,A,.04)
End DoDot:2
+14 SET BGPC=BGPC+1
SET BGPY(BGPC)="Blood Culture: "
+15 ;now check cpts/tran codes for 87040, 87103
+16 SET Z=0
FOR
SET Z=$ORDER(^AUPNVCPT("AD",V,Z))
IF Z'=+Z
QUIT
Begin DoDot:2
+17 IF '$DATA(^AUPNVCPT(Z,0))
QUIT
+18 SET C1=$$VAL^XBDIQ1(9000010.18,Z,.01)
+19 IF C1'=87040
IF C1'=87103
QUIT
+20 SET BGPC=BGPC+1
SET BGPY(BGPC)="CPT code: "_C1
+21 QUIT
End DoDot:2
+22 ;tran codes
+23 SET Z=0
FOR
SET Z=$ORDER(^AUPNVTC("AD",V,Z))
IF Z'=+Z
QUIT
Begin DoDot:2
+24 IF '$DATA(^AUPNVTC(Z,0))
QUIT
+25 SET C1=$$VAL^XBDIQ1(9000010.33,Z,.07)
+26 IF C1'=87040
IF C1'=87103
QUIT
+27 SET BGPC=BGPC+1
SET BGPY(BGPC)="TRAN CODE CPT code: "_C1
+28 QUIT
End DoDot:2
+29 SET T=$ORDER(^ATXAX("B","BGP BLOOD CULTURE LOINC",0))
+30 SET BGPLT=$ORDER(^ATXLAB("B","BGP CMS BLOOD CULTURE",0))
+31 SET B=9999999-$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
SET E=9999999-$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(D>B)
QUIT
Begin DoDot:2
+32 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:3
+33 SET A=0
FOR
SET A=$ORDER(^AUPNVLAB("AE",P,D,L,A))
IF A'=+A
QUIT
Begin DoDot:4
+34 IF '$DATA(^AUPNVLAB(A,0))
QUIT
+35 IF $$VAL^XBDIQ1(9000010.09,A,.01)="BLOOD CULTURE"
Begin DoDot:5
+36 SET BGPC=BGPC+1
SET BGPY(BGPC)=" LAB: "_$$VAL^XBDIQ1(9000010.09,A,.01)_" "_$$DATE^BGP8UTL($PIECE(BGPG(X),U))_" value: "_$PIECE(^AUPNVLAB(A,0),U,4)
QUIT
End DoDot:5
QUIT
+37 IF BGPLT
IF $PIECE(^AUPNVLAB(A,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(A,0),U)))
SET BGPC=BGPC+1
SET BGPY(BGPC)=" LAB: "_$$VAL^XBDIQ1(9000010.09,A,.01)_" "_$$DATE^BGP8UTL($PIECE(BGPG(X),U))_" value: "_$PIECE(^AUPNVLAB(A,0),U,4)
QUIT
+38 IF 'T
QUIT
+39 SET J=$PIECE($GET(^AUPNVLAB(A,11)),U,13)
IF J=""
QUIT
+40 IF '$$LOINC^BGP8D21(J,T)
QUIT
+41 SET BGPC=BGPC+1
SET BGPY(BGPC)=" LAB: "_$$VAL^XBDIQ1(9000010.09,A,.01)_" "_$$DATE^BGP8UTL($PIECE(BGPG(X),U))_" value: "_$PIECE(^AUPNVLAB(A,0),U,4)
+42 QUIT
End DoDot:4
End DoDot:3
End DoDot:2
+43 SET B=9999999-$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
SET E=9999999-$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
SET D=E-1
FOR
SET D=$ORDER(^AUPNVMIC("AE",P,D))
IF D'=+D!(D>B)
QUIT
Begin DoDot:2
+44 SET L=0
FOR
SET L=$ORDER(^AUPNVMIC("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:3
+45 SET A=0
FOR
SET A=$ORDER(^AUPNVMIC("AE",P,D,L,A))
IF A'=+A
QUIT
Begin DoDot:4
+46 IF '$DATA(^AUPNVMIC(A,0))
QUIT
+47 IF $$VAL^XBDIQ1(9000010.25,A,.01)="BLOOD CULTURE"
Begin DoDot:5
+48 SET BGPC=BGPC+1
SET BGPY(BGPC)=" MICRO: "_$$VAL^XBDIQ1(9000010.25,A,.01)_" "_$$DATE^BGP8UTL($PIECE(BGPG(X),U))_" value: "_$$VAL^XBDIQ1(9000010.25,A,.04)_" "_$PIECE(^AUPNVMIC(A,0),U,7)
QUIT
End DoDot:5
QUIT
+49 IF BGPLT
IF $PIECE(^AUPNVMIC(A,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVMIC(A,0),U)))
Begin DoDot:5
+50 SET BGPC=BGPC+1
SET BGPY(BGPC)=" MICRO: "_$$VAL^XBDIQ1(9000010.25,A,.01)_" "_$$DATE^BGP8UTL($PIECE(BGPG(X),U))_" value: "_$$VAL^XBDIQ1(9000010.25,A,.04)_" "_$PIECE(^AUPNVMIC(A,0),U,7)
QUIT
End DoDot:5
+51 IF 'T
QUIT
+52 SET J=$PIECE($GET(^AUPNVMIC(A,11)),U,13)
IF J=""
QUIT
+53 IF '$$LOINC^BGP8D21(J,T)
QUIT
+54 SET BGPC=BGPC+1
SET BGPY(BGPC)=" MICRO: "_$$VAL^XBDIQ1(9000010.25,A,.01)_" "_$$DATE^BGP8UTL($PIECE(BGPG(X),U))_" value: "_$$VAL^XBDIQ1(9000010.25,A,.04)_" "_$PIECE(^AUPNVMIC(A,0),U,7)
+55 QUIT
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+56 QUIT
AMA(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=3
QUIT 1
+5 QUIT 0
PNEUDX(V) ;
+1 SET C=$$PRIMPOV^APCLV(V,"I")
+2 ;no primary dx
IF C=""
QUIT 0
+3 SET T=$ORDER(^ATXAX("B","BGP CMS PNEUMONIA DXS",0))
+4 ;primary dx of pneumonia
IF $$ICD^ATXCHK(C,T,9)
QUIT 1
+5 ;PRIMARY of resp failure and seconday of pneumonia
+6 SET T=$ORDER(^ATXAX("B","BGP CMS SEPTI/RESP FAIL DXS",0))
+7 ;resp failure not primary pov
IF '$$ICD^ATXCHK(C,T,9)
QUIT 0
+8 SET T=$ORDER(^ATXAX("B","BGP CMS PNEUMONIA DXS",0))
+9 SET (X,G)=0
FOR
SET X=$ORDER(^AUPNVPOV("AD",V,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+10 IF '$DATA(^AUPNVPOV(X,0))
QUIT
+11 IF $PIECE(^AUPNVPOV(X,0),U,12)="P"
QUIT
+12 SET I=$PIECE(^AUPNVPOV(X,0),U)
+13 IF '$$ICD^ATXCHK(I,T,9)
QUIT
+14 SET G=1
+15 QUIT
End DoDot:1
+16 QUIT G
EXPIRED(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=4!(X=5)!(X=6)!(X=7)
QUIT 1
+5 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
