BGP0D35 ; IHS/CMI/LAB - measure C ;
;;10.0;IHS CLINICAL REPORTING;;JUN 18, 2010
;
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^BGP0D32(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 var"
I $$PLTAX^BGP0DU(P,"BGP VARICELLA EVIDENCE") Q 4_U_"evid var"
F BGPZ=21,94 S X=$$EVIDVAR(P,BGPZ,EDATE) Q:X]""
I X]"" Q 4_U_"evid var"
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 var"
I $$PLTAX^BGP0DU(P,"BGP VARICELLA CONTRA") Q 4_U_"contra var"
F BGPZ=21,94 S X=$$MMRCONT^BGP0D31(P,BGPZ,EDATE) Q:X]""
I X]"" Q 4_U_"contra var"
;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 var",1:"ref var")
;now check refusals in imm pkg
F BGPIMM=21,94 S R=$$IMMREF^BGP0D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
I R Q 3_U_"ref imm pkg var"
Q ""
HEP(P,EDATE) ;EP
K BGPC,BGPG,BGPX
;gather up all immunizations, cpts, povs and check for 3 each ten days apart
K BGPHEP
;get all immunizations
S C="8^42^43^44^45^51^102^104^110"
D GETIMMS^BGP0D32(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 BGP00743=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 BGP00743=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 BGP00743=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"
I BGPHEP=2,BGP00743 Q 1_U_" 2 HEP, 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"
I $$PLTAX^BGP0DU(P,"BGP HEP EVIDENCE") Q 4_U_"evid hep"
;now go to refusals
S B=$$DOB^AUPNPAT(P),E=EDATE,BGPNMI="",R=""
F BGPIMM="8",42,43,44,45,51,102,104,110 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"
;now check refusals in imm pkg
F BGPIMM=8,42,43,44,45,51,102,104,110 S R=$$IMMREF^BGP0D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"ref")_" hep"
F BGPZ=8,42,43,44,45,51,102,104,110 S X=$$ANCONT^BGP0D31(P,BGPZ,EDATE) Q:X]"" ;cmi/maw 12/17/07 missing edate
I X]"" Q 4_U_"contra - HEP"
Q ""
HIB(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"
D GETIMMS^BGP0D32(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^BGP0DU(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 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 S R=$$IMMREF^BGP0D32(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 S X=$$ANCONT^BGP0D31(P,BGPZ,EDATE) Q:X]"" ;cmi/maw 12/17/07 missing edate
I X]"" Q 4_U_"contra - Polio"
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^BGP0D32(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^BGP0D32(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^BGP0D31(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
BGP0D35 ; IHS/CMI/LAB - measure C ;
+1 ;;10.0;IHS CLINICAL REPORTING;;JUN 18, 2010
+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^BGP0D32(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 var"
+24 IF $$PLTAX^BGP0DU(P,"BGP VARICELLA EVIDENCE")
QUIT 4_U_"evid var"
+25 FOR BGPZ=21,94
SET X=$$EVIDVAR(P,BGPZ,EDATE)
IF X]""
QUIT
+26 IF X]""
QUIT 4_U_"evid var"
+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 var"
+29 IF $$PLTAX^BGP0DU(P,"BGP VARICELLA CONTRA")
QUIT 4_U_"contra var"
+30 FOR BGPZ=21,94
SET X=$$MMRCONT^BGP0D31(P,BGPZ,EDATE)
IF X]""
QUIT
+31 IF X]""
QUIT 4_U_"contra var"
+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 var",1:"ref var")
+38 ;now check refusals in imm pkg
+39 FOR BGPIMM=21,94
SET R=$$IMMREF^BGP0D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
+40 IF R
QUIT 3_U_"ref imm pkg var"
+41 QUIT ""
HEP(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 BGPHEP
+4 ;get all immunizations
+5 SET C="8^42^43^44^45^51^102^104^110"
+6 DO GETIMMS^BGP0D32(P,EDATE,C,.BGPX)
+7 ;go through and set into array if 10 days apart
+8 SET X=0
FOR
SET X=$ORDER(BGPX(X))
IF X'=+X
QUIT
SET BGPHEP(X)=""
+9 ;now get cpts
+10 SET ED=9999999-EDATE
SET BD=9999999-$$DOB^AUPNPAT(P)
SET G=0
+11 SET T=$ORDER(^ATXAX("B","BGP HEPATITIS CPTS",0))
+12 SET BGP00743=0
FOR
SET ED=$ORDER(^AUPNVSIT("AA",P,ED))
IF ED=""!($PIECE(ED,".")>BD)
QUIT
Begin DoDot:1
+13 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))
IF V'=+V
QUIT
Begin DoDot:2
+14 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+15 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+16 SET Y=$PIECE(^AUPNVCPT(X,0),U)
SET Z=$PIECE($$CPT^ICPTCOD(Y),U,2)
IF Z=90743
SET BGP00743=1
IF $$ICD^ATXCHK(Y,T,1)
SET BGPHEP(9999999-$PIECE(ED,"."))=""
End DoDot:3
+17 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+18 SET Y=$PIECE(^AUPNVTC(X,0),U,7)
IF 'Y
QUIT
SET Z=$PIECE($$CPT^ICPTCOD(Y),U,2)
IF Z=90743
SET BGP00743=1
IF $$ICD^ATXCHK(Y,T,1)
SET BGPHEP(9999999-$PIECE(ED,"."))=""
End DoDot:3
End DoDot:2
End DoDot:1
+19 ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
+20 SET X=""
SET Y=""
SET C=0
FOR
SET X=$ORDER(BGPHEP(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+21 IF C=1
SET Y=X
QUIT
+22 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPHEP(X)
QUIT
+23 SET Y=X
End DoDot:1
+24 ;now count them and see if there are 4 of them
+25 SET BGPHEP=0
SET X=0
FOR
SET X=$ORDER(BGPHEP(X))
IF X'=+X
QUIT
SET BGPHEP=BGPHEP+1
+26 IF BGPHEP>2
QUIT 1_U_"3 HEP"
+27 IF BGPHEP=2
IF BGP00743
QUIT 1_U_" 2 HEP, 90743"
+28 ;check for evidence of desease and contraindications and if yes, then quit
+29 KILL BGPG
SET %=P_"^LAST DX [BGP HEP EVIDENCE;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+30 IF $DATA(BGPG(1))
QUIT 4_U_"evid hep"
+31 IF $$PLTAX^BGP0DU(P,"BGP HEP EVIDENCE")
QUIT 4_U_"evid hep"
+32 ;now go to refusals
+33 SET B=$$DOB^AUPNPAT(P)
SET E=EDATE
SET BGPNMI=""
SET R=""
+34 FOR BGPIMM="8",42,43,44,45,51,102,104,110
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",1:"ref")_" hep"
+38 ;now check refusals in imm pkg
+39 FOR BGPIMM=8,42,43,44,45,51,102,104,110
SET R=$$IMMREF^BGP0D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
+40 IF R
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI",1:"ref")_" hep"
+41 ;cmi/maw 12/17/07 missing edate
FOR BGPZ=8,42,43,44,45,51,102,104,110
SET X=$$ANCONT^BGP0D31(P,BGPZ,EDATE)
IF X]""
QUIT
+42 IF X]""
QUIT 4_U_"contra - HEP"
+43 QUIT ""
HIB(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"
+6 DO GETIMMS^BGP0D32(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>2
QUIT 1_U_"3 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>2
QUIT 2_U_"3 HIB"
+37 ;check for evidence of desease and contraindications and if yes, then quit
+38 ;K BGPG S %=P_"^LAST DX [BGP HIB EVIDENCE;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
+39 ;I $D(BGPG(1)) Q 4_U_"evid HIB"
+40 ;I $$PLTAX^BGP0DU(P,"BGP HIB EVIDENCE") Q 4_U_"evid HIB"
+41 ;now go to refusals
+42 SET B=$$DOB^AUPNPAT(P)
SET E=EDATE
SET BGPNMI=""
SET R=""
+43 FOR BGPIMM=22,46,47,48,49,50,51,102,120
Begin DoDot:1
+44 SET I=$ORDER(^AUTTIMM("C",BGPIMM,0))
IF 'I
QUIT
+45 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
+46 IF R
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI",1:"ref")_" hib"
+47 ;now check refusals in imm pkg
+48 FOR BGPIMM=17,22,46,47,48,49,50,51,102,120
SET R=$$IMMREF^BGP0D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
+49 IF R
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI",1:"ref")_" hib"
+50 ;cmi/maw 12/17/07 missing edate
FOR BGPZ=17,22,46,47,48,49,50,51,102,120
SET X=$$ANCONT^BGP0D31(P,BGPZ,EDATE)
IF X]""
QUIT
+51 IF X]""
QUIT 4_U_"contra - Polio"
+52 QUIT ""
PNEUMO(P,EDATE,MINN) ;EP
+1 KILL BGPC,BGPG,BGPX
+2 ;gather up all immunizations, cpts, povs and check for 3 each ten days apart
+3 KILL BGPPNU,BGPAPNU
+4 ;get all immunizations
+5 SET C="33^100^109^133"
+6 DO GETIMMS^BGP0D32(P,EDATE,C,.BGPX)
+7 SET X=0
FOR
SET X=$ORDER(BGPX(X))
IF X'=+X
QUIT
SET BGPPNU(X)=""
SET BGPAPNU(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 $$ICD^ATXCHK($PIECE(^AUPNVCPT(X,0),U),$ORDER(^ATXAX("B","BGP PNEUMO IZ CPTS",0)),1)
SET BGPPNU(9999999-$PIECE(ED,"."))=""
SET BGPAPNU(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 $$ICD^ATXCHK($PIECE(^AUPNVTC(X,0),U),$ORDER(^ATXAX("B","BGP PNEUMO IZ CPTS",0)),1)
SET BGPPNU(9999999-$PIECE(ED,"."))=""
SET BGPAPNU(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(BGPPNU(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 BGPPNU(X)
QUIT
+21 SET Y=X
End DoDot:1
+22 ;now count them and see if there are 4 of them
+23 SET BGPPNU=0
SET X=0
FOR
SET X=$ORDER(BGPPNU(X))
IF X'=+X
QUIT
SET BGPPNU=BGPPNU+1
+24 IF BGPPNU>(MINN-1)
QUIT 1_U_MINN_" PNEUMO"
+25 ;now get povs
+26 KILL BGPPNU
MERGE BGPPNU=BGPAPNU
+27 KILL BGPG
SET %=P_"^ALL DX V03.82;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 BGPPNU($PIECE(BGPG(X),U))=""
SET BGPAPNU($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(BGPPNU(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 BGPPNU(X)
QUIT
+33 SET Y=X
End DoDot:1
+34 ;now get povs
+35 KILL BGPPNU
MERGE BGPPNU=BGPAPNU
+36 KILL BGPG
SET %=P_"^ALL DX V06.6;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+37 IF $DATA(BGPG(1))
SET X=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X
QUIT
SET BGPPNU($PIECE(BGPG(X),U))=""
SET BGPAPNU($PIECE(BGPG(X),U))=""
+38 ;now check to see if they are all spaced 10 days apart, if not, kill off the odd ones
+39 SET X=""
SET Y=""
SET C=0
FOR
SET X=$ORDER(BGPPNU(X))
IF X'=+X
QUIT
SET C=C+1
Begin DoDot:1
+40 IF C=1
SET Y=X
QUIT
+41 IF $$FMDIFF^XLFDT(X,Y)<11
KILL BGPPNU(X)
QUIT
+42 SET Y=X
End DoDot:1
+43 ;now count them and see if there are 4 of them
+44 SET BGPPNU=0
SET X=0
FOR
SET X=$ORDER(BGPPNU(X))
IF X'=+X
QUIT
SET BGPPNU=BGPPNU+1
+45 IF BGPPNU>(MINN-1)
QUIT 2_U_MINN_" PNEUMO/DX"
+46 ;now go to refusals
+47 SET B=$$DOB^AUPNPAT(P)
SET E=EDATE
SET BGPNMI=""
SET R=""
+48 FOR BGPIMM=33,100,109,133
Begin DoDot:1
+49 SET I=$ORDER(^AUTTIMM("C",BGPIMM,0))
IF 'I
QUIT
+50 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
+51 IF R
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI",1:"ref")_" Pneumo"
+52 ;now check refusals in imm pkg
+53 FOR BGPIMM=33,100,109,133
SET R=$$IMMREF^BGP0D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
+54 IF R
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI",1:"ref")_" Pneumo"
+55 ;cmi/maw 12/17/07 missing edate
FOR BGPZ=33,100,109,133
SET X=$$ANCONT^BGP0D31(P,BGPZ,EDATE)
IF X]""
QUIT
+56 IF X]""
QUIT 4_U_"contra - pneumo"
+57 QUIT ""
EVIDVAR(P,C,ED) ;EP - HX CHICKEN POX, IMMUNE
+1 NEW X
+2 SET X=0
SET G=""
SET Y=$ORDER(^AUTTIMM("C",C,0))
IF Y
FOR
SET X=$ORDER(^BIPC("AC",P,Y,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+3 SET R=$PIECE(^BIPC(X,0),U,3)
+4 IF R=""
QUIT
+5 IF '$DATA(^BICONT(R,0))
QUIT
+6 SET D=$PIECE(^BIPC(X,0),U,4)
+7 IF D=""
QUIT
+8 ;Q:$P(^BIPC(X,0),U,4)<BD
+9 IF $PIECE(^BIPC(X,0),U,4)>ED
QUIT
+10 IF $PIECE(^BICONT(R,0),U,1)="Hx of Chicken Pox"
SET G=D_U_"Contraindication: Hx of Chicken Pox"
+11 IF $PIECE(^BICONT(R,0),U,1)="Immune"
SET G=D_U_"Contraindication: Immune"
End DoDot:1
+12 QUIT G
