BGP3D38.m

BGP3D38 ; IHS/CMI/LAB - IMMUNIZATIONS ;

 ;;13.0;IHS CLINICAL REPORTING;;NOV 20, 2012;Build 81

 ;

INFLU(P,EDATE) ;EP

 NEW BGPC,BGPG,BGPX,BGPFLU,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 BGPFLU

 ;get all immunizations

 S C="15^16^88^111^135^140^141^144"

 D GETIMMS^BGP3D32(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 BGPFLU(X)=""

 ;now get cpts

 S ED=9999999-EDATE,BD=9999999-$$DOB^AUPNPAT(P),G=0

 S T=$O(^ATXAX("B","BGP CPT FLU",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 BGPFLU(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 BGPFLU(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 $$ICD^ATXCHK(Y,$O(^ATXAX("B","BGP FLU IZ DXS",0)),9) S BGPFLU(9999999-$P(ED,"."))=""

 ..S X=0 F  S X=$O(^AUPNVPRC("AD",V,X)) Q:X'=+X  D

 ...S Y=$P(^AUPNVPRC(X,0),U,1) Q:'Y  I $$ICD^ATXCHK(Y,$O(^ATXAX("B","BGP FLU IZ PROCEDURES",0)),0) S BGPFLU(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(BGPFLU(X)) Q:X'=+X  S C=C+1 D

 .I C=1 S Y=X Q

 .I $$FMDIFF^XLFDT(X,Y)<11 K BGPFLU(X) Q

 .S Y=X

 ;now count them and see if there are 2 of them

 S BGPFLU=0,X=0 F  S X=$O(BGPFLU(X)) Q:X'=+X  S BGPFLU=BGPFLU+1

 I BGPFLU>1 Q 1_U_"2 Influenza"

 ;

 F BGPZ=15,16,88,111,135,140,141 S X=$$ANEGCONT^BGP3D31(P,BGPZ,EDATE) Q:X]""  ;cmi/maw 12/17/07 missing edate

 I X]"" Q 4_U_"Contra Influenza"

 ;

 S B=$$DOB^AUPNPAT(P),E=EDATE,BGPNMI="",R=""

 F BGPIMM=15,16,88,111,135,140,141,144 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")_" Influenza"

 S R=$$CPTREFT^BGP3UTL1(P,$$DOB^AUPNPAT(P),EDATE,$O(^ATXAX("B","BGP CPT FLU",0)))

 I R S:$P(R,U,3)="N" BGPNMI=1 Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"Ref")_" Influenza"

 ;now check Refusals in imm pkg

 S BGPNMI=""

 F BGPIMM=15,16,88,111,135,140,141,144 S R=$$IMMREF^BGP3D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R

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

 Q ""

HIB3(P,EDATE) ;EP

 NEW BGPC,BGPG,BGPX

 ;gather up all immunizations, cpts, povs and check for 3 each ten days apart

 K BGPHIB,BGPAHIB

 ;get all immunizations

 S C="49^51"

 D GETIMMS^BGP3D32(P,EDATE,C,.BGPX)

 S X=0 F  S X=$O(BGPX(X)) Q:X'=+X  S BGPHIB(X)="",BGPAHIB(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),Y=$P($$CPT^ICPTCOD(Y),U,2) I Y=90647!(Y=90648) S BGPHIB(9999999-$P(ED,"."))="",BGPAHIB(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 Y=$P($$CPT^ICPTCOD(Y),U,2) I Y=90647!(Y=90648) S BGPHIB(9999999-$P(ED,"."))="",BGPAHIB(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(BGPHIB(X)) Q:X'=+X  S C=C+1 D

 .I C=1 S Y=X Q

 .I $$FMDIFF^XLFDT(X,Y)<11 K BGPHIB(X) Q

 .S Y=X

 ;now count them and see if there are 4 of them

 S BGPHIB=0,X=0 F  S X=$O(BGPHIB(X)) Q:X'=+X  S BGPHIB=BGPHIB+1

 I BGPHIB>2 Q 1_U_"3 3-Dose Hib"

 ;NOW CHECK TO SEE IF THE FIRST 2 ARE 49

 S BGPX=$$ADDONE(P,EDATE)

 I BGPX]"" Q BGPX

 ;now go to Refusals

 S B=$$DOB^AUPNPAT(P),E=EDATE,BGPNMI="",R=""

 F BGPIMM=49,51 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)&($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")_" 3-Dose Hib"

 S R=$$CPTREFT^BGP3UTL1(P,$$DOB^AUPNPAT(P),EDATE,$O(^ATXAX("B","BGP HIB CPT",0)))

 I R S:$P(R,U,3)="N" BGPNMI=1 I BGPNMI Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"Ref")_" Hib"

 ;now check Refusals in imm pkg

 ;F BGPIMM=49,51 S R=$$IMMREF^BGP3D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R

 ;I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"Ref")_" 3 DOSE Hib"

 F BGPZ=49,51 S X=$$ANCONT^BGP3D31(P,BGPZ,EDATE) Q:X]""  ;cmi/maw 12/17/07 missing edate

 I X]"" Q 4_U_"Contra 3-Dose Hib"

 Q ""

