BGP1D35.m

BGP1D35 ; IHS/CMI/LAB - measure C ;

 ;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33

 ;

VAR(P,EDATE) ;EP

 K BGPC,BGPG,BGPX

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

 K BGPVARI

 ;get all immunizations

 S C="21^94"

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

 ;go through and set into array if 10 days apart

 I $O(BGPX(0)) Q 1_U_"vari"

 ;now get cpts

 S ED=9999999-EDATE-1,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=90710!(Y=90716) S BGPVARI(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=90710!(Y=90716) S BGPVARI(9999999-$P(ED,"."))=""

 I $D(BGPVARI) Q 1_U_"vari"

 K BGPG S %=P_"^ALL DX V05.4;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")

 I $D(BGPG(1)) Q 2_U_"vari"

 ;check for evidence of desease and contraindications and if yes, then quit

 K BGPG S %=P_"^LAST DX [BGP VARICELLA EVIDENCE;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")

 I $D(BGPG(1)) Q 4_U_"evid vari"

 I $$PLTAX^BGP1DU(P,"BGP VARICELLA EVIDENCE") Q 4_U_"evid vari"

 F BGPZ=21,94 S X=$$EVIDVAR(P,BGPZ,EDATE) Q:X]""

 I X]"" Q 4_U_"evid vari"

 K BGPG S %=P_"^LAST DX [BGP VARICELLA CONTRA;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")

 I $D(BGPG(1)) Q 4_U_"contra vari"

 I $$PLTAX^BGP1DU(P,"BGP VARICELLA CONTRA") Q 4_U_"contra vari"

 F BGPZ=21,94 S X=$$MMRCONT^BGP1D31(P,BGPZ,EDATE) Q:X]""

 I X]"" Q 4_U_"contra vari"

 ;now go to refusals

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

 F BGPIMM=21,94  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 vari",1:"ref vari")

 ;now check refusals in imm pkg

 F BGPIMM=21,94 S R=$$IMMREF^BGP1D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R

 I R Q 3_U_"ref imm pkg vari"

 Q ""

HEP(P,EDATE) ;EP

 K BGPC,BGPG,BGPX

 K BGPHEP

 ;get all immunizations

 S C="8^42^43^44^45^51^102^104^110^132"

 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 BGPHEP(X)=""

 ;now get cpts

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

 S T=$O(^ATXAX("B","BGP HEPATITIS CPTS",0))

 S BGP10743=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) S:Z=90743 BGP10743=1 I $$ICD^ATXCHK(Y,T,1) S BGPHEP(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) S:Z=90743 BGP10743=1 I $$ICD^ATXCHK(Y,T,1) S BGPHEP(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(BGPHEP(X)) Q:X'=+X  S C=C+1 D

 .I C=1 S Y=X Q

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

 .S Y=X

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

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

 I BGPHEP>2 Q 1_U_"3 Hep B"

 I BGPHEP=2,BGP10743 Q 1_U_" 2 Hep B +(90743)"

 ;check for evidence of desease and contraindications and if yes, then quit

 K BGPG S %=P_"^LAST DX [BGP HEP EVIDENCE;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")

 I $D(BGPG(1)) Q 4_U_"evid Hep B"

 I $$PLTAX^BGP1DU(P,"BGP HEP EVIDENCE") Q 4_U_"evid Hep B"

 ;now go to refusals

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

 F BGPIMM="8",42,43,44,45,51,102,104,110,132  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 B"

 ;now check refusals in imm pkg

 F BGPIMM=8,42,43,44,45,51,102,104,110,132 S R=$$IMMREF^BGP1D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R

 I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"ref")_" Hep B"

 F BGPZ=8,42,43,44,45,51,102,104,110,132 S X=$$ANCONT^BGP1D31(P,BGPZ,EDATE) Q:X]""  ;cmi/maw 12/17/07 missing edate

 I X]"" Q 4_U_"contra - Hep B"

 Q ""

HIB(P,EDATE) ;EP

 K BGPC,BGPG,BGPX

 K BGPHIB,BGPAHIB

 ;get all immunizations

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

 D GETIMMS^BGP1D32(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>2 Q 1_U_"3 HIB"

 ;now get povs

 K BGPHIB M BGPHIB=BGPAHIB

 K BGPG S %=P_"^ALL DX V03.81;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>2 Q 2_U_"3 HIB"

 ;check for evidence of desease and contraindications and if yes, then quit

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

 ;I $D(BGPG(1)) Q 4_U_"evid HIB"

 ;I $$PLTAX^BGP1DU(P,"BGP HIB EVIDENCE") Q 4_U_"evid 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 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")_" hib"

 ;now check refusals in imm pkg

 F BGPIMM=17,22,46,47,48,49,50,51,102,120,132 S R=$$IMMREF^BGP1D32(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 S X=$$ANCONT^BGP1D31(P,BGPZ,EDATE) Q:X]""  ;cmi/maw 12/17/07 missing edate

 I X]"" Q 4_U_"contra - hib"

 Q ""

