Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BUDCRP6H

BUDCRP6H.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1.  ;
  1. N ;EP - DENTAL SEALANT
  1.  ;must Be 6-9 yrs old
  1.  S BUDX9YRB=($E(BUDBD,1,3)-9)_"0101"
  1.  S BUDX6YRE=($E(BUDED,1,3)-6)_"1231"
  1.  S BUDDOB=$P(^DPT(DFN,0),U,3)
  1.  Q:BUDDOB<BUDX9YRB
  1.  Q:BUDDOB>BUDX6YRE
  1.  Q:'$$ORALASS(DFN,BUDBD,BUDED)  ;had to have at least one oral assessment/exam
  1.  ;
  1.  Q:$$NOSEAL(DFN,BUDED)  ;prob list or POV OF NO TEETH
  1.  I '$$MHRISK(DFN,BUDBD,BUDED) Q  ;not high or moderate risk
  1.  S BUDSECTN("PTS")=$G(BUDSECTN("PTS"))+1
  1.  S BUDCTA=$$SEAL(DFN,BUDBD,BUDED)  ;did they have a sealant in the report period?
  1.  I BUDCTA]"" D  Q
  1.  .S BUDSECTN("SEAL")=$G(BUDSECTN("SEAL"))+1 D  Q
  1.  ..I $G(BUDDS1L) D
  1.  ...S ^XTMP("BUDCRP6B",BUDJ,BUDH,"DS1",BUDAGE,$P(^DPT(DFN,0),U),BUDCOM,DFN)=$P(BUDCTA,U,2)
  1.  ..Q
  1.  I $G(BUDDS2L) D
  1.  .S ^XTMP("BUDCRP6B",BUDJ,BUDH,"DS2",BUDAGE,$P(^DPT(DFN,0),U),BUDCOM,DFN)=""
  1.  Q
  1. ORALASS(P,BDATE,EDATE) ;
  1.  NEW BUDG,X,Y,Z,E,G
  1.  S Y=$$CPT^BUDCDU(P,BDATE,EDATE,$O(^ATXAX("B","BUD ORAL EXAM CPTS",0)),5)
  1.  I Y Q 1
  1.  ;now check ada
  1.  S G=""
  1.  K BUDG S %=P_"^ALL ADA;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
  1.  S X=0 F  S X=$O(BUDG(X)) Q:X'=+X!(G)  D
  1.  .S Y=$P(BUDG(X),U,2)
  1.  .I Y="0191" S G=1 Q
  1.  .I Y="0120" S G=1 Q
  1.  .I Y="0145" S G=1 Q
  1.  .I Y="0150" S G=1 Q
  1.  .I Y="0180" S G=1 Q
  1.  Q G
  1. MHRISK(P,BDATE,EDATE) ;
  1.  NEW BUDG,X,Y,Z,E,G
  1.  S Y=$$CPTI^BUDCDU(P,BDATE,EDATE,$P($$CPT^ICPTCOD("D0602"),U,1))
  1.  I Y Q 1
  1.  S Y=$$CPTI^BUDCDU(P,BDATE,EDATE,$P($$CPT^ICPTCOD("D0603"),U,1))
  1.  I Y Q 1
  1.  ;now check ada
  1.  S G=""
  1.  K BUDG S %=P_"^ALL ADA;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
  1.  S X=0 F  S X=$O(BUDG(X)) Q:X'=+X!(G)  D
  1.  .S Y=$P(BUDG(X),U,2)
  1.  .I Y="0602" S G=1 Q
  1.  .I Y="0603" S G=1 Q
  1.  Q G
  1. NOSEAL(P,EDATE) ;
  1.  ;V10.0 ICD10
  1.  NEW BUDG,%,E,T,X,G,Y
  1.  K BUDG S %=P_"^ALL DX;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
  1.  S T=$O(^BUDCTSSC("B","NOSEAL DIAGNOSES",0))
  1.  S X=0,G="" F  S X=$O(BUDG(X)) Q:X'=+X!(G]"")  D
  1.  .S Y=+$P(BUDG(X),U,4)
  1.  .S Y=$P($G(^AUPNVPOV(Y,0)),U,1)
  1.  .I $D(^BUDCTSSC("AD",Y,T)) S G=1
  1.  I G]"" Q G
  1.  S X=$$PLCL^BUDCDU(P,"NOSEAL DIAGNOSES") I X Q 1
  1.  Q G
  1. SEAL(P,BDATE,EDATE) ;
  1.  ;get all ada from v dental
  1.  ;get all cpts from v cpt
  1.  NEW BGPG,%,E,G,D,A,T
  1.  S G=""
  1.  S %=P_"^ALL ADA;DURING "_$$DATE^BGP6UTL(BDATE)_"-"_$$DATE^BGP6UTL(EDATE),E=$$START1^APCLDF(%,"BGPG(")
  1.  S E=0 F  S E=$O(BGPG(E)) Q:E'=+E!(G)  D
  1.  .S D=+$P(BGPG(E),U,4)
  1.  .S A=$$VAL^XBDIQ1(9000010.05,D,.01)
  1.  .S T=$$VALI^XBDIQ1(9000010.05,D,.05)
  1.  .Q:'T
  1.  .S T=$P($G(^ADEOPS(T,88)),U,1)
  1.  .I A'=1350,A'=1351,A'=1352 Q
  1.  .I T'=3,T'=14,T'=19,T'=30 Q  ;not first molar
  1.  .S G=1_U_"ADA "_A_" on "_$$FMTE^XLFDT($P(BGPG(E),U))
  1.  I G Q G
  1.  ;cpts
  1.  S Y=$$CPTI^BUDCDU(P,BDATE,EDATE,$P($$CPT^ICPTCOD("D1350"),U,1))
  1.  I Y Q 1_U_"CPT D1350 on "_$$FMTE^XLFDT($P(Y,U,2))
  1.  S Y=$$CPTI^BUDCDU(P,BDATE,EDATE,$P($$CPT^ICPTCOD("D1351"),U,1))
  1.  I Y Q 1_U_"CPT D1351 on "_$$FMTE^XLFDT($P(Y,U,2))
  1.  S Y=$$CPTI^BUDCDU(P,BDATE,EDATE,$P($$CPT^ICPTCOD("D1352"),U,1))
  1.  I Y Q 1_U_"CPT D1352 on "_$$FMTE^XLFDT($P(Y,U,2))
  1.  ;
  1.  Q ""