BGP2D38 ; IHS/CMI/LAB - IMMUNIZATIONS ;
;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
;
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^BGP2D32(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^BGP2D31(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^BGP2UTL1(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^BGP2D32(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^BGP2D32(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^BGP2UTL1(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=49,51 S R=$$IMMREF^BGP2D32(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^BGP2D31(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^BGP2D32(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^BGP2UTL1(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^BGP2D32(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^BGP2D31(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^BGP2D32(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 ""
BGP2D38 ; IHS/CMI/LAB - IMMUNIZATIONS ;
+1 ;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
+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^BGP2D32(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^BGP2D31(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^BGP2UTL1(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^BGP2D32(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^BGP2D32(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^BGP2UTL1(P,$$DOB^AUPNPAT(P),EDATE,$ORDER(^ATXAX("B","BGP HIB CPT",0)))
+35 IF R
IF $PIECE(R,U,3)="N"
SET BGPNMI=1
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^BGP2D32(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^BGP2D31(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^BGP2D32(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 [BGP HIB IZ DXS;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,146
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 SET R=$$CPTREFT^BGP2UTL1(P,$$DOB^AUPNPAT(P),EDATE,$ORDER(^ATXAX("B","BGP HIB CPT",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")_" Hib"
+45 ;now check Refusals in imm pkg
+46 ;F BGPIMM=17,22,46,47,48,49,50,51,102,120,132 S R=$$IMMREF^BGP2D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
+47 ;I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"Ref")_" Hib"
+48 ;cmi/maw 12/17/07 missing edate
FOR BGPZ=17,22,46,47,48,49,50,51,102,120,132,146
SET X=$$ANCONT^BGP2D31(P,BGPZ,EDATE)
IF X]""
QUIT
+49 IF X]""
QUIT 4_U_"Contra 4-Dose Hib"
+50 QUIT ""
ADDONE(P,EDATE) ;
+1 NEW BGPC,BGPG,BGPX,G,C,BGPHIB,BGPAHIB
+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^BGP2D32(P,EDATE,C,.BGPX)
+7 SET X=0
FOR
SET X=$ORDER(BGPX(X))
IF X'=+X
QUIT
SET BGPHIB(X)=$PIECE(^AUTTIMM(BGPX(X),0),U,3)
SET BGPAHIB(X)=$PIECE(^AUTTIMM(BGPX(X),0),U,3)
+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,"."))=Y
SET BGPAHIB(9999999-$PIECE(ED,"."))=Y
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,"."))=Y
SET BGPAHIB(9999999-$PIECE(ED,"."))=Y
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 ;S BGPHIB=0,X=0 F S X=$O(BGPHIB(X)) Q:X'=+X S BGPHIB=BGPHIB+1
+24 ;I BGPHIB>0 Q 1_U_"3 3-DOSE Hib"
+25 ;now get povs
+26 KILL BGPHIB
MERGE BGPHIB=BGPAHIB
+27 KILL BGPG
SET %=P_"^ALL DX [BGP HIB IZ DXS;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))=$PIECE(BGPG(1),U,2)
SET BGPAHIB($PIECE(BGPG(X),U))=$PIECE(BGPG(X),U,2)
+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 ;S BGPHIB=0,X=0 F S X=$O(BGPHIB(X)) Q:X'=+X S BGPHIB=BGPHIB+1
+36 ;I BGPHIB>0 Q 1_U_"3 3-DOSE Hib"
+37 ;IF FIRST 2 ARE 49 AND HAS A 3RD Q ON 3 DOSE
+38 SET (G,C)=0
SET X=0
FOR
SET X=$ORDER(BGPHIB(X))
IF X'=+X!(C>1)
QUIT
Begin DoDot:1
+39 IF BGPHIB(X)=49
SET G=G+1
+40 SET C=C+1
End DoDot:1
+41 IF G=2
QUIT 1_U_"3 3-Dose Hib"
+42 QUIT ""
