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

ADEKNT2.m

Go to the documentation of this file. 
  1. ADEKNT2 ; IHS/HQT/MJL - COMPILE DENTAL REPORTS ;   [ 04/03/2001  6:56 PM ]
  1.  ;;6.0;ADE;**4,7,15,26**;JAN 01, 2004;Build 13
  1.  ;;IHS/OIT/GAB 10.2014 Modified for 2015 Code Updates - PATCH 26
  1. OBJECT ;EP
  1.  ;Called for each patient to execute patient level counts
  1.  ;Get dental history in ^TMP("ADEHXF",$J,CODE,DATE)=FACILITY
  1.  N ADEHXC,ADEHXO,ADEHXF
  1.  D GETHX^ADEGRL33(ADEDFN)
  1.  Q:'$D(^TMP("ADEHXF",$J))
  1.  D:ADESELOB["USER"!(ADESELOB["ALL") DUSER
  1.  ;$O thru ^ADEKOB("AD","p",ADEIEN) - PATIENT LEVEL OBJECTIVES
  1.  ;Quit if '$D(ADEOBJ(ADEIEN))
  1.  ;Else execute logic in ^TMP($J,"CTR",ADEIEN,"LOGIC")
  1.  S ADEIEN=0
  1.  F  S ADEIEN=$O(^ADEKOB("AD","p",ADEIEN)) Q:'+ADEIEN  D
  1.  . Q:'$D(ADEOBJ(ADEIEN))
  1.  . ;B:ADEIEN=17!(ADEIEN=19)  ;***Before ^TMP($J,"CTR",ADEIEN,"LOGIC")
  1.  . X ^TMP($J,"CTR",ADEIEN,"LOGIC")
  1.  . ;B:ADEIEN=17!(ADEIEN=19)  ;***after Xecuting ^TMP($J,"CTR",ADEIEN,"LOGIC")
  1.  Q
  1.  ;
  1.  ;Logic for each objective in subs below
  1.  ;Each entry point is contained in the LOGIC field of the OBJECTIVE file
  1.  ;
  1.  ;ADELIM=1:Indians only, 2:Non-Indians only, 0:ALL (no limit)
  1.  ;
  1. NEWUSER(ADEASOF,ADELIM) ;EP
  1.  ;Dental NEW user count (new user as of ADEASOF)
  1.  ;ADEASOF can by "FY" or "3YR" to switch between
  1.  ;counting fy new users and 3yr new users.
  1.  N ADEVD,ADEK
  1.  I ADELIM Q:'(ADELIM=ADEIND)
  1.  ;Merge 0190 and 0000 dates
  1.  F ADEVD="0000","0190" D
  1.  . Q:'$D(^TMP("ADEHXF",$J,ADEVD))
  1.  . S ADEK=0 F  S ADEK=$O(^TMP("ADEHXF",$J,ADEVD,ADEK)) Q:'+ADEK  S ADEVD(ADEK)=$P(^TMP("ADEHXF",$J,ADEVD,ADEK),U,2)
  1.  I ADEASOF="3YR" D  Q
  1.  . S ADEVD=$$NEWU2()
  1.  . Q:'+ADEVD
  1.  . Q:+ADEVD>ADEED
  1.  . D INCREM(ADEIEN,ADEOBJ(ADEIEN),"",+ADEVD,1)
  1.  . D INCREM(ADEIEN,ADEOBJ(ADEIEN),$P(ADEVD,U,2),+ADEVD,1)
  1.  ;
  1.  ;beginning Y2K fix
  1.  ;S ADEASOF="2"_$S($E(ADEED,4,5)<10:$E(ADEED,2,3)-1,1:$E(ADEED,2,3))_"1000"
  1.  S ADEASOF=$E($P($$FISCAL^XBDT(ADEED),U,2),1,5)_"00" ;Y2000
  1.  ;end Y2K fix block
  1.  S ADEVD=$O(ADEVD(ADEASOF))
  1.  Q:'+ADEVD
  1.  Q:+ADEVD>ADEED
  1.  D INCREMFY(ADEIEN,ADEOBJ(ADEIEN),"",+ADEVD,1) ;No facility-level count
  1.  Q
  1.  ;
  1. NEWU2() ;EP
  1.  ;Assumes ADEVD(; returns date when pt was last new
  1.  ;Or zero if last new was before ADE3BD
  1.  ;2nd piece of ADEVD is facility at which pt was last new
  1.  ;
  1.  N ADEVD1,ADEVD2
  1.  I '+$O(ADEVD(0)) Q 0
  1.  I $O(ADEVD(0))>ADE3BD Q $O(ADEVD(0))
  1.  S ADEVD=0
  1.  S ADEVD1=$O(ADEVD(0))
  1.  F  S ADEVD2=$O(ADEVD(ADEVD1)) Q:'+ADEVD2  D  Q:+ADEVD  Q:ADEVD="NO"
  1.  . I ADEVD2<ADE3BD S ADEVD1=ADEVD2 Q
  1.  . I ADEVD2>(ADEVD1+30000) S ADEVD=ADEVD2_U_$P(ADEVD(ADEVD2),U,2) Q
  1.  . S ADEVD="NO"
  1.  S:ADEVD="NO" ADEVD=0
  1.  Q ADEVD
  1.  ;
  1. DUSER ;EP
  1.  ;Dental Different user count - # of different people per period
  1.  ;Get latest visit (0190 or 0000) prior to ending date ADEED
  1.  ;
  1.  N ADEVD,ADEIEN,K,L,ADEF
  1.  ;
  1.  ;First, set all-facility counter
  1.  S ADEVD("0190")=0,ADEVD("0000")=0
  1.  I $D(ADEHXC("0190")) S ADEVD("0190")=$O(ADEHXC("0190",ADEED+1),-1)
  1.  I $D(ADEHXC("0000")) S ADEVD("0000")=$O(ADEHXC("0000",ADEED+1),-1)
  1.  S ADEVD=ADEVD("0190")
  1.  I ADEVD("0000")>ADEVD S ADEVD=ADEVD("0000")
  1.  Q:ADEVD=0
  1.  Q:ADEVD<ADE3BD
  1.  S ADEVD=9999999-ADEVD
  1.  ;F ADEIEN="DENTAL USER (ALL)",$S(ADEIND=1:"DENTAL USER (INDIAN)",1:"DENTAL USER (NON-INDIAN)") D
  1.  F ADEIEN=6,$S(ADEIND=1:4,1:5) D
  1.  . F K=$S(ADEVD'>ADEQBDI:1,ADEVD'>ADE1BDI:2,1:3):1:3 S $P(^TMP($J,"CTR",ADEIEN,ADEOBJ(ADEIEN)),U,K)=$P(^TMP($J,"CTR",ADEIEN,ADEOBJ(ADEIEN)),U,K)+1
  1.  ;
  1.  ;
  1.  ;Next, For each facility in ADEFAC
  1.  F J=1:1:$L(ADEFAC,U) S ADELOE=$P(ADEFAC,U,J) D
  1.  . K ADEF
  1.  . S ADEVD("0190")=0,ADEVD("0000")=0
  1.  . I $D(^TMP("ADEHXF",$J,"0190")) S L=0 F  S L=$O(^TMP("ADEHXF",$J,"0190",L)) Q:'+L  D
  1.  . . S:$P(^TMP("ADEHXF",$J,"0190",L),U,2)=ADELOE ADEF("0190",L)=^TMP("ADEHXF",$J,"0190",L)
  1.  . I $D(^TMP("ADEHXF",$J,"0000")) S L=0 F  S L=$O(^TMP("ADEHXF",$J,"0000",L)) Q:'+L  D
  1.  . . S:$P(^TMP("ADEHXF",$J,"0000",L),U,2)=ADELOE ADEF("0000",L)=^TMP("ADEHXF",$J,"0000",L)
  1.  . I $D(ADEF("0190")) S ADEVD("0190")=$O(ADEF("0190",ADEED+1),-1)
  1.  . I $D(ADEF("0000")) S ADEVD("0000")=$O(ADEF("0000",ADEED+1),-1)
  1.  . S ADEVD=ADEVD("0190")
  1.  . I ADEVD("0000")>ADEVD S ADEVD=ADEVD("0000")
  1.  . Q:'+ADEVD
  1.  . Q:ADEVD<ADE3BD
  1.  . S ADEVD=9999999-ADEVD
  1.  . F ADEIEN=6,$S(ADEIND=1:4,1:5) D
  1.  . . F K=$S(ADEVD'>ADEQBDI:1,ADEVD'>ADE1BDI:2,1:3):1:3 S $P(^TMP($J,"CTR",ADEIEN,ADEOBJ(ADEIEN),ADELOE),U,K)=$P(^TMP($J,"CTR",ADEIEN,ADEOBJ(ADEIEN),ADELOE),U,K)+1
  1.  . Q
  1.  Q
  1.  ;
  1. COUNT(ADECOD,ADELIM)       ;EP
  1.  ;Count PATIENTS with one of the codes in ADECOD
  1.  ;where ADECOD is ^-delimited list of ADA codes
  1.  ;and where code occurred on visit between ADE3BD and ADEED
  1.  ;
  1.  I ADELIM Q:'(ADELIM=ADEIND)
  1.  N ADEVD,ADEC,ADED,ADELOE,ADEF
  1.  ;First, do overall count
  1.  S ADEC=0
  1.  F K=1:1:$L(ADECOD,U) D  Q:ADEC
  1.  . S ADED=$P(ADECOD,U,K)
  1.  . Q:ADED=""
  1.  . Q:'$D(ADEHXC(ADED))
  1.  . S ADEVD=$O(ADEHXC(ADED,ADEED+1),-1)
  1.  . Q:'+ADEVD
  1.  . Q:ADEVD<ADE3BD
  1.  . D INCREM(ADEIEN,ADEOBJ(ADEIEN),"",ADEVD,1)
  1.  . S ADEC=1
  1.  . Q
  1.  ;Next, do facility count
  1.  F J=1:1:$L(ADEFAC,U) S ADELOE=$P(ADEFAC,U,J) D
  1.  . K ADEF
  1.  . S ADEC=0 F  S ADEC=$O(^TMP("ADEHXF",$J,ADEC)) Q:ADEC=""  D
  1.  . . S ADED=0 F  S ADED=$O(^TMP("ADEHXF",$J,ADEC,ADED))  Q:'+ADED  D
  1.  . . . S:$P(^TMP("ADEHXF",$J,ADEC,ADED),U,2)=ADELOE ADEF(ADEC,ADED)=^TMP("ADEHXF",$J,ADEC,ADED)
  1.  . . . Q
  1.  . . Q
  1.  . S ADEC=0
  1.  . F K=1:1:$L(ADECOD,U) D  Q:ADEC
  1.  . . S ADED=$P(ADECOD,U,K)
  1.  . . Q:ADED=""
  1.  . . Q:'$D(ADEF(ADED))
  1.  . . S ADEVD=$O(ADEF(ADED,ADEED+1),-1)
  1.  . . Q:'+ADEVD
  1.  . . Q:ADEVD<ADE3BD
  1.  . . D INCREM(ADEIEN,ADEOBJ(ADEIEN),ADELOE,ADEVD,1)
  1.  . . S ADEC=1
  1.  . . Q
  1.  . Q
  1.  Q
  1.  ;
  1. TOTAL(ADECOD,ADELIM)         ;EP
  1.  ;Count Total Number of CODES ADECOD between ADEVD and ADE3BD
  1.  N ADEVD,J,ADEF,ADED,ADELOE,K
  1.  I ADELIM Q:'(ADELIM=ADEIND)
  1.  Q:'$D(^TMP("ADEHXF",$J,ADECOD))
  1.  F J=1:1:$L(ADEFAC,U) S ADELOE=$P(ADEFAC,U,J) D
  1.  . K ADEF
  1.  . S ADED=0 F  S ADED=$O(^TMP("ADEHXF",$J,ADECOD,ADED))  Q:'+ADED  D
  1.  . . S:$P(^TMP("ADEHXF",$J,ADECOD,ADED),U,2)=ADELOE ADEF(ADECOD,ADED)=^TMP("ADEHXF",$J,ADECOD,ADED)
  1.  . . Q
  1.  . Q:'$D(ADEF(ADECOD))
  1.  . F K="",ADELOE D
  1.  . . S ADEVD=ADEED+1
  1.  . . F  S ADEVD=$O(ADEF(ADECOD,ADEVD),-1) Q:'+ADEVD  Q:ADEVD<ADE3BD  D INCREM(ADEIEN,ADEOBJ(ADEIEN),K,$P(ADEVD,"."),+ADEF(ADECOD,ADEVD))
  1.  . Q
  1.  Q
  1.  ;
  1. SVC(ADELIM,ADEMIN)           ;
  1.  ;ADEMIN=1:Count Services, 0:Count Minutes
  1.  ; ----- BEGIN IHS MODIFICATIONS ADE*6.0*15
  1.  ; ADEMIN=2:Count RVU's
  1.  ; ----- END IHS MODIFICATIONS
  1.  ;Between ADEVD and ADE3BD
  1.  N ADECOD,J,K,ADEF
  1.  I ADELIM Q:'(ADELIM=ADEIND)
  1.  S ADECOD=0
  1.  F J=1:1:$L(ADEFAC,U) S ADELOE=$P(ADEFAC,U,J) D
  1.  . K ADEF
  1.  . S ADEC=0 F  S ADEC=$O(^TMP("ADEHXF",$J,ADEC)) Q:ADEC=""  D
  1.  . . S ADED=0 F  S ADED=$O(^TMP("ADEHXF",$J,ADEC,ADED))  Q:'+ADED  D
  1.  . . . S:$P(^TMP("ADEHXF",$J,ADEC,ADED),U,2)=ADELOE ADEF(ADEC,ADED)=^TMP("ADEHXF",$J,ADEC,ADED)
  1.  . . . Q
  1.  . . Q
  1.  . S ADECOD=0
  1.  . ;B  ;New facility
  1.  . F  S ADECOD=$O(ADEF(ADECOD)) Q:ADECOD=""  D
  1.  . . ;IHS/OIT/GAB 10.2014 Modified below line and added the next for 2015 Code updates - PATCH #26
  1.  . . ;Q:"0000;0190;9130;9140;9990"[ADECOD
  1.  . . Q:"0000;0190;9130;9140;9986;9987;9990"[ADECOD
  1.  . . Q:ADECOD?1"IH"2N
  1.  . . N ADENOD,ADELVL
  1.  . . S ADENOD=$O(^AUTTADA("B",ADECOD,0)) Q:'ADENOD
  1.  . . ; ----- BEGIN IHS MODIFICATIONS ADE*6.0*15
  1.  . . S ADERVU=$P($G(^AUTTADA(ADENOD,5)),U)
  1.  . . ; ----- END IHS MODIFICATIONS
  1.  . . S ADENOD=^AUTTADA(ADENOD,0)
  1.  . . S ADELVL=$P(ADENOD,U,5)
  1.  . . Q:ADELVL<1!(ADELVL>6)
  1.  . . F K="",ADELOE D
  1.  . . . S ADEVD=ADEED+1
  1.  . . . ; ----- BEGIN IHS MODIFICATIONS ADE*6.0*15
  1.  . . . ;F  S ADEVD=$O(ADEF(ADECOD,ADEVD),-1) Q:'+ADEVD  Q:ADEVD<ADE3BD  D INCREM(ADEIEN,ADEOBJ(ADEIEN),K,ADEVD,$S(ADEMIN:+ADEF(ADECOD,ADEVD),1:+ADEF(ADECOD,ADEVD)*$P(ADENOD,U,4)))
  1.  . . . F  S ADEVD=$O(ADEF(ADECOD,ADEVD),-1) Q:'+ADEVD  Q:ADEVD<ADE3BD  D
  1.  . . . . S ADEINCR=(+ADEF(ADECOD,ADEVD)*$P(ADENOD,U,4))
  1.  . . . . S:ADEMIN=1 ADEINCR=+ADEF(ADECOD,ADEVD)
  1.  . . . . I ADEMIN=2 D
  1.  . . . . . S ADEINCR=(+ADEF(ADECOD,ADEVD)*ADERVU)
  1.  . . . . . S ADEINCR=$FN(ADEINCR,"",2)
  1.  . . . . D INCREM(ADEIEN,ADEOBJ(ADEIEN),K,ADEVD,ADEINCR)
  1.  . . . ; ----- END IHS MODIFICATIONS
  1.  . Q
  1.  Q
  1.  ;
  1. ASSESSD ;EP
  1.  ;Get most recent any 437 code prior to ADEED increment counter
  1.  ;INDIANS ONLY
  1.  Q:ADEIND'=1
  1.  N ADECOD,ADEASD,ADELOE,J,ADEF,ADEC,ADED
  1.  S ADEASD=0
  1.  F ADECOD="IH70","IH71","IH72","IH73","IH74","IH75","IH76","IH77" I $D(ADEHXC(ADECOD)) D
  1.  . S ADEVD=$O(ADEHXC(ADECOD,ADEED+1),-1)
  1.  . S ADEVD=$P(ADEVD,".")
  1.  . S:ADEVD>ADEASD ADEASD=ADEVD
  1.  Q:'ADEASD
  1.  S ADEVD=ADEASD
  1.  I ADEVD<ADE3BDI D INCREM(ADEIEN,ADEOBJ(ADEIEN),"",ADEVD,1)
  1.  ;
  1.  ;Next, do facility count
  1.  F J=1:1:$L(ADEFAC,U) S ADELOE=$P(ADEFAC,U,J) D
  1.  . K ADEF
  1.  . S ADEC=0 F  S ADEC=$O(^TMP("ADEHXF",$J,ADEC)) Q:ADEC=""  D
  1.  . . S ADED=0 F  S ADED=$O(^TMP("ADEHXF",$J,ADEC,ADED))  Q:'+ADED  D
  1.  . . . S:$P(^TMP("ADEHXF",$J,ADEC,ADED),U,2)=ADELOE ADEF(ADEC,ADED)=^TMP("ADEHXF",$J,ADEC,ADED)
  1.  . . . Q
  1.  . . Q
  1.  . S ADEASD=0
  1.  . F ADECOD="IH70","IH71","IH72","IH73","IH74","IH75","IH76","IH77" I $D(ADEF(ADECOD)) D
  1.  . . S ADEVD=$O(ADEF(ADECOD,ADEED+1),-1)
  1.  . . S ADEVD=$P(ADEVD,".")
  1.  . . S:ADEVD>ADEASD ADEASD=ADEVD
  1.  . Q:'ADEASD
  1.  . S ADEVD=ADEASD
  1.  . I ADEVD<ADE3BDI D INCREM(ADEIEN,ADEOBJ(ADEIEN),ADELOE,ADEVD,1)
  1.  Q
  1.  ;
  1. INCREM(ADEIEN,ADEAGEG,ADELOE,ADEVD,ADEINC) ;EP
  1.  ;Increment counter ^TMP($J,"CTR",ADEIEN,ADEOBJ(ADEIEN)[,ADELOE]) by ADEINC
  1.  ;using visit date ADEVD
  1.  N K
  1.  S ADEVD=9999999-ADEVD
  1.  I '+ADELOE D  Q
  1.  . F K=$S(ADEVD'>ADEQBDI:1,ADEVD'>ADE1BDI:2,1:3):1:3 S $P(^TMP($J,"CTR",ADEIEN,ADEAGEG),U,K)=$P(^TMP($J,"CTR",ADEIEN,ADEAGEG),U,K)+ADEINC
  1.  F K=$S(ADEVD'>ADEQBDI:1,ADEVD'>ADE1BDI:2,1:3):1:3 S $P(^TMP($J,"CTR",ADEIEN,ADEAGEG,ADELOE),U,K)=$P(^TMP($J,"CTR",ADEIEN,ADEAGEG,ADELOE),U,K)+ADEINC
  1.  ;
  1.  Q
  1.  ;
  1. INCREMFY(ADEIEN,ADEAGEG,ADELOE,ADEVD,ADEINC)       ;EP
  1.  ;Same as increm, but use FY as beginning date and skip setting
  1.  ;the 3-year piece
  1.  N K
  1.  S ADEVD=9999999-ADEVD
  1.  I '+ADELOE D  Q
  1.  . F K=$S(ADEVD'>ADEQBDI:1,1:2):1:2 S $P(^TMP($J,"CTR",ADEIEN,ADEOBJ(ADEIEN)),U,K)=$P(^TMP($J,"CTR",ADEIEN,ADEOBJ(ADEIEN)),U,K)+ADEINC
  1.  F K=$S(ADEVD'>ADEQBDI:1,ADEVD'>ADE1BDI:2,1:3):1:3 S $P(^TMP($J,"CTR",ADEIEN,ADEAGEG,ADELOE),U,K)=$P(^TMP($J,"CTR",ADEIEN,ADEAGEG,ADELOE),U,K)+ADEINC
  1.  Q