HLUOPT4 ;OIFO-O/LJA - Purging Entries in file #772 and #773 ;02/04/2004 16:37
;;1.6;HEALTH LEVEL SEVEN;**109**;Oct 13, 1995
;
; This routine was created by patch HL*1.6*109
;
SHOW120 ; Call SHOWXTMP with 30 second redisplay...
D SHOWXTMP(120)
QUIT
;
ASKSHOW ; Ask whether want to monitor purging job progress...
N ACTION,XTMP
S XTMP=$O(^XTMP("HLUOPT1 9999999.999999"),-1) QUIT:XTMP'["HLUOPT1 " ;->
W !!,"As purging jobs run, they record critical information in the ^XTMP global for"
W !,"later review. (This information is updated every two minutes.) You can view"
W !,"purge information now..."
F S ACTION=$$ACTION QUIT:'ACTION D
. I ACTION=1 D SHOWALL^HLUOPT5(XTMP)
. I ACTION=2 D SHOWXTMP(120)
. I ACTION=3 D
. . W @IOF
. . D GRAPH^HLUOPT5
. . S X=$$BTE^HLCSMON("Press RETURN to continue... ",1)
QUIT
;
ACTION() ;
N DIR,DIRUT,DTOUT,DUOUT,X,Y
S DIR(0)="S^1:Display all available purging data (full screen);2:Display purging summary (single line);3:Display purging graph;4:Exit."
S DIR("?",1)="Option #1 displays all available purging data, for the last job."
S DIR("?",2)=""
S DIR("?",3)="Option #2 displays the most valuable purging data, but not all data. This"
S DIR("?",4)="option includes data for the last purging job, plus previous puring jobs."
S DIR("?",5)=""
S DIR("?")="Option #3 displays purging times and totals in a graphic representation."
D ^DIR
QUIT $S(+Y=1:1,+Y=2:2,+Y=3:3,1:"")
;
SHOWXTMP(SEC) ; Continual redisplay of purging progress ever SEC seconds...
N ABORT,ACTIVE,HDR,IOINHI,IOINORM,X,XTMP
;
S X="IOINHI;IOINORM" D ENDR^%ZISS
S HDR=" Task-Number Start-Time Timestamp Finish-time 772@ 773@ Time-NOW"
;
; Get last purging process' XTMP...
S XTMP=$O(^XTMP("HLUOPT1 9999999.999999"),-1)
S ACTIVE=0 ; Default...
I XTMP]"" S X=$P($G(^XTMP(XTMP,"RUN")),U,4) I X'?7N.E S ACTIVE=1
;
; Show last 10 runs...
D SHOWNUM($S(ACTIVE:9,1:18))
;
; Redisplay SEC defaults to 30...
S SEC=$S($G(SEC)>0:+SEC,1:30)
;
; What if no purging process exists?
I XTMP']""!('ACTIVE) D QUIT ;->
. W !!,"There is no currently running purge job..."
. S X=$$BTE^HLCSMON("Press RETURN to exit... ",1)
;
W !!,"Any old jobs that exist will be shown above. The current (or last) purge job"
W !,"is shown below. The information on each line will automatically refresh"
W !,"every ",SEC," seconds (or whenever you press RETURN.)"
W !!,IOINHI,"Note!!",IOINORM," Enter '^' when you are ready to exit."
W !!,"Current (or last) purge job..."
W !
S CT=0
;
F D QUIT:ABORT
. S ABORT=1,CT=CT+1
. D LINERUN(XTMP)
. R X:SEC QUIT:X]"" ;-> Quit if they enter anything
. I CT>17 W ! S CT=0
. S ABORT=0
;
QUIT
;
SHOWNUM(NUM) ; Show last NUM entries...
N CT,HOLD,XTMP
; ACTIVE -- req
S XTMP="HLUOPT1 9999999.99999"
; If last job is active, don't include it in array...
I ACTIVE S XTMP=$O(^XTMP(XTMP),-1) QUIT:XTMP'["HLUOPT1 " ;->
S CT=0
F S XTMP=$O(^XTMP(XTMP),-1) Q:(CT>(NUM-1))!(XTMP'["HLUOPT1 ") D
. S CT=CT+1
. S HOLD(XTMP)=""
QUIT:'$D(HOLD) ;->
W !!,"Recent purge runs..."
W !!,HDR,!,$$REPEAT^XLFSTR("-",IOM)
S XTMP=""
F S XTMP=$O(HOLD(XTMP)) Q:XTMP']"" D
. D LINERUN(XTMP)
QUIT
;
LINERUN(XTMP) ; Display one line...
N I,PCE1,PCE2,PCE3,PCE4,PCE5,PCE6,PCE7,PCE8,PCE9,PCE10,PCE11
N PCE12,PCE13,PCE14
S RUN=$G(^XTMP(XTMP,"RUN"))
F I=1:1:14 S @("PCE"_I)=$P(RUN,U,I)
S PCE2=$$SDT(PCE2),PCE3=$$SDT(PCE3),PCE4=$$SDT(PCE4)
I ($P(PCE2,"@"))=$$SDT(DT) S PCE3=" "_$P(PCE3,"@",2)
I ($P(PCE2,"@"))=$$SDT(DT) S PCE4=" "_$P(PCE4,"@",2)
I CT=1 W !,HDR,!,$$REPEAT^XLFSTR("-",IOM)
W !,$J(PCE1,12),?14,PCE2,?26,PCE3,?38,PCE4,?50,$J(PCE8,8)
W ?59,$J(PCE10,8)
W ?69,$$SDT($$NOW^XLFDT)
QUIT
;
SDT(DATE) ; Return shortened form of date...
I DATE?7N QUIT $E(DATE,4,5)_"/"_$E(DATE,6,7) ;->
I DATE?7N1"."1.N QUIT $E(DATE,4,5)_"/"_$E(DATE,6,7)_"@"_$E($P($$FMTE^XLFDT(DATE),"@",2),1,5)
QUIT ""
;
XTMPBEGN ; Initialize ^XTMP nodes for use in purging monitoring...
N NOW
S NOW=$$NOW^XLFDT,XTMP="HLUOPT1 "_NOW
S ^XTMP(XTMP,0)=$$FMADD^XLFDT(NOW,14)_U_NOW_U_$G(DUZ)_U_"HLUOPT1 Purging"
S ^XTMP(XTMP,"RUN")=$G(ZTSK)_U_NOW_U_NOW_U_U_"RUNNING"_U_"XTMPBEGN"
QUIT
;
XTMPUPD(XTMP,STATUS,WHERE) ; Update the data in purging's ^XTMP...
N NOW,RUN
;
; Required variables...
S NOW=$$NOW^XLFDT
;
; Update node...
S RUN=$G(^XTMP(XTMP,"RUN"))
S $P(RUN,U,3)=$$NOW^XLFDT ; Timestamp
I STATUS="FINISHED"!(STATUS["ABORTED") S $P(RUN,U,4)=NOW ; Finish time
S $P(RUN,U,5)=STATUS ; Status
S $P(RUN,U,6)=WHERE ; Whereabouts
S $P(RUN,U,7)=$G(XTMP(772,"REV")) ; # 772 reviewed
S $P(RUN,U,8)=$G(XTMP(772,"DEL")) ; # 772 deleted
S $P(RUN,U,9)=$G(XTMP(773,"REV")) ; # 773 reviewed
S $P(RUN,U,10)=$G(XTMP(773,"DEL")) ;# 773 deleted
S $P(RUN,U,11)=$G(XTMP(772,"LAST")) ; Last 772 IEN
S $P(RUN,U,12)=$G(XTMP(772,"FAIL")) ; # failed purge check (in a row)
S $P(RUN,U,13)=$G(XTMP(773,"LAST")) ; Last 773 IEN
S $P(RUN,U,14)=$G(XTMP(773,"FAIL")) ; # failed purge check (in a row)
S $P(RUN,U,15)=$G(XTMP(772,"LAST","TIME")) ; Last 772s .01 time
S $P(RUN,U,16)=$G(XTMP(773,"LAST","TIME")) ; Last 773's 772s .01 time
S ^XTMP(XTMP,"RUN")=RUN
;
QUIT
;
LOCKTELL ; Process is locked, so new purge job can't be started...
N X
W !!,"The '^HL(""HLUOPT1"")' lock is already owned by another purge job! So, this"
W !,"purge job cannot be started."
S X=$$BTE^HLCSMON("Press RETURN to exit... ",1)
QUIT
;
INIT ; Moved here from HLUOPT1 (ran out of room)
; If no data are stored in file 869.3, fields 41, 42, and 43,
; the default number for these fields is 7, 30, 90, respectively.
N I,HLIEN,HLREC,HLDEF
S HLDEF="7^30^90^90"
S HLIEN=+$O(^HLCS(869.3,0))
S HLREC=$S(HLIEN:$G(^HLCS(869.3,HLIEN,4)),1:"")
F I=1:1:4 I '$P(HLREC,U,I) S $P(HLREC,U,I)=$P(HLDEF,U,I)
;
; If AWAITING ACK<COMPLETED -- or -- AWAITING ACK > ALL -- or -- PURGE < ALL use the default values (for an invalid date(s) has been entered into the paramters)
I $P(HLREC,U,2)<$P(HLREC,U,1)!($P(HLREC,U,3)<$P(HLREC,U,2))!($P(HLREC,U,3)>$P(HLREC,U,4)) D
. S HLREC=HLDEF
;
I $D(ZTQUEUED) D Q
. S HLPDT("COMP")=$$FMADD^XLFDT(DT,-$P(HLREC,U,1))_.9
. S HLPDT("WAIT")=$$FMADD^XLFDT(DT,-$P(HLREC,U,2))_.9
. S HLPDT("ALL")=$$FMADD^XLFDT(DT,-$P(HLREC,U,3))_.9
. S HLPDT("ERR")=$$FMADD^XLFDT(DT,-$P(HLREC,U,4))_.9
;
; get input data from user
N DIR,X,Y,DIRUT
; input cutoff date for "Successfully Completed" messages
S DIR(0)="D^:"_$$FMADD^XLFDT(DT,-1)_":EX"
S DIR("A",1)=" Enter inclusive date up to which to purge SUCCESSFULLY COMPLETED"
S DIR("A")=" messages"
S DIR("B")="T"_-$P(HLREC,U,1)
S DIR("?",1)=" The suggested cutoff date to purge 'Successfully Completed' messages"
S DIR("?",2)=" is seven days prior to today."
S DIR("?")=" Must be on or before "_$$FMTE^XLFDT($$FMADD^XLFDT(DT,-1),2)_"."
W ! D ^DIR I $D(DIRUT) S HLEXIT=1 Q
S HLPDT("COMP")=Y
K DIR
;
; input cutoff date for "Awaiting Acknowledgement" messages
S DIR(0)="D^:"_HLPDT("COMP")_":EX"
S DIR("A",1)=" Enter inclusive date up to which to purge AWAITING ACK"
S DIR("A")=" messages"
S DIR("B")="T"_-$P(HLREC,U,2)
S DIR("?",1)=" The suggested cutoff date to purge 'Awaiting Acknowledgment' messages"
S DIR("?",2)=" is thirty days prior to today."
S DIR("?")=" Must be on or before "_$$FMTE^XLFDT(HLPDT("COMP"),2)_"."
W ! D ^DIR I $D(DIRUT) S HLEXIT=1 Q
S HLPDT("WAIT")=Y
K DIR
;
; Input for Vaporization Date
S DIR(0)="D^:"_HLPDT("WAIT")_":EX"
S DIR("A",1)=" Enter inclusive date up to which to purge all messages, regardless"
S DIR("A")=" of status (except ERROR status)"
S DIR("B")="T"_-$P(HLREC,U,3)
S DIR("?",1)=" The suggested cutoff date to purge all messages (except for 'Error' messages)"
S DIR("?",2)=" is 90 days prior to today."
S DIR("?")=" Must be on or before "_$$FMTE^XLFDT(HLPDT("WAIT"),2)_"."
W ! D ^DIR I $D(DIRUT) S HLEXIT=1 Q
S HLPDT("ALL")=Y+.9
K DIR
;
; prompt whether to purge "Error" messages
S DIR(0)="Y"
S DIR("A")=" Do you also want to purge messages with an ERROR status"
S DIR("B")="NO"
S DIR("?",1)=" Enter 'Yes' to purge entries whose status is 'error'."
S DIR("?",2)=" If you have reviewed/resolved the cause of the problem of those",DIR("?")=" entries with an 'error' status answer 'Yes'. Otherwise answer 'No'."
W ! D ^DIR I $D(DIRUT) S HLEXIT=1 Q
K DIR
I 'Y S HLPDT("ERR")=0
E D Q:HLEXIT
. ; input cutoff date for "Error" messages
. S DIR(0)="D^:"_HLPDT("WAIT")_":EX"
. S DIR("A",1)=" WARNING: You should have investigated all errors because purging"
. S DIR("A",2)=" these messages permanently removes them from the system."
. S DIR("A",3)=" "
. S DIR("A",4)=" Enter inclusive date up to which to purge ERROR"
. S DIR("A")=" messages"
. S DIR("B")="T"_-$P(HLREC,U,4)
. S DIR("?",1)=" The suggested cutoff date to purge 'Error' messages"
. S DIR("?",2)=" is 90 days prior to today."
. S DIR("?")=" Must be on or before "_$$FMTE^XLFDT(HLPDT("WAIT"),2)_"."
. W ! D ^DIR I $D(DIRUT) S HLEXIT=1 Q
. S HLPDT("ERR")=Y+.9
. K DIR
;
; prompt whether to run this purge in the background
S DIR(0)="YA"
S DIR("A")=" Would you like to queue this purge? "
S DIR("B")="YES"
S DIR("?")=" If run in the foreground, you will see dots and a total count."
W ! D ^DIR I $D(DIRUT) S HLEXIT=1 Q
S HLTASK=Y
K DIR
W !," "
;
S HLPDT("COMP")=HLPDT("COMP")+.9,HLPDT("WAIT")=HLPDT("WAIT")+.9
Q
;
EOR ;HLUOPT4 - Purging Entries in file #772 and #773 ;12/10/02 16:37
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLUOPT4 9683 printed Sep 23, 2025@19:36:28 Page 2
HLUOPT4 ;OIFO-O/LJA - Purging Entries in file #772 and #773 ;02/04/2004 16:37
+1 ;;1.6;HEALTH LEVEL SEVEN;**109**;Oct 13, 1995
+2 ;
+3 ; This routine was created by patch HL*1.6*109
+4 ;
SHOW120 ; Call SHOWXTMP with 30 second redisplay...
+1 DO SHOWXTMP(120)
+2 QUIT
+3 ;
ASKSHOW ; Ask whether want to monitor purging job progress...
+1 NEW ACTION,XTMP
+2 ;->
SET XTMP=$ORDER(^XTMP("HLUOPT1 9999999.999999"),-1)
if XTMP'["HLUOPT1 "
QUIT
+3 WRITE !!,"As purging jobs run, they record critical information in the ^XTMP global for"
+4 WRITE !,"later review. (This information is updated every two minutes.) You can view"
+5 WRITE !,"purge information now..."
+6 FOR
SET ACTION=$$ACTION
if 'ACTION
QUIT
Begin DoDot:1
+7 IF ACTION=1
DO SHOWALL^HLUOPT5(XTMP)
+8 IF ACTION=2
DO SHOWXTMP(120)
+9 IF ACTION=3
Begin DoDot:2
+10 WRITE @IOF
+11 DO GRAPH^HLUOPT5
+12 SET X=$$BTE^HLCSMON("Press RETURN to continue... ",1)
End DoDot:2
End DoDot:1
+13 QUIT
+14 ;
ACTION() ;
+1 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
+2 SET DIR(0)="S^1:Display all available purging data (full screen);2:Display purging summary (single line);3:Display purging graph;4:Exit."
+3 SET DIR("?",1)="Option #1 displays all available purging data, for the last job."
+4 SET DIR("?",2)=""
+5 SET DIR("?",3)="Option #2 displays the most valuable purging data, but not all data. This"
+6 SET DIR("?",4)="option includes data for the last purging job, plus previous puring jobs."
+7 SET DIR("?",5)=""
+8 SET DIR("?")="Option #3 displays purging times and totals in a graphic representation."
+9 DO ^DIR
+10 QUIT $SELECT(+Y=1:1,+Y=2:2,+Y=3:3,1:"")
+11 ;
SHOWXTMP(SEC) ; Continual redisplay of purging progress ever SEC seconds...
+1 NEW ABORT,ACTIVE,HDR,IOINHI,IOINORM,X,XTMP
+2 ;
+3 SET X="IOINHI;IOINORM"
DO ENDR^%ZISS
+4 SET HDR=" Task-Number Start-Time Timestamp Finish-time 772@ 773@ Time-NOW"
+5 ;
+6 ; Get last purging process' XTMP...
+7 SET XTMP=$ORDER(^XTMP("HLUOPT1 9999999.999999"),-1)
+8 ; Default...
SET ACTIVE=0
+9 IF XTMP]""
SET X=$PIECE($GET(^XTMP(XTMP,"RUN")),U,4)
IF X'?7N.E
SET ACTIVE=1
+10 ;
+11 ; Show last 10 runs...
+12 DO SHOWNUM($SELECT(ACTIVE:9,1:18))
+13 ;
+14 ; Redisplay SEC defaults to 30...
+15 SET SEC=$SELECT($GET(SEC)>0:+SEC,1:30)
+16 ;
+17 ; What if no purging process exists?
+18 ;->
IF XTMP']""!('ACTIVE)
Begin DoDot:1
+19 WRITE !!,"There is no currently running purge job..."
+20 SET X=$$BTE^HLCSMON("Press RETURN to exit... ",1)
End DoDot:1
QUIT
+21 ;
+22 WRITE !!,"Any old jobs that exist will be shown above. The current (or last) purge job"
+23 WRITE !,"is shown below. The information on each line will automatically refresh"
+24 WRITE !,"every ",SEC," seconds (or whenever you press RETURN.)"
+25 WRITE !!,IOINHI,"Note!!",IOINORM," Enter '^' when you are ready to exit."
+26 WRITE !!,"Current (or last) purge job..."
+27 WRITE !
+28 SET CT=0
+29 ;
+30 FOR
Begin DoDot:1
+31 SET ABORT=1
SET CT=CT+1
+32 DO LINERUN(XTMP)
+33 ;-> Quit if they enter anything
READ X:SEC
if X]""
QUIT
+34 IF CT>17
WRITE !
SET CT=0
+35 SET ABORT=0
End DoDot:1
if ABORT
QUIT
+36 ;
+37 QUIT
+38 ;
SHOWNUM(NUM) ; Show last NUM entries...
+1 NEW CT,HOLD,XTMP
+2 ; ACTIVE -- req
+3 SET XTMP="HLUOPT1 9999999.99999"
+4 ; If last job is active, don't include it in array...
+5 ;->
IF ACTIVE
SET XTMP=$ORDER(^XTMP(XTMP),-1)
if XTMP'["HLUOPT1 "
QUIT
+6 SET CT=0
+7 FOR
SET XTMP=$ORDER(^XTMP(XTMP),-1)
if (CT>(NUM-1))!(XTMP'["HLUOPT1 ")
QUIT
Begin DoDot:1
+8 SET CT=CT+1
+9 SET HOLD(XTMP)=""
End DoDot:1
+10 ;->
if '$DATA(HOLD)
QUIT
+11 WRITE !!,"Recent purge runs..."
+12 WRITE !!,HDR,!,$$REPEAT^XLFSTR("-",IOM)
+13 SET XTMP=""
+14 FOR
SET XTMP=$ORDER(HOLD(XTMP))
if XTMP']""
QUIT
Begin DoDot:1
+15 DO LINERUN(XTMP)
End DoDot:1
+16 QUIT
+17 ;
LINERUN(XTMP) ; Display one line...
+1 NEW I,PCE1,PCE2,PCE3,PCE4,PCE5,PCE6,PCE7,PCE8,PCE9,PCE10,PCE11
+2 NEW PCE12,PCE13,PCE14
+3 SET RUN=$GET(^XTMP(XTMP,"RUN"))
+4 FOR I=1:1:14
SET @("PCE"_I)=$PIECE(RUN,U,I)
+5 SET PCE2=$$SDT(PCE2)
SET PCE3=$$SDT(PCE3)
SET PCE4=$$SDT(PCE4)
+6 IF ($PIECE(PCE2,"@"))=$$SDT(DT)
SET PCE3=" "_$PIECE(PCE3,"@",2)
+7 IF ($PIECE(PCE2,"@"))=$$SDT(DT)
SET PCE4=" "_$PIECE(PCE4,"@",2)
+8 IF CT=1
WRITE !,HDR,!,$$REPEAT^XLFSTR("-",IOM)
+9 WRITE !,$JUSTIFY(PCE1,12),?14,PCE2,?26,PCE3,?38,PCE4,?50,$JUSTIFY(PCE8,8)
+10 WRITE ?59,$JUSTIFY(PCE10,8)
+11 WRITE ?69,$$SDT($$NOW^XLFDT)
+12 QUIT
+13 ;
SDT(DATE) ; Return shortened form of date...
+1 ;->
IF DATE?7N
QUIT $EXTRACT(DATE,4,5)_"/"_$EXTRACT(DATE,6,7)
+2 IF DATE?7N1"."1.N
QUIT $EXTRACT(DATE,4,5)_"/"_$EXTRACT(DATE,6,7)_"@"_$EXTRACT($PIECE($$FMTE^XLFDT(DATE),"@",2),1,5)
+3 QUIT ""
+4 ;
XTMPBEGN ; Initialize ^XTMP nodes for use in purging monitoring...
+1 NEW NOW
+2 SET NOW=$$NOW^XLFDT
SET XTMP="HLUOPT1 "_NOW
+3 SET ^XTMP(XTMP,0)=$$FMADD^XLFDT(NOW,14)_U_NOW_U_$GET(DUZ)_U_"HLUOPT1 Purging"
+4 SET ^XTMP(XTMP,"RUN")=$GET(ZTSK)_U_NOW_U_NOW_U_U_"RUNNING"_U_"XTMPBEGN"
+5 QUIT
+6 ;
XTMPUPD(XTMP,STATUS,WHERE) ; Update the data in purging's ^XTMP...
+1 NEW NOW,RUN
+2 ;
+3 ; Required variables...
+4 SET NOW=$$NOW^XLFDT
+5 ;
+6 ; Update node...
+7 SET RUN=$GET(^XTMP(XTMP,"RUN"))
+8 ; Timestamp
SET $PIECE(RUN,U,3)=$$NOW^XLFDT
+9 ; Finish time
IF STATUS="FINISHED"!(STATUS["ABORTED")
SET $PIECE(RUN,U,4)=NOW
+10 ; Status
SET $PIECE(RUN,U,5)=STATUS
+11 ; Whereabouts
SET $PIECE(RUN,U,6)=WHERE
+12 ; # 772 reviewed
SET $PIECE(RUN,U,7)=$GET(XTMP(772,"REV"))
+13 ; # 772 deleted
SET $PIECE(RUN,U,8)=$GET(XTMP(772,"DEL"))
+14 ; # 773 reviewed
SET $PIECE(RUN,U,9)=$GET(XTMP(773,"REV"))
+15 ;# 773 deleted
SET $PIECE(RUN,U,10)=$GET(XTMP(773,"DEL"))
+16 ; Last 772 IEN
SET $PIECE(RUN,U,11)=$GET(XTMP(772,"LAST"))
+17 ; # failed purge check (in a row)
SET $PIECE(RUN,U,12)=$GET(XTMP(772,"FAIL"))
+18 ; Last 773 IEN
SET $PIECE(RUN,U,13)=$GET(XTMP(773,"LAST"))
+19 ; # failed purge check (in a row)
SET $PIECE(RUN,U,14)=$GET(XTMP(773,"FAIL"))
+20 ; Last 772s .01 time
SET $PIECE(RUN,U,15)=$GET(XTMP(772,"LAST","TIME"))
+21 ; Last 773's 772s .01 time
SET $PIECE(RUN,U,16)=$GET(XTMP(773,"LAST","TIME"))
+22 SET ^XTMP(XTMP,"RUN")=RUN
+23 ;
+24 QUIT
+25 ;
LOCKTELL ; Process is locked, so new purge job can't be started...
+1 NEW X
+2 WRITE !!,"The '^HL(""HLUOPT1"")' lock is already owned by another purge job! So, this"
+3 WRITE !,"purge job cannot be started."
+4 SET X=$$BTE^HLCSMON("Press RETURN to exit... ",1)
+5 QUIT
+6 ;
INIT ; Moved here from HLUOPT1 (ran out of room)
+1 ; If no data are stored in file 869.3, fields 41, 42, and 43,
+2 ; the default number for these fields is 7, 30, 90, respectively.
+3 NEW I,HLIEN,HLREC,HLDEF
+4 SET HLDEF="7^30^90^90"
+5 SET HLIEN=+$ORDER(^HLCS(869.3,0))
+6 SET HLREC=$SELECT(HLIEN:$GET(^HLCS(869.3,HLIEN,4)),1:"")
+7 FOR I=1:1:4
IF '$PIECE(HLREC,U,I)
SET $PIECE(HLREC,U,I)=$PIECE(HLDEF,U,I)
+8 ;
+9 ; If AWAITING ACK<COMPLETED -- or -- AWAITING ACK > ALL -- or -- PURGE < ALL use the default values (for an invalid date(s) has been entered into the paramters)
+10 IF $PIECE(HLREC,U,2)<$PIECE(HLREC,U,1)!($PIECE(HLREC,U,3)<$PIECE(HLREC,U,2))!($PIECE(HLREC,U,3)>$PIECE(HLREC,U,4))
Begin DoDot:1
+11 SET HLREC=HLDEF
End DoDot:1
+12 ;
+13 IF $DATA(ZTQUEUED)
Begin DoDot:1
+14 SET HLPDT("COMP")=$$FMADD^XLFDT(DT,-$PIECE(HLREC,U,1))_.9
+15 SET HLPDT("WAIT")=$$FMADD^XLFDT(DT,-$PIECE(HLREC,U,2))_.9
+16 SET HLPDT("ALL")=$$FMADD^XLFDT(DT,-$PIECE(HLREC,U,3))_.9
+17 SET HLPDT("ERR")=$$FMADD^XLFDT(DT,-$PIECE(HLREC,U,4))_.9
End DoDot:1
QUIT
+18 ;
+19 ; get input data from user
+20 NEW DIR,X,Y,DIRUT
+21 ; input cutoff date for "Successfully Completed" messages
+22 SET DIR(0)="D^:"_$$FMADD^XLFDT(DT,-1)_":EX"
+23 SET DIR("A",1)=" Enter inclusive date up to which to purge SUCCESSFULLY COMPLETED"
+24 SET DIR("A")=" messages"
+25 SET DIR("B")="T"_-$PIECE(HLREC,U,1)
+26 SET DIR("?",1)=" The suggested cutoff date to purge 'Successfully Completed' messages"
+27 SET DIR("?",2)=" is seven days prior to today."
+28 SET DIR("?")=" Must be on or before "_$$FMTE^XLFDT($$FMADD^XLFDT(DT,-1),2)_"."
+29 WRITE !
DO ^DIR
IF $DATA(DIRUT)
SET HLEXIT=1
QUIT
+30 SET HLPDT("COMP")=Y
+31 KILL DIR
+32 ;
+33 ; input cutoff date for "Awaiting Acknowledgement" messages
+34 SET DIR(0)="D^:"_HLPDT("COMP")_":EX"
+35 SET DIR("A",1)=" Enter inclusive date up to which to purge AWAITING ACK"
+36 SET DIR("A")=" messages"
+37 SET DIR("B")="T"_-$PIECE(HLREC,U,2)
+38 SET DIR("?",1)=" The suggested cutoff date to purge 'Awaiting Acknowledgment' messages"
+39 SET DIR("?",2)=" is thirty days prior to today."
+40 SET DIR("?")=" Must be on or before "_$$FMTE^XLFDT(HLPDT("COMP"),2)_"."
+41 WRITE !
DO ^DIR
IF $DATA(DIRUT)
SET HLEXIT=1
QUIT
+42 SET HLPDT("WAIT")=Y
+43 KILL DIR
+44 ;
+45 ; Input for Vaporization Date
+46 SET DIR(0)="D^:"_HLPDT("WAIT")_":EX"
+47 SET DIR("A",1)=" Enter inclusive date up to which to purge all messages, regardless"
+48 SET DIR("A")=" of status (except ERROR status)"
+49 SET DIR("B")="T"_-$PIECE(HLREC,U,3)
+50 SET DIR("?",1)=" The suggested cutoff date to purge all messages (except for 'Error' messages)"
+51 SET DIR("?",2)=" is 90 days prior to today."
+52 SET DIR("?")=" Must be on or before "_$$FMTE^XLFDT(HLPDT("WAIT"),2)_"."
+53 WRITE !
DO ^DIR
IF $DATA(DIRUT)
SET HLEXIT=1
QUIT
+54 SET HLPDT("ALL")=Y+.9
+55 KILL DIR
+56 ;
+57 ; prompt whether to purge "Error" messages
+58 SET DIR(0)="Y"
+59 SET DIR("A")=" Do you also want to purge messages with an ERROR status"
+60 SET DIR("B")="NO"
+61 SET DIR("?",1)=" Enter 'Yes' to purge entries whose status is 'error'."
+62 SET DIR("?",2)=" If you have reviewed/resolved the cause of the problem of those"
SET DIR("?")=" entries with an 'error' status answer 'Yes'. Otherwise answer 'No'."
+63 WRITE !
DO ^DIR
IF $DATA(DIRUT)
SET HLEXIT=1
QUIT
+64 KILL DIR
+65 IF 'Y
SET HLPDT("ERR")=0
+66 IF '$TEST
Begin DoDot:1
+67 ; input cutoff date for "Error" messages
+68 SET DIR(0)="D^:"_HLPDT("WAIT")_":EX"
+69 SET DIR("A",1)=" WARNING: You should have investigated all errors because purging"
+70 SET DIR("A",2)=" these messages permanently removes them from the system."
+71 SET DIR("A",3)=" "
+72 SET DIR("A",4)=" Enter inclusive date up to which to purge ERROR"
+73 SET DIR("A")=" messages"
+74 SET DIR("B")="T"_-$PIECE(HLREC,U,4)
+75 SET DIR("?",1)=" The suggested cutoff date to purge 'Error' messages"
+76 SET DIR("?",2)=" is 90 days prior to today."
+77 SET DIR("?")=" Must be on or before "_$$FMTE^XLFDT(HLPDT("WAIT"),2)_"."
+78 WRITE !
DO ^DIR
IF $DATA(DIRUT)
SET HLEXIT=1
QUIT
+79 SET HLPDT("ERR")=Y+.9
+80 KILL DIR
End DoDot:1
if HLEXIT
QUIT
+81 ;
+82 ; prompt whether to run this purge in the background
+83 SET DIR(0)="YA"
+84 SET DIR("A")=" Would you like to queue this purge? "
+85 SET DIR("B")="YES"
+86 SET DIR("?")=" If run in the foreground, you will see dots and a total count."
+87 WRITE !
DO ^DIR
IF $DATA(DIRUT)
SET HLEXIT=1
QUIT
+88 SET HLTASK=Y
+89 KILL DIR
+90 WRITE !," "
+91 ;
+92 SET HLPDT("COMP")=HLPDT("COMP")+.9
SET HLPDT("WAIT")=HLPDT("WAIT")+.9
+93 QUIT
+94 ;
EOR ;HLUOPT4 - Purging Entries in file #772 and #773 ;12/10/02 16:37
