BGP1D37 ; IHS/CMI/LAB - IMMUNIZATIONS ;
;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
;
FLU ;EP
NEW BGPG,BGPLFLU,EDATE,X,E,%,I,T,J,V,G,D,R
K BGPG
S BGPLFLU=""
I $G(BD)="" S BD=$$FMADD^XLFDT(ED,-365)
S EDATE=$$FMTE^XLFDT(ED),BDATE=$$FMTE^XLFDT(BD)
S X=P_"^LAST IMM 88;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BGPG(")
I $D(BGPG(1)) S BGPLFLU=$P(BGPG(1),U)_U_"Imm 88"
S X=P_"^LAST IMM 111;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BGPG(")
I $D(BGPG(1)),$P(BGPLFLU,U)<$P(BGPG(1),U) S BGPLFLU=$P(BGPG(1),U)_U_"Imm 111"
S X=P_"^LAST IMM 15;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BGPG(")
I $D(BGPG(1)),$P(BGPLFLU,U)<$P(BGPG(1),U) S BGPLFLU=$P(BGPG(1),U)_U_"Imm 15"
S X=P_"^LAST IMM 16;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BGPG(")
I $D(BGPG(1)),$P(BGPLFLU,U)<$P(BGPG(1),U) S BGPLFLU=$P(BGPG(1),U)_U_"Imm 16"
S X=P_"^LAST IMM 135;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BGPG(")
I $D(BGPG(1)),$P(BGPLFLU,U)<$P(BGPG(1),U) S BGPLFLU=$P(BGPG(1),U)_U_"Imm 135"
S X=P_"^LAST IMM 140;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BGPG(")
I $D(BGPG(1)),$P(BGPLFLU,U)<$P(BGPG(1),U) S BGPLFLU=$P(BGPG(1),U)_U_"Imm 140"
S X=P_"^LAST IMM 141;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"BGPG(")
I $D(BGPG(1)),$P(BGPLFLU,U)<$P(BGPG(1),U) S BGPLFLU=$P(BGPG(1),U)_U_"Imm 141"
K BGPG S %=P_"^LAST DX V04.8;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) I $P(BGPLFLU,U)<$P(BGPG(1),U,1) S BGPLFLU=$P(BGPG(1),U,1)_U_"V04.8"
S BGPG=$$LASTPRCI^BGP1UTL1(P,"99.52",BD,ED)
I $P(BGPG,U,1)=1,$P(BGPLFLU,U)<$P(BGPG,U,3) S BGPLFLU=$P(BGPG,U,3)_U_"99.52"
K BGPG S %=P_"^LAST DX V04.81;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) D
.S T=$O(^ATXAX("B","SURVEILLANCE CPT H1N1",0))
.S X=0 F S X=$O(BGPG(X)) Q:X'=+X D
..S V=$P(BGPG(X),U,5)
..S G=0
..S J=0 F S J=$O(^AUPNVCPT("AD",V,J)) Q:J'=+J S I=$P(^AUPNVCPT(J,0),U,1) I $$ICD^ATXCHK(I,T,1)!($$H1(I)) S G=1
..Q:G=1
..I $P(BGPLFLU,U)<$P(BGPG(X),U,1) S BGPLFLU=$P(BGPG(1),U,1)_U_"POV V04.81"
K BGPG S %=P_"^LAST DX V06.6;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) D
.S T=$O(^ATXAX("B","SURVEILLANCE CPT H1N1",0))
.S X=0 F S X=$O(BGPG(X)) Q:X'=+X D
..S V=$P(BGPG(X),U,5)
..S G=0
..S J=0 F S J=$O(^AUPNVCPT("AD",V,J)) Q:J'=+J S I=$P(^AUPNVCPT(J,0),U,1) I $$ICD^ATXCHK(I,T,1)!($$H1(I)) S G=1
..Q:G=1
..I $P(BGPLFLU,U)<$P(BGPG(X),U,1) S BGPLFLU=$P(BGPG(1),U,1)_U_"POV V06.06"
S T=$O(^ATXAX("B","BGP CPT FLU",0))
I T D I X]"" I $P(BGPLFLU,U)<X S BGPLFLU=$P(X,U)_U_"CPT "_$P(X,U,2)
.S X=$$CPT^BGP1DU(P,,ED,T,5) I X]"" Q
.S X=$$TRAN^BGP1DU(P,,ED,T,5)
I BGPLFLU]"" Q BGPLFLU_U_1
;contraindication new in 8.0
F BGPZ=15,16,88,111,135,140,141 S X=$$FLCONT(P,BGPZ,$$DOB^AUPNPAT(P),ED) Q:X]""
I X]"" Q X_U_3
;NMI refusal
S G=$$NMIREF^BGP1UTL1(P,9999999.14,$O(^AUTTIMM("C",88,0)),$$DOB^AUPNPAT(P),ED)
I $P(G,U)=1 Q $P(G,U,2)_U_"NMI Refusal"_U_3
S G=$$NMIREF^BGP1UTL1(P,9999999.14,$O(^AUTTIMM("C",111,0)),$$DOB^AUPNPAT(P),ED)
I $P(G,U)=1 Q $P(G,U,2)_U_"NMI Refusal"_U_3
S G=$$NMIREF^BGP1UTL1(P,9999999.14,$O(^AUTTIMM("C",15,0)),$$DOB^AUPNPAT(P),ED)
I $P(G,U)=1 Q $P(G,U,2)_U_"NMI Refusal"_U_3
S G=$$NMIREF^BGP1UTL1(P,9999999.14,$O(^AUTTIMM("C",16,0)),$$DOB^AUPNPAT(P),ED)
I $P(G,U)=1 Q $P(G,U,2)_U_"NMI Refusal"_U_3
S G=$$NMIREF^BGP1UTL1(P,9999999.14,$O(^AUTTIMM("C",135,0)),$$DOB^AUPNPAT(P),ED)
I $P(G,U)=1 Q $P(G,U,2)_U_"NMI Refusal"_U_3
S G=$$NMIREF^BGP1UTL1(P,9999999.14,$O(^AUTTIMM("C",140,0)),$$DOB^AUPNPAT(P),ED)
I $P(G,U)=1 Q $P(G,U,2)_U_"NMI Refusal"_U_3
S G=$$NMIREF^BGP1UTL1(P,9999999.14,$O(^AUTTIMM("C",141,0)),$$DOB^AUPNPAT(P),ED)
I $P(G,U)=1 Q $P(G,U,2)_U_"NMI Refusal"_U_3
I $G(FORE) Q ""
S G=$$REFUSAL^BGP1UTL1(P,9999999.14,$O(^AUTTIMM("C",88,0)),$$FMADD^XLFDT(ED,-365),ED)
I $P(G,U)=1 Q $P(G,U,2)_U_"Refused"_U_2
S G=$$REFUSAL^BGP1UTL1(P,9999999.14,$O(^AUTTIMM("C",111,0)),$$FMADD^XLFDT(ED,-365),ED)
I $P(G,U)=1 Q $P(G,U,2)_U_"Refused"_U_2
S G=$$REFUSAL^BGP1UTL1(P,9999999.14,$O(^AUTTIMM("C",15,0)),$$FMADD^XLFDT(ED,-365),ED)
I $P(G,U)=1 Q $P(G,U,2)_U_"Refused"_U_2
S G=$$REFUSAL^BGP1UTL1(P,9999999.14,$O(^AUTTIMM("C",16,0)),$$FMADD^XLFDT(ED,-365),ED)
I $P(G,U)=1 Q $P(G,U,2)_U_"Refused"_U_2
S G=$$REFUSAL^BGP1UTL1(P,9999999.14,$O(^AUTTIMM("C",135,0)),$$FMADD^XLFDT(ED,-365),ED)
I $P(G,U)=1 Q $P(G,U,2)_U_"Refused"_U_2
S G=$$REFUSAL^BGP1UTL1(P,9999999.14,$O(^AUTTIMM("C",140,0)),$$FMADD^XLFDT(ED,-365),ED)
I $P(G,U)=1 Q $P(G,U,2)_U_"Refused"_U_2
S G=$$REFUSAL^BGP1UTL1(P,9999999.14,$O(^AUTTIMM("C",141,0)),$$FMADD^XLFDT(ED,-365),ED)
I $P(G,U)=1 Q $P(G,U,2)_U_"Refused"_U_2
S (X,G)=0,Y=$O(^AUTTIMM("C",88,0)) F S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X!(G) 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:$P(^BIPC(X,0),U,4)<BD
.Q:$P(^BIPC(X,0),U,4)>ED
.S G=1
I G Q $P(G,U,2)_U_"Refused Imm pkg"_U_2
S (X,G)=0,Y=$O(^AUTTIMM("C",111,0)) I Y F S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X!(G) 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:$P(^BIPC(X,0),U,4)<BD
.Q:$P(^BIPC(X,0),U,4)>ED
.S G=1
I G Q $P(G,U,2)_U_"Refused Imm pkg"_U_2
S (X,G)=0,Y=$O(^AUTTIMM("C",15,0)) I Y F S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X!(G) 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:$P(^BIPC(X,0),U,4)<BD
.Q:$P(^BIPC(X,0),U,4)>ED
.S G=1
I G Q $P(G,U,2)_U_"Refused Imm pkg"_U_2
S (X,G)=0,Y=$O(^AUTTIMM("C",16,0)) I Y F S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X!(G) 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:$P(^BIPC(X,0),U,4)<BD
.Q:$P(^BIPC(X,0),U,4)>ED
.S G=1
I G Q $P(G,U,2)_U_"Refused Imm pkg"_U_2
S (X,G)=0,Y=$O(^AUTTIMM("C",135,0)) I Y F S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X!(G) 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:$P(^BIPC(X,0),U,4)<BD
.Q:$P(^BIPC(X,0),U,4)>ED
.S G=1
I G Q $P(G,U,2)_U_"Refused Imm pkg"_U_2
S (X,G)=0,Y=$O(^AUTTIMM("C",140,0)) I Y F S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X!(G) 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:$P(^BIPC(X,0),U,4)<BD
.Q:$P(^BIPC(X,0),U,4)>ED
.S G=1
I G Q $P(G,U,2)_U_"Refused Imm pkg"_U_2
S (X,G)=0,Y=$O(^AUTTIMM("C",141,0)) I Y F S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X!(G) 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:$P(^BIPC(X,0),U,4)<BD
.Q:$P(^BIPC(X,0),U,4)>ED
.S G=1
I G Q $P(G,U,2)_U_"Refused Imm pkg"_U_2
Q ""
FLCONT(P,C,BD,ED) ;EP
NEW X,G,Y,R,D
S X=0,G="",Y=$O(^AUTTIMM("C",C,0)) I Y F S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X!(G) D
.S R=$P(^BIPC(X,0),U,3)
.Q:R=""
.Q:'$D(^BICONT(R,0))
.S D=$P(^BIPC(X,0),U,4)
.Q:D=""
.Q:$P(^BIPC(X,0),U,4)<BD
.Q:$P(^BIPC(X,0),U,4)>ED
.I $P(^BICONT(R,0),U,1)="Egg Allergy" S G=D_U_"Contraindication: Egg Allergy"
.I $P(^BICONT(R,0),U,1)="Anaphylaxis" S G=D_U_"Contraindication: Anaphylaxis"
Q G
H1(I) ;
I $P($G(^ICPT(I,0)),U,1)=90664 Q 1
I $P($G(^ICPT(I,0)),U,1)=90666 Q 1
I $P($G(^ICPT(I,0)),U,1)=90667 Q 1
I $P($G(^ICPT(I,0)),U,1)=90668 Q 1
Q ""
ROTA2(P,EDATE) ;EP
NEW BGPC,BGPG,BGPX,BGPROTA,C,X,ED,BD,G,V,Y,T,I,R,BGPIMM,BGPNMI
K BGPC,BGPG,BGPX
;gather up all immunizations, cpts, povs and check for 3 each ten days apart
K BGPROTA
;get all immunizations
S C="119"
D GETIMMS^BGP1D32(P,EDATE,C,.BGPX)
;go through and set into array if 10 days apart
S X=0 F S X=$O(BGPX(X)) Q:X'=+X S BGPROTA(X)=""
;now get cpts
S ED=9999999-EDATE,BD=9999999-$$DOB^AUPNPAT(P),G=0
F S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD) D
.S V=0 F S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V D
..Q:'$D(^AUPNVSIT(V,0))
..S X=0 F S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X D
...S Y=$P(^AUPNVCPT(X,0),U) S Z=$P($$CPT^ICPTCOD(Y),U,2) I Z=90681 S BGPROTA(9999999-$P(ED,"."))=""
..S X=0 F S X=$O(^AUPNVTC("AD",V,X)) Q:X'=+X D
...S Y=$P(^AUPNVTC(X,0),U,7) Q:'Y S Z=$P($$CPT^ICPTCOD(Y),U,2) I Z=90681 S BGPROTA(9999999-$P(ED,"."))=""
;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
S X="",Y="",C=0 F S X=$O(BGPROTA(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BGPROTA(X) Q
.S Y=X
;now count them and see if there are 2 of them
S BGPROTA=0,X=0 F S X=$O(BGPROTA(X)) Q:X'=+X S BGPROTA=BGPROTA+1
I BGPROTA>1 Q 1_U_"2 Rotavirus"
F BGPZ=119 S X=$$ANIMCONT^BGP1D31(P,BGPZ,EDATE) Q:X]"" ;cmi/maw 12/17/07 missing edate
I X]"" Q 4_U_"contra - Rotavirus"
;
S B=$$DOB^AUPNPAT(P),E=EDATE,BGPNMI="",R=""
F BGPIMM=119 D
.S I=$O(^AUTTIMM("C",BGPIMM,0)) Q:'I
.S X=0 F S X=$O(^AUPNPREF("AA",P,9999999.14,I,X)) Q:X'=+X S Y=0 F S Y=$O(^AUPNPREF("AA",P,9999999.14,I,X,Y)) Q:Y'=+Y S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) S:$P(^AUPNPREF(Y,0),U,7)="N" BGPNMI=1 S R=1
I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"ref")_" Rotavirus"
;now check refusals in imm pkg
S BGPNMI=""
F BGPIMM=119 S R=$$IMMREF^BGP1D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
I R Q 3_U_$S(BGPNMI:"NMI",1:"ref")_" Rotavirus"
Q ""
ROTA3(P,EDATE) ;EP
NEW BGPC,BGPG,BGPX,BGPROTA,C,X,ED,BD,G,V,Y,T,I,R,BGPIMM,BGPNMI
K BGPC,BGPG,BGPX
;gather up all immunizations, cpts, povs and check for 3 each ten days apart
K BGPROTA
;get all immunizations
S C="74^116^122^119"
D GETIMMS^BGP1D32(P,EDATE,C,.BGPX)
;go through and set into array if 10 days apart
S X=0 F S X=$O(BGPX(X)) Q:X'=+X S BGPROTA(X)=""
;now get cpts
S ED=9999999-EDATE,BD=9999999-$$DOB^AUPNPAT(P),G=0
F S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD) D
.S V=0 F S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V D
..Q:'$D(^AUPNVSIT(V,0))
..S X=0 F S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X D
...S Y=$P(^AUPNVCPT(X,0),U) S Z=$P($$CPT^ICPTCOD(Y),U,2) I Z=90680!(Z=90681) S BGPROTA(9999999-$P(ED,"."))=""
..S X=0 F S X=$O(^AUPNVTC("AD",V,X)) Q:X'=+X D
...S Y=$P(^AUPNVTC(X,0),U,7) Q:'Y S Z=$P($$CPT^ICPTCOD(Y),U,2) I Z=90680!(Z=90681) S BGPROTA(9999999-$P(ED,"."))=""
..S X=0 F S X=$O(^AUPNVPOV("AD",V,X)) Q:X'=+X D
...S Y=$P(^AUPNVPOV(X,0),U,1) Q:'Y S Z=$P(^ICD9(Y,0),U,1) I Z="V05.8" S BGPROTA(9999999-$P(ED,"."))=""
;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
S X="",Y="",C=0 F S X=$O(BGPROTA(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BGPROTA(X) Q
.S Y=X
;now count them and see if there are 2 of them
S BGPROTA=0,X=0 F S X=$O(BGPROTA(X)) Q:X'=+X S BGPROTA=BGPROTA+1
I BGPROTA>2 Q 1_U_"3 Rotavirus"
F BGPZ=119,74,116,122 S X=$$ANIMCONT^BGP1D31(P,BGPZ,EDATE) Q:X]"" ;cmi/maw 12/17/07 missing edate
I X]"" Q 4_U_"contra - Rotavirus"
;
S B=$$DOB^AUPNPAT(P),E=EDATE,BGPNMI="",R=""
F BGPIMM=119,74,116,122 D
.S I=$O(^AUTTIMM("C",BGPIMM,0)) Q:'I
.S X=0 F S X=$O(^AUPNPREF("AA",P,9999999.14,I,X)) Q:X'=+X S Y=0 F S Y=$O(^AUPNPREF("AA",P,9999999.14,I,X,Y)) Q:Y'=+Y S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) S:$P(^AUPNPREF(Y,0),U,7)="N" BGPNMI=1 S R=1
I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"ref")_" Rotavirus"
;now check refusals in imm pkg
S BGPNMI=""
F BGPIMM=119,74,116,122 S R=$$IMMREF^BGP1D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
I R Q 3_U_$S(BGPNMI:"NMI",1:"ref")_" Rotavirus"
Q ""
HEPA(P,EDATE) ;EP
NEW BGPC,BGPG,BGPX,BGPHEPA,C,X,ED,BD,G,V,Y,T,I,R,BGPIMM,BGPNMI
K BGPC,BGPG,BGPX
;gather up all immunizations, cpts, povs and check for 3 each ten days apart
K BGPHEPA
;get all immunizations
S C="31^52^83^84^85^104"
D GETIMMS^BGP1D32(P,EDATE,C,.BGPX)
;go through and set into array if 10 days apart
S X=0 F S X=$O(BGPX(X)) Q:X'=+X S BGPHEPA(X)=""
;now get cpts
S ED=9999999-EDATE,BD=9999999-$$DOB^AUPNPAT(P),G=0
S T=$O(^ATXAX("B","BGP HEPATITIS A CPTS",0))
F S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD) D
.S V=0 F S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V D
..Q:'$D(^AUPNVSIT(V,0))
..S X=0 F S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X D
...S Y=$P(^AUPNVCPT(X,0),U) S Z=$P($$CPT^ICPTCOD(Y),U,2) I $$ICD^ATXCHK(Y,T,1) S BGPHEPA(9999999-$P(ED,"."))=""
..S X=0 F S X=$O(^AUPNVTC("AD",V,X)) Q:X'=+X D
...S Y=$P(^AUPNVTC(X,0),U,7) Q:'Y S Z=$P($$CPT^ICPTCOD(Y),U,2) I $$ICD^ATXCHK(Y,T,1) S BGPHEPA(9999999-$P(ED,"."))=""
;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
S X="",Y="",C=0 F S X=$O(BGPHEPA(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BGPHEPA(X) Q
.S Y=X
;now count them and see if there are 2 of them
S BGPHEPA=0,X=0 F S X=$O(BGPHEPA(X)) Q:X'=+X S BGPHEPA=BGPHEPA+1
I BGPHEPA>1 Q 1_U_"2 HEP A"
;check for evidence of desease and contraindications and if yes, then quit
K BGPG S %=P_"^LAST DX [BGP HEPATITIS A EVIDENCE;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q 4_U_"evid hep A"
I $$PLTAX^BGP1DU(P,"BGP HEPATITIS A EVIDENCE") Q 4_U_"evid hep A"
;
F BGPZ=31,52,83,84,85,104 S X=$$ANCONT^BGP1D31(P,BGPZ,EDATE) Q:X]"" ;cmi/maw 12/17/07 missing edate
I X]"" Q 4_U_"contra - hep A"
;
S B=$$DOB^AUPNPAT(P),E=EDATE,BGPNMI="",R=""
F BGPIMM=31,52,83,84,85,104 D
.S I=$O(^AUTTIMM("C",BGPIMM,0)) Q:'I
.S X=0 F S X=$O(^AUPNPREF("AA",P,9999999.14,I,X)) Q:X'=+X S Y=0 F S Y=$O(^AUPNPREF("AA",P,9999999.14,I,X,Y)) Q:Y'=+Y S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) S:$P(^AUPNPREF(Y,0),U,7)="N" BGPNMI=1 S R=1
I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"ref")_" hep A"
;now check refusals in imm pkg
S BGPNMI=""
F BGPIMM=31,52,83,84,85,104 S R=$$IMMREF^BGP1D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
I R Q 3_U_$S(BGPNMI:"NMI",1:"ref")_" hep A"
Q ""
BGP1D37 ; IHS/CMI/LAB - IMMUNIZATIONS ;
+1 ;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
+2 ;
FLU ;EP
+1 NEW BGPG,BGPLFLU,EDATE,X,E,%,I,T,J,V,G,D,R
+2 KILL BGPG
+3 SET BGPLFLU=""
+4 IF $GET(BD)=""
SET BD=$$FMADD^XLFDT(ED,-365)
+5 SET EDATE=$$FMTE^XLFDT(ED)
SET BDATE=$$FMTE^XLFDT(BD)
+6 SET X=P_"^LAST IMM 88;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BGPG(")
+7 IF $DATA(BGPG(1))
SET BGPLFLU=$PIECE(BGPG(1),U)_U_"Imm 88"
+8 SET X=P_"^LAST IMM 111;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BGPG(")
+9 IF $DATA(BGPG(1))
IF $PIECE(BGPLFLU,U)<$PIECE(BGPG(1),U)
SET BGPLFLU=$PIECE(BGPG(1),U)_U_"Imm 111"
+10 SET X=P_"^LAST IMM 15;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BGPG(")
+11 IF $DATA(BGPG(1))
IF $PIECE(BGPLFLU,U)<$PIECE(BGPG(1),U)
SET BGPLFLU=$PIECE(BGPG(1),U)_U_"Imm 15"
+12 SET X=P_"^LAST IMM 16;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BGPG(")
+13 IF $DATA(BGPG(1))
IF $PIECE(BGPLFLU,U)<$PIECE(BGPG(1),U)
SET BGPLFLU=$PIECE(BGPG(1),U)_U_"Imm 16"
+14 SET X=P_"^LAST IMM 135;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BGPG(")
+15 IF $DATA(BGPG(1))
IF $PIECE(BGPLFLU,U)<$PIECE(BGPG(1),U)
SET BGPLFLU=$PIECE(BGPG(1),U)_U_"Imm 135"
+16 SET X=P_"^LAST IMM 140;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BGPG(")
+17 IF $DATA(BGPG(1))
IF $PIECE(BGPLFLU,U)<$PIECE(BGPG(1),U)
SET BGPLFLU=$PIECE(BGPG(1),U)_U_"Imm 140"
+18 SET X=P_"^LAST IMM 141;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"BGPG(")
+19 IF $DATA(BGPG(1))
IF $PIECE(BGPLFLU,U)<$PIECE(BGPG(1),U)
SET BGPLFLU=$PIECE(BGPG(1),U)_U_"Imm 141"
+20 KILL BGPG
SET %=P_"^LAST DX V04.8;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+21 IF $DATA(BGPG(1))
IF $PIECE(BGPLFLU,U)<$PIECE(BGPG(1),U,1)
SET BGPLFLU=$PIECE(BGPG(1),U,1)_U_"V04.8"
+22 SET BGPG=$$LASTPRCI^BGP1UTL1(P,"99.52",BD,ED)
+23 IF $PIECE(BGPG,U,1)=1
IF $PIECE(BGPLFLU,U)<$PIECE(BGPG,U,3)
SET BGPLFLU=$PIECE(BGPG,U,3)_U_"99.52"
+24 KILL BGPG
SET %=P_"^LAST DX V04.81;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+25 IF $DATA(BGPG(1))
Begin DoDot:1
+26 SET T=$ORDER(^ATXAX("B","SURVEILLANCE CPT H1N1",0))
+27 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
Begin DoDot:2
+28 SET V=$PIECE(BGPG(X),U,5)
+29 SET G=0
+30 SET J=0
FOR
SET J=$ORDER(^AUPNVCPT("AD",V,J))
IF J'=+J
QUIT
SET I=$PIECE(^AUPNVCPT(J,0),U,1)
IF $$ICD^ATXCHK(I,T,1)!($$H1(I))
SET G=1
+31 IF G=1
QUIT
+32 IF $PIECE(BGPLFLU,U)<$PIECE(BGPG(X),U,1)
SET BGPLFLU=$PIECE(BGPG(1),U,1)_U_"POV V04.81"
End DoDot:2
End DoDot:1
+33 KILL BGPG
SET %=P_"^LAST DX V06.6;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+34 IF $DATA(BGPG(1))
Begin DoDot:1
+35 SET T=$ORDER(^ATXAX("B","SURVEILLANCE CPT H1N1",0))
+36 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
Begin DoDot:2
+37 SET V=$PIECE(BGPG(X),U,5)
+38 SET G=0
+39 SET J=0
FOR
SET J=$ORDER(^AUPNVCPT("AD",V,J))
IF J'=+J
QUIT
SET I=$PIECE(^AUPNVCPT(J,0),U,1)
IF $$ICD^ATXCHK(I,T,1)!($$H1(I))
SET G=1
+40 IF G=1
QUIT
+41 IF $PIECE(BGPLFLU,U)<$PIECE(BGPG(X),U,1)
SET BGPLFLU=$PIECE(BGPG(1),U,1)_U_"POV V06.06"
End DoDot:2
End DoDot:1
+42 SET T=$ORDER(^ATXAX("B","BGP CPT FLU",0))
+43 IF T
Begin DoDot:1
+44 SET X=$$CPT^BGP1DU(P,,ED,T,5)
IF X]""
QUIT
+45 SET X=$$TRAN^BGP1DU(P,,ED,T,5)
End DoDot:1
IF X]""
IF $PIECE(BGPLFLU,U)<X
SET BGPLFLU=$PIECE(X,U)_U_"CPT "_$PIECE(X,U,2)
+46 IF BGPLFLU]""
QUIT BGPLFLU_U_1
+47 ;contraindication new in 8.0
+48 FOR BGPZ=15,16,88,111,135,140,141
SET X=$$FLCONT(P,BGPZ,$$DOB^AUPNPAT(P),ED)
IF X]""
QUIT
+49 IF X]""
QUIT X_U_3
+50 ;NMI refusal
+51 SET G=$$NMIREF^BGP1UTL1(P,9999999.14,$ORDER(^AUTTIMM("C",88,0)),$$DOB^AUPNPAT(P),ED)
+52 IF $PIECE(G,U)=1
QUIT $PIECE(G,U,2)_U_"NMI Refusal"_U_3
+53 SET G=$$NMIREF^BGP1UTL1(P,9999999.14,$ORDER(^AUTTIMM("C",111,0)),$$DOB^AUPNPAT(P),ED)
+54 IF $PIECE(G,U)=1
QUIT $PIECE(G,U,2)_U_"NMI Refusal"_U_3
+55 SET G=$$NMIREF^BGP1UTL1(P,9999999.14,$ORDER(^AUTTIMM("C",15,0)),$$DOB^AUPNPAT(P),ED)
+56 IF $PIECE(G,U)=1
QUIT $PIECE(G,U,2)_U_"NMI Refusal"_U_3
+57 SET G=$$NMIREF^BGP1UTL1(P,9999999.14,$ORDER(^AUTTIMM("C",16,0)),$$DOB^AUPNPAT(P),ED)
+58 IF $PIECE(G,U)=1
QUIT $PIECE(G,U,2)_U_"NMI Refusal"_U_3
+59 SET G=$$NMIREF^BGP1UTL1(P,9999999.14,$ORDER(^AUTTIMM("C",135,0)),$$DOB^AUPNPAT(P),ED)
+60 IF $PIECE(G,U)=1
QUIT $PIECE(G,U,2)_U_"NMI Refusal"_U_3
+61 SET G=$$NMIREF^BGP1UTL1(P,9999999.14,$ORDER(^AUTTIMM("C",140,0)),$$DOB^AUPNPAT(P),ED)
+62 IF $PIECE(G,U)=1
QUIT $PIECE(G,U,2)_U_"NMI Refusal"_U_3
+63 SET G=$$NMIREF^BGP1UTL1(P,9999999.14,$ORDER(^AUTTIMM("C",141,0)),$$DOB^AUPNPAT(P),ED)
+64 IF $PIECE(G,U)=1
QUIT $PIECE(G,U,2)_U_"NMI Refusal"_U_3
+65 IF $GET(FORE)
QUIT ""
+66 SET G=$$REFUSAL^BGP1UTL1(P,9999999.14,$ORDER(^AUTTIMM("C",88,0)),$$FMADD^XLFDT(ED,-365),ED)
+67 IF $PIECE(G,U)=1
QUIT $PIECE(G,U,2)_U_"Refused"_U_2
+68 SET G=$$REFUSAL^BGP1UTL1(P,9999999.14,$ORDER(^AUTTIMM("C",111,0)),$$FMADD^XLFDT(ED,-365),ED)
+69 IF $PIECE(G,U)=1
QUIT $PIECE(G,U,2)_U_"Refused"_U_2
+70 SET G=$$REFUSAL^BGP1UTL1(P,9999999.14,$ORDER(^AUTTIMM("C",15,0)),$$FMADD^XLFDT(ED,-365),ED)
+71 IF $PIECE(G,U)=1
QUIT $PIECE(G,U,2)_U_"Refused"_U_2
+72 SET G=$$REFUSAL^BGP1UTL1(P,9999999.14,$ORDER(^AUTTIMM("C",16,0)),$$FMADD^XLFDT(ED,-365),ED)
+73 IF $PIECE(G,U)=1
QUIT $PIECE(G,U,2)_U_"Refused"_U_2
+74 SET G=$$REFUSAL^BGP1UTL1(P,9999999.14,$ORDER(^AUTTIMM("C",135,0)),$$FMADD^XLFDT(ED,-365),ED)
+75 IF $PIECE(G,U)=1
QUIT $PIECE(G,U,2)_U_"Refused"_U_2
+76 SET G=$$REFUSAL^BGP1UTL1(P,9999999.14,$ORDER(^AUTTIMM("C",140,0)),$$FMADD^XLFDT(ED,-365),ED)
+77 IF $PIECE(G,U)=1
QUIT $PIECE(G,U,2)_U_"Refused"_U_2
+78 SET G=$$REFUSAL^BGP1UTL1(P,9999999.14,$ORDER(^AUTTIMM("C",141,0)),$$FMADD^XLFDT(ED,-365),ED)
+79 IF $PIECE(G,U)=1
QUIT $PIECE(G,U,2)_U_"Refused"_U_2
+80 SET (X,G)=0
SET Y=$ORDER(^AUTTIMM("C",88,0))
FOR
SET X=$ORDER(^BIPC("AC",P,Y,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+81 SET R=$PIECE(^BIPC(X,0),U,3)
+82 IF R=""
QUIT
+83 IF '$DATA(^BICONT(R,0))
QUIT
+84 IF $PIECE(^BICONT(R,0),U,1)'["Refusal"
QUIT
+85 SET D=$PIECE(^BIPC(X,0),U,4)
+86 IF D=""
QUIT
+87 IF $PIECE(^BIPC(X,0),U,4)<BD
QUIT
+88 IF $PIECE(^BIPC(X,0),U,4)>ED
QUIT
+89 SET G=1
End DoDot:1
+90 IF G
QUIT $PIECE(G,U,2)_U_"Refused Imm pkg"_U_2
+91 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!(G)
QUIT
Begin DoDot:1
+92 SET R=$PIECE(^BIPC(X,0),U,3)
+93 IF R=""
QUIT
+94 IF '$DATA(^BICONT(R,0))
QUIT
+95 IF $PIECE(^BICONT(R,0),U,1)'["Refusal"
QUIT
+96 SET D=$PIECE(^BIPC(X,0),U,4)
+97 IF D=""
QUIT
+98 IF $PIECE(^BIPC(X,0),U,4)<BD
QUIT
+99 IF $PIECE(^BIPC(X,0),U,4)>ED
QUIT
+100 SET G=1
End DoDot:1
+101 IF G
QUIT $PIECE(G,U,2)_U_"Refused Imm pkg"_U_2
+102 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!(G)
QUIT
Begin DoDot:1
+103 SET R=$PIECE(^BIPC(X,0),U,3)
+104 IF R=""
QUIT
+105 IF '$DATA(^BICONT(R,0))
QUIT
+106 IF $PIECE(^BICONT(R,0),U,1)'["Refusal"
QUIT
+107 SET D=$PIECE(^BIPC(X,0),U,4)
+108 IF D=""
QUIT
+109 IF $PIECE(^BIPC(X,0),U,4)<BD
QUIT
+110 IF $PIECE(^BIPC(X,0),U,4)>ED
QUIT
+111 SET G=1
End DoDot:1
+112 IF G
QUIT $PIECE(G,U,2)_U_"Refused Imm pkg"_U_2
+113 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!(G)
QUIT
Begin DoDot:1
+114 SET R=$PIECE(^BIPC(X,0),U,3)
+115 IF R=""
QUIT
+116 IF '$DATA(^BICONT(R,0))
QUIT
+117 IF $PIECE(^BICONT(R,0),U,1)'["Refusal"
QUIT
+118 SET D=$PIECE(^BIPC(X,0),U,4)
+119 IF D=""
QUIT
+120 IF $PIECE(^BIPC(X,0),U,4)<BD
QUIT
+121 IF $PIECE(^BIPC(X,0),U,4)>ED
QUIT
+122 SET G=1
End DoDot:1
+123 IF G
QUIT $PIECE(G,U,2)_U_"Refused Imm pkg"_U_2
+124 SET (X,G)=0
SET Y=$ORDER(^AUTTIMM("C",135,0))
IF Y
FOR
SET X=$ORDER(^BIPC("AC",P,Y,X))
IF X'=+X!(G)
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 $PIECE(^BIPC(X,0),U,4)<BD
QUIT
+132 IF $PIECE(^BIPC(X,0),U,4)>ED
QUIT
+133 SET G=1
End DoDot:1
+134 IF G
QUIT $PIECE(G,U,2)_U_"Refused Imm pkg"_U_2
+135 SET (X,G)=0
SET Y=$ORDER(^AUTTIMM("C",140,0))
IF Y
FOR
SET X=$ORDER(^BIPC("AC",P,Y,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+136 SET R=$PIECE(^BIPC(X,0),U,3)
+137 IF R=""
QUIT
+138 IF '$DATA(^BICONT(R,0))
QUIT
+139 IF $PIECE(^BICONT(R,0),U,1)'["Refusal"
QUIT
+140 SET D=$PIECE(^BIPC(X,0),U,4)
+141 IF D=""
QUIT
+142 IF $PIECE(^BIPC(X,0),U,4)<BD
QUIT
+143 IF $PIECE(^BIPC(X,0),U,4)>ED
QUIT
+144 SET G=1
End DoDot:1
+145 IF G
QUIT $PIECE(G,U,2)_U_"Refused Imm pkg"_U_2
+146 SET (X,G)=0
SET Y=$ORDER(^AUTTIMM("C",141,0))
IF Y
FOR
SET X=$ORDER(^BIPC("AC",P,Y,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+147 SET R=$PIECE(^BIPC(X,0),U,3)
+148 IF R=""
QUIT
+149 IF '$DATA(^BICONT(R,0))
QUIT
+150 IF $PIECE(^BICONT(R,0),U,1)'["Refusal"
QUIT
+151 SET D=$PIECE(^BIPC(X,0),U,4)
+152 IF D=""
QUIT
+153 IF $PIECE(^BIPC(X,0),U,4)<BD
QUIT
+154 IF $PIECE(^BIPC(X,0),U,4)>ED
QUIT
+155 SET G=1
End DoDot:1
+156 IF G
QUIT $PIECE(G,U,2)_U_"Refused Imm pkg"_U_2
+157 QUIT ""
FLCONT(P,C,BD,ED) ;EP
+1 NEW X,G,Y,R,D
+2 SET X=0
SET G=""
SET Y=$ORDER(^AUTTIMM("C",C,0))
IF Y
FOR
SET X=$ORDER(^BIPC("AC",P,Y,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+3 SET R=$PIECE(^BIPC(X,0),U,3)
+4 IF R=""
QUIT
+5 IF '$DATA(^BICONT(R,0))
QUIT
+6 SET D=$PIECE(^BIPC(X,0),U,4)
+7 IF D=""
QUIT
+8 IF $PIECE(^BIPC(X,0),U,4)<BD
QUIT
+9 IF $PIECE(^BIPC(X,0),U,4)>ED
QUIT
+10 IF $PIECE(^BICONT(R,0),U,1)="Egg Allergy"
SET G=D_U_"Contraindication: Egg Allergy"
+11 IF $PIECE(^BICONT(R,0),U,1)="Anaphylaxis"
SET G=D_U_"Contraindication: Anaphylaxis"
End DoDot:1
+12 QUIT G
H1(I) ;
+1 IF $PIECE($GET(^ICPT(I,0)),U,1)=90664
QUIT 1
+2 IF $PIECE($GET(^ICPT(I,0)),U,1)=90666
QUIT 1
+3 IF $PIECE($GET(^ICPT(I,0)),U,1)=90667
QUIT 1
+4 IF $PIECE($GET(^ICPT(I,0)),U,1)=90668
QUIT 1
+5 QUIT ""
ROTA2(P,EDATE) ;EP
+1 NEW BGPC,BGPG,BGPX,BGPROTA,C,X,ED,BD,G,V,Y,T,I,R,BGPIMM,BGPNMI
+2 KILL BGPC,BGPG,BGPX
+3 ;gather up all immunizations, cpts, povs and check for 3 each ten days apart
+4 KILL BGPROTA
+5 ;get all immunizations
+6 SET C="119"
+7 DO GETIMMS^BGP1D32(P,EDATE,C,.BGPX)
+8 ;go through and set into array if 10 days apart
+9 SET X=0
FOR
SET X=$ORDER(BGPX(X))
IF X'=+X
QUIT
SET BGPROTA(X)=""
+10 ;now get cpts
+11 SET ED=9999999-EDATE
SET BD=9999999-$$DOB^AUPNPAT(P)
SET G=0
+12 FOR
SET ED=$ORDER(^AUPNVSIT("AA",P,ED))
IF ED=""!($PIECE(ED,".")>BD)
QUIT
Begin DoDot:1
+13 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))
IF V'=+V
QUIT
Begin DoDot:2
+14 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+15 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+16 SET Y=$PIECE(^AUPNVCPT(X,0),U)
SET Z=$PIECE($$CPT^ICPTCOD(Y),U,2)
IF Z=90681
SET BGPROTA(9999999-$PIECE(ED,"."))=""
End DoDot:3
+17 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+18 SET Y=$PIECE(^AUPNVTC(X,0),U,7)
IF 'Y
QUIT
SET Z=$PIECE($$CPT^ICPTCOD(Y),U,2)
IF Z=90681
SET BGPROTA(9999999-$PIECE(ED,"."))=""
End DoDot:3
End DoDot:2
End DoDot:1
+19 ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
+20 SET X=""
SET Y=""
SET C=0
FOR
SET X=$ORDER(BGPROTA(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+21 IF C=1
SET Y=X
QUIT
+22 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPROTA(X)
QUIT
+23 SET Y=X
End DoDot:1
+24 ;now count them and see if there are 2 of them
+25 SET BGPROTA=0
SET X=0
FOR
SET X=$ORDER(BGPROTA(X))
IF X'=+X
QUIT
SET BGPROTA=BGPROTA+1
+26 IF BGPROTA>1
QUIT 1_U_"2 Rotavirus"
+27 ;cmi/maw 12/17/07 missing edate
FOR BGPZ=119
SET X=$$ANIMCONT^BGP1D31(P,BGPZ,EDATE)
IF X]""
QUIT
+28 IF X]""
QUIT 4_U_"contra - Rotavirus"
+29 ;
+30 SET B=$$DOB^AUPNPAT(P)
SET E=EDATE
SET BGPNMI=""
SET R=""
+31 FOR BGPIMM=119
Begin DoDot:1
+32 SET I=$ORDER(^AUTTIMM("C",BGPIMM,0))
IF 'I
QUIT
+33 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,9999999.14,I,X))
IF X'=+X
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",P,9999999.14,I,X,Y))
IF Y'=+Y
QUIT
SET D=$PIECE(^AUPNPREF(Y,0),U,3)
IF D'<B&(D'>E)
IF $PIECE(^AUPNPREF(Y,0),U,7)="N"
SET BGPNMI=1
SET R=1
End DoDot:1
+34 IF R
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI",1:"ref")_" Rotavirus"
+35 ;now check refusals in imm pkg
+36 SET BGPNMI=""
+37 FOR BGPIMM=119
SET R=$$IMMREF^BGP1D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
+38 IF R
QUIT 3_U_$SELECT(BGPNMI:"NMI",1:"ref")_" Rotavirus"
+39 QUIT ""
ROTA3(P,EDATE) ;EP
+1 NEW BGPC,BGPG,BGPX,BGPROTA,C,X,ED,BD,G,V,Y,T,I,R,BGPIMM,BGPNMI
+2 KILL BGPC,BGPG,BGPX
+3 ;gather up all immunizations, cpts, povs and check for 3 each ten days apart
+4 KILL BGPROTA
+5 ;get all immunizations
+6 SET C="74^116^122^119"
+7 DO GETIMMS^BGP1D32(P,EDATE,C,.BGPX)
+8 ;go through and set into array if 10 days apart
+9 SET X=0
FOR
SET X=$ORDER(BGPX(X))
IF X'=+X
QUIT
SET BGPROTA(X)=""
+10 ;now get cpts
+11 SET ED=9999999-EDATE
SET BD=9999999-$$DOB^AUPNPAT(P)
SET G=0
+12 FOR
SET ED=$ORDER(^AUPNVSIT("AA",P,ED))
IF ED=""!($PIECE(ED,".")>BD)
QUIT
Begin DoDot:1
+13 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))
IF V'=+V
QUIT
Begin DoDot:2
+14 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+15 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+16 SET Y=$PIECE(^AUPNVCPT(X,0),U)
SET Z=$PIECE($$CPT^ICPTCOD(Y),U,2)
IF Z=90680!(Z=90681)
SET BGPROTA(9999999-$PIECE(ED,"."))=""
End DoDot:3
+17 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+18 SET Y=$PIECE(^AUPNVTC(X,0),U,7)
IF 'Y
QUIT
SET Z=$PIECE($$CPT^ICPTCOD(Y),U,2)
IF Z=90680!(Z=90681)
SET BGPROTA(9999999-$PIECE(ED,"."))=""
End DoDot:3
+19 SET X=0
FOR
SET X=$ORDER(^AUPNVPOV("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+20 SET Y=$PIECE(^AUPNVPOV(X,0),U,1)
IF 'Y
QUIT
SET Z=$PIECE(^ICD9(Y,0),U,1)
IF Z="V05.8"
SET BGPROTA(9999999-$PIECE(ED,"."))=""
End DoDot:3
End DoDot:2
End DoDot:1
+21 ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
+22 SET X=""
SET Y=""
SET C=0
FOR
SET X=$ORDER(BGPROTA(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+23 IF C=1
SET Y=X
QUIT
+24 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPROTA(X)
QUIT
+25 SET Y=X
End DoDot:1
+26 ;now count them and see if there are 2 of them
+27 SET BGPROTA=0
SET X=0
FOR
SET X=$ORDER(BGPROTA(X))
IF X'=+X
QUIT
SET BGPROTA=BGPROTA+1
+28 IF BGPROTA>2
QUIT 1_U_"3 Rotavirus"
+29 ;cmi/maw 12/17/07 missing edate
FOR BGPZ=119,74,116,122
SET X=$$ANIMCONT^BGP1D31(P,BGPZ,EDATE)
IF X]""
QUIT
+30 IF X]""
QUIT 4_U_"contra - Rotavirus"
+31 ;
+32 SET B=$$DOB^AUPNPAT(P)
SET E=EDATE
SET BGPNMI=""
SET R=""
+33 FOR BGPIMM=119,74,116,122
Begin DoDot:1
+34 SET I=$ORDER(^AUTTIMM("C",BGPIMM,0))
IF 'I
QUIT
+35 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,9999999.14,I,X))
IF X'=+X
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",P,9999999.14,I,X,Y))
IF Y'=+Y
QUIT
SET D=$PIECE(^AUPNPREF(Y,0),U,3)
IF D'<B&(D'>E)
IF $PIECE(^AUPNPREF(Y,0),U,7)="N"
SET BGPNMI=1
SET R=1
End DoDot:1
+36 IF R
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI",1:"ref")_" Rotavirus"
+37 ;now check refusals in imm pkg
+38 SET BGPNMI=""
+39 FOR BGPIMM=119,74,116,122
SET R=$$IMMREF^BGP1D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
+40 IF R
QUIT 3_U_$SELECT(BGPNMI:"NMI",1:"ref")_" Rotavirus"
+41 QUIT ""
HEPA(P,EDATE) ;EP
+1 NEW BGPC,BGPG,BGPX,BGPHEPA,C,X,ED,BD,G,V,Y,T,I,R,BGPIMM,BGPNMI
+2 KILL BGPC,BGPG,BGPX
+3 ;gather up all immunizations, cpts, povs and check for 3 each ten days apart
+4 KILL BGPHEPA
+5 ;get all immunizations
+6 SET C="31^52^83^84^85^104"
+7 DO GETIMMS^BGP1D32(P,EDATE,C,.BGPX)
+8 ;go through and set into array if 10 days apart
+9 SET X=0
FOR
SET X=$ORDER(BGPX(X))
IF X'=+X
QUIT
SET BGPHEPA(X)=""
+10 ;now get cpts
+11 SET ED=9999999-EDATE
SET BD=9999999-$$DOB^AUPNPAT(P)
SET G=0
+12 SET T=$ORDER(^ATXAX("B","BGP HEPATITIS A CPTS",0))
+13 FOR
SET ED=$ORDER(^AUPNVSIT("AA",P,ED))
IF ED=""!($PIECE(ED,".")>BD)
QUIT
Begin DoDot:1
+14 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))
IF V'=+V
QUIT
Begin DoDot:2
+15 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+16 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+17 SET Y=$PIECE(^AUPNVCPT(X,0),U)
SET Z=$PIECE($$CPT^ICPTCOD(Y),U,2)
IF $$ICD^ATXCHK(Y,T,1)
SET BGPHEPA(9999999-$PIECE(ED,"."))=""
End DoDot:3
+18 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+19 SET Y=$PIECE(^AUPNVTC(X,0),U,7)
IF 'Y
QUIT
SET Z=$PIECE($$CPT^ICPTCOD(Y),U,2)
IF $$ICD^ATXCHK(Y,T,1)
SET BGPHEPA(9999999-$PIECE(ED,"."))=""
End DoDot:3
End DoDot:2
End DoDot:1
+20 ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
+21 SET X=""
SET Y=""
SET C=0
FOR
SET X=$ORDER(BGPHEPA(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+22 IF C=1
SET Y=X
QUIT
+23 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPHEPA(X)
QUIT
+24 SET Y=X
End DoDot:1
+25 ;now count them and see if there are 2 of them
+26 SET BGPHEPA=0
SET X=0
FOR
SET X=$ORDER(BGPHEPA(X))
IF X'=+X
QUIT
SET BGPHEPA=BGPHEPA+1
+27 IF BGPHEPA>1
QUIT 1_U_"2 HEP A"
+28 ;check for evidence of desease and contraindications and if yes, then quit
+29 KILL BGPG
SET %=P_"^LAST DX [BGP HEPATITIS A EVIDENCE;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+30 IF $DATA(BGPG(1))
QUIT 4_U_"evid hep A"
+31 IF $$PLTAX^BGP1DU(P,"BGP HEPATITIS A EVIDENCE")
QUIT 4_U_"evid hep A"
+32 ;
+33 ;cmi/maw 12/17/07 missing edate
FOR BGPZ=31,52,83,84,85,104
SET X=$$ANCONT^BGP1D31(P,BGPZ,EDATE)
IF X]""
QUIT
+34 IF X]""
QUIT 4_U_"contra - hep A"
+35 ;
+36 SET B=$$DOB^AUPNPAT(P)
SET E=EDATE
SET BGPNMI=""
SET R=""
+37 FOR BGPIMM=31,52,83,84,85,104
Begin DoDot:1
+38 SET I=$ORDER(^AUTTIMM("C",BGPIMM,0))
IF 'I
QUIT
+39 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,9999999.14,I,X))
IF X'=+X
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",P,9999999.14,I,X,Y))
IF Y'=+Y
QUIT
SET D=$PIECE(^AUPNPREF(Y,0),U,3)
IF D'<B&(D'>E)
IF $PIECE(^AUPNPREF(Y,0),U,7)="N"
SET BGPNMI=1
SET R=1
End DoDot:1
+40 IF R
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI",1:"ref")_" hep A"
+41 ;now check refusals in imm pkg
+42 SET BGPNMI=""
+43 FOR BGPIMM=31,52,83,84,85,104
SET R=$$IMMREF^BGP1D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
+44 IF R
QUIT 3_U_$SELECT(BGPNMI:"NMI",1:"ref")_" hep A"
+45 QUIT ""
