TIUTSK ; SLC/JER - TIU's Nightly Daemon ;01/30/23 14:09
;;1.0;TEXT INTEGRATION UTILITIES;**7,53,100,113,157,210,221,355**;Jun 20, 1997;Build 11
;
Q
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)) ; grace period for purge (obsolete)
S TIUODT=$$FMADD^XLFDT(DT,-$P(TIUPRM0,U,5)) ; grace period for signature
; 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 ; length of signer alert period
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 ; additional signer alerts were NOT sent if START OF ADD SGNR ALERT PERIOD was not set
. ; sites reported additional signer alerts not being sent as OVERDUE as patient safety, START OF ADD SGNR ALERT PERIOD defaults to 12M
. 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 return START OF ADD SGNR ALERT PERIOD computation
; TIUDA = 2 return END OF ADD SGNR ALERT PERIOD computation
; TIUDA = 3 return LENGTH OF SIGNER ALERT PERIOD computation
N TIUDIV,TIUPARM,TIUY,TIUVAL
S TIUY=0
I TIUDA=1 D DT^DILF("P","T-7D",.TIUY) ; *355 - default to 30 days
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUTSK 5802 printed Dec 13, 2024@02:46:20 Page 2
TIUTSK ; SLC/JER - TIU's Nightly Daemon ;01/30/23 14:09
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**7,53,100,113,157,210,221,355**;Jun 20, 1997;Build 11
+2 ;
+3 QUIT
MAIN ;
+1 ; All records are read. DC date updated, Record purged, Alerts are
+2 ; generated if appropriate
+3 NEW TIUDA,TIUPRM0,TIUPRM1,TIUDATE,TIUENTDT,TIUPDT,TIUODT
+4 NEW TIUSTART,TIUEND,TIUADDL
+5 DO SETPARM^TIULE
+6 SET TIUSTART=$$TSKPARM(1)
SET TIUEND=$$TSKPARM(2)
+7 ; Traverse "FIX" X-ref to fix temporary reference dates & back-fill
+8 ; Discharge Dates
+9 SET TIUDA=""
FOR
SET TIUDA=$ORDER(^TIU(8925,"FIX",1,TIUDA))
if TIUDA'>0
QUIT
Begin DoDot:1
+10 ;Ref Date fixed/DC Date updated if missing
DO UPDDCDT(TIUDA)
End DoDot:1
+11 ; Traverse "F" X-ref to identify records for which the grace period
+12 ; for purge has expired
+13 ; grace period for purge (obsolete)
SET TIUPDT=$$FMADD^XLFDT(DT,-$PIECE(TIUPRM0,U,4))
+14 ; grace period for signature
SET TIUODT=$$FMADD^XLFDT(DT,-$PIECE(TIUPRM0,U,5))
+15 ; Traverse "F" X-ref to identify records overdue for signature or purge
+16 ; NOTE: Following VHA Directive 10-92-077, the purge is disabled until
+17 ; further notice **53**
+18 ;VMP/ELR PATCH 221 SET UP TIUADDL IS OVERDUE ONLY BECAUSE OF ADDITIONAL SIGNER TO STOP AMENDMENT ALERT
+19 SET TIUADDL=0
+20 ; length of signer alert period
SET TIUENTDT=($$TSKPARM(3)-1)+.999999
+21 FOR
SET TIUENTDT=$ORDER(^TIU(8925,"F",TIUENTDT))
if +TIUENTDT'>0!(TIUENTDT>TIUODT)
QUIT
Begin DoDot:1
+22 SET TIUDA=0
FOR
SET TIUDA=$ORDER(^TIU(8925,"F",+TIUENTDT,TIUDA))
if +TIUDA'>0
QUIT
Begin DoDot:2
+23 ; I (TIUPDT<$$FMADD^XLFDT(DT,-90)),+$$PURGE^TIULC(TIUDA) D PURGE(TIUDA) Purges old records (see NOTE above) **53**
+24 ;Alert for overdue
IF +$$OVERDUE(TIUDA,TIUSTART,TIUEND)
DO SEND^TIUALRT(TIUDA,1)
SET TIUADDL=0
End DoDot:2
End DoDot:1
+25 ; If upload buffer rec older than 30 days, delete it & its alerts
+26 SET TIUDA=0
FOR
SET TIUDA=$ORDER(^TIU(8925.2,TIUDA))
if TIUDA'>0
QUIT
Begin DoDot:1
+27 NEW TIUDATE
+28 SET TIUDATE=$PIECE($GET(^TIU(8925.2,TIUDA,0)),U,3)
+29 if +TIUDATE'>0
QUIT
+30 IF $$FMDIFF^XLFDT(DT,TIUDATE)>30
Begin DoDot:2
+31 NEW TIUEI
SET TIUEI=0
+32 ; JOEL, 12/21/00:
+33 FOR
SET TIUEI=$ORDER(^TIU(8925.2,TIUDA,"ERR",TIUEI))
if +TIUEI'>0
QUIT
Begin DoDot:3
+34 NEW TIUEDA
+35 SET TIUEDA=+$GET(^TIU(8925.2,TIUDA,"ERR",TIUEI,0))
if +TIUEDA'>0
QUIT
+36 DO ALERTDEL^TIUPEVNT(TIUEDA)
End DoDot:3
+37 DO BUFPURGE^TIUPUTC(TIUDA)
End DoDot:2
End DoDot:1
+38 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 ; I '$$TSKPARM^TIUTSK(1) Q ; additional signer alerts were NOT sent if START OF ADD SGNR ALERT PERIOD was not set
+13 ; sites reported additional signer alerts not being sent as OVERDUE as patient safety, START OF ADD SGNR ALERT PERIOD defaults to 12M
+14 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 return START OF ADD SGNR ALERT PERIOD computation
+2 ; TIUDA = 2 return END OF ADD SGNR ALERT PERIOD computation
+3 ; TIUDA = 3 return LENGTH OF SIGNER ALERT PERIOD computation
+4 NEW TIUDIV,TIUPARM,TIUY,TIUVAL
+5 SET TIUY=0
+6 ; *355 - default to 30 days
IF TIUDA=1
DO DT^DILF("P","T-7D",.TIUY)
+7 IF TIUDA=2
SET TIUY=DT
+8 IF TIUDA=3
DO DT^DILF("P","T-12M",.TIUY)
+9 IF '$DATA(TIUPRM0)
DO SETPARM^TIULE
+10 IF '$GET(TIUPRM0)
QUIT TIUY
+11 SET TIUDIV=$PIECE(TIUPRM0,U,1)
+12 IF '$GET(TIUDIV)
QUIT TIUY
+13 SET TIUPARM=$ORDER(^TIU(8925.99,"B",TIUDIV,""))
+14 IF '$GET(TIUPARM)
QUIT TIUY
+15 SET TIUVAL=$PIECE($GET(^TIU(8925.99,TIUPARM,3)),U,TIUDA)
+16 IF '$GET(TIUVAL)
QUIT TIUY
+17 DO DT^DILF("P","T-"_TIUVAL,.TIUY)
+18 QUIT TIUY
