- HLUOPT1 ;AISC/SAW - Purging Entries in file #772 and #773 ;02/04/2004 09:58
- ;;1.6;HEALTH LEVEL SEVEN;**10,13,21,36,19,47,62,109,108**;Oct 13, 1995
- ;
- ; 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
- . 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 HLPTR=+$G(^HLMA(HLIEN,0)) Q:'HLPTR
- . S HLMADT=+$G(^HL(772,HLPTR,0))
- . ;HLY=status, HLMADT1=processed date
- . S HLY=+$G(^HLMA(HLIEN,"P")),HLMADT1=+$G(^("S"))
- . ;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?
- QUIT $S($G(XTMP(FILE,"FAIL"))>200000:1,1:"")
- ;
- HLUOPT1 ;AISC/SAW - Purging Entries in file #772 and #773 ;02/04/2004 09:58
- +1 ;;1.6;HEALTH LEVEL SEVEN;**10,13,21,36,19,47,62,109,108**;Oct 13, 1995
- +2 ;
- +3 ; Purge data of the HL7 message in file #772 and #773.
- +4 ;
- +5 ; Patch 47 - For Purging Option scheduled on a recurring basis,
- +6 ; numbers of days kept for various Status of message are stored
- +7 ; in file #869.3, fields 41, 42, and 43. Default values for these
- +8 ; fields are 7, 30, and 90, respectively.
- +9 ;
- +10 ; Patch 36 - a message will never be purged if the new field, "Don't
- +11 ; Purge" (#772,15), is set to 1.
- +12 ;
- 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 DO CHK4STOP(.HLEXIT)
- IF HLEXIT
- QUIT
- +14 ; 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
- +15 ;
- +16 ;check if the record is reserved for FAST PURGE
- +17 IF ($PIECE($GET(^HLMA(HLIEN,2)),"^",2)\1)>FPDATE
- QUIT
- +18 ;
- +19 SET HLPTR=+$GET(^HLMA(HLIEN,0))
- IF 'HLPTR
- QUIT
- +20 SET HLMADT=+$GET(^HL(772,HLPTR,0))
- +21 ;HLY=status, HLMADT1=processed date
- +22 SET HLY=+$GET(^HLMA(HLIEN,"P"))
- SET HLMADT1=+$GET(^("S"))
- +23 ;error status, quit if flag set to no
- +24 IF HLY>3
- IF HLY<8
- IF 'HLPDT("ERR")
- QUIT
- +25 ;check if date entered is less than purge all date
- +26 IF HLMADT<HLPDT("ALL")
- DO KILL773(HLIEN,HLLT773,.HLDELCNT)
- QUIT
- +27 ;pending, being generated, awaiting processing, or no processed date
- +28 IF HLY=1!(HLY>7)!('HLMADT1)
- QUIT
- +29 ;awaiting ack, no purge date or date>purge date
- +30 IF HLY=2
- IF HLMADT1>HLPDT("WAIT")
- QUIT
- +31 ;successfully transmitted
- +32 IF HLY=3
- IF HLMADT1>HLPDT("COMP")
- QUIT
- +33 ;error status
- +34 IF HLY>3
- IF HLY<8
- IF HLMADT1>HLPDT("ERR")
- QUIT
- +35 DO KILL773(HLIEN,HLLT773,.HLDELCNT)
- End DoDot:1
- IF HLEXIT
- QUIT
- IF $$FAIL(773)
- QUIT
- +36 ; HL*1.6*109
- DO XTMPUPD^HLUOPT4(.XTMP,"RUNNING","END-773")
- +37 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 QUIT $SELECT($GET(XTMP(FILE,"FAIL"))>200000:1,1:"")
- +2 ;
