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