BGP3CU4 ; IHS/CMI/LAB - calc CMS measures 26 Sep 2004 11:28 AM 04 May 2010 2:38 PM 05 Dec 2009 5:23 PM 18 Nov 2010 6:46 AM ;
;;13.0;IHS CLINICAL REPORTING;;NOV 20, 2012;Build 81
;
EXCLCOMP(P,ADMD,DSCHD,BGPY) ;EP
NEW X,BGPC
S BGPC=0
;
;HIV/AIDS dxs
S X=$$HIV(P,$$DOB^AUPNPAT(P),ADMD)
I X S BGPC=BGPC+1,BGPY(BGPC)="HIV/AIDS: ["_$P(X,U,2)_"] "_$$DATE^BGP3UTL($P(X,U,3))
;
;Systemic Chemotherapy
S X=$$SYSCHEMO(P,$$FMADD^XLFDT(ADMD,-90),ADMD)
I X S BGPC=BGPC+1,BGPY(BGPC)=$P(X,U,6)
;
;Systemic Immunotherapy
S X=$$SYSIMMUN(P,$$FMADD^XLFDT(ADMD,-90),ADMD)
I X S BGPC=BGPC+1,BGPY(BGPC)=$P(X,U,6)
;
;Leukemia
S X=$$LEUKEMIA(P,$$FMADD^XLFDT(ADMD,-90),ADMD)
I X S BGPC=BGPC+1,BGPY(BGPC)=$P(X,U,6)
;
;Lymphoma
S X=$$LYMPHOMA(P,$$FMADD^XLFDT(ADMD,-90),ADMD)
I X S BGPC=BGPC+1,BGPY(BGPC)=$P(X,U,6)
;
;Radiation Therapy
S X=$$RADTHER(P,$$FMADD^XLFDT(ADMD,-90),ADMD)
I X S BGPC=BGPC+1,BGPY(BGPC)=$P(X,U,6)
;
;chronic dialysis
S X=$$CHRDIAL(P,$$FMADD^XLFDT(ADMD,-30),ADMD)
I X S BGPC=BGPC+1,BGPY(BGPC)=$P(X,U,2,99)
;
Q
COMP(P,ADMD,DSCHD,BGPY) ;EP
NEW X,BGPC
S BGPC=0
;
;HIV/AIDS dxs
S X=$$HIV(P,$$DOB^AUPNPAT(P),DSCHD)
I X S BGPC=BGPC+1,BGPY(BGPC)="HIV/AIDS: ["_$P(X,U,2)_"] "_$$DATE^BGP3UTL($P(X,U,3))
;
;Systemic Chemotherapy
S X=$$SYSCHEMO(P,$$FMADD^XLFDT(ADMD,-90),ADMD)
I X S BGPC=BGPC+1,BGPY(BGPC)=$P(X,U,6)
;
;Systemic Immunotherapy
S X=$$SYSIMMUN(P,$$FMADD^XLFDT(ADMD,-90),ADMD)
I X S BGPC=BGPC+1,BGPY(BGPC)=$P(X,U,6)
;
;Leukemia
S X=$$LEUKEMIA(P,$$FMADD^XLFDT(ADMD,-90),ADMD)
I X S BGPC=BGPC+1,BGPY(BGPC)=$P(X,U,6)
;
;Lymphoma
S X=$$LYMPHOMA(P,$$FMADD^XLFDT(ADMD,-90),ADMD)
I X S BGPC=BGPC+1,BGPY(BGPC)=$P(X,U,6)
;
;Radiation Therapy
S X=$$RADTHER(P,$$FMADD^XLFDT(ADMD,-90),ADMD)
I X S BGPC=BGPC+1,BGPY(BGPC)=$P(X,U,6)
;
Q
HIV(P,BDATE,EDATE) ;EP
NEW X
S X=$$LASTDX^BGP3UTL1(P,"BGP HIV/AIDS DXS",BDATE,EDATE)
I X Q 1_U_$P(X,U,2)_" "_$$DATE^BGP3UTL($P(X,U,3))
Q ""
;
SYSCHEMO(P,BDATE,EDATE) ;EP
NEW X
;
S X=$$LASTDXI^BGP3UTL1(P,"V58.11",BDATE,EDATE)
I X S $P(X,U,6)="SYSTEMIC CHEMOTHERAPY: [V58.11] "_$$DATE^BGP3UTL($P(X,U,3)) Q X
;
S X=$$LASTPRCI^BGP3UTL1(P,"99.25",BDATE,EDATE)
I X S $P(X,U,6)="SYSTEMIC CHEMOTHERAPY: [99.25] "_$$DATE^BGP3UTL($P(X,U,3)) Q X
;
NEW BGPG,I,D,G,C
K BGPG
S G=""
D GETMEDS^BGP3UTL2(P,BDATE,EDATE,"","","","",.BGPG)
S T=$O(^ATXAX("B","BGP CMS SYSTEMIC CHEMO MEDS",0))
S X=0 F S X=$O(BGPG(X)) Q:X'=+X!(G) D
.S I=+$P(BGPG(X),U,4)
.S D=$P($G(^AUPNVMED(I,0)),U)
.Q:'D
.S C=$P($G(^PSDRUG(D,0)),U,2)
.I C["AN" S G=1_"^^^^^SYSTEMIC CHEMOTHERAPY: "_$P(^PSDRUG(D,0),U)_" CLASS: "_$P(^PSDRUG(D,0),U,2) Q
.I $D(^ATXAX(T,21,"B",D)) S G=1_"^^^^^SYSTEMIC CHEMOTHERAPY: "_$P(^PSDRUG(D,0),U)_" CLASS: "_$P(^PSDRUG(D,0),U,2) Q
I G Q G
Q ""
;
SYSIMMUN(P,BDATE,EDATE) ;EP
NEW X
;
S X=$$LASTDXI^BGP3UTL1(P,"V58.12",BDATE,EDATE)
I X S $P(X,U,6)="SYSTEMIC IMMUNOSUPPRESSIVE THERAPY: [V58.12] "_$$DATE^BGP3UTL($P(X,U,3)) Q X
;
S X=$$LASTPRCI^BGP3UTL1(P,"00.15",BDATE,EDATE)
I X S $P(X,U,6)="SYSTEMIC IMMUNOSUPPRESSIVE THERAPY: [00.15] "_$$DATE^BGP3UTL($P(X,U,3)) Q X
;
S X=$$LASTPRCI^BGP3UTL1(P,"99.28",BDATE,EDATE)
I X S $P(X,U,6)="SYSTEMIC IMMUNOSUPPRESSIVE THERAPY: [99.28] "_$$DATE^BGP3UTL($P(X,U,3)) Q X
;
NEW BGPG,I,D,G,C
K BGPG
S G=""
D GETMEDS^BGP3UTL2(P,BDATE,EDATE,"","","","",.BGPG)
S T=$O(^ATXAX("B","BGP CMS IMMUNOSUPPRESSIVE MEDS",0))
S X=0 F S X=$O(BGPG(X)) Q:X'=+X!(G) D
.S I=+$P(BGPG(X),U,4)
.S D=$P($G(^AUPNVMED(I,0)),U)
.Q:'D
.S C=$P($G(^PSDRUG(D,0)),U,2)
.I C["AN" S G=1_"^^^^^IMMUNOSUPPRESSIVE MED: "_$P(^PSDRUG(D,0),U)_" CLASS: "_$P(^PSDRUG(D,0),U,2) Q
.I $D(^ATXAX(T,21,"B",D)) S G=1_"^^^^^IMMUNOSUPPRESSIVE MED: "_$P(^PSDRUG(D,0),U)_" CLASS: "_$P(^PSDRUG(D,0),U,2) Q
I G Q G
Q ""
;
LEUKEMIA(P,BDATE,EDATE) ;EP
NEW X
S X=$$LASTDX^BGP3UTL1(P,"BGP CMS LEUKEMIA DXS",BDATE,EDATE)
I X S $P(X,U,6)="LEUKEMIA ["_$P(X,U,2)_"] "_$$DATE^BGP3UTL($P(X,U,3)) Q X
Q ""
;
LYMPHOMA(P,BDATE,EDATE) ;EP
NEW X
S X=$$LASTDX^BGP3UTL1(P,"BGP CMS LYMPHOMA DXS",BDATE,EDATE)
I X S $P(X,U,6)="LYMPHOMA ["_$P(X,U,2)_"] "_$$DATE^BGP3UTL($P(X,U,3)) Q X
Q ""
;
RADTHER(P,BDATE,EDATE) ;EP
NEW X
;
S X=$$LASTDXI^BGP3UTL1(P,"V58.0",BDATE,EDATE)
I X S $P(X,U,6)="RADIATION THERAPY: [V58.0] "_$$DATE^BGP3UTL($P(X,U,3)) Q X
;
S X=$$LASTPRC^BGP3UTL1(P,"BGP CMS RADIATION THER DXS",BDATE,EDATE)
I X S $P(X,U,6)="RADIATION THERAPY: ["_$P(X,U,2)_"] "_$$DATE^BGP3UTL($P(X,U,3)) Q X
;
Q ""
;
PRIORHOS(P,BDATE,EDATE,VSIT) ;EP
NEW X,D,G,V
S G=""
S X=0 F S X=$O(^AUPNVINP("AC",P,X)) Q:X'=+X D
.S D=$P($P($G(^AUPNVINP(X,0)),U),".")
.Q:D<BDATE
.Q:D>EDATE
.S V=$P(^AUPNVINP(X,0),U,3)
.Q:V=VSIT
.Q:$P($G(^AUPNVSIT(X,0)),U,3)="C"
.Q:$$TRANS^BGP3CU(X)
.S G=1_U_"Prior Hospital Stay: "_$$DATE^BGP3UTL($P($P(^AUPNVSIT(V,0),U),"."))_"-"_$$DATE^BGP3UTL(D)
.Q
Q G
;
HOS2DAYS(P,BDATE,EDATE) ;EP
NEW X,D,G,V,C,Y,E
S C=0,E=0
S G=""
S X=0 F S X=$O(^AUPNVINP("AC",P,X)) Q:X'=+X D
.S D=$P($P($G(^AUPNVINP(X,0)),U),".")
.Q:D<BDATE
.Q:D>EDATE
.S V=$P(^AUPNVINP(X,0),U,3)
.;Q:$P($G(^AUPNVSIT(X,0)),U,3)="C"
.;Q:$$TRANS^BGP3CU(X)
.S C=C+$$LOS^APCLV(V),E=E+1,Y(E)=$$DATE^BGP3UTL($P($P(^AUPNVSIT(V,0),U),"."))_"-"_$$DATE^BGP3UTL(D)
.Q
I C>1 D Q G
.S G=1_U_"Hospitalized for "_C_" days: " S V=0 F S V=$O(Y(V)) Q:V'=+V S $P(G,U,3)=$P(G,U,3)_Y(V)_"; "
Q ""
;
NURSHOME(P,BDATE,EDATE) ;EP
NEW X,D,G,V,BGPG,Z,B
S G=""
K BGPG
S A="BGPG(",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
I '$D(BGPG(1)) Q ""
S (X,G)=0 F S X=$O(BGPG(X)) Q:X'=+X!(G) 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:$P(^AUPNVSIT(V,0),U,7)'="R"
.Q:$P(^AUPNVSIT(V,0),U,6)=""
.S G=1_U_"Nursing Home Visit: "_$$DATE^BGP3UTL($P($P(^AUPNVSIT(V,0),U),"."))
.Q
Q G
;
CHRDIAL(P,BDATE,EDATE) ;EP
NEW G,X,D,V,Z,B,Q,T,T1
S G=""
NEW X,D,G,V,BGPG,Z,B,R
S G=""
K BGPG
S A="BGPG(",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
I '$D(BGPG(1)) Q ""
S T=$O(^ATXAX("B","BGP CMS CHRONIC DIALYSIS DXS",0))
S T1=$O(^ATXAX("B","BGP CMS CHRONIC DIALYSIS CPTS",0))
S (X,G)=0 F S X=$O(BGPG(X)) Q:X'=+X!(G) 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)
.S Z=0,Q="" F S Z=$O(^AUPNVPOV("AD",V,Z)) Q:Z'=+Z!(Q) D
..Q:'$D(^AUPNVPOV(Z,0))
..Q:'$$ICD^ATXCHK($P(^AUPNVPOV(Z,0),U),T,9)
..S Q=1_U_"DX: "_$$VAL^XBDIQ1(9000010.07,Z,.01)_" "_$$VAL^XBDIQ1(9000010.07,Z,.04)
.Q:'Q
.S Z=0,R="" F S Z=$O(^AUPNVCPT("AD",V,Z)) Q:Z'=+Z!(R) D
..Q:'$D(^AUPNVCPT(Z,0))
..Q:'$$ICD^ATXCHK($P(^AUPNVCPT(Z,0),U),T1,1)
..S R=1_U_"CPT: "_$$VAL^XBDIQ1(9000010.18,Z,.01)
..Q
.Q:'R
.S G=1_U_$P(Q,U,2)_" ; "_$P(R,U,2)_" "_$$DATE^BGP3UTL($$VD^APCLV(V))
.Q
Q G
;
WOUNDCAR(P,BDATE,EDATE) ;EP
NEW G,X,D,V,Z,B,Q,T,T1,K
S G=""
NEW X,D,G,V,BGPG,Z,B,R
S G=""
K BGPG
S A="BGPG(",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
I '$D(BGPG(1)) Q ""
S T=$O(^ATXAX("B","BGP CMS WOUND CARE DXS",0))
S (X,G)=0 F S X=$O(BGPG(X)) Q:X'=+X!(G) 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)
.S K=0
.I $$CLINIC^APCLV(V)=11 S K=1
.I $P(^AUPNVSIT(V,0),U,6)=$P($G(^BGPSITE(DUZ(2),0)),U,2) S K=1
.Q:'K ;not a home visit
.S Z=0,Q="" F S Z=$O(^AUPNVPOV("AD",V,Z)) Q:Z'=+Z!(Q) D
..Q:'$D(^AUPNVPOV(Z,0))
..Q:'$$ICD^ATXCHK($P(^AUPNVPOV(Z,0),U),T,9)
..S G=1_U_"HOME WOUND CARE DX: "_$$VAL^XBDIQ1(9000010.07,Z,.01)_" "_$$VAL^XBDIQ1(9000010.07,Z,.04)
.Q
Q G
;
PSEUDO(H) ;EP
NEW X,Y,Z,A,B,C,T,V
S G=""
I $G(H)="" Q ""
I '$D(^AUPNVINP(H,0)) Q ""
;S T=$O(^ATXAX("B","BGP CMS BRONCHIECTASIS DXS",0))
;S X=$P(^AUPNVINP(H,0),U,12)
I $$VAL^XBDIQ1(9000010.02,H,.12)="496." Q 1_U_"Bronchiectasis: Admitting DX: ["_$$VAL^XBDIQ1(9000010.02,H,.12)_"]"
S V=$P(^AUPNVINP(H,0),U,3)
S X=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"
.I $$VAL^XBDIQ1(9000010.02,X,.01)'="496." Q
.S G=1_U_"Bronchiectasis DX: "_$$VAL^XBDIQ1(9000010.07,X,.01)_" "_$$VAL^XBDIQ1(9000010.07,X,.04)
.Q
Q G
COPD(P,EDATE) ;EP
;now check for COPD ever
S X=$$LASTDX^BGP3UTL1(P,"BGP COPD DXS",$$DOB^AUPNPAT(P),EDATE)
I X Q 1_U_"COPD DX: "_$P(X,U,2)_" "_$$DATE^BGP3UTL($P(X,U,3))_" "_$$VAL^XBDIQ1(9000010.07,$P(X,U,5),.04)
Q ""
;
FLUVAX(P,BDATE,EDATE,BGPDD,BGPY) ;EP
NEW BGPG,BGPX,BGPC,X,Y,Z,A,B,C,R,C1,T
S BGPC=0
S X=0 F S X=$O(^AUPNVIMM("AC",P,X)) Q:X'=+X D
.S Y=$P($G(^AUPNVIMM(X,0)),U)
.Q:'Y
.S C=$P($G(^AUTTIMM(Y,0)),U,3)
.I C'=88,C'=15,C'=16,C'=111 Q
.S D=$P(^AUPNVIMM(X,0),U,3)
.S D=$P($P($G(^AUPNVSIT(D,0)),U),".")
.Q:D<BDATE
.Q:D>EDATE
.S BGPC=BGPC+1,BGPY(BGPC)="Immunization CVX: "_C_" "_$$DATE^BGP3UTL($P($P(^AUPNVSIT($P(^AUPNVIMM(X,0),U,3),0),U),"."))
K BGPG S %=P_"^ALL PROCEDURE 99.52;DURING "_BDATE_"-"_EDATE,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 BGPC=BGPC+1,BGPY(BGPC)="Procedure 99.52: "_$$DATE^BGP3UTL(D)
.Q
K BGPG S %=P_"^ALL DX [BGP FLU IZ DXS;DURING "_BDATE_"-"_EDATE,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 BGPC=BGPC+1,BGPY(BGPC)="Diagnosis "_$P(BGPG(X),U,2)_": "_$$DATE^BGP3UTL(D)
.Q
;now check for cpts
S T=$O(^ATXAX("B","BGP CPT FLU",0))
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)
.S C=$P(^AUPNVCPT(X,0),U)
.I '$$ICD^ATXCHK(C,T,1) Q ;not a flu cpt
.S D=$P(^AUPNVCPT(X,0),U,3)
.S D=$P($P($G(^AUPNVSIT(D,0)),U),".")
.Q:D<BDATE
.Q:D>EDATE
.S BGPC=BGPC+1,BGPY(BGPC)="CPT: "_C1_" "_$$DATE^BGP3UTL(D)
.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)
.S C=$P(^AUPNVTC(X,0),U,7)
.I '$$ICD^ATXCHK(C,T,1) Q ;not a flu cpt
.S D=$P(^AUPNVTC(X,0),U,3)
.S D=$P($P($G(^AUPNVSIT(D,0)),U),".")
.Q:D<BDATE
.Q:D>EDATE
.S BGPC=BGPC+1,BGPY(BGPC)="Tran code: "_C1_" "_$$DATE^BGP3UTL(D)
.Q
;Refusals?
K BGPI F X=88,15,16,111 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))
.S D=0 F S D=$O(^AUPNPREF("AA",P,9999999.14,X,D)) Q:D'=+D D
..S I=0 F S I=$O(^AUPNPREF("AA",P,9999999.14,X,D,I)) Q:I'=+I D
...Q:"NR"'[$P(^AUPNPREF(I,0),U,7)
...Q:(9999999-D)<BDATE
...Q:(9999999-D)>EDATE
...S BGPC=BGPC+1,BGPY(BGPC)="REFUSAL: "_$$VAL^XBDIQ1(9000022,I,.07)_" - "_$$VAL^XBDIQ1(9000022,I,.04)_" "_$$DATE^BGP3UTL($P(^AUPNPREF(I,0),U,3))_" "_$$VAL^XBDIQ1(9000022,I,1101)
..Q
.Q
S (X,G)=0,Y=$O(^AUTTIMM("C",88,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<BDATE
.Q:D>EDATE
.S BGPC=BGPC+1,BGPY(BGPC)="REFUSAL: Immunization Package CVX 88 "_$$DATE^BGP3UTL(D)
S (X,G)=0,Y=$O(^AUTTIMM("C",15,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<BDATE
.Q:D>EDATE
.S BGPC=BGPC+1,BGPY(BGPC)="REFUSAL: Immunization Package CVX 15 "_$$DATE^BGP3UTL(D)
S (X,G)=0,Y=$O(^AUTTIMM("C",16,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<BDATE
.Q:D>EDATE
.S BGPC=BGPC+1,BGPY(BGPC)="REFUSAL: Immunization Package CVX 16 "_$$DATE^BGP3UTL(D)
S (X,G)=0,Y=$O(^AUTTIMM("C",111,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<BDATE
.Q:D>EDATE
.S BGPC=BGPC+1,BGPY(BGPC)="REFUSAL: Immunization Package CVX 111 "_$$DATE^BGP3UTL(D)
;Contraindication new in 8.0
F BGPZ=15,16,88,111 S X=$$FLCONT^BGP3D37(P,BGPZ,$$DOB^AUPNPAT(DFN),EDATE) Q:X]""
I X]"" S BGPC=BGPC+1,BGPY(BGPC)="NMI: "_$$DATE^BGP3UTL($P(X,U))_" "_$P(X,U,2)
;now check for bone marrow Contraindication
S X=$$LASTDXI^BGP3UTL1(P,"357.0",$$FMADD^XLFDT(BGPDD,-365),BGPDD)
I X S BGPC=BGPC+1,BGPY(BGPC)="Bone Marrow Contraindication: ["_$P(X,U,2)_"] "_$$DATE^BGP3UTL($P(X,U,3))
S X=$$LASTPRC^BGP3UTL1(P,"BGP CMS BONE MARROW PROC",$$FMADD^XLFDT(BGPDD,-365),BGPDD)
I X S BGPC=BGPC+1,BGPY(BGPC)="Bone Marrow Contraindication: ["_$P(X,U,2)_"] "_$$DATE^BGP3UTL($P(X,U,3))
S X=$$CPT^BGP3DU(P,$$FMADD^XLFDT(BGPDD,-365),BGPDD,$O(^ATXAX("B","BGP CMS BONE MARROW CPT",0)),6)
I X S BGPC=BGPC+1,BGPY(BGPC)="Bone Marrow Contraindication: ["_$P(X,U,3)_"] "_$$DATE^BGP3UTL($P(X,U,2))
Q
BGP3CU4 ; IHS/CMI/LAB - calc CMS measures 26 Sep 2004 11:28 AM 04 May 2010 2:38 PM 05 Dec 2009 5:23 PM 18 Nov 2010 6:46 AM ;
+1 ;;13.0;IHS CLINICAL REPORTING;;NOV 20, 2012;Build 81
+2 ;
EXCLCOMP(P,ADMD,DSCHD,BGPY) ;EP
+1 NEW X,BGPC
+2 SET BGPC=0
+3 ;
+4 ;HIV/AIDS dxs
+5 SET X=$$HIV(P,$$DOB^AUPNPAT(P),ADMD)
+6 IF X
SET BGPC=BGPC+1
SET BGPY(BGPC)="HIV/AIDS: ["_$PIECE(X,U,2)_"] "_$$DATE^BGP3UTL($PIECE(X,U,3))
+7 ;
+8 ;Systemic Chemotherapy
+9 SET X=$$SYSCHEMO(P,$$FMADD^XLFDT(ADMD,-90),ADMD)
+10 IF X
SET BGPC=BGPC+1
SET BGPY(BGPC)=$PIECE(X,U,6)
+11 ;
+12 ;Systemic Immunotherapy
+13 SET X=$$SYSIMMUN(P,$$FMADD^XLFDT(ADMD,-90),ADMD)
+14 IF X
SET BGPC=BGPC+1
SET BGPY(BGPC)=$PIECE(X,U,6)
+15 ;
+16 ;Leukemia
+17 SET X=$$LEUKEMIA(P,$$FMADD^XLFDT(ADMD,-90),ADMD)
+18 IF X
SET BGPC=BGPC+1
SET BGPY(BGPC)=$PIECE(X,U,6)
+19 ;
+20 ;Lymphoma
+21 SET X=$$LYMPHOMA(P,$$FMADD^XLFDT(ADMD,-90),ADMD)
+22 IF X
SET BGPC=BGPC+1
SET BGPY(BGPC)=$PIECE(X,U,6)
+23 ;
+24 ;Radiation Therapy
+25 SET X=$$RADTHER(P,$$FMADD^XLFDT(ADMD,-90),ADMD)
+26 IF X
SET BGPC=BGPC+1
SET BGPY(BGPC)=$PIECE(X,U,6)
+27 ;
+28 ;chronic dialysis
+29 SET X=$$CHRDIAL(P,$$FMADD^XLFDT(ADMD,-30),ADMD)
+30 IF X
SET BGPC=BGPC+1
SET BGPY(BGPC)=$PIECE(X,U,2,99)
+31 ;
+32 QUIT
COMP(P,ADMD,DSCHD,BGPY) ;EP
+1 NEW X,BGPC
+2 SET BGPC=0
+3 ;
+4 ;HIV/AIDS dxs
+5 SET X=$$HIV(P,$$DOB^AUPNPAT(P),DSCHD)
+6 IF X
SET BGPC=BGPC+1
SET BGPY(BGPC)="HIV/AIDS: ["_$PIECE(X,U,2)_"] "_$$DATE^BGP3UTL($PIECE(X,U,3))
+7 ;
+8 ;Systemic Chemotherapy
+9 SET X=$$SYSCHEMO(P,$$FMADD^XLFDT(ADMD,-90),ADMD)
+10 IF X
SET BGPC=BGPC+1
SET BGPY(BGPC)=$PIECE(X,U,6)
+11 ;
+12 ;Systemic Immunotherapy
+13 SET X=$$SYSIMMUN(P,$$FMADD^XLFDT(ADMD,-90),ADMD)
+14 IF X
SET BGPC=BGPC+1
SET BGPY(BGPC)=$PIECE(X,U,6)
+15 ;
+16 ;Leukemia
+17 SET X=$$LEUKEMIA(P,$$FMADD^XLFDT(ADMD,-90),ADMD)
+18 IF X
SET BGPC=BGPC+1
SET BGPY(BGPC)=$PIECE(X,U,6)
+19 ;
+20 ;Lymphoma
+21 SET X=$$LYMPHOMA(P,$$FMADD^XLFDT(ADMD,-90),ADMD)
+22 IF X
SET BGPC=BGPC+1
SET BGPY(BGPC)=$PIECE(X,U,6)
+23 ;
+24 ;Radiation Therapy
+25 SET X=$$RADTHER(P,$$FMADD^XLFDT(ADMD,-90),ADMD)
+26 IF X
SET BGPC=BGPC+1
SET BGPY(BGPC)=$PIECE(X,U,6)
+27 ;
+28 QUIT
HIV(P,BDATE,EDATE) ;EP
+1 NEW X
+2 SET X=$$LASTDX^BGP3UTL1(P,"BGP HIV/AIDS DXS",BDATE,EDATE)
+3 IF X
QUIT 1_U_$PIECE(X,U,2)_" "_$$DATE^BGP3UTL($PIECE(X,U,3))
+4 QUIT ""
+5 ;
SYSCHEMO(P,BDATE,EDATE) ;EP
+1 NEW X
+2 ;
+3 SET X=$$LASTDXI^BGP3UTL1(P,"V58.11",BDATE,EDATE)
+4 IF X
SET $PIECE(X,U,6)="SYSTEMIC CHEMOTHERAPY: [V58.11] "_$$DATE^BGP3UTL($PIECE(X,U,3))
QUIT X
+5 ;
+6 SET X=$$LASTPRCI^BGP3UTL1(P,"99.25",BDATE,EDATE)
+7 IF X
SET $PIECE(X,U,6)="SYSTEMIC CHEMOTHERAPY: [99.25] "_$$DATE^BGP3UTL($PIECE(X,U,3))
QUIT X
+8 ;
+9 NEW BGPG,I,D,G,C
+10 KILL BGPG
+11 SET G=""
+12 DO GETMEDS^BGP3UTL2(P,BDATE,EDATE,"","","","",.BGPG)
+13 SET T=$ORDER(^ATXAX("B","BGP CMS SYSTEMIC CHEMO MEDS",0))
+14 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+15 SET I=+$PIECE(BGPG(X),U,4)
+16 SET D=$PIECE($GET(^AUPNVMED(I,0)),U)
+17 IF 'D
QUIT
+18 SET C=$PIECE($GET(^PSDRUG(D,0)),U,2)
+19 IF C["AN"
SET G=1_"^^^^^SYSTEMIC CHEMOTHERAPY: "_$PIECE(^PSDRUG(D,0),U)_" CLASS: "_$PIECE(^PSDRUG(D,0),U,2)
QUIT
+20 IF $DATA(^ATXAX(T,21,"B",D))
SET G=1_"^^^^^SYSTEMIC CHEMOTHERAPY: "_$PIECE(^PSDRUG(D,0),U)_" CLASS: "_$PIECE(^PSDRUG(D,0),U,2)
QUIT
End DoDot:1
+21 IF G
QUIT G
+22 QUIT ""
+23 ;
SYSIMMUN(P,BDATE,EDATE) ;EP
+1 NEW X
+2 ;
+3 SET X=$$LASTDXI^BGP3UTL1(P,"V58.12",BDATE,EDATE)
+4 IF X
SET $PIECE(X,U,6)="SYSTEMIC IMMUNOSUPPRESSIVE THERAPY: [V58.12] "_$$DATE^BGP3UTL($PIECE(X,U,3))
QUIT X
+5 ;
+6 SET X=$$LASTPRCI^BGP3UTL1(P,"00.15",BDATE,EDATE)
+7 IF X
SET $PIECE(X,U,6)="SYSTEMIC IMMUNOSUPPRESSIVE THERAPY: [00.15] "_$$DATE^BGP3UTL($PIECE(X,U,3))
QUIT X
+8 ;
+9 SET X=$$LASTPRCI^BGP3UTL1(P,"99.28",BDATE,EDATE)
+10 IF X
SET $PIECE(X,U,6)="SYSTEMIC IMMUNOSUPPRESSIVE THERAPY: [99.28] "_$$DATE^BGP3UTL($PIECE(X,U,3))
QUIT X
+11 ;
+12 NEW BGPG,I,D,G,C
+13 KILL BGPG
+14 SET G=""
+15 DO GETMEDS^BGP3UTL2(P,BDATE,EDATE,"","","","",.BGPG)
+16 SET T=$ORDER(^ATXAX("B","BGP CMS IMMUNOSUPPRESSIVE MEDS",0))
+17 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+18 SET I=+$PIECE(BGPG(X),U,4)
+19 SET D=$PIECE($GET(^AUPNVMED(I,0)),U)
+20 IF 'D
QUIT
+21 SET C=$PIECE($GET(^PSDRUG(D,0)),U,2)
+22 IF C["AN"
SET G=1_"^^^^^IMMUNOSUPPRESSIVE MED: "_$PIECE(^PSDRUG(D,0),U)_" CLASS: "_$PIECE(^PSDRUG(D,0),U,2)
QUIT
+23 IF $DATA(^ATXAX(T,21,"B",D))
SET G=1_"^^^^^IMMUNOSUPPRESSIVE MED: "_$PIECE(^PSDRUG(D,0),U)_" CLASS: "_$PIECE(^PSDRUG(D,0),U,2)
QUIT
End DoDot:1
+24 IF G
QUIT G
+25 QUIT ""
+26 ;
LEUKEMIA(P,BDATE,EDATE) ;EP
+1 NEW X
+2 SET X=$$LASTDX^BGP3UTL1(P,"BGP CMS LEUKEMIA DXS",BDATE,EDATE)
+3 IF X
SET $PIECE(X,U,6)="LEUKEMIA ["_$PIECE(X,U,2)_"] "_$$DATE^BGP3UTL($PIECE(X,U,3))
QUIT X
+4 QUIT ""
+5 ;
LYMPHOMA(P,BDATE,EDATE) ;EP
+1 NEW X
+2 SET X=$$LASTDX^BGP3UTL1(P,"BGP CMS LYMPHOMA DXS",BDATE,EDATE)
+3 IF X
SET $PIECE(X,U,6)="LYMPHOMA ["_$PIECE(X,U,2)_"] "_$$DATE^BGP3UTL($PIECE(X,U,3))
QUIT X
+4 QUIT ""
+5 ;
RADTHER(P,BDATE,EDATE) ;EP
+1 NEW X
+2 ;
+3 SET X=$$LASTDXI^BGP3UTL1(P,"V58.0",BDATE,EDATE)
+4 IF X
SET $PIECE(X,U,6)="RADIATION THERAPY: [V58.0] "_$$DATE^BGP3UTL($PIECE(X,U,3))
QUIT X
+5 ;
+6 SET X=$$LASTPRC^BGP3UTL1(P,"BGP CMS RADIATION THER DXS",BDATE,EDATE)
+7 IF X
SET $PIECE(X,U,6)="RADIATION THERAPY: ["_$PIECE(X,U,2)_"] "_$$DATE^BGP3UTL($PIECE(X,U,3))
QUIT X
+8 ;
+9 QUIT ""
+10 ;
PRIORHOS(P,BDATE,EDATE,VSIT) ;EP
+1 NEW X,D,G,V
+2 SET G=""
+3 SET X=0
FOR
SET X=$ORDER(^AUPNVINP("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+4 SET D=$PIECE($PIECE($GET(^AUPNVINP(X,0)),U),".")
+5 IF D<BDATE
QUIT
+6 IF D>EDATE
QUIT
+7 SET V=$PIECE(^AUPNVINP(X,0),U,3)
+8 IF V=VSIT
QUIT
+9 IF $PIECE($GET(^AUPNVSIT(X,0)),U,3)="C"
QUIT
+10 IF $$TRANS^BGP3CU(X)
QUIT
+11 SET G=1_U_"Prior Hospital Stay: "_$$DATE^BGP3UTL($PIECE($PIECE(^AUPNVSIT(V,0),U),"."))_"-"_$$DATE^BGP3UTL(D)
+12 QUIT
End DoDot:1
+13 QUIT G
+14 ;
HOS2DAYS(P,BDATE,EDATE) ;EP
+1 NEW X,D,G,V,C,Y,E
+2 SET C=0
SET E=0
+3 SET G=""
+4 SET X=0
FOR
SET X=$ORDER(^AUPNVINP("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+5 SET D=$PIECE($PIECE($GET(^AUPNVINP(X,0)),U),".")
+6 IF D<BDATE
QUIT
+7 IF D>EDATE
QUIT
+8 SET V=$PIECE(^AUPNVINP(X,0),U,3)
+9 ;Q:$P($G(^AUPNVSIT(X,0)),U,3)="C"
+10 ;Q:$$TRANS^BGP3CU(X)
+11 SET C=C+$$LOS^APCLV(V)
SET E=E+1
SET Y(E)=$$DATE^BGP3UTL($PIECE($PIECE(^AUPNVSIT(V,0),U),"."))_"-"_$$DATE^BGP3UTL(D)
+12 QUIT
End DoDot:1
+13 IF C>1
Begin DoDot:1
+14 SET G=1_U_"Hospitalized for "_C_" days: "
SET V=0
FOR
SET V=$ORDER(Y(V))
IF V'=+V
QUIT
SET $PIECE(G,U,3)=$PIECE(G,U,3)_Y(V)_"; "
End DoDot:1
QUIT G
+15 QUIT ""
+16 ;
NURSHOME(P,BDATE,EDATE) ;EP
+1 NEW X,D,G,V,BGPG,Z,B
+2 SET G=""
+3 KILL BGPG
+4 SET A="BGPG("
SET B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(B,A)
+5 IF '$DATA(BGPG(1))
QUIT ""
+6 SET (X,G)=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X!(G)
QUIT
SET V=$PIECE(BGPG(X),U,5)
Begin DoDot:1
+7 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+8 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+9 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+10 IF $PIECE(^AUPNVSIT(V,0),U,7)'="R"
QUIT
+11 IF $PIECE(^AUPNVSIT(V,0),U,6)=""
QUIT
+12 SET G=1_U_"Nursing Home Visit: "_$$DATE^BGP3UTL($PIECE($PIECE(^AUPNVSIT(V,0),U),"."))
+13 QUIT
End DoDot:1
+14 QUIT G
+15 ;
CHRDIAL(P,BDATE,EDATE) ;EP
+1 NEW G,X,D,V,Z,B,Q,T,T1
+2 SET G=""
+3 NEW X,D,G,V,BGPG,Z,B,R
+4 SET G=""
+5 KILL BGPG
+6 SET A="BGPG("
SET B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(B,A)
+7 IF '$DATA(BGPG(1))
QUIT ""
+8 SET T=$ORDER(^ATXAX("B","BGP CMS CHRONIC DIALYSIS DXS",0))
+9 SET T1=$ORDER(^ATXAX("B","BGP CMS CHRONIC DIALYSIS CPTS",0))
+10 SET (X,G)=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X!(G)
QUIT
SET V=$PIECE(BGPG(X),U,5)
Begin DoDot:1
+11 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+12 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+13 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+14 SET Z=0
SET Q=""
FOR
SET Z=$ORDER(^AUPNVPOV("AD",V,Z))
IF Z'=+Z!(Q)
QUIT
Begin DoDot:2
+15 IF '$DATA(^AUPNVPOV(Z,0))
QUIT
+16 IF '$$ICD^ATXCHK($PIECE(^AUPNVPOV(Z,0),U),T,9)
QUIT
+17 SET Q=1_U_"DX: "_$$VAL^XBDIQ1(9000010.07,Z,.01)_" "_$$VAL^XBDIQ1(9000010.07,Z,.04)
End DoDot:2
+18 IF 'Q
QUIT
+19 SET Z=0
SET R=""
FOR
SET Z=$ORDER(^AUPNVCPT("AD",V,Z))
IF Z'=+Z!(R)
QUIT
Begin DoDot:2
+20 IF '$DATA(^AUPNVCPT(Z,0))
QUIT
+21 IF '$$ICD^ATXCHK($PIECE(^AUPNVCPT(Z,0),U),T1,1)
QUIT
+22 SET R=1_U_"CPT: "_$$VAL^XBDIQ1(9000010.18,Z,.01)
+23 QUIT
End DoDot:2
+24 IF 'R
QUIT
+25 SET G=1_U_$PIECE(Q,U,2)_" ; "_$PIECE(R,U,2)_" "_$$DATE^BGP3UTL($$VD^APCLV(V))
+26 QUIT
End DoDot:1
+27 QUIT G
+28 ;
WOUNDCAR(P,BDATE,EDATE) ;EP
+1 NEW G,X,D,V,Z,B,Q,T,T1,K
+2 SET G=""
+3 NEW X,D,G,V,BGPG,Z,B,R
+4 SET G=""
+5 KILL BGPG
+6 SET A="BGPG("
SET B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(B,A)
+7 IF '$DATA(BGPG(1))
QUIT ""
+8 SET T=$ORDER(^ATXAX("B","BGP CMS WOUND CARE DXS",0))
+9 SET (X,G)=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X!(G)
QUIT
SET V=$PIECE(BGPG(X),U,5)
Begin DoDot:1
+10 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+11 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+12 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+13 SET K=0
+14 IF $$CLINIC^APCLV(V)=11
SET K=1
+15 IF $PIECE(^AUPNVSIT(V,0),U,6)=$PIECE($GET(^BGPSITE(DUZ(2),0)),U,2)
SET K=1
+16 ;not a home visit
IF 'K
QUIT
+17 SET Z=0
SET Q=""
FOR
SET Z=$ORDER(^AUPNVPOV("AD",V,Z))
IF Z'=+Z!(Q)
QUIT
Begin DoDot:2
+18 IF '$DATA(^AUPNVPOV(Z,0))
QUIT
+19 IF '$$ICD^ATXCHK($PIECE(^AUPNVPOV(Z,0),U),T,9)
QUIT
+20 SET G=1_U_"HOME WOUND CARE DX: "_$$VAL^XBDIQ1(9000010.07,Z,.01)_" "_$$VAL^XBDIQ1(9000010.07,Z,.04)
End DoDot:2
+21 QUIT
End DoDot:1
+22 QUIT G
+23 ;
PSEUDO(H) ;EP
+1 NEW X,Y,Z,A,B,C,T,V
+2 SET G=""
+3 IF $GET(H)=""
QUIT ""
+4 IF '$DATA(^AUPNVINP(H,0))
QUIT ""
+5 ;S T=$O(^ATXAX("B","BGP CMS BRONCHIECTASIS DXS",0))
+6 ;S X=$P(^AUPNVINP(H,0),U,12)
+7 IF $$VAL^XBDIQ1(9000010.02,H,.12)="496."
QUIT 1_U_"Bronchiectasis: Admitting DX: ["_$$VAL^XBDIQ1(9000010.02,H,.12)_"]"
+8 SET V=$PIECE(^AUPNVINP(H,0),U,3)
+9 SET X=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 IF $$VAL^XBDIQ1(9000010.02,X,.01)'="496."
QUIT
+13 SET G=1_U_"Bronchiectasis DX: "_$$VAL^XBDIQ1(9000010.07,X,.01)_" "_$$VAL^XBDIQ1(9000010.07,X,.04)
+14 QUIT
End DoDot:1
+15 QUIT G
COPD(P,EDATE) ;EP
+1 ;now check for COPD ever
+2 SET X=$$LASTDX^BGP3UTL1(P,"BGP COPD DXS",$$DOB^AUPNPAT(P),EDATE)
+3 IF X
QUIT 1_U_"COPD DX: "_$PIECE(X,U,2)_" "_$$DATE^BGP3UTL($PIECE(X,U,3))_" "_$$VAL^XBDIQ1(9000010.07,$PIECE(X,U,5),.04)
+4 QUIT ""
+5 ;
FLUVAX(P,BDATE,EDATE,BGPDD,BGPY) ;EP
+1 NEW BGPG,BGPX,BGPC,X,Y,Z,A,B,C,R,C1,T
+2 SET BGPC=0
+3 SET X=0
FOR
SET X=$ORDER(^AUPNVIMM("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+4 SET Y=$PIECE($GET(^AUPNVIMM(X,0)),U)
+5 IF 'Y
QUIT
+6 SET C=$PIECE($GET(^AUTTIMM(Y,0)),U,3)
+7 IF C'=88
IF C'=15
IF C'=16
IF C'=111
QUIT
+8 SET D=$PIECE(^AUPNVIMM(X,0),U,3)
+9 SET D=$PIECE($PIECE($GET(^AUPNVSIT(D,0)),U),".")
+10 IF D<BDATE
QUIT
+11 IF D>EDATE
QUIT
+12 SET BGPC=BGPC+1
SET BGPY(BGPC)="Immunization CVX: "_C_" "_$$DATE^BGP3UTL($PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVIMM(X,0),U,3),0),U),"."))
End DoDot:1
+13 KILL BGPG
SET %=P_"^ALL PROCEDURE 99.52;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"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(^AUPNVPRC(Y,0))
QUIT
+16 SET Y=$PIECE(^AUPNVPRC(Y,0),U,1)
+17 IF 'Y
QUIT
+18 SET D=$PIECE(BGPG(X),U)
+19 SET BGPC=BGPC+1
SET BGPY(BGPC)="Procedure 99.52: "_$$DATE^BGP3UTL(D)
+20 QUIT
End DoDot:1
+21 KILL BGPG
SET %=P_"^ALL DX [BGP FLU IZ DXS;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+22 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET Y=+$PIECE(BGPG(X),U,4)
Begin DoDot:1
+23 IF '$DATA(^AUPNVPOV(Y,0))
QUIT
+24 SET Y=$PIECE(^AUPNVPOV(Y,0),U,1)
+25 IF 'Y
QUIT
+26 SET D=$PIECE(BGPG(X),U)
+27 SET BGPC=BGPC+1
SET BGPY(BGPC)="Diagnosis "_$PIECE(BGPG(X),U,2)_": "_$$DATE^BGP3UTL(D)
+28 QUIT
End DoDot:1
+29 ;now check for cpts
+30 SET T=$ORDER(^ATXAX("B","BGP CPT FLU",0))
+31 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+32 IF '$DATA(^AUPNVCPT(X,0))
QUIT
+33 SET C1=$$VAL^XBDIQ1(9000010.18,X,.01)
+34 SET C=$PIECE(^AUPNVCPT(X,0),U)
+35 ;not a flu cpt
IF '$$ICD^ATXCHK(C,T,1)
QUIT
+36 SET D=$PIECE(^AUPNVCPT(X,0),U,3)
+37 SET D=$PIECE($PIECE($GET(^AUPNVSIT(D,0)),U),".")
+38 IF D<BDATE
QUIT
+39 IF D>EDATE
QUIT
+40 SET BGPC=BGPC+1
SET BGPY(BGPC)="CPT: "_C1_" "_$$DATE^BGP3UTL(D)
+41 QUIT
End DoDot:1
+42 ;tran codes
+43 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+44 IF '$DATA(^AUPNVTC(X,0))
QUIT
+45 SET C1=$$VAL^XBDIQ1(9000010.33,X,.07)
+46 SET C=$PIECE(^AUPNVTC(X,0),U,7)
+47 ;not a flu cpt
IF '$$ICD^ATXCHK(C,T,1)
QUIT
+48 SET D=$PIECE(^AUPNVTC(X,0),U,3)
+49 SET D=$PIECE($PIECE($GET(^AUPNVSIT(D,0)),U),".")
+50 IF D<BDATE
QUIT
+51 IF D>EDATE
QUIT
+52 SET BGPC=BGPC+1
SET BGPY(BGPC)="Tran code: "_C1_" "_$$DATE^BGP3UTL(D)
+53 QUIT
End DoDot:1
+54 ;Refusals?
+55 KILL BGPI
FOR X=88,15,16,111
SET Y=$ORDER(^AUTTIMM("C",X,0))
IF Y
SET BGPI(Y)=""
+56 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,9999999.14,X))
IF X'=+X
QUIT
Begin DoDot:1
+57 IF '$DATA(BGPI(X))
QUIT
+58 SET D=0
FOR
SET D=$ORDER(^AUPNPREF("AA",P,9999999.14,X,D))
IF D'=+D
QUIT
Begin DoDot:2
+59 SET I=0
FOR
SET I=$ORDER(^AUPNPREF("AA",P,9999999.14,X,D,I))
IF I'=+I
QUIT
Begin DoDot:3
+60 IF "NR"'[$PIECE(^AUPNPREF(I,0),U,7)
QUIT
+61 IF (9999999-D)<BDATE
QUIT
+62 IF (9999999-D)>EDATE
QUIT
+63 SET BGPC=BGPC+1
SET BGPY(BGPC)="REFUSAL: "_$$VAL^XBDIQ1(9000022,I,.07)_" - "_$$VAL^XBDIQ1(9000022,I,.04)_" "_$$DATE^BGP3UTL($PIECE(^AUPNPREF(I,0),U,3))_" "_$$VAL^XBDIQ1(9000022,I,1101)
End DoDot:3
+64 QUIT
End DoDot:2
+65 QUIT
End DoDot:1
+66 SET (X,G)=0
SET Y=$ORDER(^AUTTIMM("C",88,0))
FOR
SET X=$ORDER(^BIPC("AC",P,Y,X))
IF X'=+X
QUIT
Begin DoDot:1
+67 SET R=$PIECE(^BIPC(X,0),U,3)
+68 IF R=""
QUIT
+69 IF '$DATA(^BICONT(R,0))
QUIT
+70 IF $PIECE(^BICONT(R,0),U,1)'["Refusal"
QUIT
+71 SET D=$PIECE(^BIPC(X,0),U,4)
+72 IF D=""
QUIT
+73 IF D<BDATE
QUIT
+74 IF D>EDATE
QUIT
+75 SET BGPC=BGPC+1
SET BGPY(BGPC)="REFUSAL: Immunization Package CVX 88 "_$$DATE^BGP3UTL(D)
End DoDot:1
+76 SET (X,G)=0
SET Y=$ORDER(^AUTTIMM("C",15,0))
IF Y
FOR
SET X=$ORDER(^BIPC("AC",P,Y,X))
IF X'=+X
QUIT
Begin DoDot:1
+77 SET R=$PIECE(^BIPC(X,0),U,3)
+78 IF R=""
QUIT
+79 IF '$DATA(^BICONT(R,0))
QUIT
+80 IF $PIECE(^BICONT(R,0),U,1)'["Refusal"
QUIT
+81 SET D=$PIECE(^BIPC(X,0),U,4)
+82 IF D=""
QUIT
+83 IF D<BDATE
QUIT
+84 IF D>EDATE
QUIT
+85 SET BGPC=BGPC+1
SET BGPY(BGPC)="REFUSAL: Immunization Package CVX 15 "_$$DATE^BGP3UTL(D)
End DoDot:1
+86 SET (X,G)=0
SET Y=$ORDER(^AUTTIMM("C",16,0))
IF Y
FOR
SET X=$ORDER(^BIPC("AC",P,Y,X))
IF X'=+X
QUIT
Begin DoDot:1
+87 SET R=$PIECE(^BIPC(X,0),U,3)
+88 IF R=""
QUIT
+89 IF '$DATA(^BICONT(R,0))
QUIT
+90 IF $PIECE(^BICONT(R,0),U,1)'["Refusal"
QUIT
+91 SET D=$PIECE(^BIPC(X,0),U,4)
+92 IF D=""
QUIT
+93 IF D<BDATE
QUIT
+94 IF D>EDATE
QUIT
+95 SET BGPC=BGPC+1
SET BGPY(BGPC)="REFUSAL: Immunization Package CVX 16 "_$$DATE^BGP3UTL(D)
End DoDot:1
+96 SET (X,G)=0
SET Y=$ORDER(^AUTTIMM("C",111,0))
IF Y
FOR
SET X=$ORDER(^BIPC("AC",P,Y,X))
IF X'=+X
QUIT
Begin DoDot:1
+97 SET R=$PIECE(^BIPC(X,0),U,3)
+98 IF R=""
QUIT
+99 IF '$DATA(^BICONT(R,0))
QUIT
+100 IF $PIECE(^BICONT(R,0),U,1)'["Refusal"
QUIT
+101 SET D=$PIECE(^BIPC(X,0),U,4)
+102 IF D=""
QUIT
+103 IF D<BDATE
QUIT
+104 IF D>EDATE
QUIT
+105 SET BGPC=BGPC+1
SET BGPY(BGPC)="REFUSAL: Immunization Package CVX 111 "_$$DATE^BGP3UTL(D)
End DoDot:1
+106 ;Contraindication new in 8.0
+107 FOR BGPZ=15,16,88,111
SET X=$$FLCONT^BGP3D37(P,BGPZ,$$DOB^AUPNPAT(DFN),EDATE)
IF X]""
QUIT
+108 IF X]""
SET BGPC=BGPC+1
SET BGPY(BGPC)="NMI: "_$$DATE^BGP3UTL($PIECE(X,U))_" "_$PIECE(X,U,2)
+109 ;now check for bone marrow Contraindication
+110 SET X=$$LASTDXI^BGP3UTL1(P,"357.0",$$FMADD^XLFDT(BGPDD,-365),BGPDD)
+111 IF X
SET BGPC=BGPC+1
SET BGPY(BGPC)="Bone Marrow Contraindication: ["_$PIECE(X,U,2)_"] "_$$DATE^BGP3UTL($PIECE(X,U,3))
+112 SET X=$$LASTPRC^BGP3UTL1(P,"BGP CMS BONE MARROW PROC",$$FMADD^XLFDT(BGPDD,-365),BGPDD)
+113 IF X
SET BGPC=BGPC+1
SET BGPY(BGPC)="Bone Marrow Contraindication: ["_$PIECE(X,U,2)_"] "_$$DATE^BGP3UTL($PIECE(X,U,3))
+114 SET X=$$CPT^BGP3DU(P,$$FMADD^XLFDT(BGPDD,-365),BGPDD,$ORDER(^ATXAX("B","BGP CMS BONE MARROW CPT",0)),6)
+115 IF X
SET BGPC=BGPC+1
SET BGPY(BGPC)="Bone Marrow Contraindication: ["_$PIECE(X,U,3)_"] "_$$DATE^BGP3UTL($PIECE(X,U,2))
+116 QUIT