PNEUMO(P,EDATE,MINN) ;EP

 K BGPC,BGPG,BGPX

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

 K BGPPNU,BGPAPNU

 ;get all immunizations

 S C="33^100^109^133"

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

 S X=0 F  S X=$O(BGPX(X)) Q:X'=+X  S BGPPNU(X)="",BGPAPNU(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 $$ICD^ATXCHK($P(^AUPNVCPT(X,0),U),$O(^ATXAX("B","BGP PNEUMO IZ CPTS",0)),1) S BGPPNU(9999999-$P(ED,"."))="",BGPAPNU(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 $$ICD^ATXCHK($P(^AUPNVTC(X,0),U),$O(^ATXAX("B","BGP PNEUMO IZ CPTS",0)),1) S BGPPNU(9999999-$P(ED,"."))="",BGPAPNU(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(BGPPNU(X)) Q:X'=+X  S C=C+1 D

 .I C=1 S Y=X Q

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

 .S Y=X

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

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

 I BGPPNU>(MINN-1) Q 1_U_MINN_" PNEUMO"

 ;now get povs

 K BGPPNU M BGPPNU=BGPAPNU

 K BGPG S %=P_"^ALL DX V03.82;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 BGPPNU($P(BGPG(X),U))="",BGPAPNU($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(BGPPNU(X)) Q:X'=+X  S C=C+1 D

 .I C=1 S Y=X Q

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

 .S Y=X

 ;now get povs

 K BGPPNU M BGPPNU=BGPAPNU

 K BGPG S %=P_"^ALL DX V06.6;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 BGPPNU($P(BGPG(X),U))="",BGPAPNU($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(BGPPNU(X)) Q:X'=+X  S C=C+1 D

 .I C=1 S Y=X Q

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

 .S Y=X

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

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

 I BGPPNU>(MINN-1) Q 2_U_MINN_" PNEUMO/DX"

 ;now go to refusals

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

 F BGPIMM=33,100,109,133 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")_" Pneumo"

 ;now check refusals in imm pkg

 F BGPIMM=33,100,109,133 S R=$$IMMREF^BGP1D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R

 I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"ref")_" Pneumo"

 F BGPZ=33,100,109,133 S X=$$ANCONT^BGP1D31(P,BGPZ,EDATE) Q:X]""  ;cmi/maw 12/17/07 missing edate

 I X]"" Q 4_U_"contra - pneumo"

 Q ""

EVIDVAR(P,C,ED) ;EP - HX CHICKEN POX, IMMUNE

 NEW X

 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)="Hx of Chicken Pox" S G=D_U_"Contraindication: Hx of Chicken Pox"

 .I $P(^BICONT(R,0),U,1)="Immune" S G=D_U_"Contraindication: Immune"

 Q G

BGP1D35   ; IHS/CMI/LAB - measure C ;

 +1       ;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33

 +2       ;

VAR(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 BGPVARI

 +4       ;get all immunizations

 +5        SET C="21^94"

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

 +7       ;go through and set into array if 10 days apart

 +8        IF $ORDER(BGPX(0))

               QUIT 1_U_"vari"

 +9       ;now get cpts

 +10       SET ED=9999999-EDATE-1

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

           SET G=0

 +11       FOR 

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

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

                   QUIT 

               Begin DoDot:1

 +12               SET V=0

                   FOR 

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

                       IF V'=+V

                           QUIT 

                       Begin DoDot:2

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

                               QUIT 

 +14                       SET X=0

                           FOR 

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

                               IF X'=+X

                                   QUIT 

                               Begin DoDot:3

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

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

                                   IF Y=90710!(Y=90716)

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

                               End DoDot:3

 +16                       SET X=0

                           FOR 

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

                               IF X'=+X

                                   QUIT 

                               Begin DoDot:3

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

                                   IF 'Y

                                       QUIT 

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

                                   IF Y=90710!(Y=90716)

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

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +18       IF $DATA(BGPVARI)

               QUIT 1_U_"vari"

 +19       KILL BGPG

           SET %=P_"^ALL DX V05.4;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE

           SET E=$$START1^APCLDF(%,"BGPG(")

 +20       IF $DATA(BGPG(1))

               QUIT 2_U_"vari"

 +21      ;check for evidence of desease and contraindications and if yes, then quit

 +22       KILL BGPG

           SET %=P_"^LAST DX [BGP VARICELLA EVIDENCE;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE

           SET E=$$START1^APCLDF(%,"BGPG(")

 +23       IF $DATA(BGPG(1))

               QUIT 4_U_"evid vari"

 +24       IF $$PLTAX^BGP1DU(P,"BGP VARICELLA EVIDENCE")

               QUIT 4_U_"evid vari"

 +25       FOR BGPZ=21,94

               SET X=$$EVIDVAR(P,BGPZ,EDATE)

               IF X]""

                   QUIT 

 +26       IF X]""

               QUIT 4_U_"evid vari"

 +27       KILL BGPG

           SET %=P_"^LAST DX [BGP VARICELLA CONTRA;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE

           SET E=$$START1^APCLDF(%,"BGPG(")

 +28       IF $DATA(BGPG(1))

               QUIT 4_U_"contra vari"

 +29       IF $$PLTAX^BGP1DU(P,"BGP VARICELLA CONTRA")

               QUIT 4_U_"contra vari"

 +30       FOR BGPZ=21,94

               SET X=$$MMRCONT^BGP1D31(P,BGPZ,EDATE)

               IF X]""

                   QUIT 

 +31       IF X]""

               QUIT 4_U_"contra vari"

 +32      ;now go to refusals

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

           SET E=EDATE

           SET BGPNMI=""

           SET R=""

 +34       FOR BGPIMM=21,94

               Begin DoDot:1

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

                   IF 'I

                       QUIT 

 +36               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

 +37       IF R

               QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI vari",1:"ref vari")

 +38      ;now check refusals in imm pkg

 +39       FOR BGPIMM=21,94

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

 +40       IF R

               QUIT 3_U_"ref imm pkg vari"

 +41       QUIT ""

