BGP8D37 ; IHS/CMI/LAB - IMMUNIZATIONS ;
;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
;
FLU ;EP
NEW BGPG,BGPLFLU,EDATE,X,E,%,I,T,J,V,G,D,R,CVX,BGPT
K BGPG
S BGPLFLU=""
I $G(BD)="" S BD=$$FMADD^XLFDT(ED,-365)
S EDATE=$$FMTE^XLFDT(ED),BDATE=$$FMTE^XLFDT(BD)
S T=$O(^ATXAX("B","BGP FLU IZ CVX CODES",0))
S X=0 F S X=$O(^AUPNVIMM("AC",P,X)) Q:X'=+X D
.S I=$P($G(^AUPNVIMM(X,0)),U,1)
.I 'I Q
.S CVX=$P($G(^AUTTIMM(I,0)),U,3)
.Q:CVX=""
.I '$D(^ATXAX(T,21,"B",CVX)) Q ;NOT IN TAXONOMY
.S D=$$VD^APCLV($P(^AUPNVIMM(X,0),U,3))
.Q:D<BD
.Q:D>ED
.I $P(BGPLFLU,U)<D S BGPLFLU=D_U_"Imm "_CVX
K BGPG S %=P_"^LAST DX [BGP FLU IZ 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_$P(BGPG(1),U,2)
;S BGPG=$$LASTPRC^BGP8UTL1(P,"BGP FLU IZ PROCEDURES",BD,ED) ;NOT IN 14.1
;I $P(BGPG,U,1)=1,$P(BGPLFLU,U)<$P(BGPG,U,3) S BGPLFLU=$P(BGPG,U,3)_U_"Proc "_$P(BGPG,U,2)
K BGPG S %=P_"^LAST DX [BGP FLU IZ DXS;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^BGP8UTL2(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_$P(BGPG(1),U,2)
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^BGP8DU(P,,ED,T,5) I X]"" Q
.S X=$$TRAN^BGP8DU(P,,ED,T,5)
I BGPLFLU]"" Q BGPLFLU_U_1
;Contraindication new in 8.0
S BGPT=$O(^ATXAX("B","BGP FLU IZ CVX CODES",0))
S BGPZ=0 F S BGPZ=$O(^ATXAX(BGPT,21,"B",BGPZ)) Q:BGPZ=""!(X]"") S X=$$FLCONT(P,BGPZ,$$DOB^AUPNPAT(P),ED)
;F BGPZ=15,16,88,111,135,140,141,144,149,150,151,153,155,158,161 S X=$$FLCONT(P,BGPZ,$$DOB^AUPNPAT(P),ED) Q:X]""
I X]"" Q X_U_3
;NMI Refusal
S BGPZ=0,G="" F S BGPZ=$O(^ATXAX(BGPT,21,"B",BGPZ)) Q:BGPZ=""!(G) D
.S G=$$NMIREF^BGP8UTL1(P,9999999.14,$O(^AUTTIMM("C",BGPZ,0)),$$DOB^AUPNPAT(P),ED)
.I $P(G,U)=1 S G=$P(G,U,2)_U_"NMI Refusal"_U_3
I G Q G
S R=$$CPTREFT^BGP8UTL1(P,$$DOB^AUPNPAT(P),ED,$O(^ATXAX("B","BGP CPT FLU",0)),"N")
I R Q $P(R,U,2)_U_"NMI Refusal "_$P(R,U,4)_U_3
;now check Refusals in imm pkg
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_"Contra: Egg Allergy"
.I $P(^BICONT(R,0),U,1)="Anaphylaxis" S G=D_U_"Contra 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^BGP8D32(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 Rota"
S BGPZ=$$SCID^BGP8D36(P,EDATE) I BGPZ Q 4_U_"Contra Rota"
S BGPZ=$$INTUSS^BGP8D36(P,EDATE) I BGPZ Q 4_U_"Contra Rota"
F BGPZ=119 S X=$$ANIMCONT^BGP8D31(P,BGPZ,EDATE) Q:X]"" ;cmi/maw 12/17/07 missing edate
I X]"" Q 4_U_"Contra Rota"
;
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) I $P(^AUPNPREF(Y,0),U,7)="N" S BGPNMI=1 S R=1
I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"Ref")_" Rota"
;now check Refusals in imm pkg
S BGPNMI=""
;F BGPIMM=119 S R=$$IMMREF^BGP8D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
;I R Q 3_U_$S(BGPNMI:"NMI",1:"Ref")_" Rota"
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^BGP8D32(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 Rota"
S BGPZ=$$SCID^BGP8D36(P,EDATE) I BGPZ Q 4_U_"Contra Rota"
S BGPZ=$$INTUSS^BGP8D36(P,EDATE) I BGPZ Q 4_U_"Contra Rota"
F BGPZ=119,74,116,122 S X=$$ANIMCONT^BGP8D31(P,BGPZ,EDATE) Q:X]"" ;cmi/maw 12/17/07 missing edate
I X]"" Q 4_U_"Contra Rota"
;
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) I $P(^AUPNPREF(Y,0),U,7)="N" S BGPNMI=1 S R=1
I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"Ref")_" Rota"
F BGPIMM=90680,90681 D
.S I=+$$CODEN^ICPTCOD(BGPIMM) Q:'I
.S X=0 F S X=$O(^AUPNPREF("AA",P,81,I,X)) Q:X'=+X S Y=0 F S Y=$O(^AUPNPREF("AA",P,81,I,X,Y)) Q:Y'=+Y S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) I $P(^AUPNPREF(Y,0),U,7)="N" S BGPNMI=1 S R=1
I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"Ref")_" Rota"
;now check Refusals in imm pkg
S BGPNMI=""
;F BGPIMM=119,74,116,122 S R=$$IMMREF^BGP8D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
;I R Q 3_U_$S(BGPNMI:"NMI",1:"Ref")_" Rota"
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^BGP8D32(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^BGP8UTL2(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^BGP8UTL2(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>0 Q 1_U_"1 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^BGP8DU(P,"BGP HEPATITIS A EVIDENCE") Q 4_U_"Evid Hep A"
I $$PLTAXND^BGP8DU(P,"BGP HEPATITIS A EVIDENCE",EDATE) Q 4_U_"Evid Hep A"
I $$IPLSNOND^BGP8DU(P,"PXRM BGP HEPATITIS A",EDATE) Q 4_U_"Evid Hep A"
;
F BGPZ=31,52,83,84,85,104 S X=$$ANCONT^BGP8D31(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) I $P(^AUPNPREF(Y,0),U,7)="N" S BGPNMI=1 S R=1
I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"Ref")_" Hep A"
S R=$$CPTREFT^BGP8UTL1(P,$$DOB^AUPNPAT(P),EDATE,$O(^ATXAX("B","BGP HEPATITIS A CPTS",0)))
I R,$P(R,U,3)="N" S BGPNMI=1 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^BGP8D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
;I R Q 3_U_$S(BGPNMI:"NMI",1:"Ref")_" Hep A"
Q ""
BGP8D37 ; IHS/CMI/LAB - IMMUNIZATIONS ;
+1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
+2 ;
FLU ;EP
+1 NEW BGPG,BGPLFLU,EDATE,X,E,%,I,T,J,V,G,D,R,CVX,BGPT
+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 T=$ORDER(^ATXAX("B","BGP FLU IZ CVX CODES",0))
+7 SET X=0
FOR
SET X=$ORDER(^AUPNVIMM("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+8 SET I=$PIECE($GET(^AUPNVIMM(X,0)),U,1)
+9 IF 'I
QUIT
+10 SET CVX=$PIECE($GET(^AUTTIMM(I,0)),U,3)
+11 IF CVX=""
QUIT
+12 ;NOT IN TAXONOMY
IF '$DATA(^ATXAX(T,21,"B",CVX))
QUIT
+13 SET D=$$VD^APCLV($PIECE(^AUPNVIMM(X,0),U,3))
+14 IF D<BD
QUIT
+15 IF D>ED
QUIT
+16 IF $PIECE(BGPLFLU,U)<D
SET BGPLFLU=D_U_"Imm "_CVX
End DoDot:1
+17 KILL BGPG
SET %=P_"^LAST DX [BGP FLU IZ DX V04.8;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+18 IF $DATA(BGPG(1))
IF $PIECE(BGPLFLU,U)<$PIECE(BGPG(1),U,1)
SET BGPLFLU=$PIECE(BGPG(1),U,1)_U_$PIECE(BGPG(1),U,2)
+19 ;S BGPG=$$LASTPRC^BGP8UTL1(P,"BGP FLU IZ PROCEDURES",BD,ED) ;NOT IN 14.1
+20 ;I $P(BGPG,U,1)=1,$P(BGPLFLU,U)<$P(BGPG,U,3) S BGPLFLU=$P(BGPG,U,3)_U_"Proc "_$P(BGPG,U,2)
+21 KILL BGPG
SET %=P_"^LAST DX [BGP FLU IZ DXS;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+22 IF $DATA(BGPG(1))
Begin DoDot:1
+23 SET T=$ORDER(^ATXAX("B","SURVEILLANCE CPT H1N1",0))
+24 SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
Begin DoDot:2
+25 SET V=$PIECE(BGPG(X),U,5)
+26 SET G=0
+27 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^BGP8UTL2(I,T,1)!($$H1(I))
SET G=1
+28 IF G=1
QUIT
+29 IF $PIECE(BGPLFLU,U)<$PIECE(BGPG(X),U,1)
SET BGPLFLU=$PIECE(BGPG(1),U,1)_U_$PIECE(BGPG(1),U,2)
End DoDot:2
End DoDot:1
+30 SET T=$ORDER(^ATXAX("B","BGP CPT FLU",0))
+31 IF T
Begin DoDot:1
+32 SET X=$$CPT^BGP8DU(P,,ED,T,5)
IF X]""
QUIT
+33 SET X=$$TRAN^BGP8DU(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)
+34 IF BGPLFLU]""
QUIT BGPLFLU_U_1
+35 ;Contraindication new in 8.0
+36 SET BGPT=$ORDER(^ATXAX("B","BGP FLU IZ CVX CODES",0))
+37 SET BGPZ=0
FOR
SET BGPZ=$ORDER(^ATXAX(BGPT,21,"B",BGPZ))
IF BGPZ=""!(X]"")
QUIT
SET X=$$FLCONT(P,BGPZ,$$DOB^AUPNPAT(P),ED)
+38 ;F BGPZ=15,16,88,111,135,140,141,144,149,150,151,153,155,158,161 S X=$$FLCONT(P,BGPZ,$$DOB^AUPNPAT(P),ED) Q:X]""
+39 IF X]""
QUIT X_U_3
+40 ;NMI Refusal
+41 SET BGPZ=0
SET G=""
FOR
SET BGPZ=$ORDER(^ATXAX(BGPT,21,"B",BGPZ))
IF BGPZ=""!(G)
QUIT
Begin DoDot:1
+42 SET G=$$NMIREF^BGP8UTL1(P,9999999.14,$ORDER(^AUTTIMM("C",BGPZ,0)),$$DOB^AUPNPAT(P),ED)
+43 IF $PIECE(G,U)=1
SET G=$PIECE(G,U,2)_U_"NMI Refusal"_U_3
End DoDot:1
+44 IF G
QUIT G
+45 SET R=$$CPTREFT^BGP8UTL1(P,$$DOB^AUPNPAT(P),ED,$ORDER(^ATXAX("B","BGP CPT FLU",0)),"N")
+46 IF R
QUIT $PIECE(R,U,2)_U_"NMI Refusal "_$PIECE(R,U,4)_U_3
+47 ;now check Refusals in imm pkg
+48 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 ;I $P(^BICONT(R,0),U,1)="Egg Allergy" S G=D_U_"Contra: Egg Allergy"
+11 IF $PIECE(^BICONT(R,0),U,1)="Anaphylaxis"
SET G=D_U_"Contra 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^BGP8D32(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 Rota"
+27 SET BGPZ=$$SCID^BGP8D36(P,EDATE)
IF BGPZ
QUIT 4_U_"Contra Rota"
+28 SET BGPZ=$$INTUSS^BGP8D36(P,EDATE)
IF BGPZ
QUIT 4_U_"Contra Rota"
+29 ;cmi/maw 12/17/07 missing edate
FOR BGPZ=119
SET X=$$ANIMCONT^BGP8D31(P,BGPZ,EDATE)
IF X]""
QUIT
+30 IF X]""
QUIT 4_U_"Contra Rota"
+31 ;
+32 SET B=$$DOB^AUPNPAT(P)
SET E=EDATE
SET BGPNMI=""
SET R=""
+33 FOR BGPIMM=119
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")_" Rota"
+37 ;now check Refusals in imm pkg
+38 SET BGPNMI=""
+39 ;F BGPIMM=119 S R=$$IMMREF^BGP8D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
+40 ;I R Q 3_U_$S(BGPNMI:"NMI",1:"Ref")_" Rota"
+41 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^BGP8D32(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 Rota"
+29 SET BGPZ=$$SCID^BGP8D36(P,EDATE)
IF BGPZ
QUIT 4_U_"Contra Rota"
+30 SET BGPZ=$$INTUSS^BGP8D36(P,EDATE)
IF BGPZ
QUIT 4_U_"Contra Rota"
+31 ;cmi/maw 12/17/07 missing edate
FOR BGPZ=119,74,116,122
SET X=$$ANIMCONT^BGP8D31(P,BGPZ,EDATE)
IF X]""
QUIT
+32 IF X]""
QUIT 4_U_"Contra Rota"
+33 ;
+34 SET B=$$DOB^AUPNPAT(P)
SET E=EDATE
SET BGPNMI=""
SET R=""
+35 FOR BGPIMM=119,74,116,122
Begin DoDot:1
+36 SET I=$ORDER(^AUTTIMM("C",BGPIMM,0))
IF 'I
QUIT
+37 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
+38 IF R
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI",1:"Ref")_" Rota"
+39 FOR BGPIMM=90680,90681
Begin DoDot:1
+40 SET I=+$$CODEN^ICPTCOD(BGPIMM)
IF 'I
QUIT
+41 SET X=0
FOR
SET X=$ORDER(^AUPNPREF("AA",P,81,I,X))
IF X'=+X
QUIT
SET Y=0
FOR
SET Y=$ORDER(^AUPNPREF("AA",P,81,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
+42 IF R
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI",1:"Ref")_" Rota"
+43 ;now check Refusals in imm pkg
+44 SET BGPNMI=""
+45 ;F BGPIMM=119,74,116,122 S R=$$IMMREF^BGP8D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
+46 ;I R Q 3_U_$S(BGPNMI:"NMI",1:"Ref")_" Rota"
+47 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^BGP8D32(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^BGP8UTL2(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^BGP8UTL2(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>0
QUIT 1_U_"1 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 ;I $$PLTAX^BGP8DU(P,"BGP HEPATITIS A EVIDENCE") Q 4_U_"Evid Hep A"
+32 IF $$PLTAXND^BGP8DU(P,"BGP HEPATITIS A EVIDENCE",EDATE)
QUIT 4_U_"Evid Hep A"
+33 IF $$IPLSNOND^BGP8DU(P,"PXRM BGP HEPATITIS A",EDATE)
QUIT 4_U_"Evid Hep A"
+34 ;
+35 ;cmi/maw 12/17/07 missing edate
FOR BGPZ=31,52,83,84,85,104
SET X=$$ANCONT^BGP8D31(P,BGPZ,EDATE)
IF X]""
QUIT
+36 IF X]""
QUIT 4_U_"Contra Hep A"
+37 ;
+38 SET B=$$DOB^AUPNPAT(P)
SET E=EDATE
SET BGPNMI=""
SET R=""
+39 FOR BGPIMM=31,52,83,84,85,104
Begin DoDot:1
+40 SET I=$ORDER(^AUTTIMM("C",BGPIMM,0))
IF 'I
QUIT
+41 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
+42 IF R
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI",1:"Ref")_" Hep A"
+43 SET R=$$CPTREFT^BGP8UTL1(P,$$DOB^AUPNPAT(P),EDATE,$ORDER(^ATXAX("B","BGP HEPATITIS A CPTS",0)))
+44 IF R
IF $PIECE(R,U,3)="N"
SET BGPNMI=1
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI",1:"Ref")_" Hep A"
+45 ;now check Refusals in imm pkg
+46 SET BGPNMI=""
+47 ;F BGPIMM=31,52,83,84,85,104 S R=$$IMMREF^BGP8D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
+48 ;I R Q 3_U_$S(BGPNMI:"NMI",1:"Ref")_" Hep A"
+49 QUIT ""
