BGP8D86 ; IHS/CMI/LAB - measure C 06 Nov 2009 2:26 PM ;
;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
;
;
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^BGP8D32(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^BGP8D31(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^BGP8D32(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^BGP8D32(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^BGP8D31(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^BGP8D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
;I R Q 3_U_"Ref imm pkg Td"
Q ""
BGP8D86 ; IHS/CMI/LAB - measure C 06 Nov 2009 2:26 PM ;
+1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
+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^BGP8D32(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^BGP8D31(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^BGP8D32(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^BGP8D32(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^BGP8D31(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^BGP8D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
+35 ;I R Q 3_U_"Ref imm pkg Td"
+36 QUIT ""
