BGP1D38 ; IHS/CMI/LAB - IMMUNIZATIONS ;
;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
;
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"
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 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 S Z=$P(^ICD0(Y,0),U,1) I Z="99.52" 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^BGP1D31(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 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"
;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")_" Influenza"
Q ""
HIB3(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="49^51"
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=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 get povs
K BGPHIB M BGPHIB=BGPAHIB
;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 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"
;now check refusals in imm pkg
;F BGPIMM=49,51 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")_" 3 DOSE hib"
F BGPZ=49,51 S X=$$ANCONT^BGP1D31(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"
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>3 Q 1_U_"4 4-DOSE 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>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 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"
;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 - 4-DOSE hib"
Q ""
BGP1D38 ; IHS/CMI/LAB - IMMUNIZATIONS ;
+1 ;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
+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"
+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 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
SET Z=$PIECE(^ICD0(Y,0),U,1)
IF Z="99.52"
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^BGP1D31(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
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 ;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")_" Influenza"
+45 QUIT ""
HIB3(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="49^51"
+6 DO GETIMMS^BGP1D32(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 get povs
+26 KILL BGPHIB
MERGE BGPHIB=BGPAHIB
+27 ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
+28 SET X=""
SET Y=""
SET C=0
FOR
SET X=$ORDER(BGPHIB(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+29 IF C=1
SET Y=X
QUIT
+30 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPHIB(X)
QUIT
+31 SET Y=X
End DoDot:1
+32 ;now count them and see if there are 4 of them
+33 SET BGPHIB=0
SET X=0
FOR
SET X=$ORDER(BGPHIB(X))
IF X'=+X
QUIT
SET BGPHIB=BGPHIB+1
+34 IF BGPHIB>2
QUIT 1_U_"3 3-DOSE HIB"
+35 ;now go to refusals
+36 SET B=$$DOB^AUPNPAT(P)
SET E=EDATE
SET BGPNMI=""
SET R=""
+37 FOR BGPIMM=49,51
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)&($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")_" 3-DOSE HIB"
+41 ;now check refusals in imm pkg
+42 ;F BGPIMM=49,51 S R=$$IMMREF^BGP1D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
+43 ;I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"ref")_" 3 DOSE hib"
+44 ;cmi/maw 12/17/07 missing edate
FOR BGPZ=49,51
SET X=$$ANCONT^BGP1D31(P,BGPZ,EDATE)
IF X]""
QUIT
+45 IF X]""
QUIT 4_U_"contra - 3-DOSE hib"
+46 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"
+6 DO GETIMMS^BGP1D32(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=90645!(Y=90646)!(Y=90647)!(Y=90648)!(Y=90698)!(Y=90720)!(Y=90721)!(Y=90748)!(Y=90737)
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=90645!(Y=90646)!(Y=90647)!(Y=90648)!(Y=90698)!(Y=90720)!(Y=90721)!(Y=90748)!(Y=90737)
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>3
QUIT 1_U_"4 4-DOSE HIB"
+25 ;now get povs
+26 KILL BGPHIB
MERGE BGPHIB=BGPAHIB
+27 KILL BGPG
SET %=P_"^ALL DX V03.81;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+28 IF $DATA(BGPG(1))
SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET BGPHIB($PIECE(BGPG(X),U))=""
SET BGPAHIB($PIECE(BGPG(X),U))=""
+29 ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
+30 SET X=""
SET Y=""
SET C=0
FOR
SET X=$ORDER(BGPHIB(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+31 IF C=1
SET Y=X
QUIT
+32 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPHIB(X)
QUIT
+33 SET Y=X
End DoDot:1
+34 ;now count them and see if there are 4 of them
+35 SET BGPHIB=0
SET X=0
FOR
SET X=$ORDER(BGPHIB(X))
IF X'=+X
QUIT
SET BGPHIB=BGPHIB+1
+36 IF BGPHIB>3
QUIT 1_U_"4 4-DOSE HIB"
+37 ;now go to refusals
+38 SET B=$$DOB^AUPNPAT(P)
SET E=EDATE
SET BGPNMI=""
SET R=""
+39 FOR BGPIMM=22,46,47,48,49,50,51,102,120,132
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)&($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")_" 4-DOSE hib"
+43 ;now check refusals in imm pkg
+44 ;F BGPIMM=17,22,46,47,48,49,50,51,102,120,132 S R=$$IMMREF^BGP1D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
+45 ;I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"ref")_" hib"
+46 ;cmi/maw 12/17/07 missing edate
FOR BGPZ=17,22,46,47,48,49,50,51,102,120,132
SET X=$$ANCONT^BGP1D31(P,BGPZ,EDATE)
IF X]""
QUIT
+47 IF X]""
QUIT 4_U_"contra - 4-DOSE hib"
+48 QUIT ""
