- 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
