HLUOPT1 ;AISC/SAW - Purging Entries in file #772 and #773 ;12/30/2010
;;1.6;HEALTH LEVEL SEVEN;**10,13,21,36,19,47,62,109,108,153**;Oct 13, 1995;Build 11
;Per VHA Directive 2004-038, this routine should not be modified.
;
; Purge data of the HL7 message in file #772 and #773.
;
; Patch 47 - For Purging Option scheduled on a recurring basis,
; numbers of days kept for various Status of message are stored
; in file #869.3, fields 41, 42, and 43. Default values for these
; fields are 7, 30, and 90, respectively.
;
; Patch 36 - a message will never be purged if the new field, "Don't
; Purge" (#772,15), is set to 1.
;
PURGE ;
; HLPDT("COMP") - 'completed' status cutoff date
; HLPDT("WAIT") - 'awaiting ack' status cutoff date
; HLPDT("ERR") - 'error' status cutoff date
; (=0 means don't delete msgs in 'error' status)
; HLPDT("ALL") - all other status (except 'error') cutoff date
N HLPDT,HLTASK,HLEXIT
;
S (HLTASK,HLEXIT)=0
D INIT(.HLPDT,.HLTASK,.HLEXIT) Q:HLEXIT
;
; HL*1.6*109 lock logic...
L +^HL("HLUOPT1"):2 I '$T D:'$D(ZTQUEUED) LOCKTELL^HLUOPT4 QUIT ;->
L -^HL("HLUOPT1") ; Locked again at the top of DQ
;
; HL*1.6*109
I '$D(ZTQUEUED) I $$BTE^HLCSMON("Press RETURN to "_$S(HLTASK:"queue job",1:"start purging")_", or enter '^' to exit... ",1) D QUIT ;->
. I HLTASK W " no task started..."
. I 'HLTASK W " exiting..."
;
I HLTASK D TASKIT Q
K HLTASK,HLEXIT ; not needed
D DQ
;
Q
;
INIT(HLPDT,HLTASK,HLEXIT) ; Get data from file #869.3
D INIT^HLUOPT4 ; HL*1.6*109
Q
;
TASKIT ; Queue task to run in the background
N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
S ZTRTN="DQ^HLUOPT1",ZTIO="",ZTSAVE("HLPDT(")="",ZTDTH=$H
S ZTDESC="Purge HL7 message text on or before "_$$FMTE^XLFDT(HLPDT("COMP"),"5D")
D ^%ZTLOAD
I $D(ZTSK) W !," Task #",ZTSK," queued to run now...",! Q ; HL*1.6*109
W !," Queuing of Purge task failed.",! ; HL*1.6*109
Q
DQ ; Entry point for running purge of HL7 message text
N HLDELCNT,HLEXIT,HLOOPCT
;
S HLOOPCT=0
;
; HL*1.6*109
N XTMP D XTMPBEGN^HLUOPT4
;
; Lock to ensures no other purge job can run...
L +^HL("HLUOPT1"):10 I '$T D QUIT ;->
. D XTMPUPD^HLUOPT4(.XTMP,"NO-LOCK","DONE")
. I $D(ZTQUEUED) S ZTREQ="@"
;
; Purge 773s...
S (HLDELCNT,HLEXIT)=0
D CHK773(.HLPDT,.HLDELCNT,.HLEXIT)
;
; Update piece 4 of file's zero node...
D UPDP4(773)
;
; Purge 772s...
I 'HLEXIT D CHK772(.HLPDT,.HLDELCNT,.HLEXIT)
;
; Update piece 4 of file's zero node...
D UPDP4(772)
;
; HL*1.6*109
L -^HL("HLUOPT1")
;
D XTMPUPD^HLUOPT4(.XTMP,"FINISHED","DONE")
I $D(ZTQUEUED) S ZTREQ="@" Q
;
W !!," #",HLDELCNT," entries purged...",! ; HL*1.6*109
;
Q
;
UPDP4(FNO) ; Update piece 4 of file's zero node...
N GBL,NODE,NODEL,P4
S GBL=$S(+FNO=772:"^HL(772,0)",+FNO=773:"^HLMA(0)",1:"") QUIT:GBL']"" ;->
S NODEL=$G(XTMP(+FNO,"DEL")) QUIT:NODEL'>0 ;->
L +@GBL:30 ; If don't get lock, update piece 4 anyway...
S NODE=$G(@GBL) ; Get node...
S P4=$P(NODE,U,4)-NODEL,P4=$S(P4>0:+P4,1:"") ; Recalc piece 4...
S $P(NODE,U,4)=P4 ; Reset node's piece 4...
S @GBL=NODE ; Store in file's zero node...
L -@GBL
Q
;
CHK773(HLPDT,HLDELCNT,HLEXIT) ; Check file 773
N FPDATE,HLIEN,HLPTR,HLMADT,HLY,HLMADT1,HLLT773
;
; HL*1.6*109
I '$G(HLTASK) W !,"Looping through file 773..."
D XTMPUPD^HLUOPT4(.XTMP,"RUNNING","START-773")
;
;calculate cuttoff date for records reserved by Fast Purge - records with a more recent FAST PURGE DT/TM then this should be left to the Fast Purge to delete
S FPDATE=$$FMADD^XLFDT(DT,-2)
;
S HLLT773=$O(^HLMA(";"),-1) ; last ien for 773
S HLIEN=0
F S HLIEN=$O(^HLMA(HLIEN)) Q:'HLIEN D Q:HLEXIT Q:$$FAIL(773) ;HL*1.6*109
.N NODE0,NODEP
. D CHK4STOP(.HLEXIT) Q:HLEXIT
. S XTMP(773,"REV")=$G(XTMP(773,"REV"))+1,XTMP(773,"LAST")=HLIEN,XTMP(773,"FAIL")=$G(XTMP(773,"FAIL"))+1 ; HL*1.6*109
. ;
. ;check if the record is reserved for FAST PURGE
. I ($P($G(^HLMA(HLIEN,2)),"^",2)\1)>FPDATE Q
. ;
. S NODE0=$G(^HLMA(HLIEN,0))
. S HLPTR=+NODE0 Q:'HLPTR
. S HLMADT=+$G(^HL(772,HLPTR,0))
. ;HLY=status, HLMADT1=processed date
. S NODEP=$G(^HLMA(HLIEN,"P"))
. S HLY=+NODEP,HLMADT1=+$G(^("S"))
.;** P153 START CJM
. ;Delete incoming duplicate records as if completed, despite error status
. I HLY>3,HLY<7,'(HLMADT1>HLPDT("COMP")),$P(NODE0,"^",3)="I",$P(NODEP,"^",4)=109 D KILL773(HLIEN,HLLT773,.HLDELCNT) Q
.;** P153 END CJM
. ;error status, quit if flag set to no
. I HLY>3,HLY<8,'HLPDT("ERR") Q
. ;check if date entered is less than purge all date
. I HLMADT<HLPDT("ALL") D KILL773(HLIEN,HLLT773,.HLDELCNT) Q
. ;pending, being generated, awaiting processing, or no processed date
. I HLY=1!(HLY>7)!('HLMADT1) Q
. ;awaiting ack, no purge date or date>purge date
. I HLY=2,HLMADT1>HLPDT("WAIT") Q
. ;successfully transmitted
. I HLY=3,HLMADT1>HLPDT("COMP") Q
. ;error status
. I HLY>3,HLY<8,HLMADT1>HLPDT("ERR") Q
. D KILL773(HLIEN,HLLT773,.HLDELCNT)
D XTMPUPD^HLUOPT4(.XTMP,"RUNNING","END-773") ; HL*1.6*109
Q
KILL773(HLIEN,HLLT773,HLDELCNT) ; delete in file 773
;
; quit if don't purge flag is set or the entry is the last one
Q:$G(^HLMA(HLIEN,2))!(HLIEN=HLLT773)
;
S X=$G(^HLMA(+HLIEN,0)),X=+$G(^HL(772,+X,0)),XTMP(773,"LAST","TIME")=$S(X?7N1"."1.N:+X,1:"")
;
D DEL773^HLUOPT3(HLIEN) ; Purge w/direct kills...
;
S HLDELCNT=HLDELCNT+1
;
S XTMP(773,"DEL")=$G(XTMP(773,"DEL"))+1,XTMP(773,"FAIL")=0
;
Q
;
CHK772(HLPDT,HLDELCNT,HLEXIT) ; Check file 772 for parents and children
N FPDATE,HLOOP2,HLPTR,HLINK,HLIEN,HLMADT,HLY,HLLT772
;
; HL*1.6*109
I '$G(HLTASK) W !,"Looping through file 772..."
D XTMPUPD^HLUOPT4(.XTMP,"RUNNING","START-772")
;
;calculate cuttoff date for records reserved by Fast Purge - records with a more recent FAST PURGE DT/TM then this should be left to the Fast Purge to delete
S FPDATE=$$FMADD^XLFDT(DT,-2)
;
S HLLT772=$O(^HL(772,";"),-1) ; last ien for 772
F HLOOP2=1:1:2 D Q:HLEXIT ; Kill children first, then parents
. S XTMP(772,"FAIL")=0 ; HL*1.6*109
. S HLPTR=0
. F S HLPTR=$O(^HL(772,"B",HLPTR)) Q:HLPTR'>0 D Q:HLEXIT Q:$$FAIL(772) ; HL*1.6*109
. . D CHK4STOP(.HLEXIT) Q:HLEXIT
. . S HLIEN=0
. . F S HLIEN=$O(^HL(772,"B",HLPTR,HLIEN)) Q:'HLIEN D
. . . S XTMP(772,"REV")=$G(XTMP(772,"REV"))+1,XTMP(772,"LAST")=HLIEN,XTMP(772,"FAIL")=$G(XTMP(772,"FAIL"))+1 ; HL*1.6*109
... ;
... ;check if the record is reserved for FAST PURGE
... I ($P($G(^HL(772,+HLIEN,2)),"^",2)\1)>FPDATE Q
... ;
. . . S HLMADT=+$G(^HL(772,+HLIEN,0)) Q:'HLMADT
. . . I HLMADT>HLPDT("COMP") Q
. . . S HLY=$P($G(^HL(772,HLIEN,"P")),U)
. . . I HLY?1U S HLY=$TR(HLY,"PASE",1234)
. . . I HLY>3,HLY<8,'HLPDT("ERR") Q
. . . I HLMADT<HLPDT("ALL") D KILL772(HLIEN,HLLT772,.HLDELCNT) Q
. . . I HLY=3,HLMADT>HLPDT("COMP") Q
. . . I HLY=2,HLMADT>HLPDT("WAIT") Q
. . . I HLY>3,HLY<8,HLMADT>HLPDT("ERR") Q
. . . I HLY=1!(HLY>7) Q
. . . I $O(^HL(772,"AI",HLIEN,HLIEN)) Q
. . . D KILL772(HLIEN,HLLT772,.HLDELCNT)
D XTMPUPD^HLUOPT4(.XTMP,"RUNNING","END-772") ; HL*1.6*109
S HLINK=0
F S HLINK=$O(^HL(772,"A-XMIT-OUT",HLINK)) Q:'HLINK D
. S HLIEN=0
. F S HLIEN=$O(^HL(772,"A-XMIT-OUT",HLINK,HLIEN)) Q:'HLIEN D
. . I '$D(^HL(772,HLIEN)) K ^HL(772,"A-XMIT-OUT",HLINK,HLIEN)
Q
KILL772(HLIEN,HLLT772,HLDELCNT) ;
;
; quit if the corresponding entry in #773 exists
I $O(^HLMA("B",HLIEN,0)) Q
;
; quit if don't purge flag is set or the entry is the last one
Q:+$G(^HL(772,HLIEN,2))!(HLIEN=HLLT772)
;
N XMDUZ,XMK,XMZ,DIK,DA,HLX
;
S HLX=$G(^HL(772,HLIEN,0))
S XMZ=$P(HLX,U,5)
I XMZ S XMK=1,XMDUZ=.5 D KLQ^XMA1B
;
S XTMP(772,"LAST","TIME")=$S(+HLX?7N1"."1.N:+HLX,1:"")
;
D DEL772^HLUOPT3(+HLIEN)
;
S HLDELCNT=HLDELCNT+1
S XTMP(772,"DEL")=$G(XTMP(772,"DEL"))+1,XTMP(772,"FAIL")=0 ; HL*1.6*109
;
Q
;
CHK4STOP(HLEXIT) ;
; HL*1.6*109 modified from 60 to 120...
;
S HLOOPCT=HLOOPCT+1
I '$D(ZTQUEUED) W:'(HLOOPCT#2000) "."
;
S:$G(HLEXIT("LASTCHK"))']"" HLEXIT("LASTCHK")=$H
;
Q:$$HDIFF^XLFDT($H,$G(HLEXIT("LASTCHK")),2)<120
;
; HL*1.6*109 modified...
I $$S^%ZTLOAD D Q
. S HLEXIT=1
. D XTMPUPD^HLUOPT4(.XTMP,"ABORTED-TASKMAN","CHK4STOP")
;
S HLEXIT("LASTCHK")=$H
;
D XTMPUPD^HLUOPT4(.XTMP,"RUNNING","CHK4STOP") ; HL*1.6*109
;
Q
;
FAIL(FILE) ; Has number entries w/o purging any been exceeded?
; **P153 START CJM **
;This check is causing the purge to fail
;QUIT $S($G(XTMP(FILE,"FAIL"))>200000:1,1:"")
Q ""
; **p153 end cjm **
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLUOPT1 8626 printed Dec 13, 2024@02:00:19 Page 2
HLUOPT1 ;AISC/SAW - Purging Entries in file #772 and #773 ;12/30/2010
+1 ;;1.6;HEALTH LEVEL SEVEN;**10,13,21,36,19,47,62,109,108,153**;Oct 13, 1995;Build 11
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; Purge data of the HL7 message in file #772 and #773.
+5 ;
+6 ; Patch 47 - For Purging Option scheduled on a recurring basis,
+7 ; numbers of days kept for various Status of message are stored
+8 ; in file #869.3, fields 41, 42, and 43. Default values for these
+9 ; fields are 7, 30, and 90, respectively.
+10 ;
+11 ; Patch 36 - a message will never be purged if the new field, "Don't
+12 ; Purge" (#772,15), is set to 1.
+13 ;
PURGE ;
+1 ; HLPDT("COMP") - 'completed' status cutoff date
+2 ; HLPDT("WAIT") - 'awaiting ack' status cutoff date
+3 ; HLPDT("ERR") - 'error' status cutoff date
+4 ; (=0 means don't delete msgs in 'error' status)
+5 ; HLPDT("ALL") - all other status (except 'error') cutoff date
+6 NEW HLPDT,HLTASK,HLEXIT
+7 ;
+8 SET (HLTASK,HLEXIT)=0
+9 DO INIT(.HLPDT,.HLTASK,.HLEXIT)
if HLEXIT
QUIT
+10 ;
+11 ; HL*1.6*109 lock logic...
+12 ;->
LOCK +^HL("HLUOPT1"):2
IF '$TEST
if '$DATA(ZTQUEUED)
DO LOCKTELL^HLUOPT4
QUIT
+13 ; Locked again at the top of DQ
LOCK -^HL("HLUOPT1")
+14 ;
+15 ; HL*1.6*109
+16 ;->
IF '$DATA(ZTQUEUED)
IF $$BTE^HLCSMON("Press RETURN to "_$SELECT(HLTASK:"queue job",1:"start purging")_", or enter '^' to exit... ",1)
Begin DoDot:1
+17 IF HLTASK
WRITE " no task started..."
+18 IF 'HLTASK
WRITE " exiting..."
End DoDot:1
QUIT
+19 ;
+20 IF HLTASK
DO TASKIT
QUIT
+21 ; not needed
KILL HLTASK,HLEXIT
+22 DO DQ
+23 ;
+24 QUIT
+25 ;
INIT(HLPDT,HLTASK,HLEXIT) ; Get data from file #869.3
+1 ; HL*1.6*109
DO INIT^HLUOPT4
+2 QUIT
+3 ;
TASKIT ; Queue task to run in the background
+1 NEW ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
+2 SET ZTRTN="DQ^HLUOPT1"
SET ZTIO=""
SET ZTSAVE("HLPDT(")=""
SET ZTDTH=$HOROLOG
+3 SET ZTDESC="Purge HL7 message text on or before "_$$FMTE^XLFDT(HLPDT("COMP"),"5D")
+4 DO ^%ZTLOAD
+5 ; HL*1.6*109
IF $DATA(ZTSK)
WRITE !," Task #",ZTSK," queued to run now...",!
QUIT
+6 ; HL*1.6*109
WRITE !," Queuing of Purge task failed.",!
+7 QUIT
DQ ; Entry point for running purge of HL7 message text
+1 NEW HLDELCNT,HLEXIT,HLOOPCT
+2 ;
+3 SET HLOOPCT=0
+4 ;
+5 ; HL*1.6*109
+6 NEW XTMP
DO XTMPBEGN^HLUOPT4
+7 ;
+8 ; Lock to ensures no other purge job can run...
+9 ;->
LOCK +^HL("HLUOPT1"):10
IF '$TEST
Begin DoDot:1
+10 DO XTMPUPD^HLUOPT4(.XTMP,"NO-LOCK","DONE")
+11 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
End DoDot:1
QUIT
+12 ;
+13 ; Purge 773s...
+14 SET (HLDELCNT,HLEXIT)=0
+15 DO CHK773(.HLPDT,.HLDELCNT,.HLEXIT)
+16 ;
+17 ; Update piece 4 of file's zero node...
+18 DO UPDP4(773)
+19 ;
+20 ; Purge 772s...
+21 IF 'HLEXIT
DO CHK772(.HLPDT,.HLDELCNT,.HLEXIT)
+22 ;
+23 ; Update piece 4 of file's zero node...
+24 DO UPDP4(772)
+25 ;
+26 ; HL*1.6*109
+27 LOCK -^HL("HLUOPT1")
+28 ;
+29 DO XTMPUPD^HLUOPT4(.XTMP,"FINISHED","DONE")
+30 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
+31 ;
+32 ; HL*1.6*109
WRITE !!," #",HLDELCNT," entries purged...",!
+33 ;
+34 QUIT
+35 ;
UPDP4(FNO) ; Update piece 4 of file's zero node...
+1 NEW GBL,NODE,NODEL,P4
+2 ;->
SET GBL=$SELECT(+FNO=772:"^HL(772,0)",+FNO=773:"^HLMA(0)",1:"")
if GBL']""
QUIT
+3 ;->
SET NODEL=$GET(XTMP(+FNO,"DEL"))
if NODEL'>0
QUIT
+4 ; If don't get lock, update piece 4 anyway...
LOCK +@GBL:30
+5 ; Get node...
SET NODE=$GET(@GBL)
+6 ; Recalc piece 4...
SET P4=$PIECE(NODE,U,4)-NODEL
SET P4=$SELECT(P4>0:+P4,1:"")
+7 ; Reset node's piece 4...
SET $PIECE(NODE,U,4)=P4
+8 ; Store in file's zero node...
SET @GBL=NODE
+9 LOCK -@GBL
+10 QUIT
+11 ;
CHK773(HLPDT,HLDELCNT,HLEXIT) ; Check file 773
+1 NEW FPDATE,HLIEN,HLPTR,HLMADT,HLY,HLMADT1,HLLT773
+2 ;
+3 ; HL*1.6*109
+4 IF '$GET(HLTASK)
WRITE !,"Looping through file 773..."
+5 DO XTMPUPD^HLUOPT4(.XTMP,"RUNNING","START-773")
+6 ;
+7 ;calculate cuttoff date for records reserved by Fast Purge - records with a more recent FAST PURGE DT/TM then this should be left to the Fast Purge to delete
+8 SET FPDATE=$$FMADD^XLFDT(DT,-2)
+9 ;
+10 ; last ien for 773
SET HLLT773=$ORDER(^HLMA(";"),-1)
+11 SET HLIEN=0
+12 ;HL*1.6*109
FOR
SET HLIEN=$ORDER(^HLMA(HLIEN))
if 'HLIEN
QUIT
Begin DoDot:1
+13 NEW NODE0,NODEP
+14 DO CHK4STOP(.HLEXIT)
if HLEXIT
QUIT
+15 ; HL*1.6*109
SET XTMP(773,"REV")=$GET(XTMP(773,"REV"))+1
SET XTMP(773,"LAST")=HLIEN
SET XTMP(773,"FAIL")=$GET(XTMP(773,"FAIL"))+1
+16 ;
+17 ;check if the record is reserved for FAST PURGE
+18 IF ($PIECE($GET(^HLMA(HLIEN,2)),"^",2)\1)>FPDATE
QUIT
+19 ;
+20 SET NODE0=$GET(^HLMA(HLIEN,0))
+21 SET HLPTR=+NODE0
if 'HLPTR
QUIT
+22 SET HLMADT=+$GET(^HL(772,HLPTR,0))
+23 ;HLY=status, HLMADT1=processed date
+24 SET NODEP=$GET(^HLMA(HLIEN,"P"))
+25 SET HLY=+NODEP
SET HLMADT1=+$GET(^("S"))
+26 ;** P153 START CJM
+27 ;Delete incoming duplicate records as if completed, despite error status
+28 IF HLY>3
IF HLY<7
IF '(HLMADT1>HLPDT("COMP"))
IF $PIECE(NODE0,"^",3)="I"
IF $PIECE(NODEP,"^",4)=109
DO KILL773(HLIEN,HLLT773,.HLDELCNT)
QUIT
+29 ;** P153 END CJM
+30 ;error status, quit if flag set to no
+31 IF HLY>3
IF HLY<8
IF 'HLPDT("ERR")
QUIT
+32 ;check if date entered is less than purge all date
+33 IF HLMADT<HLPDT("ALL")
DO KILL773(HLIEN,HLLT773,.HLDELCNT)
QUIT
+34 ;pending, being generated, awaiting processing, or no processed date
+35 IF HLY=1!(HLY>7)!('HLMADT1)
QUIT
+36 ;awaiting ack, no purge date or date>purge date
+37 IF HLY=2
IF HLMADT1>HLPDT("WAIT")
QUIT
+38 ;successfully transmitted
+39 IF HLY=3
IF HLMADT1>HLPDT("COMP")
QUIT
+40 ;error status
+41 IF HLY>3
IF HLY<8
IF HLMADT1>HLPDT("ERR")
QUIT
+42 DO KILL773(HLIEN,HLLT773,.HLDELCNT)
End DoDot:1
if HLEXIT
QUIT
if $$FAIL(773)
QUIT
+43 ; HL*1.6*109
DO XTMPUPD^HLUOPT4(.XTMP,"RUNNING","END-773")
+44 QUIT
KILL773(HLIEN,HLLT773,HLDELCNT) ; delete in file 773
+1 ;
+2 ; quit if don't purge flag is set or the entry is the last one
+3 if $GET(^HLMA(HLIEN,2))!(HLIEN=HLLT773)
QUIT
+4 ;
+5 SET X=$GET(^HLMA(+HLIEN,0))
SET X=+$GET(^HL(772,+X,0))
SET XTMP(773,"LAST","TIME")=$SELECT(X?7N1"."1.N:+X,1:"")
+6 ;
+7 ; Purge w/direct kills...
DO DEL773^HLUOPT3(HLIEN)
+8 ;
+9 SET HLDELCNT=HLDELCNT+1
+10 ;
+11 SET XTMP(773,"DEL")=$GET(XTMP(773,"DEL"))+1
SET XTMP(773,"FAIL")=0
+12 ;
+13 QUIT
+14 ;
CHK772(HLPDT,HLDELCNT,HLEXIT) ; Check file 772 for parents and children
+1 NEW FPDATE,HLOOP2,HLPTR,HLINK,HLIEN,HLMADT,HLY,HLLT772
+2 ;
+3 ; HL*1.6*109
+4 IF '$GET(HLTASK)
WRITE !,"Looping through file 772..."
+5 DO XTMPUPD^HLUOPT4(.XTMP,"RUNNING","START-772")
+6 ;
+7 ;calculate cuttoff date for records reserved by Fast Purge - records with a more recent FAST PURGE DT/TM then this should be left to the Fast Purge to delete
+8 SET FPDATE=$$FMADD^XLFDT(DT,-2)
+9 ;
+10 ; last ien for 772
SET HLLT772=$ORDER(^HL(772,";"),-1)
+11 ; Kill children first, then parents
FOR HLOOP2=1:1:2
Begin DoDot:1
+12 ; HL*1.6*109
SET XTMP(772,"FAIL")=0
+13 SET HLPTR=0
+14 ; HL*1.6*109
FOR
SET HLPTR=$ORDER(^HL(772,"B",HLPTR))
if HLPTR'>0
QUIT
Begin DoDot:2
+15 DO CHK4STOP(.HLEXIT)
if HLEXIT
QUIT
+16 SET HLIEN=0
+17 FOR
SET HLIEN=$ORDER(^HL(772,"B",HLPTR,HLIEN))
if 'HLIEN
QUIT
Begin DoDot:3
+18 ; HL*1.6*109
SET XTMP(772,"REV")=$GET(XTMP(772,"REV"))+1
SET XTMP(772,"LAST")=HLIEN
SET XTMP(772,"FAIL")=$GET(XTMP(772,"FAIL"))+1
+19 ;
+20 ;check if the record is reserved for FAST PURGE
+21 IF ($PIECE($GET(^HL(772,+HLIEN,2)),"^",2)\1)>FPDATE
QUIT
+22 ;
+23 SET HLMADT=+$GET(^HL(772,+HLIEN,0))
if 'HLMADT
QUIT
+24 IF HLMADT>HLPDT("COMP")
QUIT
+25 SET HLY=$PIECE($GET(^HL(772,HLIEN,"P")),U)
+26 IF HLY?1U
SET HLY=$TRANSLATE(HLY,"PASE",1234)
+27 IF HLY>3
IF HLY<8
IF 'HLPDT("ERR")
QUIT
+28 IF HLMADT<HLPDT("ALL")
DO KILL772(HLIEN,HLLT772,.HLDELCNT)
QUIT
+29 IF HLY=3
IF HLMADT>HLPDT("COMP")
QUIT
+30 IF HLY=2
IF HLMADT>HLPDT("WAIT")
QUIT
+31 IF HLY>3
IF HLY<8
IF HLMADT>HLPDT("ERR")
QUIT
+32 IF HLY=1!(HLY>7)
QUIT
+33 IF $ORDER(^HL(772,"AI",HLIEN,HLIEN))
QUIT
+34 DO KILL772(HLIEN,HLLT772,.HLDELCNT)
End DoDot:3
End DoDot:2
if HLEXIT
QUIT
if $$FAIL(772)
QUIT
End DoDot:1
if HLEXIT
QUIT
+35 ; HL*1.6*109
DO XTMPUPD^HLUOPT4(.XTMP,"RUNNING","END-772")
+36 SET HLINK=0
+37 FOR
SET HLINK=$ORDER(^HL(772,"A-XMIT-OUT",HLINK))
if 'HLINK
QUIT
Begin DoDot:1
+38 SET HLIEN=0
+39 FOR
SET HLIEN=$ORDER(^HL(772,"A-XMIT-OUT",HLINK,HLIEN))
if 'HLIEN
QUIT
Begin DoDot:2
+40 IF '$DATA(^HL(772,HLIEN))
KILL ^HL(772,"A-XMIT-OUT",HLINK,HLIEN)
End DoDot:2
End DoDot:1
+41 QUIT
KILL772(HLIEN,HLLT772,HLDELCNT) ;
+1 ;
+2 ; quit if the corresponding entry in #773 exists
+3 IF $ORDER(^HLMA("B",HLIEN,0))
QUIT
+4 ;
+5 ; quit if don't purge flag is set or the entry is the last one
+6 if +$GET(^HL(772,HLIEN,2))!(HLIEN=HLLT772)
QUIT
+7 ;
+8 NEW XMDUZ,XMK,XMZ,DIK,DA,HLX
+9 ;
+10 SET HLX=$GET(^HL(772,HLIEN,0))
+11 SET XMZ=$PIECE(HLX,U,5)
+12 IF XMZ
SET XMK=1
SET XMDUZ=.5
DO KLQ^XMA1B
+13 ;
+14 SET XTMP(772,"LAST","TIME")=$SELECT(+HLX?7N1"."1.N:+HLX,1:"")
+15 ;
+16 DO DEL772^HLUOPT3(+HLIEN)
+17 ;
+18 SET HLDELCNT=HLDELCNT+1
+19 ; HL*1.6*109
SET XTMP(772,"DEL")=$GET(XTMP(772,"DEL"))+1
SET XTMP(772,"FAIL")=0
+20 ;
+21 QUIT
+22 ;
CHK4STOP(HLEXIT) ;
+1 ; HL*1.6*109 modified from 60 to 120...
+2 ;
+3 SET HLOOPCT=HLOOPCT+1
+4 IF '$DATA(ZTQUEUED)
if '(HLOOPCT#2000)
WRITE "."
+5 ;
+6 if $GET(HLEXIT("LASTCHK"))']""
SET HLEXIT("LASTCHK")=$HOROLOG
+7 ;
+8 if $$HDIFF^XLFDT($HOROLOG,$GET(HLEXIT("LASTCHK")),2)<120
QUIT
+9 ;
+10 ; HL*1.6*109 modified...
+11 IF $$S^%ZTLOAD
Begin DoDot:1
+12 SET HLEXIT=1
+13 DO XTMPUPD^HLUOPT4(.XTMP,"ABORTED-TASKMAN","CHK4STOP")
End DoDot:1
QUIT
+14 ;
+15 SET HLEXIT("LASTCHK")=$HOROLOG
+16 ;
+17 ; HL*1.6*109
DO XTMPUPD^HLUOPT4(.XTMP,"RUNNING","CHK4STOP")
+18 ;
+19 QUIT
+20 ;
FAIL(FILE) ; Has number entries w/o purging any been exceeded?
+1 ; **P153 START CJM **
+2 ;This check is causing the purge to fail
+3 ;QUIT $S($G(XTMP(FILE,"FAIL"))>200000:1,1:"")
+4 QUIT ""
+5 ; **p153 end cjm **
+6 ;