HIB4(P,EDATE) ;EP

 K BGPC,BGPG,BGPX

 ;gather up all immunizations, cpts, povs and check for 3 each ten days apart

 K BGPHIB,BGPAHIB

 ;get all immunizations

 S C="17^22^46^47^48^49^50^51^102^120^132^146"

 D GETIMMS^BGP3D32(P,EDATE,C,.BGPX)

 S X=0 F  S X=$O(BGPX(X)) Q:X'=+X  S BGPHIB(X)="",BGPAHIB(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),Y=$P($$CPT^ICPTCOD(Y),U,2) I Y=90645!(Y=90646)!(Y=90647)!(Y=90648)!(Y=90698)!(Y=90720)!(Y=90721)!(Y=90748)!(Y=90737) S BGPHIB(9999999-$P(ED,"."))="",BGPAHIB(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 Y=$P($$CPT^ICPTCOD(Y),U,2) I Y=90645!(Y=90646)!(Y=90647)!(Y=90648)!(Y=90698)!(Y=90720)!(Y=90721)!(Y=90748)!(Y=90737) S BGPHIB(9999999-$P(ED,"."))="",BGPAHIB(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(BGPHIB(X)) Q:X'=+X  S C=C+1 D

 .I C=1 S Y=X Q

 .I $$FMDIFF^XLFDT(X,Y)<11 K BGPHIB(X) Q

 .S Y=X

 ;now count them and see if there are 4 of them

 S BGPHIB=0,X=0 F  S X=$O(BGPHIB(X)) Q:X'=+X  S BGPHIB=BGPHIB+1

 I BGPHIB>3 Q 1_U_"4 4-Dose Hib"

 ;now get povs

 K BGPHIB M BGPHIB=BGPAHIB

 K BGPG S %=P_"^ALL DX [BGP HIB IZ DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")

 I $D(BGPG(1)) S X=0 F  S X=$O(BGPG(X)) Q:X'=+X  S BGPHIB($P(BGPG(X),U))="",BGPAHIB($P(BGPG(X),U))=""

 ;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(BGPHIB(X)) Q:X'=+X  S C=C+1 D

 .I C=1 S Y=X Q

 .I $$FMDIFF^XLFDT(X,Y)<11 K BGPHIB(X) Q

 .S Y=X

 ;now count them and see if there are 4 of them

 S BGPHIB=0,X=0 F  S X=$O(BGPHIB(X)) Q:X'=+X  S BGPHIB=BGPHIB+1

 I BGPHIB>3 Q 1_U_"4 4-Dose Hib"

 ;now go to Refusals

 S B=$$DOB^AUPNPAT(P),E=EDATE,BGPNMI="",R=""

 F BGPIMM=22,46,47,48,49,50,51,102,120,132,146 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)&($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")_" 4-DOSE Hib"

 S R=$$CPTREFT^BGP3UTL1(P,$$DOB^AUPNPAT(P),EDATE,$O(^ATXAX("B","BGP HIB CPT",0)))

 I R S:$P(R,U,3)="N" BGPNMI=1 Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"Ref")_" Hib"

 ;now check Refusals in imm pkg

 ;F BGPIMM=17,22,46,47,48,49,50,51,102,120,132 S R=$$IMMREF^BGP3D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R

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

 F BGPZ=17,22,46,47,48,49,50,51,102,120,132,146 S X=$$ANCONT^BGP3D31(P,BGPZ,EDATE) Q:X]""  ;cmi/maw 12/17/07 missing edate

 I X]"" Q 4_U_"Contra 4-Dose Hib"

 Q ""

