BGP6D38 ; IHS/CMI/LAB - IMMUNIZATIONS ;
;;16.1;IHS CLINICAL REPORTING;;MAR 22, 2016;Build 170
;
INFLU(P,EDATE) ;EP
NEW BGPC,BGPG,BGPX,BGPFLU,C,X,ED,BD,G,V,Y,T,I,R,BGPIMM,BGPNMI,BGPT
K BGPC,BGPG,BGPX
;gather up all immunizations, cpts, povs and check for 3 each ten days apart
K BGPFLU
;get all immunizations
S BGPT=$O(^ATXAX("B","BGP FLU IZ CVX CODES",0))
S C="" F S C=$O(^ATXAX(BGPT,21,"B",C)) Q:C="" 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 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^BGP6UTL2(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^BGP6UTL2(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^BGP6UTL2(Y,$O(^ATXAX("B","BGP FLU IZ DXS",0)),9) 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"
;
S BGPT=$O(^ATXAX("B","BGP FLU IZ CVX CODES",0))
S BGPZ="" F S BGPZ=$O(^ATXAX(BGPT,21,"B",BGPZ)) Q:BGPZ=""!(X]"") S X=$$ANEGCONT^BGP6D31(P,BGPZ,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,149,150,151,153,155,158,161 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 BGPNMI Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"Ref")_" Influenza"
S R=$$CPTREFT^BGP6UTL1(P,$$DOB^AUPNPAT(P),EDATE,$O(^ATXAX("B","BGP CPT FLU",0)),"N")
I $P(R,U,3)="N" S 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,149,150,151,153,155,158 S R=$$IMMREF^BGP6D32(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^BGP6D32(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^BGP6UTL1(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^BGP6D32(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^BGP6D31(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^BGP6D32(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^BGP6UTL1(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^BGP6D32(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^BGP6D31(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^BGP6D32(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 if
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 '$D(BGPHIB(9999999-$P(ED,"."))) 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 I '$D(BGPHIB($P(BGPG(X),U))) 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 3 of them
S BGPHIB=0,X=0 F S X=$O(BGPHIB(X)) Q:X'=+X S BGPHIB=BGPHIB+1
I BGPHIB<3 Q "" ;need at least 3
;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 $$3D(BGPHIB(X)) S G=G+1
.S C=C+1
I G=2 Q 1_U_"3 3-Dose Hib"
Q ""
3D(%) ;
I %=49 Q 1
I %=51 Q 1
I %=90647 Q 1
I %=90748 Q 1
Q ""
BGP6D38 ; IHS/CMI/LAB - IMMUNIZATIONS ;
+1 ;;16.1;IHS CLINICAL REPORTING;;MAR 22, 2016;Build 170
+2 ;
INFLU(P,EDATE) ;EP
+1 NEW BGPC,BGPG,BGPX,BGPFLU,C,X,ED,BD,G,V,Y,T,I,R,BGPIMM,BGPNMI,BGPT
+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 BGPT=$ORDER(^ATXAX("B","BGP FLU IZ CVX CODES",0))
+7 SET C=""
FOR
SET C=$ORDER(^ATXAX(BGPT,21,"B",C))
IF C=""
QUIT
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 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^BGP6UTL2(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^BGP6UTL2(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^BGP6UTL2(Y,$ORDER(^ATXAX("B","BGP FLU IZ DXS",0)),9)
SET BGPFLU(9999999-$PIECE(ED,"."))=""
End DoDot:3
End DoDot:2
End DoDot:1
+22 ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
+23 SET X=""
SET Y=""
SET C=0
FOR
SET X=$ORDER(BGPFLU(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+24 IF C=1
SET Y=X
QUIT
+25 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPFLU(X)
QUIT
+26 SET Y=X
End DoDot:1
+27 ;now count them and see if there are 2 of them
+28 SET BGPFLU=0
SET X=0
FOR
SET X=$ORDER(BGPFLU(X))
IF X'=+X
QUIT
SET BGPFLU=BGPFLU+1
+29 IF BGPFLU>1
QUIT 1_U_"2 Influenza"
+30 ;
+31 SET BGPT=$ORDER(^ATXAX("B","BGP FLU IZ CVX CODES",0))
+32 SET BGPZ=""
FOR
SET BGPZ=$ORDER(^ATXAX(BGPT,21,"B",BGPZ))
IF BGPZ=""!(X]"")
QUIT
SET X=$$ANEGCONT^BGP6D31(P,BGPZ,EDATE)
+33 IF X]""
QUIT 4_U_"Contra Influenza"
+34 ;
+35 SET B=$$DOB^AUPNPAT(P)
SET E=EDATE
SET BGPNMI=""
SET R=""
+36 FOR BGPIMM=15,16,88,111,135,140,141,144,149,150,151,153,155,158,161
Begin DoDot:1
+37 SET I=$ORDER(^AUTTIMM("C",BGPIMM,0))
IF 'I
QUIT
+38 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
+39 IF BGPNMI
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI",1:"Ref")_" Influenza"
+40 SET R=$$CPTREFT^BGP6UTL1(P,$$DOB^AUPNPAT(P),EDATE,$ORDER(^ATXAX("B","BGP CPT FLU",0)),"N")
+41 IF $PIECE(R,U,3)="N"
SET BGPNMI=1
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI",1:"Ref")_" Influenza"
+42 ;now check Refusals in imm pkg
+43 ;S BGPNMI=""
+44 ;F BGPIMM=15,16,88,111,135,140,141,144,149,150,151,153,155,158 S R=$$IMMREF^BGP6D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
+45 ;I R Q 3_U_$S(BGPNMI:"NMI",1:"Ref")_" Influenza"
+46 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^BGP6D32(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^BGP6UTL1(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^BGP6D32(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^BGP6D31(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^BGP6D32(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^BGP6UTL1(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^BGP6D32(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^BGP6D31(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^BGP6D32(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 if
+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 '$DATA(BGPHIB(9999999-$PIECE(ED,".")))
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 ;K BGPHIB M 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
IF '$DATA(BGPHIB($PIECE(BGPG(X),U)))
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 3 of them
+35 SET BGPHIB=0
SET X=0
FOR
SET X=$ORDER(BGPHIB(X))
IF X'=+X
QUIT
SET BGPHIB=BGPHIB+1
+36 ;need at least 3
IF BGPHIB<3
QUIT ""
+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 $$3D(BGPHIB(X))
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 ""
3D(%) ;
+1 IF %=49
QUIT 1
+2 IF %=51
QUIT 1
+3 IF %=90647
QUIT 1
+4 IF %=90748
QUIT 1
+5 QUIT ""
