BGP7D86.m

BGP7D86 ; IHS/CMI/LAB - measure C 06 Nov 2009 2:26 PM ;

 ;;17.1;IHS CLINICAL REPORTING;;MAY 10, 2017;Build 29

 ;

 ;

TDAP(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="115"

 D GETIMMS^BGP7D32(P,EDATE,C,.BGPX)

 ;go through and set into array if 10 days apart

 I $O(BGPX(0)) Q 1_U_"Tdap"

 ;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=90715 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=90715 S BGPVARI(9999999-$P(ED,"."))=""

 I $D(BGPVARI) Q 1_U_"Tdap"

 F BGPZ=115 S X=$$ANCONT^BGP7D31(P,BGPZ,EDATE) Q:X]""

 I X]"" Q 4_U_"Contra Tdap"

 ;now go to Refusals

 S B=$$DOB^AUPNPAT(P),E=EDATE,BGPNMI="",R=""

 F BGPIMM=115  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) I $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 Tdap",1:"Ref Tdap")

 F BGPIMM=90715  D

 .S I=+$$CODEN^ICPTCOD(BGPIMM) Q:'I

 .S X=0 F  S X=$O(^AUPNPREF("AA",P,81,I,X)) Q:X'=+X  S Y=0 F  S Y=$O(^AUPNPREF("AA",P,81,I,X,Y)) Q:Y'=+Y  S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) I $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 Tdap",1:"Ref Tdap")

 ;now check Refusals in imm pkg

 ;F BGPIMM=115 S R=$$IMMREF^BGP7D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R

 ;I R Q 3_U_"Ref imm pkg Tdap"

TD ;

 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="9^113^138^139"

 D GETIMMS^BGP7D32(P,EDATE,C,.BGPX)

 ;go through and set into array if 10 days apart

 I $O(BGPX(0)) Q 1_U_"Td"

 ;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=Y=90714!(Y=90718) 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=Y=90714!(Y=90718) S BGPVARI(9999999-$P(ED,"."))=""

 I $D(BGPVARI) Q 1_U_"Td"

 K BGPG S %=P_"^ALL DX [BGP TD IZ DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")

 I $D(BGPG(1)) Q 1_U_"Td"

 F BGPZ=9,113,138,139 S X=$$ANCONT^BGP7D31(P,BGPZ,EDATE) Q:X]""

 I X]"" Q 4_U_"Contra Td"

 ;now go to Refusals

 S B=$$DOB^AUPNPAT(P),E=EDATE,BGPNMI="",R=""

 F BGPIMM=9,113,138,139 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) I $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 Td",1:"Ref Td")

 F BGPIMM=90714,90718  D

 .S I=+$$CODEN^ICPTCOD(BGPIMM) Q:'I

 .S X=0 F  S X=$O(^AUPNPREF("AA",P,81,I,X)) Q:X'=+X  S Y=0 F  S Y=$O(^AUPNPREF("AA",P,81,I,X,Y)) Q:Y'=+Y  S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) I $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 Td",1:"Ref Td")

 ;now check Refusals in imm pkg

 ;F BGPIMM=9,113 S R=$$IMMREF^BGP7D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R

 ;I R Q 3_U_"Ref imm pkg Td"

 Q ""

BGP7D86   ; IHS/CMI/LAB - measure C 06 Nov 2009 2:26 PM ;

 +1       ;;17.1;IHS CLINICAL REPORTING;;MAY 10, 2017;Build 29

 +2       ;

 +3       ;

