BGP0D3A ; IHS/CMI/LAB - measure 11 17 Oct 2008 12:40 PM ;
;;10.0;IHS CLINICAL REPORTING;**1**;JUN 18, 2010
;
;
SEALDEV(P,BDATE,EDATE) ;EP
NEW BGPG,BGPX,BGPC,%,X,V,T
S BGPC=0
S %=P_"^ALL ADA 1351;DURING "_$$DATE^BGP0UTL(BDATE)_"-"_$$DATE^BGP0UTL(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q 1_U_"ADA 1351 "_$$DATE^BGP0UTL($P(BGPG(1),U,1))
S %="",E=+$$CODEN^ICPTCOD("D1351"),%=$$CPTI^BGP0DU(P,BDATE,EDATE,E)
I % Q 1_"^CPT D1351 "_$$DATE^BGP0UTL($P(%,U,2))
S T=$$FMADD^XLFDT(EDATE,-1096)
S %=P_"^ALL ADA 0007;DURING "_$$DATE^BGP0UTL(T)_"-"_$$DATE^BGP0UTL(EDATE),E=$$START1^APCLDF(%,"BGPG(")
I $D(BGPG(1)) Q 1_U_"ADA 0007 "_$$DATE^BGP0UTL($P(BGPG(1),U,1))
S T=$$FMADD^XLFDT(EDATE,-1096)
S %="",E=+$$CODEN^ICPTCOD("D0007"),%=$$CPTI^BGP0DU(P,T,EDATE,E)
I % Q 1_"^CPT D0007 "_$$DATE^BGP0UTL($P(%,U,2))
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^BGP0UTL1(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^BGP0UTL1(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^BGP0UTL1(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^BGP0UTL1(P,81,+$$CODEN^ICPTCOD("D1351"),BDATE,EDATE)
I $P(G,U)=1 S BGPSEAL="1^"_$P(G,U,2)_"^Refused CPT D1351" Q
Q
BGP0D3A ; IHS/CMI/LAB - measure 11 17 Oct 2008 12:40 PM ;
+1 ;;10.0;IHS CLINICAL REPORTING;**1**;JUN 18, 2010
+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^BGP0UTL(BDATE)_"-"_$$DATE^BGP0UTL(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+4 IF $DATA(BGPG(1))
QUIT 1_U_"ADA 1351 "_$$DATE^BGP0UTL($PIECE(BGPG(1),U,1))
+5 SET %=""
SET E=+$$CODEN^ICPTCOD("D1351")
SET %=$$CPTI^BGP0DU(P,BDATE,EDATE,E)
+6 IF %
QUIT 1_"^CPT D1351 "_$$DATE^BGP0UTL($PIECE(%,U,2))
+7 SET T=$$FMADD^XLFDT(EDATE,-1096)
+8 SET %=P_"^ALL ADA 0007;DURING "_$$DATE^BGP0UTL(T)_"-"_$$DATE^BGP0UTL(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+9 IF $DATA(BGPG(1))
QUIT 1_U_"ADA 0007 "_$$DATE^BGP0UTL($PIECE(BGPG(1),U,1))
+10 SET T=$$FMADD^XLFDT(EDATE,-1096)
+11 SET %=""
SET E=+$$CODEN^ICPTCOD("D0007")
SET %=$$CPTI^BGP0DU(P,T,EDATE,E)
+12 IF %
QUIT 1_"^CPT D0007 "_$$DATE^BGP0UTL($PIECE(%,U,2))
+13 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^BGP0UTL1(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^BGP0UTL1(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^BGP0UTL1(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^BGP0UTL1(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
