TIUTSK ; SLC/JER - TIU's Nightly Daemon ;4/18/03 [10/18/04 10:34am]
;;1.0;TEXT INTEGRATION UTILITIES;**7,53,100,113,157,210,221**;Jun 20, 1997;Build 2
MAIN ; All records are read. DC date updated, Record purged, Alerts are
; generated if appropriate
N TIUDA,TIUPRM0,TIUPRM1,TIUDATE,TIUENTDT,TIUPDT,TIUODT
N TIUSTART,TIUEND,TIUADDL
D SETPARM^TIULE
S TIUSTART=$$TSKPARM(1),TIUEND=$$TSKPARM(2)
; Traverse "FIX" X-ref to fix temporary reference dates & back-fill
; Discharge Dates
S TIUDA="" F S TIUDA=$O(^TIU(8925,"FIX",1,TIUDA)) Q:TIUDA'>0 D
. D UPDDCDT(TIUDA) ;Ref Date fixed/DC Date updated if missing
; Traverse "F" X-ref to identify records for which the grace period
; for purge has expired
S TIUPDT=$$FMADD^XLFDT(DT,-$P(TIUPRM0,U,4))
S TIUODT=$$FMADD^XLFDT(DT,-$P(TIUPRM0,U,5))
; Traverse "F" X-ref to identify records overdue for signature or purge
; NOTE: Following VHA Directive 10-92-077, the purge is disabled until
; further notice **53**
;VMP/ELR PATCH 221 SET UP TIUADDL IS OVERDUE ONLY BECAUSE OF ADDITIONAL SIGNER TO STOP AMENDMENT ALERT
S TIUADDL=0
S TIUENTDT=($$TSKPARM(3)-1)+.999999
F S TIUENTDT=$O(^TIU(8925,"F",TIUENTDT)) Q:+TIUENTDT'>0!(TIUENTDT>TIUODT) D
. S TIUDA=0 F S TIUDA=$O(^TIU(8925,"F",+TIUENTDT,TIUDA)) Q:+TIUDA'>0 D
. . ; I (TIUPDT<$$FMADD^XLFDT(DT,-90)),+$$PURGE^TIULC(TIUDA) D PURGE(TIUDA) Purges old records (see NOTE above) **53**
. . I +$$OVERDUE(TIUDA,TIUSTART,TIUEND) D SEND^TIUALRT(TIUDA,1) S TIUADDL=0 ;Alert for overdue
; If upload buffer rec older than 30 days, delete it & its alerts
S TIUDA=0 F S TIUDA=$O(^TIU(8925.2,TIUDA)) Q:TIUDA'>0 D
. N TIUDATE
. S TIUDATE=$P($G(^TIU(8925.2,TIUDA,0)),U,3)
. Q:+TIUDATE'>0
. I $$FMDIFF^XLFDT(DT,TIUDATE)>30 D
. . N TIUEI S TIUEI=0
. . ; JOEL, 12/21/00:
. . F S TIUEI=$O(^TIU(8925.2,TIUDA,"ERR",TIUEI)) Q:+TIUEI'>0 D
. . . N TIUEDA
. . . S TIUEDA=+$G(^TIU(8925.2,TIUDA,"ERR",TIUEI,0)) Q:+TIUEDA'>0
. . . D ALERTDEL^TIUPEVNT(TIUEDA)
. . D BUFPURGE^TIUPUTC(TIUDA)
Q
UPDDCDT(TIUDA) ; If missing DC date & Patient Movement file has DC date,
; DC date updated.
N DFN,DIE,DR,TIU,TIUDAD,TIUDDT,TIUD0,TIUD14,TIUDGPM
S TIUD0=$G(^TIU(8925,+TIUDA,0)),TIUD14=$G(^TIU(8925,+TIUDA,14))
S TIUDGPM=+$P(TIUD14,U)
I +$P($G(^DGPM(+TIUDGPM,0)),U,17)'>0 D Q
. I +$P(TIUD0,U,12)>0 Q
. S DIE=8925,DR=".12////1",DA=TIUDA D ^DIE
I TIUD0'="",'+$P(TIUD0,U,6),(($P(TIUD0,U,8)="")!(+$P(TIUD0,U,12)>0)) D
. D GETTIU^TIULD(.TIU,TIUDA)
. I +$G(TIU("LDT"))>0 D
. . S TIUDAD=$P(TIUD0,U,6)
. . D FIXDC(TIUDA,TIUDAD,DFN,.TIU)
Q
PURGE(DA) ; When purge criteria met, document and addenda purged
N DR,DIE,TIUTYP,TIUDA,X,Y S TIUDA=0
F S TIUDA=+$O(^TIU(8925,"DAD",+DA,TIUDA)) Q:+TIUDA'>0 D
. I +$$ISADDNDM^TIULC1(TIUDA) D PURGE(TIUDA) I 1
. E D DIK^TIURB2(TIUDA) ; Remove components entirely. 1/3/01 updated DIK^TIURB to DIK^TIURB2 - Margy
S DIE=8925,DR=".05///PURGED;1609////"_$$NOW^TIULC_";2///@" D ^DIE
S ^TIU(8925,+DA,"TEXT",0)="^^"_2_U_2_U_DT_"^^"
S ^TIU(8925,+DA,"TEXT",1,0)=" "
S ^TIU(8925,+DA,"TEXT",2,0)=" Document Purged on "_$$DATE^TIULS(DT,"MM/DD/YY")_"."
Q
FIXDC(DA,PARENT,DFN,TIU) ; Stuff fixed field data
N FDA,FDARR,IENS,FLAGS,TIUMSG
S IENS=""""_DA_",""",FDARR="FDA(8925,"_IENS_")",FLAGS="K"
I +$G(PARENT)'>0 D
. S @FDARR@(.08)=$P(TIU("LDT"),U)
. S @FDARR@(1402)=$P($G(TIU("TS")),U)
I +$G(PARENT)>0 D
. S @FDARR@(.08)=$P(TIU("LDT"),U)
. S @FDARR@(1401)=$P(^TIU(8925,+PARENT,14),U)
. S @FDARR@(1402)=$P(^TIU(8925,+PARENT,14),U,2)
S @FDARR@(1205)=$P($G(TIU("LOC")),U)
S @FDARR@(1212)=$P($G(TIU("INST")),U)
S @FDARR@(.12)="@"
S @FDARR@(1301)=+$G(TIU("LDT"))
D FILE^DIE(FLAGS,"FDA","TIUMSG") ; File record
Q
OVERDUE(TIUDA,TIUSTART,TIUEND) ;Checks whether or not a given document is overdue
;This is the same as OVERDUE^TIULC exept for the following items:
; TIUPRM0 must be defined before calling
; also checks for additional signatures overdue
N TIUD0,TIUDATE,TIUY,TIUDPRM,TIUXTRA S TIUY=0,TIUD0=$G(^TIU(8925,TIUDA,0)),TIUXTRA=0
D DOCPRM^TIULC1(+TIUD0,.TIUDPRM,TIUDA)
I '$D(TIUDPRM) G OVERX
S TIUDATE=$S($$REQVER^TIULC(TIUDA,+$P(TIUDPRM(0),U,3)):$P($G(^TIU(8925,+TIUDA,13)),U,5),$P(TIUDPRM(0),U,2):$P($G(^TIU(8925,+TIUDA,13)),U,4),1:$P($G(^TIU(8925,+TIUDA,12)),U))
G:+TIUDATE'>0 OVERX
I $$FMDIFF^XLFDT(DT,TIUDATE)>$P(TIUPRM0,U,5),(+$P($G(^TIU(8925,+TIUDA,0)),U,5)>4),(+$P($G(^TIU(8925,+TIUDA,0)),U,5)<7) S TIUY=1 G OVERX
F S TIUXTRA=$O(^TIU(8925.7,"B",TIUDA,TIUXTRA)) Q:'TIUXTRA D
. I TIUDATE<$G(TIUSTART)!(TIUDATE>$G(TIUEND)) Q
. I '$$TSKPARM^TIUTSK(1) Q
. I $$FMDIFF^XLFDT(DT,TIUDATE)>$P(TIUPRM0,U,5),('$P($G(^TIU(8925.7,TIUXTRA,0)),U,4)) S TIUY=1,TIUADDL=1
OVERX Q TIUY
TSKPARM(TIUDA) ;Calculate a tiu parameter for the nightly task
; TIUDA = 1 then return NIGHTLY TASK START computation
; TIUDA = 2 then return NIGHTLY TASK END computation
N TIUDIV,TIUPARM,TIUY,TIUVAL
S TIUY=0
I TIUDA=2 S TIUY=DT
I TIUDA=3 D DT^DILF("P","T-12M",.TIUY)
I '$D(TIUPRM0) D SETPARM^TIULE
I '$G(TIUPRM0) Q TIUY
S TIUDIV=$P(TIUPRM0,U,1)
I '$G(TIUDIV) Q TIUY
S TIUPARM=$O(^TIU(8925.99,"B",TIUDIV,""))
I '$G(TIUPARM) Q TIUY
S TIUVAL=$P($G(^TIU(8925.99,TIUPARM,3)),U,TIUDA)
I '$G(TIUVAL) Q TIUY
D DT^DILF("P","T-"_TIUVAL,.TIUY)
Q TIUY
TIUTSK ; SLC/JER - TIU's Nightly Daemon ;4/18/03 [10/18/04 10:34am]
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**7,53,100,113,157,210,221**;Jun 20, 1997;Build 2
MAIN ; All records are read. DC date updated, Record purged, Alerts are
+1 ; generated if appropriate
+2 NEW TIUDA,TIUPRM0,TIUPRM1,TIUDATE,TIUENTDT,TIUPDT,TIUODT
+3 NEW TIUSTART,TIUEND,TIUADDL
+4 DO SETPARM^TIULE
+5 SET TIUSTART=$$TSKPARM(1)
SET TIUEND=$$TSKPARM(2)
+6 ; Traverse "FIX" X-ref to fix temporary reference dates & back-fill
+7 ; Discharge Dates
+8 SET TIUDA=""
FOR
SET TIUDA=$ORDER(^TIU(8925,"FIX",1,TIUDA))
IF TIUDA'>0
QUIT
Begin DoDot:1
+9 ;Ref Date fixed/DC Date updated if missing
DO UPDDCDT(TIUDA)
End DoDot:1
+10 ; Traverse "F" X-ref to identify records for which the grace period
+11 ; for purge has expired
+12 SET TIUPDT=$$FMADD^XLFDT(DT,-$PIECE(TIUPRM0,U,4))
+13 SET TIUODT=$$FMADD^XLFDT(DT,-$PIECE(TIUPRM0,U,5))
+14 ; Traverse "F" X-ref to identify records overdue for signature or purge
+15 ; NOTE: Following VHA Directive 10-92-077, the purge is disabled until
+16 ; further notice **53**
+17 ;VMP/ELR PATCH 221 SET UP TIUADDL IS OVERDUE ONLY BECAUSE OF ADDITIONAL SIGNER TO STOP AMENDMENT ALERT
+18 SET TIUADDL=0
+19 SET TIUENTDT=($$TSKPARM(3)-1)+.999999
+20 FOR
SET TIUENTDT=$ORDER(^TIU(8925,"F",TIUENTDT))
IF +TIUENTDT'>0!(TIUENTDT>TIUODT)
QUIT
Begin DoDot:1
+21 SET TIUDA=0
FOR
SET TIUDA=$ORDER(^TIU(8925,"F",+TIUENTDT,TIUDA))
IF +TIUDA'>0
QUIT
Begin DoDot:2
+22 ; I (TIUPDT<$$FMADD^XLFDT(DT,-90)),+$$PURGE^TIULC(TIUDA) D PURGE(TIUDA) Purges old records (see NOTE above) **53**
+23 ;Alert for overdue
IF +$$OVERDUE(TIUDA,TIUSTART,TIUEND)
DO SEND^TIUALRT(TIUDA,1)
SET TIUADDL=0
End DoDot:2
End DoDot:1
+24 ; If upload buffer rec older than 30 days, delete it & its alerts
+25 SET TIUDA=0
FOR
SET TIUDA=$ORDER(^TIU(8925.2,TIUDA))
IF TIUDA'>0
QUIT
Begin DoDot:1
+26 NEW TIUDATE
+27 SET TIUDATE=$PIECE($GET(^TIU(8925.2,TIUDA,0)),U,3)
+28 IF +TIUDATE'>0
QUIT
+29 IF $$FMDIFF^XLFDT(DT,TIUDATE)>30
Begin DoDot:2
+30 NEW TIUEI
SET TIUEI=0
+31 ; JOEL, 12/21/00:
+32 FOR
SET TIUEI=$ORDER(^TIU(8925.2,TIUDA,"ERR",TIUEI))
IF +TIUEI'>0
QUIT
Begin DoDot:3
+33 NEW TIUEDA
+34 SET TIUEDA=+$GET(^TIU(8925.2,TIUDA,"ERR",TIUEI,0))
IF +TIUEDA'>0
QUIT
+35 DO ALERTDEL^TIUPEVNT(TIUEDA)
End DoDot:3
+36 DO BUFPURGE^TIUPUTC(TIUDA)
End DoDot:2
End DoDot:1
+37 QUIT
UPDDCDT(TIUDA) ; If missing DC date & Patient Movement file has DC date,
+1 ; DC date updated.
+2 NEW DFN,DIE,DR,TIU,TIUDAD,TIUDDT,TIUD0,TIUD14,TIUDGPM
+3 SET TIUD0=$GET(^TIU(8925,+TIUDA,0))
SET TIUD14=$GET(^TIU(8925,+TIUDA,14))
+4 SET TIUDGPM=+$PIECE(TIUD14,U)
+5 IF +$PIECE($GET(^DGPM(+TIUDGPM,0)),U,17)'>0
Begin DoDot:1
+6 IF +$PIECE(TIUD0,U,12)>0
QUIT
+7 SET DIE=8925
SET DR=".12////1"
SET DA=TIUDA
DO ^DIE
End DoDot:1
QUIT
+8 IF TIUD0'=""
IF '+$PIECE(TIUD0,U,6)
IF (($PIECE(TIUD0,U,8)="")!(+$PIECE(TIUD0,U,12)>0))
Begin DoDot:1
+9 DO GETTIU^TIULD(.TIU,TIUDA)
+10 IF +$GET(TIU("LDT"))>0
Begin DoDot:2
+11 SET TIUDAD=$PIECE(TIUD0,U,6)
+12 DO FIXDC(TIUDA,TIUDAD,DFN,.TIU)
End DoDot:2
End DoDot:1
+13 QUIT
PURGE(DA) ; When purge criteria met, document and addenda purged
+1 NEW DR,DIE,TIUTYP,TIUDA,X,Y
SET TIUDA=0
+2 FOR
SET TIUDA=+$ORDER(^TIU(8925,"DAD",+DA,TIUDA))
IF +TIUDA'>0
QUIT
Begin DoDot:1
+3 IF +$$ISADDNDM^TIULC1(TIUDA)
DO PURGE(TIUDA)
IF 1
+4 ; Remove components entirely. 1/3/01 updated DIK^TIURB to DIK^TIURB2 - Margy
IF '$TEST
DO DIK^TIURB2(TIUDA)
End DoDot:1
+5 SET DIE=8925
SET DR=".05///PURGED;1609////"_$$NOW^TIULC_";2///@"
DO ^DIE
+6 SET ^TIU(8925,+DA,"TEXT",0)="^^"_2_U_2_U_DT_"^^"
+7 SET ^TIU(8925,+DA,"TEXT",1,0)=" "
+8 SET ^TIU(8925,+DA,"TEXT",2,0)=" Document Purged on "_$$DATE^TIULS(DT,"MM/DD/YY")_"."
+9 QUIT
FIXDC(DA,PARENT,DFN,TIU) ; Stuff fixed field data
+1 NEW FDA,FDARR,IENS,FLAGS,TIUMSG
+2 SET IENS=""""_DA_","""
SET FDARR="FDA(8925,"_IENS_")"
SET FLAGS="K"
+3 IF +$GET(PARENT)'>0
Begin DoDot:1
+4 SET @FDARR@(.08)=$PIECE(TIU("LDT"),U)
+5 SET @FDARR@(1402)=$PIECE($GET(TIU("TS")),U)
End DoDot:1
+6 IF +$GET(PARENT)>0
Begin DoDot:1
+7 SET @FDARR@(.08)=$PIECE(TIU("LDT"),U)
+8 SET @FDARR@(1401)=$PIECE(^TIU(8925,+PARENT,14),U)
+9 SET @FDARR@(1402)=$PIECE(^TIU(8925,+PARENT,14),U,2)
End DoDot:1
+10 SET @FDARR@(1205)=$PIECE($GET(TIU("LOC")),U)
+11 SET @FDARR@(1212)=$PIECE($GET(TIU("INST")),U)
+12 SET @FDARR@(.12)="@"
+13 SET @FDARR@(1301)=+$GET(TIU("LDT"))
+14 ; File record
DO FILE^DIE(FLAGS,"FDA","TIUMSG")
+15 QUIT
OVERDUE(TIUDA,TIUSTART,TIUEND) ;Checks whether or not a given document is overdue
+1 ;This is the same as OVERDUE^TIULC exept for the following items:
+2 ; TIUPRM0 must be defined before calling
+3 ; also checks for additional signatures overdue
+4 NEW TIUD0,TIUDATE,TIUY,TIUDPRM,TIUXTRA
SET TIUY=0
SET TIUD0=$GET(^TIU(8925,TIUDA,0))
SET TIUXTRA=0
+5 DO DOCPRM^TIULC1(+TIUD0,.TIUDPRM,TIUDA)
+6 IF '$DATA(TIUDPRM)
GOTO OVERX
+7 SET TIUDATE=$SELECT($$REQVER^TIULC(TIUDA,+$PIECE(TIUDPRM(0),U,3)):$PIECE($GET(^TIU(8925,+TIUDA,13)),U,5),$PIECE(TIUDPRM(0),U,2):$PIECE($GET(^TIU(8925,+TIUDA,13)),U,4),1:$PIECE($GET(^TIU(8925,+TIUDA,12)),U))
+8 IF +TIUDATE'>0
GOTO OVERX
+9 IF $$FMDIFF^XLFDT(DT,TIUDATE)>$PIECE(TIUPRM0,U,5)
IF (+$PIECE($GET(^TIU(8925,+TIUDA,0)),U,5)>4)
IF (+$PIECE($GET(^TIU(8925,+TIUDA,0)),U,5)<7)
SET TIUY=1
GOTO OVERX
+10 FOR
SET TIUXTRA=$ORDER(^TIU(8925.7,"B",TIUDA,TIUXTRA))
IF 'TIUXTRA
QUIT
Begin DoDot:1
+11 IF TIUDATE<$GET(TIUSTART)!(TIUDATE>$GET(TIUEND))
QUIT
+12 IF '$$TSKPARM^TIUTSK(1)
QUIT
+13 IF $$FMDIFF^XLFDT(DT,TIUDATE)>$PIECE(TIUPRM0,U,5)
IF ('$PIECE($GET(^TIU(8925.7,TIUXTRA,0)),U,4))
SET TIUY=1
SET TIUADDL=1
End DoDot:1
OVERX QUIT TIUY
TSKPARM(TIUDA) ;Calculate a tiu parameter for the nightly task
+1 ; TIUDA = 1 then return NIGHTLY TASK START computation
+2 ; TIUDA = 2 then return NIGHTLY TASK END computation
+3 NEW TIUDIV,TIUPARM,TIUY,TIUVAL
+4 SET TIUY=0
+5 IF TIUDA=2
SET TIUY=DT
+6 IF TIUDA=3
DO DT^DILF("P","T-12M",.TIUY)
+7 IF '$DATA(TIUPRM0)
DO SETPARM^TIULE
+8 IF '$GET(TIUPRM0)
QUIT TIUY
+9 SET TIUDIV=$PIECE(TIUPRM0,U,1)
+10 IF '$GET(TIUDIV)
QUIT TIUY
+11 SET TIUPARM=$ORDER(^TIU(8925.99,"B",TIUDIV,""))
+12 IF '$GET(TIUPARM)
QUIT TIUY
+13 SET TIUVAL=$PIECE($GET(^TIU(8925.99,TIUPARM,3)),U,TIUDA)
+14 IF '$GET(TIUVAL)
QUIT TIUY
+15 DO DT^DILF("P","T-"_TIUVAL,.TIUY)
+16 QUIT TIUY