ADDONE(P,EDATE) ;

 NEW BGPC,BGPG,BGPX,G,C,BGPHIB,BGPAHIB

 ;gather up all immunizations, cpts, povs and check for 3 each ten days apart

 K BGPHIB,BGPAHIB

 ;get all immunizations

 S C="17^22^46^47^48^49^50^51^102^120^132^146"

 D GETIMMS^BGP3D32(P,EDATE,C,.BGPX)

 S X=0 F  S X=$O(BGPX(X)) Q:X'=+X  S BGPHIB(X)=$P(^AUTTIMM(BGPX(X),0),U,3),BGPAHIB(X)=$P(^AUTTIMM(BGPX(X),0),U,3)

 ;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),Y=$P($$CPT^ICPTCOD(Y),U,2) I Y=90645!(Y=90646)!(Y=90647)!(Y=90648)!(Y=90698)!(Y=90720)!(Y=90721)!(Y=90748)!(Y=90737) S BGPHIB(9999999-$P(ED,"."))=Y,BGPAHIB(9999999-$P(ED,"."))=Y

 ..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 Y=$P($$CPT^ICPTCOD(Y),U,2) I Y=90645!(Y=90646)!(Y=90647)!(Y=90648)!(Y=90698)!(Y=90720)!(Y=90721)!(Y=90748)!(Y=90737) S BGPHIB(9999999-$P(ED,"."))=Y,BGPAHIB(9999999-$P(ED,"."))=Y

 ;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(BGPHIB(X)) Q:X'=+X  S C=C+1 D

 .I C=1 S Y=X Q

 .I $$FMDIFF^XLFDT(X,Y)<11 K BGPHIB(X) Q

 .S Y=X

 ;now count them and see if there are 4 of them

 ;S BGPHIB=0,X=0 F  S X=$O(BGPHIB(X)) Q:X'=+X  S BGPHIB=BGPHIB+1

 ;I BGPHIB>0 Q 1_U_"3 3-DOSE Hib"

 ;now get povs

 K BGPHIB M BGPHIB=BGPAHIB

 K BGPG S %=P_"^ALL DX [BGP HIB IZ DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")

 I $D(BGPG(1)) S X=0 F  S X=$O(BGPG(X)) Q:X'=+X  S BGPHIB($P(BGPG(X),U))=$P(BGPG(1),U,2),BGPAHIB($P(BGPG(X),U))=$P(BGPG(X),U,2)

 ;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(BGPHIB(X)) Q:X'=+X  S C=C+1 D

 .I C=1 S Y=X Q

 .I $$FMDIFF^XLFDT(X,Y)<11 K BGPHIB(X) Q

 .S Y=X

 ;now count them and see if there are 4 of them

 ;S BGPHIB=0,X=0 F  S X=$O(BGPHIB(X)) Q:X'=+X  S BGPHIB=BGPHIB+1

 ;I BGPHIB>0 Q 1_U_"3 3-DOSE Hib"

 ;IF FIRST 2 ARE 49 AND HAS A 3RD Q ON 3 DOSE

 S (G,C)=0 S X=0 F  S X=$O(BGPHIB(X)) Q:X'=+X!(C>1)  D

 .I BGPHIB(X)=49 S G=G+1

 .S C=C+1

 I G=2 Q 1_U_"3 3-Dose Hib"

 Q ""

BGP3D38   ; IHS/CMI/LAB - IMMUNIZATIONS ;

 +1       ;;13.0;IHS CLINICAL REPORTING;;NOV 20, 2012;Build 81

 +2       ;

