BGP6D37.m

BGP6D37 ; IHS/CMI/LAB - IMMUNIZATIONS ;

 ;;16.1;IHS CLINICAL REPORTING;;MAR 22, 2016;Build 170

 ;

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^BGP6UTL1(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^BGP6UTL2(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^BGP6DU(P,,ED,T,5) I X]"" Q

 .S X=$$TRAN^BGP6DU(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^BGP6UTL1(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^BGP6UTL1(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^BGP6D32(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"

 F BGPZ=119 S X=$$ANIMCONT^BGP6D31(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^BGP6D32(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^BGP6D32(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"

 F BGPZ=119,74,116,122 S X=$$ANIMCONT^BGP6D31(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^BGP6D32(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^BGP6D32(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^BGP6UTL2(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^BGP6UTL2(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^BGP6DU(P,"BGP HEPATITIS A EVIDENCE") Q 4_U_"Evid Hep A"

 ;

 F BGPZ=31,52,83,84,85,104 S X=$$ANCONT^BGP6D31(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^BGP6UTL1(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^BGP6D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R

 ;I R Q 3_U_$S(BGPNMI:"NMI",1:"Ref")_" Hep A"

 Q ""

BGP6D37   ; IHS/CMI/LAB - IMMUNIZATIONS ;

 +1       ;;16.1;IHS CLINICAL REPORTING;;MAR 22, 2016;Build 170

 +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^BGP6UTL1(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^BGP6UTL2(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^BGP6DU(P,,ED,T,5)

                   IF X]""

                       QUIT 

 +33               SET X=$$TRAN^BGP6DU(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^BGP6UTL1(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^BGP6UTL1(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                   IF $PIECE(^BICONT(R,0),U,1)="Egg Allergy"

                           SET 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^BGP6D32(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      ;cmi/maw 12/17/07 missing edate

           FOR BGPZ=119

               SET X=$$ANIMCONT^BGP6D31(P,BGPZ,EDATE)

               IF X]""

                   QUIT 

 +28       IF X]""

               QUIT 4_U_"Contra Rota"

 +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")_" Rota"

 +35      ;now check Refusals in imm pkg

 +36       SET BGPNMI=""

 +37      ;F BGPIMM=119 S R=$$IMMREF^BGP6D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R

 +38      ;I R Q 3_U_$S(BGPNMI:"NMI",1:"Ref")_" Rota"

 +39       QUIT ""

ROTA3(P,EDATE) ;EP

 +1        NEW BGPC,BGPG,BGPX,BGPROTA,C,X,ED,BD,G,V,Y,T,I,R,BGPIMM,BGPNMI