BGP9D36 ; IHS/CMI/LAB - measure C 06 Nov 2007 2:03 PM ;
;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009
;
MEN(P,EDATE) ;EP
K BGPC,BGPG,BGPX
;gather up all immunizations, cpts, povs and check for 3 each ten days apart
K BGPMENI
;get all immunizations
S C="32^108^114"
D GETIMMS^BGP9D32(P,EDATE,C,.BGPX)
;go through and set into array if 10 days apart
I $O(BGPX(0)) Q 1_U_"meningococcal"
;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=90733!(Y=90734) S BGPMENI(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=90733!(Y=90734) S BGPMENI(9999999-$P(ED,"."))=""
I $D(BGPMENI) Q 1_U_"meningococcal"
;check for evidence of desease and contraindications and if yes, then quit
F BGPZ=32,108,114 S X=$$ANCONT^BGP9D31(P,BGPZ,EDATE) Q:X]""
I X]"" Q 4_U_"contra meningococcal"
;now go to refusals
S B=$$DOB^AUPNPAT(P),E=EDATE,BGPNMI="",R=""
F BGPIMM=32,108,114 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 meni",1:"ref meni")
;now check refusals in imm pkg
F BGPIMM=32,108,114 S R=$$IMMREF^BGP9D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
I R Q 3_U_"ref imm pkg meni"
Q ""
;
HPV(P,EDATE) ;EP
K BGPC,BGPG,BGPX
;gather up all immunizations, cpts, povs and check for 3 each ten days apart
K BGPHPV
;get all immunizations
S C="62^118"
D GETIMMS^BGP9D32(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 BGPHPV(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) S Z=$P($$CPT^ICPTCOD(Y),U,2) I Z=90649!(Z=90650) S BGPHPV(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 Z=90649!(Z=90650) S BGPHPV(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(BGPHPV(X)) Q:X'=+X S C=C+1 D
.I C=1 S Y=X Q
.I $$FMDIFF^XLFDT(X,Y)<11 K BGPHPV(X) Q
.S Y=X
;now count them and see if there are 4 of them
S BGPHPV=0,X=0 F S X=$O(BGPHPV(X)) Q:X'=+X S BGPHPV=BGPHPV+1
I BGPHPV>2 Q 1_U_"3 HPV"
;check for evidence of desease and contraindications and if yes, then quit
;now go to refusals
S B=$$DOB^AUPNPAT(P),E=EDATE,BGPNMI="",R=""
F BGPIMM=62,118 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")_" HPV"
;now check refusals in imm pkg
F BGPIMM=62,118 S R=$$IMMREF^BGP9D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI",1:"ref")_" HPV"
F BGPZ=62,118 S X=$$ANCONT^BGP9D31(P,BGPZ,EDATE) Q:X]""
I X]"" Q 4_U_"contra - HPV"
Q ""
BGP9D36 ; IHS/CMI/LAB - measure C 06 Nov 2007 2:03 PM ;
+1 ;;9.0;IHS CLINICAL REPORTING;;JUL 1, 2009
+2 ;
MEN(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 BGPMENI
+4 ;get all immunizations
+5 SET C="32^108^114"
+6 DO GETIMMS^BGP9D32(P,EDATE,C,.BGPX)
+7 ;go through and set into array if 10 days apart
+8 IF $ORDER(BGPX(0))
QUIT 1_U_"meningococcal"
+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=90733!(Y=90734)
SET BGPMENI(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=90733!(Y=90734)
SET BGPMENI(9999999-$PIECE(ED,"."))=""
End DoDot:3
End DoDot:2
End DoDot:1
+18 IF $DATA(BGPMENI)
QUIT 1_U_"meningococcal"
+19 ;check for evidence of desease and contraindications and if yes, then quit
+20 FOR BGPZ=32,108,114
SET X=$$ANCONT^BGP9D31(P,BGPZ,EDATE)
IF X]""
QUIT
+21 IF X]""
QUIT 4_U_"contra meningococcal"
+22 ;now go to refusals
+23 SET B=$$DOB^AUPNPAT(P)
SET E=EDATE
SET BGPNMI=""
SET R=""
+24 FOR BGPIMM=32,108,114
Begin DoDot:1
+25 SET I=$ORDER(^AUTTIMM("C",BGPIMM,0))
IF 'I
QUIT
+26 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
+27 IF R
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI meni",1:"ref meni")
+28 ;now check refusals in imm pkg
+29 FOR BGPIMM=32,108,114
SET R=$$IMMREF^BGP9D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
+30 IF R
QUIT 3_U_"ref imm pkg meni"
+31 QUIT ""
+32 ;
HPV(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 BGPHPV
+4 ;get all immunizations
+5 SET C="62^118"
+6 DO GETIMMS^BGP9D32(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 BGPHPV(X)=""
+9 ;now get cpts
+10 SET ED=9999999-EDATE
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 Z=$PIECE($$CPT^ICPTCOD(Y),U,2)
IF Z=90649!(Z=90650)
SET BGPHPV(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=90649!(Z=90650)
SET BGPHPV(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(BGPHPV(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 BGPHPV(X)
QUIT
+22 SET Y=X
End DoDot:1
+23 ;now count them and see if there are 4 of them
+24 SET BGPHPV=0
SET X=0
FOR
SET X=$ORDER(BGPHPV(X))
IF X'=+X
QUIT
SET BGPHPV=BGPHPV+1
+25 IF BGPHPV>2
QUIT 1_U_"3 HPV"
+26 ;check for evidence of desease and contraindications and if yes, then quit
+27 ;now go to refusals
+28 SET B=$$DOB^AUPNPAT(P)
SET E=EDATE
SET BGPNMI=""
SET R=""
+29 FOR BGPIMM=62,118
Begin DoDot:1
+30 SET I=$ORDER(^AUTTIMM("C",BGPIMM,0))
IF 'I
QUIT
+31 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
+32 IF R
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI",1:"ref")_" HPV"
+33 ;now check refusals in imm pkg
+34 FOR BGPIMM=62,118
SET R=$$IMMREF^BGP9D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
+35 IF R
QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI",1:"ref")_" HPV"
+36 FOR BGPZ=62,118
SET X=$$ANCONT^BGP9D31(P,BGPZ,EDATE)
IF X]""
QUIT
+37 IF X]""
QUIT 4_U_"contra - HPV"
+38 QUIT ""