INFLU(P,EDATE) ;EP

 +1        NEW BGPC,BGPG,BGPX,BGPFLU,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 BGPFLU

 +5       ;get all immunizations

 +6        SET C="15^16^88^111^135^140^141^144"

 +7        DO GETIMMS^BGP3D32(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 BGPFLU(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 CPT FLU",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 BGPFLU(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 BGPFLU(9999999-$PIECE(ED,"."))=""

                               End DoDot:3

 +20                       SET X=0

                           FOR 

                               SET X=$ORDER(^AUPNVPOV("AD",V,X))

                               IF X'=+X

                                   QUIT 

                               Begin DoDot:3

 +21                               SET Y=$PIECE(^AUPNVPOV(X,0),U,1)

                                   IF 'Y

                                       QUIT 

                                   SET Z=$PIECE(^ICD9(Y,0),U,1)

                                   IF $$ICD^ATXCHK(Y,$ORDER(^ATXAX("B","BGP FLU IZ DXS",0)),9)

                                       SET BGPFLU(9999999-$PIECE(ED,"."))=""

                               End DoDot:3

 +22                       SET X=0

                           FOR 

                               SET X=$ORDER(^AUPNVPRC("AD",V,X))

                               IF X'=+X

                                   QUIT 

                               Begin DoDot:3

 +23                               SET Y=$PIECE(^AUPNVPRC(X,0),U,1)

                                   IF 'Y

                                       QUIT 

                                   IF $$ICD^ATXCHK(Y,$ORDER(^ATXAX("B","BGP FLU IZ PROCEDURES",0)),0)

                                       SET BGPFLU(9999999-$PIECE(ED,"."))=""

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +24      ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones

 +25       SET X=""

           SET Y=""

           SET C=0

           FOR 

               SET X=$ORDER(BGPFLU(X))

               IF X'=+X

                   QUIT 

               SET C=C+1

               Begin DoDot:1

 +26               IF C=1

                       SET Y=X

                       QUIT 

 +27               IF $$FMDIFF^XLFDT(X,Y)<11

                       KILL BGPFLU(X)

                       QUIT 

 +28               SET Y=X

               End DoDot:1

 +29      ;now count them and see if there are 2 of them

 +30       SET BGPFLU=0

           SET X=0

           FOR 

               SET X=$ORDER(BGPFLU(X))

               IF X'=+X

                   QUIT 

               SET BGPFLU=BGPFLU+1

 +31       IF BGPFLU>1

               QUIT 1_U_"2 Influenza"

 +32      ;

 +33      ;cmi/maw 12/17/07 missing edate

           FOR BGPZ=15,16,88,111,135,140,141

               SET X=$$ANEGCONT^BGP3D31(P,BGPZ,EDATE)

               IF X]""

                   QUIT 

 +34       IF X]""

               QUIT 4_U_"Contra Influenza"

 +35      ;

 +36       SET B=$$DOB^AUPNPAT(P)

           SET E=EDATE

           SET BGPNMI=""

           SET R=""

 +37       FOR BGPIMM=15,16,88,111,135,140,141,144

               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")_" Influenza"

 +41       SET R=$$CPTREFT^BGP3UTL1(P,$$DOB^AUPNPAT(P),EDATE,$ORDER(^ATXAX("B","BGP CPT FLU",0)))

 +42       IF R

               IF $PIECE(R,U,3)="N"

                   SET BGPNMI=1

               QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI",1:"Ref")_" Influenza"

 +43      ;now check Refusals in imm pkg

 +44       SET BGPNMI=""

 +45       FOR BGPIMM=15,16,88,111,135,140,141,144

               SET R=$$IMMREF^BGP3D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R

 +46       IF R

               QUIT 3_U_$SELECT(BGPNMI:"NMI",1:"Ref")_" Influenza"

 +47       QUIT ""

