BGP1D3A ; IHS/CMI/LAB - measure 11 17 Oct 2009 12:40 PM 15 Apr 2011 8:06 AM ;
;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
;
;
SEALDEV(P,BDATE,EDATE) ;EP
NEW BGPG,BGPX,BGPC,%,X,V,T
S BGPC=0
S %=P_"^ALL ADA 1351;DURING "_$$DATE^BGP1UTL(BDATE)_"-"_$$DATE^BGP1UTL(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q 1_U_$$DATE^BGP1UTL($P(BGPG(1),U,1))_" ADA 1351 "
S %="",E=+$$CODEN^ICPTCOD("D1351"),%=$$CPTI^BGP1DU(P,BDATE,EDATE,E)
I % Q 1_"^"_$$DATE^BGP1UTL($P(%,U,2))_" CPT D1351"
S %=P_"^ALL ADA 1352;DURING "_$$DATE^BGP1UTL(BDATE)_"-"_$$DATE^BGP1UTL(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q 1_U_$$DATE^BGP1UTL($P(BGPG(1),U,1))_" ADA 1352 "
S %="",E=+$$CODEN^ICPTCOD("D1352"),%=$$CPTI^BGP1DU(P,BDATE,EDATE,E)
I % Q 1_"^"_$$DATE^BGP1UTL($P(%,U,2))_" CPT D1352"
S T=$$FMADD^XLFDT(EDATE,-1096)
S %=P_"^ALL ADA 0007;DURING "_$$DATE^BGP1UTL(T)_"-"_$$DATE^BGP1UTL(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q 1_U_$$DATE^BGP1UTL($P(BGPG(1),U,1))_" ADA 0007"
S T=$$FMADD^XLFDT(EDATE,-1096)
S %="",E=+$$CODEN^ICPTCOD("D0007"),%=$$CPTI^BGP1DU(P,T,EDATE,E)
I % Q 1_"^"_$$DATE^BGP1UTL($P(%,U,2))_" CPT D0007"
Q ""
TF(P,BDATE,EDATE) ;EP
NEW T,A,%,X,Y,T,Z,G,BGPZ,BGPJ,R
K BGPG,BGPZ S BGPC=0
K ^TMP($J,"A")
S A="^TMP($J,""A"","
S Z=$O(^ATXAX("B","BGP TOPICAL FLUORIDE ADA CODES",0))
S %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,A)
S X=0,Y=0 F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(BGPC>3) S V=$P(^TMP($J,"A",X),U,5) D
.S Y=0,G=0 F S Y=$O(^AUPNVDEN("AD",V,Y)) Q:Y'=+Y!(G>0)!($P(BGPC,U,1)>3) D
..S A=$P($G(^AUPNVDEN(Y,0)),U) D
...I $D(^ATXAX(Z,21,"B",A)) S T=1 S $P(BGPC,U,1)=$P(BGPC,U,1)+1,G=G+1,$P(BGPC,U,BGPC+1)=$$VD^APCLV($P(^AUPNVDEN(Y,0),U,3))_"|ADA "_$$VAL^XBDIQ1(9000010.05,Y,.01) ;one per visit
...Q
.Q:G
.S Y=0,G=0 F S Y=$O(^AUPNVCPT("AD",V,Y)) Q:Y'=+Y!(G)!(BGPC>3) D
..S A=$P($G(^AUPNVCPT(Y,0)),U)
..Q:'A
..I $$ICD^ATXCHK(A,$O(^ATXAX("B","BGP CPT TOPICAL FLUORIDE",0)),1) S T=1 S $P(BGPC,U,1)=$P(BGPC,U,1)+1,G=G+1,$P(BGPC,U,BGPC+1)=$$VD^APCLV($P(^AUPNVCPT(Y,0),U,3))_"|CPT "_$$VAL^XBDIQ1(9000010.18,Y,.01) ;one per visit
.Q:G ;one per visit
.S Y=0,G=0 F S Y=$O(^AUPNVPOV("AD",V,Y)) Q:Y'=+Y!(G)!(BGPC>3) D
..S A=$P($G(^AUPNVPOV(Y,0)),U) I A S A=$P($$ICDDX^ICDCODE(A),U,2) D
...I A="V07.31" S $P(BGPC,U,1)=$P(BGPC,U,1)+1,G=1,$P(BGPC,U,BGPC+1)=$$VD^APCLV($P(^AUPNVPOV(Y,0),U,3))_"|POV "_$$VAL^XBDIQ1(9000010.07,Y,.01) ;one per visit
...Q
I BGPC Q BGPC
;one refusal per patient
S G=""
S BGPJ="" F S BGPJ=$O(^ATXAX(Z,21,"B",BGPJ)) Q:BGPJ'=+BGPJ!(G) D
.S G=$$REFUSAL^BGP1UTL1(P,9999999.31,BGPJ,BDATE,EDATE)
.I G S R=1_"^"_$P(G,U,2)_"^Refused ADA "_$P(^AUTTADA(BGPJ,0),U,1)
I $P(G,U)=1 Q "1^"_$P(G,U,2)_"^Refused ADA 1201"
S G="",R=""
S Z=$O(^ATXAX("B","BGP CPT TOPICAL FLUORIDE",0))
S G=$$CPTREFT^BGP1UTL1(P,BDATE,EDATE,Z)
I G S R=1_"^"_$P(G,U,2)_"^Refused CPT "_$P(G,U,4)
I $P(G,U)=1 Q R
Q ""
SEAL(P,BDATE,EDATE) ;EP
NEW A,%,X,Y,BGPC,BGPG,BGPX,G,T,S,V,BGPCNT
K BGPG,BGPX
S BGPCNT=0
K ^TMP($J,"A")
S A="^TMP($J,""A"","
S BGPC=0
S %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,A)
S X=0,Y=0 F S X=$O(^TMP($J,"A",X)) Q:X'=+X S V=$P(^TMP($J,"A",X),U,5) D
.S Y=0,G=0 F S Y=$O(^AUPNVDEN("AD",V,Y)) Q:Y'=+Y D
..S A=$P($G(^AUPNVDEN(Y,0)),U) I A S A=$P($G(^AUTTADA(A,0)),U) D
...Q:A'=1351
...S G=1
...S T=$P($G(^AUPNVDEN(Y,0)),U,4) S:T=""!(T=0) T=1
...S S=$P(^AUPNVDEN(Y,0),U,5)
...I S]"" D
....I $G(BGPX(S))<2 D
.....I T=1 S BGPX(S)=$G(BGPX(S))+T
.....I T'=1 S T=$S(T>(2-$G(BGPX(S))):(2-$G(BGPX(S))),1:T),BGPX(S)=$G(BGPX(S))+T ;only first 2 per tooth
.....S BGPCNT=BGPCNT+1 S BGPSEALS(BGPCNT,$$VD^APCLV($P(^AUPNVDEN(Y,0),U,3)))="ADA 1351 ("_T_")"
...I S="" S BGPX("NO OS")=$G(BGPX("NO OS"))+T,BGPCNT=BGPCNT+1,BGPSEALS(BGPCNT,$$VD^APCLV($P(^AUPNVDEN(Y,0),U,3)))="ADA 1351 ("_T_")"
...Q
.Q:G ;had ADA codes so skip cpts
.S Y=0,G=0 F S Y=$O(^AUPNVCPT("AD",V,Y)) Q:Y'=+Y D
..S A=$P($G(^AUPNVCPT(Y,0)),U)
..Q:'A
..S A=$P($$CPT^ICPTCOD(A),U,2) I A="D1351" D
...S T=$P($G(^AUPNVCPT(Y,0)),U,16) S:T=""!(T=0) T=1
...S BGPX("CPT")=$G(BGPX("CPT"))+T,BGPCNT=BGPCNT+1,BGPSEALS(BGPCNT,$$VD^APCLV($P(^AUPNVCPT(Y,0),U,3)))="CPT D1351 ("_T_")"
S X="" F S X=$O(BGPX(X)) Q:X="" I X'="CPT" S BGPC=BGPC+$S(BGPX(X)>2:2,1:BGPX(X))
S BGPC=BGPC+$G(BGPX("CPT"))
I BGPC S BGPSEAL=BGPC Q
SEALREF ;
;now gather up refusals - one per patient
S G=$$REFUSAL^BGP1UTL1(P,9999999.31,$O(^AUTTADA("B","1351",0)),BDATE,EDATE)
I $P(G,U)=1 S BGPSEAL="1^"_$P(G,U,2)_"^Refused ADA 1351" Q
S G=$$REFUSAL^BGP1UTL1(P,81,+$$CODEN^ICPTCOD("D1351"),BDATE,EDATE)
I $P(G,U)=1 S BGPSEAL="1^"_$P(G,U,2)_"^Refused CPT D1351" Q
Q
HIGHR(P,EDATE) ;EP
;must have 2 dx in past 3 years, then check problem list before EDATE
NEW BGPG,Y,X,G,V,BDATE,C,D
S BDATE=$$FMADD^XLFDT(EDATE,-(3*365))
S Y="BGPG(",G="",C=0
S X=P_"^ALL DX [BGP HIGH RISK FLU DXS;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,Y)
I '$D(BGPG(1)) G HRPL
K Y S X=0,G=0 F S X=$O(BGPG(X)) Q:X'=+X!(G) D
.S D=$P(BGPG(X),U,1)
.Q:$D(Y(D)) ;already had one on that day
.S Y(D)=""
.S C=C+1
.I C>1 S G=1
I G Q G
HRPL ;
S G=""
S T=$O(^ATXAX("B","BGP HIGH RISK FLU DXS",0))
S (X,G)=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G) D
.Q:$P(^AUPNPROB(X,0),U,8)>EDATE ;if added to pl after beginning of time period, no go
.S Y=$P(^AUPNPROB(X,0),U)
.Q:$P(^AUPNPROB(X,0),U,12)'="A"
.Q:'$$ICD^ATXCHK(Y,T,9)
.S G=1
.Q
Q G
DTAP(P,BDATE,EDATE) ;EP
K BGPC,BGPG,BGPX,BD,ED,BGPVARI,C,V,X,Y,BGPZ,BGPIMM
;gather up all immunizations, cpts, povs and check for 3 each ten days apart
K BGPVARI
;get all immunizations
S C="115"
D GETIMMS^BGP1D32(P,EDATE,C,.BGPX)
;go through and set into array if 10 days apart
I $O(BGPX(0)) Q 1_U_$$DATE^BGP1UTL($O(BGPVX(0)))
;now get cpts
S ED=9999999-EDATE-1,BD=9999999-BDATE,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_$$DATE^BGP1UTL($O(BGPVARI(0)))
F BGPZ=115 S X=$$ANCONT^BGP1D31(P,BGPZ,EDATE) Q:X]""
I X]"" Q 2_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) D
..Q:$P(^AUPNPREF(Y,0),U,7)'="N"
..S R=1 ;S:$P(^AUPNPREF(Y,0),U,7)="N" BGPNMI=1 S R=1
I R Q 2_U_"NMI Dtap"
Q ""
DTAPTD(P,BDATE,EDATE) ;EP
NEW BDM,X,E,B,%DT,Y,TDD,D,LTD,G,C,Z,TK,BGPC,BGPG,BGPX,BD,ED,BGPVARI,C,V,X,Y,BGPZ,BGPIMM
K TDD
D LASTTDN ;get td from v imm
S LTD=$O(TDD(0))
I LTD]"" S LTD=9999999-LTD Q 1_U_$$DATE^BGP1UTL(LTD)
;now check cpt codes
S ED=9999999-EDATE-1,BD=9999999-BDATE,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!(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=90715!(Y=90714)!(Y=90718) S BGPVARI(9999999-$P(ED,"."))=""
I $D(BGPVARI) Q 1_U_$$DATE^BGP1UTL($O(BGPVARI(0)))
K BGPG S %=P_"^LAST DX V06.5;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q 1_U_$$DATE^BGP1UTL($P(BGPG(1),U))
F BGPZ=115,9,113 S X=$$ANCONT^BGP1D31(P,BGPZ,EDATE) Q:X]""
I X]"" Q 2_U_"contra Tdap/Td"
;now go to refusals
S B=$$DOB^AUPNPAT(P),E=EDATE,BGPNMI="",R=""
F BGPIMM=115,9,113 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) D
..Q:$P(^AUPNPREF(Y,0),U,7)'="N"
..S R=1 ;S:$P(^AUPNPREF(Y,0),U,7)="N" BGPNMI=1 S R=1
I R Q 2_U_"NMI Dtap/Td"
Q ""
;
LASTTDN ;
S X=0 F S X=$O(^AUPNVIMM("AC",P,X)) Q:X'=+X D
.S Y=$P(^AUPNVIMM(X,0),U) Q:'Y
.Q:'$D(^AUTTIMM(Y,0))
.S Y=$P(^AUTTIMM(Y,0),U,3)
.S D=$P(^AUPNVIMM(X,0),U,3) Q:'D
.S D=$P($P($G(^AUPNVSIT(D,0)),U),".")
.I D<BDATE Q ;too early
.I D>EDATE Q ;after time frame
.I Y=9 S TDD(9999999-D)="" Q
.I Y=113 S TDD(9999999-D)="" Q
.I Y=115 S TDD(9999999-D)="" Q
Q
;;
HIGHRP(P,EDATE) ;EP
;must have 2 dx in past 3 years, then check problem list before EDATE
NEW BGPG,Y,X,G,V,BDATE,C,D
S BDATE=$$FMADD^XLFDT(EDATE,-(3*365))
S Y="BGPG(",G="",C=0
S X=P_"^ALL DX [BGP HIGH RISK PNEUMO DXS;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,Y)
I '$D(BGPG(1)) G HRPL
K Y S X=0,G=0 F S X=$O(BGPG(X)) Q:X'=+X!(G) D
.S D=$P(BGPG(X),U,1)
.Q:$D(Y(D)) ;already had one on that day
.S Y(D)=""
.S C=C+1
.I C>1 S G=1
I G Q G
HRPLP ;
S G=""
S T=$O(^ATXAX("B","BGP HIGH RISK PNEUMO DXS",0))
S (X,G)=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G) D
.Q:$P(^AUPNPROB(X,0),U,8)>EDATE ;if added to pl after beginning of time period, no go
.S Y=$P(^AUPNPROB(X,0),U)
.Q:$P(^AUPNPROB(X,0),U,12)'="A"
.Q:'$$ICD^ATXCHK(Y,T,9)
.S G=1
.Q
Q G
BGP1D3A ; IHS/CMI/LAB - measure 11 17 Oct 2009 12:40 PM 15 Apr 2011 8:06 AM ;
+1 ;;11.1;IHS CLINICAL REPORTING SYSTEM;;JUN 27, 2011;Build 33
+2 ;
+3 ;
SEALDEV(P,BDATE,EDATE) ;EP
+1 NEW BGPG,BGPX,BGPC,%,X,V,T
+2 SET BGPC=0
+3 SET %=P_"^ALL ADA 1351;DURING "_$$DATE^BGP1UTL(BDATE)_"-"_$$DATE^BGP1UTL(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+4 IF $DATA(BGPG(1))
QUIT 1_U_$$DATE^BGP1UTL($PIECE(BGPG(1),U,1))_" ADA 1351 "
+5 SET %=""
SET E=+$$CODEN^ICPTCOD("D1351")
SET %=$$CPTI^BGP1DU(P,BDATE,EDATE,E)
+6 IF %
QUIT 1_"^"_$$DATE^BGP1UTL($PIECE(%,U,2))_" CPT D1351"
+7 SET %=P_"^ALL ADA 1352;DURING "_$$DATE^BGP1UTL(BDATE)_"-"_$$DATE^BGP1UTL(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+8 IF $DATA(BGPG(1))
QUIT 1_U_$$DATE^BGP1UTL($PIECE(BGPG(1),U,1))_" ADA 1352 "
+9 SET %=""
SET E=+$$CODEN^ICPTCOD("D1352")
SET %=$$CPTI^BGP1DU(P,BDATE,EDATE,E)
+10 IF %
QUIT 1_"^"_$$DATE^BGP1UTL($PIECE(%,U,2))_" CPT D1352"
+11 SET T=$$FMADD^XLFDT(EDATE,-1096)
+12 SET %=P_"^ALL ADA 0007;DURING "_$$DATE^BGP1UTL(T)_"-"_$$DATE^BGP1UTL(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+13 IF $DATA(BGPG(1))
QUIT 1_U_$$DATE^BGP1UTL($PIECE(BGPG(1),U,1))_" ADA 0007"
+14 SET T=$$FMADD^XLFDT(EDATE,-1096)
+15 SET %=""
SET E=+$$CODEN^ICPTCOD("D0007")
SET %=$$CPTI^BGP1DU(P,T,EDATE,E)
+16 IF %
QUIT 1_"^"_$$DATE^BGP1UTL($PIECE(%,U,2))_" CPT D0007"
+17 QUIT ""
TF(P,BDATE,EDATE) ;EP
+1 NEW T,A,%,X,Y,T,Z,G,BGPZ,BGPJ,R
+2 KILL BGPG,BGPZ
SET BGPC=0
+3 KILL ^TMP($JOB,"A")
+4 SET A="^TMP($J,""A"","
+5 SET Z=$ORDER(^ATXAX("B","BGP TOPICAL FLUORIDE ADA CODES",0))
+6 SET %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,A)
+7 SET X=0
SET Y=0
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X!(BGPC>3)
QUIT
SET V=$PIECE(^TMP($JOB,"A",X),U,5)
Begin DoDot:1
+8 SET Y=0
SET G=0
FOR
SET Y=$ORDER(^AUPNVDEN("AD",V,Y))
IF Y'=+Y!(G>0)!($PIECE(BGPC,U,1)>3)
QUIT
Begin DoDot:2
+9 SET A=$PIECE($GET(^AUPNVDEN(Y,0)),U)
Begin DoDot:3
+10 ;one per visit
IF $DATA(^ATXAX(Z,21,"B",A))
SET T=1
SET $PIECE(BGPC,U,1)=$PIECE(BGPC,U,1)+1
SET G=G+1
SET $PIECE(BGPC,U,BGPC+1)=$$VD^APCLV($PIECE(^AUPNVDEN(Y,0),U,3))_"|ADA "_$$VAL^XBDIQ1(9000010.05,Y,.01)
+11 QUIT
End DoDot:3
End DoDot:2
+12 IF G
QUIT
+13 SET Y=0
SET G=0
FOR
SET Y=$ORDER(^AUPNVCPT("AD",V,Y))
IF Y'=+Y!(G)!(BGPC>3)
QUIT
Begin DoDot:2
+14 SET A=$PIECE($GET(^AUPNVCPT(Y,0)),U)
+15 IF 'A
QUIT
+16 ;one per visit
IF $$ICD^ATXCHK(A,$ORDER(^ATXAX("B","BGP CPT TOPICAL FLUORIDE",0)),1)
SET T=1
SET $PIECE(BGPC,U,1)=$PIECE(BGPC,U,1)+1
SET G=G+1
SET $PIECE(BGPC,U,BGPC+1)=$$VD^APCLV($PIECE(^AUPNVCPT(Y,0),U,3))_"|CPT "_$$VAL^XBDIQ1(9000010.18,Y,.01)
End DoDot:2
+17 ;one per visit
IF G
QUIT
+18 SET Y=0
SET G=0
FOR
SET Y=$ORDER(^AUPNVPOV("AD",V,Y))
IF Y'=+Y!(G)!(BGPC>3)
QUIT
Begin DoDot:2
+19 SET A=$PIECE($GET(^AUPNVPOV(Y,0)),U)
IF A
SET A=$PIECE($$ICDDX^ICDCODE(A),U,2)
Begin DoDot:3
+20 ;one per visit
IF A="V07.31"
SET $PIECE(BGPC,U,1)=$PIECE(BGPC,U,1)+1
SET G=1
SET $PIECE(BGPC,U,BGPC+1)=$$VD^APCLV($PIECE(^AUPNVPOV(Y,0),U,3))_"|POV "_$$VAL^XBDIQ1(9000010.07,Y,.01)
+21 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+22 IF BGPC
QUIT BGPC
+23 ;one refusal per patient
+24 SET G=""
+25 SET BGPJ=""
FOR
SET BGPJ=$ORDER(^ATXAX(Z,21,"B",BGPJ))
IF BGPJ'=+BGPJ!(G)
QUIT
Begin DoDot:1
+26 SET G=$$REFUSAL^BGP1UTL1(P,9999999.31,BGPJ,BDATE,EDATE)
+27 IF G
SET R=1_"^"_$PIECE(G,U,2)_"^Refused ADA "_$PIECE(^AUTTADA(BGPJ,0),U,1)
End DoDot:1
+28 IF $PIECE(G,U)=1
QUIT "1^"_$PIECE(G,U,2)_"^Refused ADA 1201"
+29 SET G=""
SET R=""
+30 SET Z=$ORDER(^ATXAX("B","BGP CPT TOPICAL FLUORIDE",0))
+31 SET G=$$CPTREFT^BGP1UTL1(P,BDATE,EDATE,Z)
+32 IF G
SET R=1_"^"_$PIECE(G,U,2)_"^Refused CPT "_$PIECE(G,U,4)
+33 IF $PIECE(G,U)=1
QUIT R
+34 QUIT ""
SEAL(P,BDATE,EDATE) ;EP
+1 NEW A,%,X,Y,BGPC,BGPG,BGPX,G,T,S,V,BGPCNT
+2 KILL BGPG,BGPX
+3 SET BGPCNT=0
+4 KILL ^TMP($JOB,"A")
+5 SET A="^TMP($J,""A"","
+6 SET BGPC=0
+7 SET %=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(%,A)
+8 SET X=0
SET Y=0
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X
QUIT
SET V=$PIECE(^TMP($JOB,"A",X),U,5)
Begin DoDot:1
+9 SET Y=0
SET G=0
FOR
SET Y=$ORDER(^AUPNVDEN("AD",V,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+10 SET A=$PIECE($GET(^AUPNVDEN(Y,0)),U)
IF A
SET A=$PIECE($GET(^AUTTADA(A,0)),U)
Begin DoDot:3
+11 IF A'=1351
QUIT
+12 SET G=1
+13 SET T=$PIECE($GET(^AUPNVDEN(Y,0)),U,4)
IF T=""!(T=0)
SET T=1
+14 SET S=$PIECE(^AUPNVDEN(Y,0),U,5)
+15 IF S]""
Begin DoDot:4
+16 IF $GET(BGPX(S))<2
Begin DoDot:5
+17 IF T=1
SET BGPX(S)=$GET(BGPX(S))+T
+18 ;only first 2 per tooth
IF T'=1
SET T=$SELECT(T>(2-$GET(BGPX(S))):(2-$GET(BGPX(S))),1:T)
SET BGPX(S)=$GET(BGPX(S))+T
+19 SET BGPCNT=BGPCNT+1
SET BGPSEALS(BGPCNT,$$VD^APCLV($PIECE(^AUPNVDEN(Y,0),U,3)))="ADA 1351 ("_T_")"
End DoDot:5
End DoDot:4
+20 IF S=""
SET BGPX("NO OS")=$GET(BGPX("NO OS"))+T
SET BGPCNT=BGPCNT+1
SET BGPSEALS(BGPCNT,$$VD^APCLV($PIECE(^AUPNVDEN(Y,0),U,3)))="ADA 1351 ("_T_")"
+21 QUIT
End DoDot:3
End DoDot:2
+22 ;had ADA codes so skip cpts
IF G
QUIT
+23 SET Y=0
SET G=0
FOR
SET Y=$ORDER(^AUPNVCPT("AD",V,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+24 SET A=$PIECE($GET(^AUPNVCPT(Y,0)),U)
+25 IF 'A
QUIT
+26 SET A=$PIECE($$CPT^ICPTCOD(A),U,2)
IF A="D1351"
Begin DoDot:3
+27 SET T=$PIECE($GET(^AUPNVCPT(Y,0)),U,16)
IF T=""!(T=0)
SET T=1
+28 SET BGPX("CPT")=$GET(BGPX("CPT"))+T
SET BGPCNT=BGPCNT+1
SET BGPSEALS(BGPCNT,$$VD^APCLV($PIECE(^AUPNVCPT(Y,0),U,3)))="CPT D1351 ("_T_")"
End DoDot:3
End DoDot:2
End DoDot:1
+29 SET X=""
FOR
SET X=$ORDER(BGPX(X))
IF X=""
QUIT
IF X'="CPT"
SET BGPC=BGPC+$SELECT(BGPX(X)>2:2,1:BGPX(X))
+30 SET BGPC=BGPC+$GET(BGPX("CPT"))
+31 IF BGPC
SET BGPSEAL=BGPC
QUIT
SEALREF ;
+1 ;now gather up refusals - one per patient
+2 SET G=$$REFUSAL^BGP1UTL1(P,9999999.31,$ORDER(^AUTTADA("B","1351",0)),BDATE,EDATE)
+3 IF $PIECE(G,U)=1
SET BGPSEAL="1^"_$PIECE(G,U,2)_"^Refused ADA 1351"
QUIT
+4 SET G=$$REFUSAL^BGP1UTL1(P,81,+$$CODEN^ICPTCOD("D1351"),BDATE,EDATE)
+5 IF $PIECE(G,U)=1
SET BGPSEAL="1^"_$PIECE(G,U,2)_"^Refused CPT D1351"
QUIT
+6 QUIT
HIGHR(P,EDATE) ;EP
+1 ;must have 2 dx in past 3 years, then check problem list before EDATE
+2 NEW BGPG,Y,X,G,V,BDATE,C,D
+3 SET BDATE=$$FMADD^XLFDT(EDATE,-(3*365))
+4 SET Y="BGPG("
SET G=""
SET C=0
+5 SET X=P_"^ALL DX [BGP HIGH RISK FLU DXS;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,Y)
+6 IF '$DATA(BGPG(1))
GOTO HRPL
+7 KILL Y
SET X=0
SET G=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+8 SET D=$PIECE(BGPG(X),U,1)
+9 ;already had one on that day
IF $DATA(Y(D))
QUIT
+10 SET Y(D)=""
+11 SET C=C+1
+12 IF C>1
SET G=1
End DoDot:1
+13 IF G
QUIT G
HRPL ;
+1 SET G=""
+2 SET T=$ORDER(^ATXAX("B","BGP HIGH RISK FLU DXS",0))
+3 SET (X,G)=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+4 ;if added to pl after beginning of time period, no go
IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+5 SET Y=$PIECE(^AUPNPROB(X,0),U)
+6 IF $PIECE(^AUPNPROB(X,0),U,12)'="A"
QUIT
+7 IF '$$ICD^ATXCHK(Y,T,9)
QUIT
+8 SET G=1
+9 QUIT
End DoDot:1
+10 QUIT G
DTAP(P,BDATE,EDATE) ;EP
+1 KILL BGPC,BGPG,BGPX,BD,ED,BGPVARI,C,V,X,Y,BGPZ,BGPIMM
+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^BGP1D32(P,EDATE,C,.BGPX)
+7 ;go through and set into array if 10 days apart
+8 IF $ORDER(BGPX(0))
QUIT 1_U_$$DATE^BGP1UTL($ORDER(BGPVX(0)))
+9 ;now get cpts
+10 SET ED=9999999-EDATE-1
SET BD=9999999-BDATE
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_$$DATE^BGP1UTL($ORDER(BGPVARI(0)))
+19 FOR BGPZ=115
SET X=$$ANCONT^BGP1D31(P,BGPZ,EDATE)
IF X]""
QUIT
+20 IF X]""
QUIT 2_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)
Begin DoDot:2
+26 IF $PIECE(^AUPNPREF(Y,0),U,7)'="N"
QUIT
+27 ;S:$P(^AUPNPREF(Y,0),U,7)="N" BGPNMI=1 S R=1
SET R=1
End DoDot:2
End DoDot:1
+28 IF R
QUIT 2_U_"NMI Dtap"
+29 QUIT ""
DTAPTD(P,BDATE,EDATE) ;EP
+1 NEW BDM,X,E,B,%DT,Y,TDD,D,LTD,G,C,Z,TK,BGPC,BGPG,BGPX,BD,ED,BGPVARI,C,V,X,Y,BGPZ,BGPIMM
+2 KILL TDD
+3 ;get td from v imm
DO LASTTDN
+4 SET LTD=$ORDER(TDD(0))
+5 IF LTD]""
SET LTD=9999999-LTD
QUIT 1_U_$$DATE^BGP1UTL(LTD)
+6 ;now check cpt codes
+7 SET ED=9999999-EDATE-1
SET BD=9999999-BDATE
SET G=0
+8 FOR
SET ED=$ORDER(^AUPNVSIT("AA",P,ED))
IF ED=""!($PIECE(ED,".")>BD)
QUIT
Begin DoDot:1
+9 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))
IF V'=+V
QUIT
Begin DoDot:2
+10 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+11 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+12 SET Y=$PIECE(^AUPNVCPT(X,0),U)
SET Y=$PIECE($$CPT^ICPTCOD(Y),U,2)
IF Y=90715!(Y=90714)!(Y=90718)
SET BGPVARI(9999999-$PIECE(ED,"."))=""
End DoDot:3
+13 SET X=0
FOR
SET X=$ORDER(^AUPNVTC("AD",V,X))
IF X'=+X
QUIT
Begin DoDot:3
+14 SET Y=$PIECE(^AUPNVTC(X,0),U,7)
IF 'Y
QUIT
SET Y=$PIECE($$CPT^ICPTCOD(Y),U,2)
IF Y=90715!(Y=90714)!(Y=90718)
SET BGPVARI(9999999-$PIECE(ED,"."))=""
End DoDot:3
End DoDot:2
End DoDot:1
+15 IF $DATA(BGPVARI)
QUIT 1_U_$$DATE^BGP1UTL($ORDER(BGPVARI(0)))
+16 KILL BGPG
SET %=P_"^LAST DX V06.5;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BGPG(")
+17 IF $DATA(BGPG(1))
QUIT 1_U_$$DATE^BGP1UTL($PIECE(BGPG(1),U))
+18 FOR BGPZ=115,9,113
SET X=$$ANCONT^BGP1D31(P,BGPZ,EDATE)
IF X]""
QUIT
+19 IF X]""
QUIT 2_U_"contra Tdap/Td"
+20 ;now go to refusals
+21 SET B=$$DOB^AUPNPAT(P)
SET E=EDATE
SET BGPNMI=""
SET R=""
+22 FOR BGPIMM=115,9,113
Begin DoDot:1
+23 SET I=$ORDER(^AUTTIMM("C",BGPIMM,0))
IF 'I
QUIT
+24 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)
Begin DoDot:2
+25 IF $PIECE(^AUPNPREF(Y,0),U,7)'="N"
QUIT
+26 ;S:$P(^AUPNPREF(Y,0),U,7)="N" BGPNMI=1 S R=1
SET R=1
End DoDot:2
End DoDot:1
+27 IF R
QUIT 2_U_"NMI Dtap/Td"
+28 QUIT ""
+29 ;
LASTTDN ;
+1 SET X=0
FOR
SET X=$ORDER(^AUPNVIMM("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+2 SET Y=$PIECE(^AUPNVIMM(X,0),U)
IF 'Y
QUIT
+3 IF '$DATA(^AUTTIMM(Y,0))
QUIT
+4 SET Y=$PIECE(^AUTTIMM(Y,0),U,3)
+5 SET D=$PIECE(^AUPNVIMM(X,0),U,3)
IF 'D
QUIT
+6 SET D=$PIECE($PIECE($GET(^AUPNVSIT(D,0)),U),".")
+7 ;too early
IF D<BDATE
QUIT
+8 ;after time frame
IF D>EDATE
QUIT
+9 IF Y=9
SET TDD(9999999-D)=""
QUIT
+10 IF Y=113
SET TDD(9999999-D)=""
QUIT
+11 IF Y=115
SET TDD(9999999-D)=""
QUIT
End DoDot:1
+12 QUIT
+13 ;;
HIGHRP(P,EDATE) ;EP
+1 ;must have 2 dx in past 3 years, then check problem list before EDATE
+2 NEW BGPG,Y,X,G,V,BDATE,C,D
+3 SET BDATE=$$FMADD^XLFDT(EDATE,-(3*365))
+4 SET Y="BGPG("
SET G=""
SET C=0
+5 SET X=P_"^ALL DX [BGP HIGH RISK PNEUMO DXS;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,Y)
+6 IF '$DATA(BGPG(1))
GOTO HRPL
+7 KILL Y
SET X=0
SET G=0
FOR
SET X=$ORDER(BGPG(X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+8 SET D=$PIECE(BGPG(X),U,1)
+9 ;already had one on that day
IF $DATA(Y(D))
QUIT
+10 SET Y(D)=""
+11 SET C=C+1
+12 IF C>1
SET G=1
End DoDot:1
+13 IF G
QUIT G
HRPLP ;
+1 SET G=""
+2 SET T=$ORDER(^ATXAX("B","BGP HIGH RISK PNEUMO DXS",0))
+3 SET (X,G)=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+4 ;if added to pl after beginning of time period, no go
IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+5 SET Y=$PIECE(^AUPNPROB(X,0),U)
+6 IF $PIECE(^AUPNPROB(X,0),U,12)'="A"
QUIT
+7 IF '$$ICD^ATXCHK(Y,T,9)
QUIT
+8 SET G=1
+9 QUIT
End DoDot:1
+10 QUIT G