HEP(P,EDATE) ;EP

 +1        KILL BGPC,BGPG,BGPX

 +2        KILL BGPHEP

 +3       ;get all immunizations

 +4        SET C="8^42^43^44^45^51^102^104^110^132"

 +5        DO GETIMMS^BGP1D32(P,EDATE,C,.BGPX)

 +6       ;go through and set into array if 10 days apart

 +7        SET X=0

           FOR 

               SET X=$ORDER(BGPX(X))

               IF X'=+X

                   QUIT 

               SET BGPHEP(X)=""

 +8       ;now get cpts

 +9        SET ED=9999999-EDATE

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

           SET G=0

 +10       SET T=$ORDER(^ATXAX("B","BGP HEPATITIS CPTS",0))

 +11       SET BGP10743=0

           FOR 

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

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

                   QUIT 

               Begin DoDot:1

 +12               SET V=0

                   FOR 

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

                       IF V'=+V

                           QUIT 

                       Begin DoDot:2

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

                               QUIT 

 +14                       SET X=0

                           FOR 

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

                               IF X'=+X

                                   QUIT 

                               Begin DoDot:3

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

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

                                   IF Z=90743

                                       SET BGP10743=1

                                   IF $$ICD^ATXCHK(Y,T,1)

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

                               End DoDot:3

 +16                       SET X=0

                           FOR 

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

                               IF X'=+X

                                   QUIT 

                               Begin DoDot:3

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

                                   IF 'Y

                                       QUIT 

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

                                   IF Z=90743

                                       SET BGP10743=1

                                   IF $$ICD^ATXCHK(Y,T,1)

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

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

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

 +19       SET X=""

           SET Y=""

           SET C=0

           FOR 

               SET X=$ORDER(BGPHEP(X))

               IF X'=+X

                   QUIT 

               SET C=C+1

               Begin DoDot:1

 +20               IF C=1

                       SET Y=X

                       QUIT 

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

                       KILL BGPHEP(X)

                       QUIT 

 +22               SET Y=X

               End DoDot:1

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

 +24       SET BGPHEP=0

           SET X=0

           FOR 

               SET X=$ORDER(BGPHEP(X))

               IF X'=+X

                   QUIT 

               SET BGPHEP=BGPHEP+1

 +25       IF BGPHEP>2

               QUIT 1_U_"3 Hep B"

 +26       IF BGPHEP=2

               IF BGP10743

                   QUIT 1_U_" 2 Hep B +(90743)"

 +27      ;check for evidence of desease and contraindications and if yes, then quit

 +28       KILL BGPG

           SET %=P_"^LAST DX [BGP HEP EVIDENCE;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE

           SET E=$$START1^APCLDF(%,"BGPG(")

 +29       IF $DATA(BGPG(1))

               QUIT 4_U_"evid Hep B"

 +30       IF $$PLTAX^BGP1DU(P,"BGP HEP EVIDENCE")

               QUIT 4_U_"evid Hep B"

 +31      ;now go to refusals

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

           SET E=EDATE

           SET BGPNMI=""

           SET R=""

 +33       FOR BGPIMM="8",42,43,44,45,51,102,104,110,132

               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")_" Hep B"

 +37      ;now check refusals in imm pkg

 +38       FOR BGPIMM=8,42,43,44,45,51,102,104,110,132

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