ADEKNT ; IHS/HQT/MJL - COMPILE DENTAL REPORTS ; [ 03/24/1999 9:04 AM ]
;;6.0;ADE;**23**;JUN 6, 2011
;
; TODO: Add facility capability to reports
;Entry points:
; ADEKNT - prompt year,quarter & do all objectives.
; EN(Objective)- prompt year.quarter, do objectives in parameter
; ZTM - Tasked option ADEK-QUARTER
; KNS - Called by ADEKNS installation routine
;
N ADEYQ,ADESELOB
TOP ;
S ADEYQ=$$ASKYQ^ADEKNT4()
G:'ADEYQ END
;Objective(s) to be processed are stored in ;-delimited string ADESELOB
;which may also contain "ALL", "DATE", or "USER"
S:'$D(ADESELOB) ADESELOB="ALL"
S ZTRTN="START^ADEKNT",ZTDESC="DENTAL STATS "_ADEYQ,ZTIO="",ZTSAVE("ADEYQ")="",ZTSAVE("ADESELOB")="" D ^%ZTLOAD G END ;***TODO: Uncomment after test
G START
;
ZTM ;EP - Entry point for tasked option ADEK-QUARTER
N ADEYQ,ADESELOB
S ADEYQ=$$QTR^ADEKNT5(DT)
S ADESELOB="ALL"
G START
;
KNS(ADEYQ,ADESELOB) ;EP - Called by ADEKNS installation routine
G START
;
START ;EP
N ADEBDI,ADEEDI,ADEDFN,ADEV,ADEVD,ADEVDFN,ADEUP,ADEDUP
N ADECLIN,ADEFAC
N ADEPER,ADE3BD,ADE1BD,ADEED,ADE3BDI,ADE1BDI,ADEQBDI,ADEEDI
N ADECTR,ADEOBJ,ADEDOB,ADEHXC,ADEHXO,ADEIEN,ADEIND,ADELOE,ADEOGRP
N ADEPAT,ADEQBD,ADEYR,ADE
N DR,DIE,DIC
K ^TMP($J,"CTR")
;
S2 ;
;Get Start time
S ADE("STARTTIME")=$H
;Set error trap to send mailman message that count routine abended
I $D(^%ZOSF("TRAP")) S X="ERR^ADEKNT3",@^%ZOSF("TRAP")
;I $D(^%ZOSF("MAXSIZ")) S X=255 X ^%ZOSF("MAXSIZ")
;
;INIT:
S ADEPER=$$PERIOD^ADEKNT5($P(ADEYQ,"."),+$P(ADEYQ,".",2))
S ADE3BD=$P(ADEPER,U,3)
S ADE1BD=$P(ADEPER,U,4)
S ADEQBD=$P(ADEPER,U,5)
S ADEED=$P(ADEPER,U,2)
;
;Set inverse beginning and ending dates
S ADE3BDI=9999999-ADE3BD
S ADE1BDI=9999999-ADE1BD
S ADEQBDI=9999999-ADEQBD
S ADEEDI=9999999-ADEED
;
;Get ^-delimited dental facility IENs in ADEFAC
S ADEFAC=$$LOADFAC^ADEKRP()
;
;Initialize counter array ^TMP($J,"CTR", for all objectives in ^ADEKOB
D ARRAY^ADEKNT1(ADESELOB)
;
;B ;Break here to examine initial ^TMP($J,"CTR",
;
PROC ;$O Thru ^AUPNPAT
S ADEDFN=0
;This is the production line:
I ADESELOB'="DATE" F S ADEDFN=$O(^AUPNPAT(ADEDFN)) Q:+ADEDFN'=ADEDFN D
. ;I ADESELOB'="DATE" F ADEDFN=1,2 D ;***COMMENT AFTER TEST
. ;This is the test line:
. ;Get DOB
. Q:'$D(^AUPNPAT(ADEDFN,0))
. Q:'$D(^DPT(ADEDFN,0))
. S ADEDOB=$P(^DPT(ADEDFN,0),U,3)
. Q:'+ADEDOB ;Quit if no DOB
. Q:ADEDOB>ADEED ;Quit if born after enddate
. I ($E(DT,1,3)-$E(ADEDOB,1,3))>123 Q ;Age > 123 -- DOB Wrong
. ;Set objective age group array ADEOBJ(
. D ADEOBJ(ADEDOB)
. ;Indian or Non-Indian (ADEIND)
. S ADEIND=$$INDIAN(ADEDFN)
. ;Increment User Counters
. D:ADESELOB["ALL"!(ADESELOB["USER") USER
. ;Increment Objective Counters
. D OBJECT^ADEKNT2 ;***Uncomment after test of visit counters
;
;Increment daily & visit Counters
D:ADESELOB["ALL"!(ADESELOB["DATE") DATE^ADEKNT1
;
;Q ;Break here to examine finished ^TMP($J,"CTR",
;Update DENTAL OBJECTIVE COUNT file
D FILE^ADEKNT3
;Send mail message
D BULL^ADEKNT3(1)
;California stats
D CFBULL^ADEKNT6(+ADEYQ)
;Processing time in minutes
S ADE("PROC_TIME")=$$MIN^ADEKNT3(ADE("STARTTIME"),$H)
S ^ADEUTL("ADEKNT_TIME")=(60*$P(ADE("PROC_TIME"),U))+($P(ADE("PROC_TIME"),U,2))+60
;
END ;EP
;All local variables are NEW; none have to be KILLed
Q
;
USERDONE() ;Return 1 if all facilities have a visit count
N ADEDON,J
S ADEDON=1
Q:'ADEGOTV 0
F J=1:1:$L(ADEFAC,U) D Q:'ADEDON
. I '+$G(ADEGOTV($P(ADEFAC,U,J))) S ADEDON=0
Q ADEDON
;
USER ;$O Thru ^AUPNVSIT entries for patient ADEDFN
N ADEGOTV
S ADEGOTV=0
S ADEV=ADEEDI-1
F S ADEV=$O(^AUPNVSIT("AA",ADEDFN,ADEV)) Q:ADEV'=+ADEV S ADEVD=$P(ADEV,".") Q:ADEVD>ADE3BDI D Q:$$USERDONE()
. S ADEVDFN=0
. F S ADEVDFN=$O(^AUPNVSIT("AA",ADEDFN,ADEV,ADEVDFN)) Q:ADEVDFN'=+ADEVDFN D Q:$$USERDONE()
. . ;If pt had visit S ADEGOTV=1
. . Q:'$D(^AUPNVSIT(ADEVDFN,0))
. . N ADENOD
. . S ADENOD=^AUPNVSIT(ADEVDFN,0)
. . Q:$P(ADENOD,U,11) ;Delete flag
. . Q:'$P(ADENOD,U,9) ;Dependent entries
. . Q:"DXECT"[$P(ADENOD,U,7) ;Service Category
. . Q:'$D(^AUPNVPOV("AD",ADEVDFN)) ;No POV
. . Q:'$D(^AUPNVPRV("AD",ADEVDFN)) ;No Provider
. . S ADELOE=$P(ADENOD,U,6) ;Location
. . ;It's a legit visit so if ADEGOTV hasn't already been set
. . ;then set it to 1 and increment the med visit counters
. . I 'ADEGOTV D ;All Facilities
. . . S ADEGOTV=1
. . . ;F ADEIEN="MEDICAL USER (ALL)",$S(ADEIND=1:"MEDICAL USER (INDIAN)",1:"MEDICAL USER (NON-INDIAN)") D
. . . F ADEIEN=3,$S(ADEIND=1:1,1:2) D
. . . . Q:$G(^TMP($J,"CTR",ADEIEN,ADEOBJ(ADEIEN)))="" 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
. . . Q
. . I '+$G(ADEGOTV(ADELOE)) D
. . . S ADEGOTV(ADELOE)=1
. . . F ADEIEN=3,$S(ADEIND=1:1,1:2) D
. . . . Q:$G(^TMP($J,"CTR",ADEIEN,ADEOBJ(ADEIEN),ADELOE))="" 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
Q
;
INDIAN(ADEDFN) ;EP
;Return 1 if Indian or if NO TRIBE at all
;Else return 2 (NON-Indian)
;Conforms to logic in APCLACC2
N ADEIND
I '$D(^AUPNPAT(ADEDFN,11)) Q 1
S ADEIND=$P(^AUPNPAT(ADEDFN,11),U,8)
I ADEIND="" Q 1
I '$D(^AUTTTRI(ADEIND,0)) Q 1
S ADEIND=$P(^AUTTTRI(ADEIND,0),U,2)
I +ADEIND,ADEIND<969 Q 1
I ADEIND=997 Q 1
Q 2
;
ADEOBJ(ADEDOB) ;EP
;$O thru ^TMP($J,"CTR", and
;Set ADEOBJ( array based on ADEDOB
N ADEIEN
S ADEIEN=0 K ADEOBJ
F S ADEIEN=$O(^TMP($J,"CTR",ADEIEN)) Q:'+ADEIEN D
. S ADEOGRP=0
. F S ADEOGRP=$O(^TMP($J,"CTR",ADEIEN,ADEOGRP)) Q:ADEOGRP'?1N.E D Q:$D(ADEOBJ(ADEIEN))
. . Q:ADEDOB<$P(^TMP($J,"CTR",ADEIEN,ADEOGRP),U,4)
. . Q:ADEDOB>$P(^TMP($J,"CTR",ADEIEN,ADEOGRP),U,5)
. . S ADEOBJ(ADEIEN)=ADEOGRP
. . Q
. Q
Q
;
EN(ADESELOB) ;EP
;Enter here with ADESELOB defined
;
N ADEYQ
G TOP
ADEKNT ; IHS/HQT/MJL - COMPILE DENTAL REPORTS ; [ 03/24/1999 9:04 AM ]
+1 ;;6.0;ADE;**23**;JUN 6, 2011
+2 ;
+3 ; TODO: Add facility capability to reports
+4 ;Entry points:
+5 ; ADEKNT - prompt year,quarter & do all objectives.
+6 ; EN(Objective)- prompt year.quarter, do objectives in parameter
+7 ; ZTM - Tasked option ADEK-QUARTER
+8 ; KNS - Called by ADEKNS installation routine
+9 ;
+10 NEW ADEYQ,ADESELOB
TOP ;
+1 SET ADEYQ=$$ASKYQ^ADEKNT4()
+2 IF 'ADEYQ
GOTO END
+3 ;Objective(s) to be processed are stored in ;-delimited string ADESELOB
+4 ;which may also contain "ALL", "DATE", or "USER"
+5 IF '$DATA(ADESELOB)
SET ADESELOB="ALL"
+6 ;***TODO: Uncomment after test
SET ZTRTN="START^ADEKNT"
SET ZTDESC="DENTAL STATS "_ADEYQ
SET ZTIO=""
SET ZTSAVE("ADEYQ")=""
SET ZTSAVE("ADESELOB")=""
DO ^%ZTLOAD
GOTO END
+7 GOTO START
+8 ;
ZTM ;EP - Entry point for tasked option ADEK-QUARTER
+1 NEW ADEYQ,ADESELOB
+2 SET ADEYQ=$$QTR^ADEKNT5(DT)
+3 SET ADESELOB="ALL"
+4 GOTO START
+5 ;
KNS(ADEYQ,ADESELOB) ;EP - Called by ADEKNS installation routine
+1 GOTO START
+2 ;
START ;EP
+1 NEW ADEBDI,ADEEDI,ADEDFN,ADEV,ADEVD,ADEVDFN,ADEUP,ADEDUP
+2 NEW ADECLIN,ADEFAC
+3 NEW ADEPER,ADE3BD,ADE1BD,ADEED,ADE3BDI,ADE1BDI,ADEQBDI,ADEEDI
+4 NEW ADECTR,ADEOBJ,ADEDOB,ADEHXC,ADEHXO,ADEIEN,ADEIND,ADELOE,ADEOGRP
+5 NEW ADEPAT,ADEQBD,ADEYR,ADE
+6 NEW DR,DIE,DIC
+7 KILL ^TMP($JOB,"CTR")
+8 ;
S2 ;
+1 ;Get Start time
+2 SET ADE("STARTTIME")=$HOROLOG
+3 ;Set error trap to send mailman message that count routine abended
+4 IF $DATA(^%ZOSF("TRAP"))
SET X="ERR^ADEKNT3"
SET @^%ZOSF("TRAP")
+5 ;I $D(^%ZOSF("MAXSIZ")) S X=255 X ^%ZOSF("MAXSIZ")
+6 ;
+7 ;INIT:
+8 SET ADEPER=$$PERIOD^ADEKNT5($PIECE(ADEYQ,"."),+$PIECE(ADEYQ,".",2))
+9 SET ADE3BD=$PIECE(ADEPER,U,3)
+10 SET ADE1BD=$PIECE(ADEPER,U,4)
+11 SET ADEQBD=$PIECE(ADEPER,U,5)
+12 SET ADEED=$PIECE(ADEPER,U,2)
+13 ;
+14 ;Set inverse beginning and ending dates
+15 SET ADE3BDI=9999999-ADE3BD
+16 SET ADE1BDI=9999999-ADE1BD
+17 SET ADEQBDI=9999999-ADEQBD
+18 SET ADEEDI=9999999-ADEED
+19 ;
+20 ;Get ^-delimited dental facility IENs in ADEFAC
+21 SET ADEFAC=$$LOADFAC^ADEKRP()
+22 ;
+23 ;Initialize counter array ^TMP($J,"CTR", for all objectives in ^ADEKOB
+24 DO ARRAY^ADEKNT1(ADESELOB)
+25 ;
+26 ;B ;Break here to examine initial ^TMP($J,"CTR",
+27 ;
PROC ;$O Thru ^AUPNPAT
+1 SET ADEDFN=0
+2 ;This is the production line:
+3 IF ADESELOB'="DATE"
FOR
SET ADEDFN=$ORDER(^AUPNPAT(ADEDFN))
IF +ADEDFN'=ADEDFN
QUIT
Begin DoDot:1
+4 ;I ADESELOB'="DATE" F ADEDFN=1,2 D ;***COMMENT AFTER TEST
+5 ;This is the test line:
+6 ;Get DOB
+7 IF '$DATA(^AUPNPAT(ADEDFN,0))
QUIT
+8 IF '$DATA(^DPT(ADEDFN,0))
QUIT
+9 SET ADEDOB=$PIECE(^DPT(ADEDFN,0),U,3)
+10 ;Quit if no DOB
IF '+ADEDOB
QUIT
+11 ;Quit if born after enddate
IF ADEDOB>ADEED
QUIT
+12 ;Age > 123 -- DOB Wrong
IF ($EXTRACT(DT,1,3)-$EXTRACT(ADEDOB,1,3))>123
QUIT
+13 ;Set objective age group array ADEOBJ(
+14 DO ADEOBJ(ADEDOB)
+15 ;Indian or Non-Indian (ADEIND)
+16 SET ADEIND=$$INDIAN(ADEDFN)
+17 ;Increment User Counters
+18 IF ADESELOB["ALL"!(ADESELOB["USER")
DO USER
+19 ;Increment Objective Counters
+20 ;***Uncomment after test of visit counters
DO OBJECT^ADEKNT2
End DoDot:1
+21 ;
+22 ;Increment daily & visit Counters
+23 IF ADESELOB["ALL"!(ADESELOB["DATE")
DO DATE^ADEKNT1
+24 ;
+25 ;Q ;Break here to examine finished ^TMP($J,"CTR",
+26 ;Update DENTAL OBJECTIVE COUNT file
+27 DO FILE^ADEKNT3
+28 ;Send mail message
+29 DO BULL^ADEKNT3(1)
+30 ;California stats
+31 DO CFBULL^ADEKNT6(+ADEYQ)
+32 ;Processing time in minutes
+33 SET ADE("PROC_TIME")=$$MIN^ADEKNT3(ADE("STARTTIME"),$HOROLOG)
+34 SET ^ADEUTL("ADEKNT_TIME")=(60*$PIECE(ADE("PROC_TIME"),U))+($PIECE(ADE("PROC_TIME"),U,2))+60
+35 ;
END ;EP
+1 ;All local variables are NEW; none have to be KILLed
+2 QUIT
+3 ;
USERDONE() ;Return 1 if all facilities have a visit count
+1 NEW ADEDON,J
+2 SET ADEDON=1
+3 IF 'ADEGOTV
QUIT 0
+4 FOR J=1:1:$LENGTH(ADEFAC,U)
Begin DoDot:1
+5 IF '+$GET(ADEGOTV($PIECE(ADEFAC,U,J)))
SET ADEDON=0
End DoDot:1
IF 'ADEDON
QUIT
+6 QUIT ADEDON
+7 ;
USER ;$O Thru ^AUPNVSIT entries for patient ADEDFN
+1 NEW ADEGOTV
+2 SET ADEGOTV=0
+3 SET ADEV=ADEEDI-1
+4 FOR
SET ADEV=$ORDER(^AUPNVSIT("AA",ADEDFN,ADEV))
IF ADEV'=+ADEV
QUIT
SET ADEVD=$PIECE(ADEV,".")
IF ADEVD>ADE3BDI
QUIT
Begin DoDot:1
+5 SET ADEVDFN=0
+6 FOR
SET ADEVDFN=$ORDER(^AUPNVSIT("AA",ADEDFN,ADEV,ADEVDFN))
IF ADEVDFN'=+ADEVDFN
QUIT
Begin DoDot:2
+7 ;If pt had visit S ADEGOTV=1
+8 IF '$DATA(^AUPNVSIT(ADEVDFN,0))
QUIT
+9 NEW ADENOD
+10 SET ADENOD=^AUPNVSIT(ADEVDFN,0)
+11 ;Delete flag
IF $PIECE(ADENOD,U,11)
QUIT
+12 ;Dependent entries
IF '$PIECE(ADENOD,U,9)
QUIT
+13 ;Service Category
IF "DXECT"[$PIECE(ADENOD,U,7)
QUIT
+14 ;No POV
IF '$DATA(^AUPNVPOV("AD",ADEVDFN))
QUIT
+15 ;No Provider
IF '$DATA(^AUPNVPRV("AD",ADEVDFN))
QUIT
+16 ;Location
SET ADELOE=$PIECE(ADENOD,U,6)
+17 ;It's a legit visit so if ADEGOTV hasn't already been set
+18 ;then set it to 1 and increment the med visit counters
+19 ;All Facilities
IF 'ADEGOTV
Begin DoDot:3
+20 SET ADEGOTV=1
+21 ;F ADEIEN="MEDICAL USER (ALL)",$S(ADEIND=1:"MEDICAL USER (INDIAN)",1:"MEDICAL USER (NON-INDIAN)") D
+22 FOR ADEIEN=3,$SELECT(ADEIND=1:1,1:2)
Begin DoDot:4
+23 IF $GET(^TMP($JOB,"CTR",ADEIEN,ADEOBJ(ADEIEN)))=""
QUIT
Begin DoDot:5
+24 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:5
End DoDot:4
+25 QUIT
End DoDot:3
+26 IF '+$GET(ADEGOTV(ADELOE))
Begin DoDot:3
+27 SET ADEGOTV(ADELOE)=1
+28 FOR ADEIEN=3,$SELECT(ADEIND=1:1,1:2)
Begin DoDot:4
+29 IF $GET(^TMP($JOB,"CTR",ADEIEN,ADEOBJ(ADEIEN),ADELOE))=""
QUIT
Begin DoDot:5
+30 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:5
End DoDot:4
End DoDot:3
+31 QUIT
End DoDot:2
IF $$USERDONE()
QUIT
+32 QUIT
End DoDot:1
IF $$USERDONE()
QUIT
+33 QUIT
+34 ;
INDIAN(ADEDFN) ;EP
+1 ;Return 1 if Indian or if NO TRIBE at all
+2 ;Else return 2 (NON-Indian)
+3 ;Conforms to logic in APCLACC2
+4 NEW ADEIND
+5 IF '$DATA(^AUPNPAT(ADEDFN,11))
QUIT 1
+6 SET ADEIND=$PIECE(^AUPNPAT(ADEDFN,11),U,8)
+7 IF ADEIND=""
QUIT 1
+8 IF '$DATA(^AUTTTRI(ADEIND,0))
QUIT 1
+9 SET ADEIND=$PIECE(^AUTTTRI(ADEIND,0),U,2)
+10 IF +ADEIND
IF ADEIND<969
QUIT 1
+11 IF ADEIND=997
QUIT 1
+12 QUIT 2
+13 ;
ADEOBJ(ADEDOB) ;EP
+1 ;$O thru ^TMP($J,"CTR", and
+2 ;Set ADEOBJ( array based on ADEDOB
+3 NEW ADEIEN
+4 SET ADEIEN=0
KILL ADEOBJ
+5 FOR
SET ADEIEN=$ORDER(^TMP($JOB,"CTR",ADEIEN))
IF '+ADEIEN
QUIT
Begin DoDot:1
+6 SET ADEOGRP=0
+7 FOR
SET ADEOGRP=$ORDER(^TMP($JOB,"CTR",ADEIEN,ADEOGRP))
IF ADEOGRP'?1N.E
QUIT
Begin DoDot:2
+8 IF ADEDOB<$PIECE(^TMP($JOB,"CTR",ADEIEN,ADEOGRP),U,4)
QUIT
+9 IF ADEDOB>$PIECE(^TMP($JOB,"CTR",ADEIEN,ADEOGRP),U,5)
QUIT
+10 SET ADEOBJ(ADEIEN)=ADEOGRP
+11 QUIT
End DoDot:2
IF $DATA(ADEOBJ(ADEIEN))
QUIT
+12 QUIT
End DoDot:1
+13 QUIT
+14 ;
EN(ADESELOB) ;EP
+1 ;Enter here with ADESELOB defined
+2 ;
+3 NEW ADEYQ
+4 GOTO TOP
