BGP9D36.m

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 ""