BUDCRP6H ; IHS/CMI/LAB - UDS REPORT PROCESSOR 01 Dec 2015 3:10 PM 30 Dec 2015 7:19 PM ;
;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
;
;
N ;EP - DENTAL SEALANT
;must Be 6-9 yrs old
S BUDX9YRB=($E(BUDBD,1,3)-9)_"0101"
S BUDX6YRE=($E(BUDED,1,3)-6)_"1231"
S BUDDOB=$P(^DPT(DFN,0),U,3)
Q:BUDDOB<BUDX9YRB
Q:BUDDOB>BUDX6YRE
Q:'$$ORALASS(DFN,BUDBD,BUDED) ;had to have at least one oral assessment/exam
;
Q:$$NOSEAL(DFN,BUDED) ;prob list or POV OF NO TEETH
I '$$MHRISK(DFN,BUDBD,BUDED) Q ;not high or moderate risk
S BUDSECTN("PTS")=$G(BUDSECTN("PTS"))+1
S BUDCTA=$$SEAL(DFN,BUDBD,BUDED) ;did they have a sealant in the report period?
I BUDCTA]"" D Q
.S BUDSECTN("SEAL")=$G(BUDSECTN("SEAL"))+1 D Q
..I $G(BUDDS1L) D
...S ^XTMP("BUDCRP6B",BUDJ,BUDH,"DS1",BUDAGE,$P(^DPT(DFN,0),U),BUDCOM,DFN)=$P(BUDCTA,U,2)
..Q
I $G(BUDDS2L) D
.S ^XTMP("BUDCRP6B",BUDJ,BUDH,"DS2",BUDAGE,$P(^DPT(DFN,0),U),BUDCOM,DFN)=""
Q
ORALASS(P,BDATE,EDATE) ;
NEW BUDG,X,Y,Z,E,G
S Y=$$CPT^BUDCDU(P,BDATE,EDATE,$O(^ATXAX("B","BUD ORAL EXAM CPTS",0)),5)
I Y Q 1
;now check ada
S G=""
K BUDG S %=P_"^ALL ADA;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
S X=0 F S X=$O(BUDG(X)) Q:X'=+X!(G) D
.S Y=$P(BUDG(X),U,2)
.I Y="0191" S G=1 Q
.I Y="0120" S G=1 Q
.I Y="0145" S G=1 Q
.I Y="0150" S G=1 Q
.I Y="0180" S G=1 Q
Q G
MHRISK(P,BDATE,EDATE) ;
NEW BUDG,X,Y,Z,E,G
S Y=$$CPTI^BUDCDU(P,BDATE,EDATE,$P($$CPT^ICPTCOD("D0602"),U,1))
I Y Q 1
S Y=$$CPTI^BUDCDU(P,BDATE,EDATE,$P($$CPT^ICPTCOD("D0603"),U,1))
I Y Q 1
;now check ada
S G=""
K BUDG S %=P_"^ALL ADA;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
S X=0 F S X=$O(BUDG(X)) Q:X'=+X!(G) D
.S Y=$P(BUDG(X),U,2)
.I Y="0602" S G=1 Q
.I Y="0603" S G=1 Q
Q G
NOSEAL(P,EDATE) ;
;V10.0 ICD10
NEW BUDG,%,E,T,X,G,Y
K BUDG S %=P_"^ALL DX;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
S T=$O(^BUDCTSSC("B","NOSEAL DIAGNOSES",0))
S X=0,G="" F S X=$O(BUDG(X)) Q:X'=+X!(G]"") D
.S Y=+$P(BUDG(X),U,4)
.S Y=$P($G(^AUPNVPOV(Y,0)),U,1)
.I $D(^BUDCTSSC("AD",Y,T)) S G=1
I G]"" Q G
S X=$$PLCL^BUDCDU(P,"NOSEAL DIAGNOSES") I X Q 1
Q G
SEAL(P,BDATE,EDATE) ;
;get all ada from v dental
;get all cpts from v cpt
NEW BGPG,%,E,G,D,A,T
S G=""
S %=P_"^ALL ADA;DURING "_$$DATE^BGP6UTL(BDATE)_"-"_$$DATE^BGP6UTL(EDATE),E=$$START1^APCLDF(%,"BGPG(")
S E=0 F S E=$O(BGPG(E)) Q:E'=+E!(G) D
.S D=+$P(BGPG(E),U,4)
.S A=$$VAL^XBDIQ1(9000010.05,D,.01)
.S T=$$VALI^XBDIQ1(9000010.05,D,.05)
.Q:'T
.S T=$P($G(^ADEOPS(T,88)),U,1)
.I A'=1350,A'=1351,A'=1352 Q
.I T'=3,T'=14,T'=19,T'=30 Q ;not first molar
.S G=1_U_"ADA "_A_" on "_$$FMTE^XLFDT($P(BGPG(E),U))
I G Q G
;cpts
S Y=$$CPTI^BUDCDU(P,BDATE,EDATE,$P($$CPT^ICPTCOD("D1350"),U,1))
I Y Q 1_U_"CPT D1350 on "_$$FMTE^XLFDT($P(Y,U,2))
S Y=$$CPTI^BUDCDU(P,BDATE,EDATE,$P($$CPT^ICPTCOD("D1351"),U,1))
I Y Q 1_U_"CPT D1351 on "_$$FMTE^XLFDT($P(Y,U,2))
S Y=$$CPTI^BUDCDU(P,BDATE,EDATE,$P($$CPT^ICPTCOD("D1352"),U,1))
I Y Q 1_U_"CPT D1352 on "_$$FMTE^XLFDT($P(Y,U,2))
;
Q ""
BUDCRP6H ; IHS/CMI/LAB - UDS REPORT PROCESSOR 01 Dec 2015 3:10 PM 30 Dec 2015 7:19 PM ;
+1 ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
+2 ;
+3 ;
N ;EP - DENTAL SEALANT
+1 ;must Be 6-9 yrs old
+2 SET BUDX9YRB=($EXTRACT(BUDBD,1,3)-9)_"0101"
+3 SET BUDX6YRE=($EXTRACT(BUDED,1,3)-6)_"1231"
+4 SET BUDDOB=$PIECE(^DPT(DFN,0),U,3)
+5 IF BUDDOB<BUDX9YRB
QUIT
+6 IF BUDDOB>BUDX6YRE
QUIT
+7 ;had to have at least one oral assessment/exam
IF '$$ORALASS(DFN,BUDBD,BUDED)
QUIT
+8 ;
+9 ;prob list or POV OF NO TEETH
IF $$NOSEAL(DFN,BUDED)
QUIT
+10 ;not high or moderate risk
IF '$$MHRISK(DFN,BUDBD,BUDED)
QUIT
+11 SET BUDSECTN("PTS")=$GET(BUDSECTN("PTS"))+1
+12 ;did they have a sealant in the report period?
SET BUDCTA=$$SEAL(DFN,BUDBD,BUDED)
+13 IF BUDCTA]""
Begin DoDot:1
+14 SET BUDSECTN("SEAL")=$GET(BUDSECTN("SEAL"))+1
Begin DoDot:2
+15 IF $GET(BUDDS1L)
Begin DoDot:3
+16 SET ^XTMP("BUDCRP6B",BUDJ,BUDH,"DS1",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCOM,DFN)=$PIECE(BUDCTA,U,2)
End DoDot:3
+17 QUIT
End DoDot:2
QUIT
End DoDot:1
QUIT
+18 IF $GET(BUDDS2L)
Begin DoDot:1
+19 SET ^XTMP("BUDCRP6B",BUDJ,BUDH,"DS2",BUDAGE,$PIECE(^DPT(DFN,0),U),BUDCOM,DFN)=""
End DoDot:1
+20 QUIT
ORALASS(P,BDATE,EDATE) ;
+1 NEW BUDG,X,Y,Z,E,G
+2 SET Y=$$CPT^BUDCDU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BUD ORAL EXAM CPTS",0)),5)
+3 IF Y
QUIT 1
+4 ;now check ada
+5 SET G=""
+6 KILL BUDG
SET %=P_"^ALL ADA;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+7 SET X=0
FOR
SET X=$ORDER(BUDG(X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+8 SET Y=$PIECE(BUDG(X),U,2)
+9 IF Y="0191"
SET G=1
QUIT
+10 IF Y="0120"
SET G=1
QUIT
+11 IF Y="0145"
SET G=1
QUIT
+12 IF Y="0150"
SET G=1
QUIT
+13 IF Y="0180"
SET G=1
QUIT
End DoDot:1
+14 QUIT G
MHRISK(P,BDATE,EDATE) ;
+1 NEW BUDG,X,Y,Z,E,G
+2 SET Y=$$CPTI^BUDCDU(P,BDATE,EDATE,$PIECE($$CPT^ICPTCOD("D0602"),U,1))
+3 IF Y
QUIT 1
+4 SET Y=$$CPTI^BUDCDU(P,BDATE,EDATE,$PIECE($$CPT^ICPTCOD("D0603"),U,1))
+5 IF Y
QUIT 1
+6 ;now check ada
+7 SET G=""
+8 KILL BUDG
SET %=P_"^ALL ADA;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+9 SET X=0
FOR
SET X=$ORDER(BUDG(X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+10 SET Y=$PIECE(BUDG(X),U,2)
+11 IF Y="0602"
SET G=1
QUIT
+12 IF Y="0603"
SET G=1
QUIT
End DoDot:1
+13 QUIT G
NOSEAL(P,EDATE) ;
+1 ;V10.0 ICD10
+2 NEW BUDG,%,E,T,X,G,Y
+3 KILL BUDG
SET %=P_"^ALL DX;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+4 SET T=$ORDER(^BUDCTSSC("B","NOSEAL DIAGNOSES",0))
+5 SET X=0
SET G=""
FOR
SET X=$ORDER(BUDG(X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:1
+6 SET Y=+$PIECE(BUDG(X),U,4)
+7 SET Y=$PIECE($GET(^AUPNVPOV(Y,0)),U,1)
+8 IF $DATA(^BUDCTSSC("AD",Y,T))
SET G=1
End DoDot:1
+9 IF G]""
QUIT G
+10 SET X=$$PLCL^BUDCDU(P,"NOSEAL DIAGNOSES")
IF X
QUIT 1
+11 QUIT G
SEAL(P,BDATE,EDATE) ;
+1 ;get all ada from v dental
+2 ;get all cpts from v cpt
+3 NEW BGPG,%,E,G,D,A,T
+4 SET G=""
+5 SET %=P_"^ALL ADA;DURING "_$$DATE^BGP6UTL(BDATE)_"-"_$$DATE^BGP6UTL(EDATE)
SET E=$$START1^APCLDF(%,"BGPG(")
+6 SET E=0
FOR
SET E=$ORDER(BGPG(E))
IF E'=+E!(G)
QUIT
Begin DoDot:1
+7 SET D=+$PIECE(BGPG(E),U,4)
+8 SET A=$$VAL^XBDIQ1(9000010.05,D,.01)
+9 SET T=$$VALI^XBDIQ1(9000010.05,D,.05)
+10 IF 'T
QUIT
+11 SET T=$PIECE($GET(^ADEOPS(T,88)),U,1)
+12 IF A'=1350
IF A'=1351
IF A'=1352
QUIT
+13 ;not first molar
IF T'=3
IF T'=14
IF T'=19
IF T'=30
QUIT
+14 SET G=1_U_"ADA "_A_" on "_$$FMTE^XLFDT($PIECE(BGPG(E),U))
End DoDot:1
+15 IF G
QUIT G
+16 ;cpts
+17 SET Y=$$CPTI^BUDCDU(P,BDATE,EDATE,$PIECE($$CPT^ICPTCOD("D1350"),U,1))
+18 IF Y
QUIT 1_U_"CPT D1350 on "_$$FMTE^XLFDT($PIECE(Y,U,2))
+19 SET Y=$$CPTI^BUDCDU(P,BDATE,EDATE,$PIECE($$CPT^ICPTCOD("D1351"),U,1))
+20 IF Y
QUIT 1_U_"CPT D1351 on "_$$FMTE^XLFDT($PIECE(Y,U,2))
+21 SET Y=$$CPTI^BUDCDU(P,BDATE,EDATE,$PIECE($$CPT^ICPTCOD("D1352"),U,1))
+22 IF Y
QUIT 1_U_"CPT D1352 on "_$$FMTE^XLFDT($PIECE(Y,U,2))
+23 ;
+24 QUIT ""
