HLOPURGE ;IRMFO-ALB/CJM - Purging Old Messages;03/24/2004 14:43 ;06/17/2009
;;1.6;HEALTH LEVEL SEVEN;**126,134,136,137,139,143**;Oct 13, 1995;Build 3
;Per VHA Directive 2004-038, this routine should not be modified.
;
GETWORK(WORK) ;
;
N OK
S OK=0
I $G(WORK)]"" L -HLPURGE(WORK)
F WORK="IN","OUT","OLD778","OLD777" I '$G(WORK("DONE",WORK)) S WORK("DONE",WORK)=1 L +HLPURGE(WORK):0 S OK=$T Q:OK
I 'OK K WORK("DONE") S WORK=""
Q OK
;
DOWORK(WORK) ;
I WORK="OLD778" D OLD778
I WORK="OLD777" D OLD777
I (WORK="IN")!(WORK="OUT") D
.N TIME,NOW
.S NOW=$$NOW^XLFDT
.S TIME=0
.F S TIME=$O(^HLB("AD",WORK,TIME)) Q:TIME="" Q:TIME>NOW D
..N MSGIEN
..S MSGIEN=0
..F S MSGIEN=$O(^HLB("AD",WORK,TIME,MSGIEN)) Q:'MSGIEN D
...K ^HLB("AD",WORK,TIME,MSGIEN)
...D DELETE(MSGIEN)
L -HLPURGE(WORK)
Q
OLD778 ;
N OLD,START,END,APP,TYPE,TODAY,PARMS
S TODAY=$$DT^XLFDT
S OLD=$$FMADD^XLFDT(TODAY,-$$OLDPURGE^HLOSITE)
F START=0,100000000000,200000000000,300000000000 D
.S END=(START+100000000000)-1
.N MSGIEN,QUIT
.S QUIT=0
.S MSGIEN=START
.F S MSGIEN=$O(^HLB(MSGIEN)) Q:'MSGIEN Q:(MSGIEN>END) D Q:QUIT
..N WHEN,BODY,NODE
..S NODE=$G(^HLB(MSGIEN,0))
..S WHEN=$P(NODE,"^",16)
..I WHEN,WHEN<OLD,$P(NODE,"^",9)<TODAY D DELETE(MSGIEN) Q
..I 'WHEN D
...S BODY=$P(NODE,"^",2)
...Q:'BODY
...S WHEN=+$G(^HLA(BODY,0))
...I WHEN,WHEN<OLD D Q
....;I've seen messages sitting on outgoing queues forever, but it should never happen for incoming
....I $E($P(NODE,"^",4))="O",$P(NODE,"^",5)]"",$P(NODE,"^",6)]"" D
.....N FROM
.....S FROM=$P(NODE,"^",5)
.....I $P(NODE,"^",8) S FROM=FROM_":"_$P(NODE,"^",8)
.....Q:'$D(^HLB("QUEUE","OUT",FROM,$P(NODE,"^",6),MSGIEN))
.....D DEQUE^HLOQUE(FROM,$P(NODE,"^",6),"OUT",MSGIEN)
....D DELETE(MSGIEN) Q
...;stop looking for old records?
...I WHEN,WHEN>OLD S QUIT=1
;
;also kill old errors left lying around
D SYSPARMS^HLOSITE(.PARMS)
S OLD=$$FMADD^XLFDT($$DT^XLFDT,-PARMS("ERROR PURGE"))
S APP=""
F S APP=$O(^HLB("ERRORS",APP)) Q:APP="" D
.N TIME
.S TIME=0
.F S TIME=$O(^HLB("ERRORS",APP,TIME)) Q:'TIME Q:TIME>OLD K ^HLB("ERRORS",APP,TIME)
Q
OLD777 ;
N OLD,TIME,TODAY
S TODAY=$$DT^XLFDT
S OLD=$$FMADD^XLFDT(TODAY,-$$OLDPURGE^HLOSITE)
S TIME=0
F S TIME=$O(^HLA("B",TIME)) Q:'TIME Q:TIME>OLD D
.N MSGIEN
.S MSGIEN=0
.F S MSGIEN=$O(^HLA("B",TIME,MSGIEN)) Q:'MSGIEN D
..N IEN778,STOP
..S (STOP,IEN778)=0
..F S IEN778=$O(^HLB("C",MSGIEN,IEN778)) Q:'IEN778 D
...I $P($G(^HLB(IEN778,0)),"^",9)>TODAY S STOP=1 Q
...D DELETE(IEN778,1)
..K:'STOP ^HLB("C",MSGIEN),^HLA("B",TIME,MSGIEN),^HLA(MSGIEN)
Q
;
DELETE(MSGIEN,FLAG) ;
;Input:
; MSGIEN - IEN, file 778
; FLAG - if $G(FLAG), will not delete the pointed to record in file 777
N AC,SUBIEN,RAPP,SAPP,FS,CS,MSG
I '$$GETMSG^HLOMSG(MSGIEN,.MSG) ;MSG is corrupted, but there sill may be nodes to delete
S (RAPP,SAPP)=""
D
.; ** Begin HL*1.6*143 changes
.;S FS=$E(MSG("HDR",1),4)
.S FS=$E($G(MSG("HDR",1)),4)
.;Q:FS=""
.;S CS=$E($G(MSG("HDR",1)),5)
.S CS=$E($G(MSG("HDR",1)),5)
.; .S SAPP=$P($P(MSG("HDR",1),FS,3),CS)
.S SAPP=$P($P($G(MSG("HDR",1)),FS,3),CS)
.I SAPP="" S SAPP="UNKNOWN"
.;.S RAPP=$P($P(MSG("HDR",1),FS,5),CS)
.S RAPP=$P($P($G(MSG("HDR",1)),FS,5),CS)
.; ** End HL*1.6*143 changes
.I RAPP="" S RAPP="UNKNOWN"
;
I 'MSG("BATCH") D KSEARCH(.MSG,MSG("MESSAGE TYPE"),MSG("EVENT"),SAPP,RAPP,MSGIEN)
;if an error status,take care of the "ERRORS" x-ref
I MSG("STATUS")'="",MSG("STATUS")'="SU",MSG("BODY") D
.K ^HLB("ERRORS",RAPP,MSG("DT/TM CREATED"),MSGIEN)
.I MSG("STATUS")="ER" D
..N SUB
..S SUB=MSGIEN_"^"
..K ^HLB("ERRORS",RAPP,MSG("DT/TM CREATED"),SUB)
..F S SUB=$O(^HLB("ERRORS",RAPP,MSG("DT/TM CREATED"),SUB)) Q:SUB="" Q:+SUB'=MSGIEN K ^HLB("ERRORS",RAPP,MSG("DT/TM CREATED"),SUB)
;
;kill the whole-file xrefs for the message ien within a batch
S SUBIEN=0
F S SUBIEN=$O(^HLB(MSGIEN,3,SUBIEN)) Q:'SUBIEN D
.N MSGID
.I FS]"" D
..N VALUE,HDR2,MSGTYPE,EVENT
..S HDR2=$G(^HLB(MSGIEN,3,SUBIEN,2))
..S VALUE=$P(HDR2,FS,4)
..S MSGTYPE=$P(VALUE,CS)
..S EVENT=$P(VALUE,CS,2)
..D KSEARCH(.MSG,MSGTYPE,EVENT,SAPP,RAPP,MSGIEN_"^"_SUBIEN)
.S MSGID=$P($G(^HLB(MSGIEN,3,SUBIEN,0)),"^",2)
.I MSGID]"" K ^HLB("AE",MSGID,MSGIEN_"^"_SUBIEN)
;
I MSG("DIRECTION")="IN" D
.Q:FS=""
.N VALUE,HDR
.S HDR("SENDING APPLICATION")=$P(MSG("HDR",1),FS,3)
.S VALUE=$P(MSG("HDR",1),FS,4)
.S HDR("SENDING FACILITY",1)=$P(VALUE,CS)
.S HDR("SENDING FACILITY",2)=$P(VALUE,CS,2)
.S HDR("SENDING FACILITY",3)=$P(VALUE,CS,3)
.S AC=$S(HDR("SENDING FACILITY",2)]"":HDR("SENDING FACILITY",2),1:HDR("SENDING FACILITY",1))_HDR("SENDING APPLICATION")_MSG("ID")
K ^HLB(MSGIEN)
I MSG("STATUS","PURGE"),MSG("DIRECTION")'="" K ^HLB("AD",MSG("DIRECTION"),MSG("STATUS","PURGE"),MSGIEN)
K:(MSG("ID")]"") ^HLB("B",MSG("ID"),MSGIEN)
I MSG("DIRECTION")="IN" D
.K:($G(AC)]"") ^HLB("AC",AC,MSGIEN)
.I MSG("BODY"),'$G(FLAG) D KILL777(MSG("BODY"))
I MSG("DIRECTION")="OUT" D
.K ^HLB("C",+MSG("BODY"),MSGIEN)
.I '$G(FLAG),'$O(^HLB("C",+MSG("BODY"),0)) D KILL777(MSG("BODY"))
Q
;
KILL777(BODY) ;
Q:'$G(BODY)
N TIME
S TIME=$P($G(^HLA(BODY,0)),"^")
K ^HLA(BODY)
K:(TIME]"") ^HLA("B",TIME,BODY)
Q
;
KSEARCH(MSG,MSGTYPE,EVENT,SAPP,RAPP,IEN) ;
;Kills the ^HLB("SEARCH") x-ref
;
N APP
S:MSGTYPE="" MSGTYPE="<none>"
S:EVENT="" EVENT="<none>"
Q:'MSG("DT/TM CREATED")
I MSG("DIRECTION")'="IN",MSG("DIRECTION")'="OUT" Q
S APP=$S(MSG("DIRECTION")="IN":RAPP,1:SAPP)
Q:APP=""
K ^HLB("SEARCH",MSG("DIRECTION"),MSG("DT/TM CREATED"),APP,MSGTYPE,EVENT,IEN)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHLOPURGE 5688 printed Oct 16, 2024@17:59:52 Page 2
HLOPURGE ;IRMFO-ALB/CJM - Purging Old Messages;03/24/2004 14:43 ;06/17/2009
+1 ;;1.6;HEALTH LEVEL SEVEN;**126,134,136,137,139,143**;Oct 13, 1995;Build 3
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
GETWORK(WORK) ;
+1 ;
+2 NEW OK
+3 SET OK=0
+4 IF $GET(WORK)]""
LOCK -HLPURGE(WORK)
+5 FOR WORK="IN","OUT","OLD778","OLD777"
IF '$GET(WORK("DONE",WORK))
SET WORK("DONE",WORK)=1
LOCK +HLPURGE(WORK):0
SET OK=$TEST
if OK
QUIT
+6 IF 'OK
KILL WORK("DONE")
SET WORK=""
+7 QUIT OK
+8 ;
DOWORK(WORK) ;
+1 IF WORK="OLD778"
DO OLD778
+2 IF WORK="OLD777"
DO OLD777
+3 IF (WORK="IN")!(WORK="OUT")
Begin DoDot:1
+4 NEW TIME,NOW
+5 SET NOW=$$NOW^XLFDT
+6 SET TIME=0
+7 FOR
SET TIME=$ORDER(^HLB("AD",WORK,TIME))
if TIME=""
QUIT
if TIME>NOW
QUIT
Begin DoDot:2
+8 NEW MSGIEN
+9 SET MSGIEN=0
+10 FOR
SET MSGIEN=$ORDER(^HLB("AD",WORK,TIME,MSGIEN))
if 'MSGIEN
QUIT
Begin DoDot:3
+11 KILL ^HLB("AD",WORK,TIME,MSGIEN)
+12 DO DELETE(MSGIEN)
End DoDot:3
End DoDot:2
End DoDot:1
+13 LOCK -HLPURGE(WORK)
+14 QUIT
OLD778 ;
+1 NEW OLD,START,END,APP,TYPE,TODAY,PARMS
+2 SET TODAY=$$DT^XLFDT
+3 SET OLD=$$FMADD^XLFDT(TODAY,-$$OLDPURGE^HLOSITE)
+4 FOR START=0,100000000000,200000000000,300000000000
Begin DoDot:1
+5 SET END=(START+100000000000)-1
+6 NEW MSGIEN,QUIT
+7 SET QUIT=0
+8 SET MSGIEN=START
+9 FOR
SET MSGIEN=$ORDER(^HLB(MSGIEN))
if 'MSGIEN
QUIT
if (MSGIEN>END)
QUIT
Begin DoDot:2
+10 NEW WHEN,BODY,NODE
+11 SET NODE=$GET(^HLB(MSGIEN,0))
+12 SET WHEN=$PIECE(NODE,"^",16)
+13 IF WHEN
IF WHEN<OLD
IF $PIECE(NODE,"^",9)<TODAY
DO DELETE(MSGIEN)
QUIT
+14 IF 'WHEN
Begin DoDot:3
+15 SET BODY=$PIECE(NODE,"^",2)
+16 if 'BODY
QUIT
+17 SET WHEN=+$GET(^HLA(BODY,0))
+18 IF WHEN
IF WHEN<OLD
Begin DoDot:4
+19 ;I've seen messages sitting on outgoing queues forever, but it should never happen for incoming
+20 IF $EXTRACT($PIECE(NODE,"^",4))="O"
IF $PIECE(NODE,"^",5)]""
IF $PIECE(NODE,"^",6)]""
Begin DoDot:5
+21 NEW FROM
+22 SET FROM=$PIECE(NODE,"^",5)
+23 IF $PIECE(NODE,"^",8)
SET FROM=FROM_":"_$PIECE(NODE,"^",8)
+24 if '$DATA(^HLB("QUEUE","OUT",FROM,$PIECE(NODE,"^",6),MSGIEN))
QUIT
+25 DO DEQUE^HLOQUE(FROM,$PIECE(NODE,"^",6),"OUT",MSGIEN)
End DoDot:5
+26 DO DELETE(MSGIEN)
QUIT
End DoDot:4
QUIT
+27 ;stop looking for old records?
+28 IF WHEN
IF WHEN>OLD
SET QUIT=1
End DoDot:3
End DoDot:2
if QUIT
QUIT
End DoDot:1
+29 ;
+30 ;also kill old errors left lying around
+31 DO SYSPARMS^HLOSITE(.PARMS)
+32 SET OLD=$$FMADD^XLFDT($$DT^XLFDT,-PARMS("ERROR PURGE"))
+33 SET APP=""
+34 FOR
SET APP=$ORDER(^HLB("ERRORS",APP))
if APP=""
QUIT
Begin DoDot:1
+35 NEW TIME
+36 SET TIME=0
+37 FOR
SET TIME=$ORDER(^HLB("ERRORS",APP,TIME))
if 'TIME
QUIT
if TIME>OLD
QUIT
KILL ^HLB("ERRORS",APP,TIME)
End DoDot:1
+38 QUIT
OLD777 ;
+1 NEW OLD,TIME,TODAY
+2 SET TODAY=$$DT^XLFDT
+3 SET OLD=$$FMADD^XLFDT(TODAY,-$$OLDPURGE^HLOSITE)
+4 SET TIME=0
+5 FOR
SET TIME=$ORDER(^HLA("B",TIME))
if 'TIME
QUIT
if TIME>OLD
QUIT
Begin DoDot:1
+6 NEW MSGIEN
+7 SET MSGIEN=0
+8 FOR
SET MSGIEN=$ORDER(^HLA("B",TIME,MSGIEN))
if 'MSGIEN
QUIT
Begin DoDot:2
+9 NEW IEN778,STOP
+10 SET (STOP,IEN778)=0
+11 FOR
SET IEN778=$ORDER(^HLB("C",MSGIEN,IEN778))
if 'IEN778
QUIT
Begin DoDot:3
+12 IF $PIECE($GET(^HLB(IEN778,0)),"^",9)>TODAY
SET STOP=1
QUIT
+13 DO DELETE(IEN778,1)
End DoDot:3
+14 if 'STOP
KILL ^HLB("C",MSGIEN),^HLA("B",TIME,MSGIEN),^HLA(MSGIEN)
End DoDot:2
End DoDot:1
+15 QUIT
+16 ;
DELETE(MSGIEN,FLAG) ;
+1 ;Input:
+2 ; MSGIEN - IEN, file 778
+3 ; FLAG - if $G(FLAG), will not delete the pointed to record in file 777
+4 NEW AC,SUBIEN,RAPP,SAPP,FS,CS,MSG
+5 ;MSG is corrupted, but there sill may be nodes to delete
IF '$$GETMSG^HLOMSG(MSGIEN,.MSG)
+6 SET (RAPP,SAPP)=""
+7 Begin DoDot:1
+8 ; ** Begin HL*1.6*143 changes
+9 ;S FS=$E(MSG("HDR",1),4)
+10 SET FS=$EXTRACT($GET(MSG("HDR",1)),4)
+11 ;Q:FS=""
+12 ;S CS=$E($G(MSG("HDR",1)),5)
+13 SET CS=$EXTRACT($GET(MSG("HDR",1)),5)
+14 ; .S SAPP=$P($P(MSG("HDR",1),FS,3),CS)
+15 SET SAPP=$PIECE($PIECE($GET(MSG("HDR",1)),FS,3),CS)
+16 IF SAPP=""
SET SAPP="UNKNOWN"
+17 ;.S RAPP=$P($P(MSG("HDR",1),FS,5),CS)
+18 SET RAPP=$PIECE($PIECE($GET(MSG("HDR",1)),FS,5),CS)
+19 ; ** End HL*1.6*143 changes
+20 IF RAPP=""
SET RAPP="UNKNOWN"
End DoDot:1
+21 ;
+22 IF 'MSG("BATCH")
DO KSEARCH(.MSG,MSG("MESSAGE TYPE"),MSG("EVENT"),SAPP,RAPP,MSGIEN)
+23 ;if an error status,take care of the "ERRORS" x-ref
+24 IF MSG("STATUS")'=""
IF MSG("STATUS")'="SU"
IF MSG("BODY")
Begin DoDot:1
+25 KILL ^HLB("ERRORS",RAPP,MSG("DT/TM CREATED"),MSGIEN)
+26 IF MSG("STATUS")="ER"
Begin DoDot:2
+27 NEW SUB
+28 SET SUB=MSGIEN_"^"
+29 KILL ^HLB("ERRORS",RAPP,MSG("DT/TM CREATED"),SUB)
+30 FOR
SET SUB=$ORDER(^HLB("ERRORS",RAPP,MSG("DT/TM CREATED"),SUB))
if SUB=""
QUIT
if +SUB'=MSGIEN
QUIT
KILL ^HLB("ERRORS",RAPP,MSG("DT/TM CREATED"),SUB)
End DoDot:2
End DoDot:1
+31 ;
+32 ;kill the whole-file xrefs for the message ien within a batch
+33 SET SUBIEN=0
+34 FOR
SET SUBIEN=$ORDER(^HLB(MSGIEN,3,SUBIEN))
if 'SUBIEN
QUIT
Begin DoDot:1
+35 NEW MSGID
+36 IF FS]""
Begin DoDot:2
+37 NEW VALUE,HDR2,MSGTYPE,EVENT
+38 SET HDR2=$GET(^HLB(MSGIEN,3,SUBIEN,2))
+39 SET VALUE=$PIECE(HDR2,FS,4)
+40 SET MSGTYPE=$PIECE(VALUE,CS)
+41 SET EVENT=$PIECE(VALUE,CS,2)
+42 DO KSEARCH(.MSG,MSGTYPE,EVENT,SAPP,RAPP,MSGIEN_"^"_SUBIEN)
End DoDot:2
+43 SET MSGID=$PIECE($GET(^HLB(MSGIEN,3,SUBIEN,0)),"^",2)
+44 IF MSGID]""
KILL ^HLB("AE",MSGID,MSGIEN_"^"_SUBIEN)
End DoDot:1
+45 ;
+46 IF MSG("DIRECTION")="IN"
Begin DoDot:1
+47 if FS=""
QUIT
+48 NEW VALUE,HDR
+49 SET HDR("SENDING APPLICATION")=$PIECE(MSG("HDR",1),FS,3)
+50 SET VALUE=$PIECE(MSG("HDR",1),FS,4)
+51 SET HDR("SENDING FACILITY",1)=$PIECE(VALUE,CS)
+52 SET HDR("SENDING FACILITY",2)=$PIECE(VALUE,CS,2)
+53 SET HDR("SENDING FACILITY",3)=$PIECE(VALUE,CS,3)
+54 SET AC=$SELECT(HDR("SENDING FACILITY",2)]"":HDR("SENDING FACILITY",2),1:HDR("SENDING FACILITY",1))_HDR("SENDING APPLICATION")_MSG("ID")
End DoDot:1
+55 KILL ^HLB(MSGIEN)
+56 IF MSG("STATUS","PURGE")
IF MSG("DIRECTION")'=""
KILL ^HLB("AD",MSG("DIRECTION"),MSG("STATUS","PURGE"),MSGIEN)
+57 if (MSG("ID")]"")
KILL ^HLB("B",MSG("ID"),MSGIEN)
+58 IF MSG("DIRECTION")="IN"
Begin DoDot:1
+59 if ($GET(AC)]"")
KILL ^HLB("AC",AC,MSGIEN)
+60 IF MSG("BODY")
IF '$GET(FLAG)
DO KILL777(MSG("BODY"))
End DoDot:1
+61 IF MSG("DIRECTION")="OUT"
Begin DoDot:1
+62 KILL ^HLB("C",+MSG("BODY"),MSGIEN)
+63 IF '$GET(FLAG)
IF '$ORDER(^HLB("C",+MSG("BODY"),0))
DO KILL777(MSG("BODY"))
End DoDot:1
+64 QUIT
+65 ;
KILL777(BODY) ;
+1 if '$GET(BODY)
QUIT
+2 NEW TIME
+3 SET TIME=$PIECE($GET(^HLA(BODY,0)),"^")
+4 KILL ^HLA(BODY)
+5 if (TIME]"")
KILL ^HLA("B",TIME,BODY)
+6 QUIT
+7 ;
KSEARCH(MSG,MSGTYPE,EVENT,SAPP,RAPP,IEN) ;
+1 ;Kills the ^HLB("SEARCH") x-ref
+2 ;
+3 NEW APP
+4 if MSGTYPE=""
SET MSGTYPE="<none>"
+5 if EVENT=""
SET EVENT="<none>"
+6 if 'MSG("DT/TM CREATED")
QUIT
+7 IF MSG("DIRECTION")'="IN"
IF MSG("DIRECTION")'="OUT"
QUIT
+8 SET APP=$SELECT(MSG("DIRECTION")="IN":RAPP,1:SAPP)
+9 if APP=""
QUIT
+10 KILL ^HLB("SEARCH",MSG("DIRECTION"),MSG("DT/TM CREATED"),APP,MSGTYPE,EVENT,IEN)
+11 QUIT