TDAP(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="115"

 +6        DO GETIMMS^BGP7D32(P,EDATE,C,.BGPX)

 +7       ;go through and set into array if 10 days apart

 +8        IF $ORDER(BGPX(0))

               QUIT 1_U_"Tdap"

 +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=90715

                                       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=90715

                                       SET BGPVARI(9999999-$PIECE(ED,"."))=""

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +18       IF $DATA(BGPVARI)

               QUIT 1_U_"Tdap"

 +19       FOR BGPZ=115

               SET X=$$ANCONT^BGP7D31(P,BGPZ,EDATE)

               IF X]""

                   QUIT 

 +20       IF X]""

               QUIT 4_U_"Contra Tdap"

 +21      ;now go to Refusals

 +22       SET B=$$DOB^AUPNPAT(P)

           SET E=EDATE

           SET BGPNMI=""

           SET R=""

 +23       FOR BGPIMM=115

               Begin DoDot:1

 +24               SET I=$ORDER(^AUTTIMM("C",BGPIMM,0))

                   IF 'I

                       QUIT 

 +25               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

 +26       IF R

               QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI Tdap",1:"Ref Tdap")

 +27       FOR BGPIMM=90715

               Begin DoDot:1

 +28               SET I=+$$CODEN^ICPTCOD(BGPIMM)

                   IF 'I

                       QUIT 

 +29               SET X=0

                   FOR 

                       SET X=$ORDER(^AUPNPREF("AA",P,81,I,X))

                       IF X'=+X

                           QUIT 

                       SET Y=0

                       FOR 

                           SET Y=$ORDER(^AUPNPREF("AA",P,81,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

 +30       IF R

               QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI Tdap",1:"Ref Tdap")

 +31      ;now check Refusals in imm pkg

 +32      ;F BGPIMM=115 S R=$$IMMREF^BGP7D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R

 +33      ;I R Q 3_U_"Ref imm pkg Tdap"

TD        ;

 +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="9^113^138^139"

 +6        DO GETIMMS^BGP7D32(P,EDATE,C,.BGPX)

 +7       ;go through and set into array if 10 days apart

 +8        IF $ORDER(BGPX(0))

               QUIT 1_U_"Td"

 +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=Y=90714!(Y=90718)

                                       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=Y=90714!(Y=90718)

                                       SET BGPVARI(9999999-$PIECE(ED,"."))=""

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +18       IF $DATA(BGPVARI)

               QUIT 1_U_"Td"

 +19       KILL BGPG

           SET %=P_"^ALL DX [BGP TD IZ DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE

           SET E=$$START1^APCLDF(%,"BGPG(")

 +20       IF $DATA(BGPG(1))

               QUIT 1_U_"Td"

 +21       FOR BGPZ=9,113,138,139

               SET X=$$ANCONT^BGP7D31(P,BGPZ,EDATE)

               IF X]""

                   QUIT 

 +22       IF X]""

               QUIT 4_U_"Contra Td"

 +23      ;now go to Refusals

 +24       SET B=$$DOB^AUPNPAT(P)

           SET E=EDATE

           SET BGPNMI=""

           SET R=""

 +25       FOR BGPIMM=9,113,138,139

               Begin DoDot:1

 +26               SET I=$ORDER(^AUTTIMM("C",BGPIMM,0))

                   IF 'I

                       QUIT 

 +27               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

 +28       IF R

               QUIT $SELECT(BGPNMI:4,1:3)_U_$SELECT(BGPNMI:"NMI Td",1:"Ref Td")

 +29       FOR BGPIMM=90714,90718

               Begin DoDot:1

 +30               SET I=+$$CODEN^ICPTCOD(BGPIMM)

                   IF 'I

                       QUIT 

 +31               SET X=0

                   FOR 

                       SET X=$ORDER(^AUPNPREF("AA",P,81,I,X))

                       IF X'=+X

                           QUIT 

                       SET Y=0

                       FOR 

                           SET Y=$ORDER(^AUPNPREF("AA",P,81,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 Td",1:"Ref Td")

 +33      ;now check Refusals in imm pkg

 +34      ;F BGPIMM=9,113 S R=$$IMMREF^BGP7D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R

 +35      ;I R Q 3_U_"Ref imm pkg Td"

 +36       QUIT ""