HIB3(P,EDATE) ;EP

 +1        NEW BGPC,BGPG,BGPX

 +2       ;gather up all immunizations, cpts, povs and check for 3 each ten days apart

 +3        KILL BGPHIB,BGPAHIB

 +4       ;get all immunizations

 +5        SET C="49^51"

 +6        DO GETIMMS^BGP3D32(P,EDATE,C,.BGPX)

 +7        SET X=0

           FOR 

               SET X=$ORDER(BGPX(X))

               IF X'=+X

                   QUIT 

               SET BGPHIB(X)=""

               SET BGPAHIB(X)=""

 +8       ;now get cpts

 +9        SET ED=9999999-EDATE

           SET BD=9999999-$$DOB^AUPNPAT(P)

           SET G=0

 +10       FOR 

               SET ED=$ORDER(^AUPNVSIT("AA",P,ED))

               IF ED=""!($PIECE(ED,".")>BD)

                   QUIT 

               Begin DoDot:1

 +11               SET V=0

                   FOR 

                       SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))

                       IF V'=+V

                           QUIT 

                       Begin DoDot:2

 +12                       IF '$DATA(^AUPNVSIT(V,0))

                               QUIT 

 +13                       SET X=0

                           FOR 

                               SET X=$ORDER(^AUPNVCPT("AD",V,X))

                               IF X'=+X

                                   QUIT 

                               Begin DoDot:3

 +14                               SET Y=$PIECE(^AUPNVCPT(X,0),U)

                                   SET Y=$PIECE($$CPT^ICPTCOD(Y),U,2)

                                   IF Y=90647!(Y=90648)

                                       SET BGPHIB(9999999-$PIECE(ED,"."))=""

                                       SET BGPAHIB(9999999-$PIECE(ED,"."))=""

                               End DoDot:3

 +15                       SET X=0

                           FOR 

                               SET X=$ORDER(^AUPNVTC("AD",V,X))

                               IF X'=+X

                                   QUIT 

                               Begin DoDot:3

 +16                               SET Y=$PIECE(^AUPNVTC(X,0),U,7)

                                   IF 'Y

                                       QUIT 

                                   SET Y=$PIECE($$CPT^ICPTCOD(Y),U,2)

                                   IF Y=90647!(Y=90648)

                                       SET BGPHIB(9999999-$PIECE(ED,"."))=""

                                       SET BGPAHIB(9999999-$PIECE(ED,"."))=""

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +17      ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones

 +18       SET X=""

           SET Y=""

           SET C=0

           FOR 

               SET X=$ORDER(BGPHIB(X))

               IF X'=+X

                   QUIT 

               SET C=C+1

               Begin DoDot:1

 +19               IF C=1

                       SET Y=X

                       QUIT 

 +20               IF $$FMDIFF^XLFDT(X,Y)<11

                       KILL BGPHIB(X)

                       QUIT 

 +21               SET Y=X

               End DoDot:1

 +22      ;now count them and see if there are 4 of them

 +23       SET BGPHIB=0

           SET X=0

           FOR 

               SET X=$ORDER(BGPHIB(X))

               IF X'=+X

                   QUIT 

               SET BGPHIB=BGPHIB+1

 +24       IF BGPHIB>2

               QUIT 1_U_"3 3-Dose Hib"

 +25      ;NOW CHECK TO SEE IF THE FIRST 2 ARE 49

 +26       SET BGPX=$$ADDONE(P,EDATE)

 +27       IF BGPX]""

               QUIT BGPX

 +28      ;now go to Refusals

 +29       SET B=$$DOB^AUPNPAT(P)

           SET E=EDATE

           SET BGPNMI=""

           SET R=""

 +30       FOR BGPIMM=49,51

               Begin DoDot:1

 +31               SET I=$ORDER(^AUTTIMM("C",BGPIMM,0))

                   IF 'I

                       QUIT 

 +32               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)&($PIECE(^AUPNPREF(Y,0),U,7)="N")

                               SET BGPNMI=1

                               SET R=1

               End DoDot:1

 +33       IF R

               QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI",1:"Ref")_" 3-Dose Hib"

 +34       SET R=$$CPTREFT^BGP3UTL1(P,$$DOB^AUPNPAT(P),EDATE,$ORDER(^ATXAX("B","BGP HIB CPT",0)))

 +35       IF R

               IF $PIECE(R,U,3)="N"

                   SET BGPNMI=1

               IF BGPNMI

                   QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI",1:"Ref")_" Hib"

 +36      ;now check Refusals in imm pkg

 +37      ;F BGPIMM=49,51 S R=$$IMMREF^BGP3D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R

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

 +39      ;cmi/maw 12/17/07 missing edate

           FOR BGPZ=49,51

               SET X=$$ANCONT^BGP3D31(P,BGPZ,EDATE)

               IF X]""

                   QUIT 

 +40       IF X]""

               QUIT 4_U_"Contra 3-Dose Hib"

 +41       QUIT ""

HIB4(P,EDATE) ;EP

 +1        KILL BGPC,BGPG,BGPX

 +2       ;gather up all immunizations, cpts, povs and check for 3 each ten days apart

 +3        KILL BGPHIB,BGPAHIB

 +4       ;get all immunizations

 +5        SET C="17^22^46^47^48^49^50^51^102^120^132^146"

 +6        DO GETIMMS^BGP3D32(P,EDATE,C,.BGPX)

 +7        SET X=0