HLOPURGE ;IRMFO-ALB/CJM - Purging Old Messages;03/24/2004 14:43
;;1.6;HEALTH LEVEL SEVEN;**126**;Oct 13, 1995
;
GETWORK(WORK) ;
;
N OK S OK=0
I $G(WORK)]"" L -HLPURGE(WORK)
F WORK="IN","OUT","OLD778","OLD777" I '$G(WORK("DONE",WORK)) L +HLPURGE(WORK):0 S OK=$T Q:OK
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
...D DELETE(MSGIEN)
...K ^HLB("AD",WORK,TIME,MSGIEN)
S WORK("DONE",WORK)=1
Q
OLD778 ;
N OLD,START,END,APP,TYPE
S OLD=$$FMADD^XLFDT($$DT^XLFDT,-45)
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 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
F TYPE="TF","AE","SE" S APP="" F S APP=$O(^HLB("ERRORS",TYPE,APP)) Q:APP="" D
.N TIME
.S TIME=0
.F S TIME=$O(^HLB("ERRORS",TYPE,APP,TIME)) Q:'TIME Q:TIME>OLD K ^HLB("ERRORS",TYPE,APP,TIME)
Q
OLD777 ;
N OLD,TIME
S OLD=$$FMADD^XLFDT($$DT^XLFDT,-45)
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
..S IEN778=0
..F S IEN778=$O(^HLB("C",MSGIEN,IEN778)) Q:'IEN778 D DELETE(IEN778,1)
..K ^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
Q:'$$GETMSG^HLOMSG(MSGIEN,.MSG)
S (RAPP,SAPP)=""
D
.S FS=$E(MSG("HDR",1),4)
.Q:FS=""
.S CS=$E(MSG("HDR",1),5)
.S SAPP=$P($P(MSG("HDR",1),FS,3),CS)
.I SAPP="" S SAPP="UNKNOWN"
.S RAPP=$P($P(MSG("HDR",1),FS,5),CS)
.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
.N APP
.S APP=$S(MSG("STATUS")="TF":SAPP,1:RAPP)
.K ^HLB("ERRORS",MSG("STATUS"),APP,MSG("DT/TM CREATED"),MSGIEN)
.I MSG("STATUS")="AE" D
..N SUB
..S SUB=MSGIEN_"^"
..K ^HLB("ERRORS","AE",APP,MSG("DT/TM CREATED"),SUB)
..F S SUB=$O(^HLB("ERRORS","AE",APP,MSG("DT/TM CREATED"),SUB)) Q:SUB="" Q:+SUB'=MSGIEN K ^HLB("ERRORS","AE",APP,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:(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) ;
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
Q:MSGTYPE=""
Q:EVENT=""
Q:'MSG("DT/TM CREATED")
I MSG("DIRECTION")'="IN",MSG("DIRECTION")'="OUT" Q
S APP=$S(MSG("DIRECTION")="IN":RAPP,1:SAPP)
K ^HLB("SEARCH",MSG("DIRECTION"),MSG("DT/TM CREATED"),APP,MSGTYPE,EVENT,IEN)
Q
HLOPURGE ;IRMFO-ALB/CJM - Purging Old Messages;03/24/2004 14:43
+1 ;;1.6;HEALTH LEVEL SEVEN;**126**;Oct 13, 1995
+2 ;
GETWORK(WORK) ;
+1 ;
+2 NEW OK
SET OK=0
+3 IF $GET(WORK)]""
LOCK -HLPURGE(WORK)
+4 FOR WORK="IN","OUT","OLD778","OLD777"
IF '$GET(WORK("DONE",WORK))
LOCK +HLPURGE(WORK):0
SET OK=$TEST
IF OK
QUIT
+5 QUIT OK
+6 ;
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 DO DELETE(MSGIEN)
+12 KILL ^HLB("AD",WORK,TIME,MSGIEN)
End DoDot:3
End DoDot:2
End DoDot:1
+13 SET WORK("DONE",WORK)=1
+14 QUIT
OLD778 ;
+1 NEW OLD,START,END,APP,TYPE
+2 SET OLD=$$FMADD^XLFDT($$DT^XLFDT,-45)
+3 FOR START=0,100000000000,200000000000,300000000000
Begin DoDot:1
+4 SET END=(START+100000000000)-1
+5 NEW MSGIEN,QUIT
+6 SET QUIT=0
+7 SET MSGIEN=START
+8 FOR
SET MSGIEN=$ORDER(^HLB(MSGIEN))
IF 'MSGIEN
QUIT
IF (MSGIEN>END)
QUIT
Begin DoDot:2
+9 NEW WHEN,BODY,NODE
+10 SET NODE=$GET(^HLB(MSGIEN,0))
+11 SET WHEN=$PIECE(NODE,"^",16)
+12 IF WHEN
IF WHEN<OLD
DO DELETE(MSGIEN)
QUIT
+13 IF 'WHEN
Begin DoDot:3
+14 SET BODY=$PIECE(NODE,"^",2)
+15 IF 'BODY
QUIT
+16 SET WHEN=+$GET(^HLA(BODY,0))
+17 IF WHEN
IF WHEN<OLD
Begin DoDot:4
+18 ;I've seen messages sitting on outgoing queues forever, but it should never happen for incoming
+19 IF $EXTRACT($PIECE(NODE,"^",4))="O"
IF $PIECE(NODE,"^",5)]""
IF $PIECE(NODE,"^",6)]""
Begin DoDot:5
+20 NEW FROM
+21 SET FROM=$PIECE(NODE,"^",5)
+22 IF $PIECE(NODE,"^",8)
SET FROM=FROM_":"_$PIECE(NODE,"^",8)
+23 IF '$DATA(^HLB("QUEUE","OUT",FROM,$PIECE(NODE,"^",6),MSGIEN))
QUIT
+24 DO DEQUE^HLOQUE(FROM,$PIECE(NODE,"^",6),"OUT",MSGIEN)
End DoDot:5
+25 DO DELETE(MSGIEN)
QUIT
End DoDot:4
QUIT
+26 ;stop looking for old records?
+27 IF WHEN
IF WHEN>OLD
SET QUIT=1
End DoDot:3
End DoDot:2
IF QUIT
QUIT
End DoDot:1
+28 ;
+29 ;also kill old errors left lying around
+30 FOR TYPE="TF","AE","SE"
SET APP=""
FOR
SET APP=$ORDER(^HLB("ERRORS",TYPE,APP))
IF APP=""
QUIT
Begin DoDot:1
+31 NEW TIME
+32 SET TIME=0
+33 FOR
SET TIME=$ORDER(^HLB("ERRORS",TYPE,APP,TIME))
IF 'TIME
QUIT
IF TIME>OLD
QUIT
KILL ^HLB("ERRORS",TYPE,APP,TIME)
End DoDot:1
+34 QUIT
OLD777 ;
+1 NEW OLD,TIME
+2 SET OLD=$$FMADD^XLFDT($$DT^XLFDT,-45)
+3 SET TIME=0
+4 FOR
SET TIME=$ORDER(^HLA("B",TIME))
IF 'TIME
QUIT
IF TIME>OLD
QUIT
Begin DoDot:1
+5 NEW MSGIEN
+6 SET MSGIEN=0
+7 FOR
SET MSGIEN=$ORDER(^HLA("B",TIME,MSGIEN))
IF 'MSGIEN
QUIT
Begin DoDot:2
+8 NEW IEN778
+9 SET IEN778=0
+10 FOR
SET IEN778=$ORDER(^HLB("C",MSGIEN,IEN778))
IF 'IEN778
QUIT
DO DELETE(IEN778,1)
+11 KILL ^HLB("C",MSGIEN),^HLA("B",TIME,MSGIEN),^HLA(MSGIEN)
End DoDot:2
End DoDot:1
+12 QUIT
+13 ;
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
+5 IF '$$GETMSG^HLOMSG(MSGIEN,.MSG)
QUIT
+6 SET (RAPP,SAPP)=""
+7 Begin DoDot:1
+8 SET FS=$EXTRACT(MSG("HDR",1),4)
+9 IF FS=""
QUIT
+10 SET CS=$EXTRACT(MSG("HDR",1),5)
+11 SET SAPP=$PIECE($PIECE(MSG("HDR",1),FS,3),CS)
+12 IF SAPP=""
SET SAPP="UNKNOWN"
+13 SET RAPP=$PIECE($PIECE(MSG("HDR",1),FS,5),CS)
+14 IF RAPP=""
SET RAPP="UNKNOWN"
End DoDot:1
+15 ;
+16 IF 'MSG("BATCH")
DO KSEARCH(.MSG,MSG("MESSAGE TYPE"),MSG("EVENT"),SAPP,RAPP,MSGIEN)
+17 ;if an error status,take care of the "ERRORS" x-ref
+18 IF MSG("STATUS")'=""
IF MSG("STATUS")'="SU"
IF MSG("BODY")
Begin DoDot:1
+19 NEW APP
+20 SET APP=$SELECT(MSG("STATUS")="TF":SAPP,1:RAPP)
+21 KILL ^HLB("ERRORS",MSG("STATUS"),APP,MSG("DT/TM CREATED"),MSGIEN)
+22 IF MSG("STATUS")="AE"
Begin DoDot:2
+23 NEW SUB
+24 SET SUB=MSGIEN_"^"
+25 KILL ^HLB("ERRORS","AE",APP,MSG("DT/TM CREATED"),SUB)
+26 FOR
SET SUB=$ORDER(^HLB("ERRORS","AE",APP,MSG("DT/TM CREATED"),SUB))
IF SUB=""
QUIT
IF +SUB'=MSGIEN
QUIT
KILL ^HLB("ERRORS","AE",APP,MSG("DT/TM CREATED"),SUB)
End DoDot:2
End DoDot:1
+27 ;
+28 ;kill the whole-file xrefs for the message ien within a batch
+29 SET SUBIEN=0
+30 FOR
SET SUBIEN=$ORDER(^HLB(MSGIEN,3,SUBIEN))
IF 'SUBIEN
QUIT
Begin DoDot:1
+31 NEW MSGID
+32 IF FS]""
Begin DoDot:2
+33 NEW VALUE,HDR2,MSGTYPE,EVENT
+34 SET HDR2=$GET(^HLB(MSGIEN,3,SUBIEN,2))
+35 SET VALUE=$PIECE(HDR2,FS,4)
+36 SET MSGTYPE=$PIECE(VALUE,CS)
+37 SET EVENT=$PIECE(VALUE,CS,2)
+38 DO KSEARCH(.MSG,MSGTYPE,EVENT,SAPP,RAPP,MSGIEN_"^"_SUBIEN)
End DoDot:2
+39 SET MSGID=$PIECE($GET(^HLB(MSGIEN,3,SUBIEN,0)),"^",2)
+40 IF MSGID]""
KILL ^HLB("AE",MSGID,MSGIEN_"^"_SUBIEN)
End DoDot:1
+41 ;
+42 IF MSG("DIRECTION")="IN"
Begin DoDot:1
+43 IF FS=""
QUIT
+44 NEW VALUE,HDR
+45 SET HDR("SENDING APPLICATION")=$PIECE(MSG("HDR",1),FS,3)
+46 SET VALUE=$PIECE(MSG("HDR",1),FS,4)
+47 SET HDR("SENDING FACILITY",1)=$PIECE(VALUE,CS)
+48 SET HDR("SENDING FACILITY",2)=$PIECE(VALUE,CS,2)
+49 SET HDR("SENDING FACILITY",3)=$PIECE(VALUE,CS,3)
+50 SET AC=$SELECT(HDR("SENDING FACILITY",2)]"":HDR("SENDING FACILITY",2),1:HDR("SENDING FACILITY",1))_HDR("SENDING APPLICATION")_MSG("ID")
End DoDot:1
+51 KILL ^HLB(MSGIEN)
+52 IF MSG("STATUS","PURGE")
IF MSG("DIRECTION")'=""
KILL ^HLB("AD",MSG("DIRECTION"),MSG("STATUS","PURGE"),MSGIEN)
+53 IF (MSG("ID")]"")
KILL ^HLB("B",MSG("ID"),MSGIEN)
+54 IF MSG("DIRECTION")="IN"
Begin DoDot:1
+55 IF (AC]"")
KILL ^HLB("AC",AC,MSGIEN)
+56 IF MSG("BODY")
IF '$GET(FLAG)
DO KILL777(MSG("BODY"))
End DoDot:1
+57 IF MSG("DIRECTION")="OUT"
Begin DoDot:1
+58 KILL ^HLB("C",+MSG("BODY"),MSGIEN)
+59 IF '$GET(FLAG)
IF '$ORDER(^HLB("C",+MSG("BODY"),0))
DO KILL777(MSG("BODY"))
End DoDot:1
+60 QUIT
+61 ;
KILL777(BODY) ;
+1 NEW TIME
+2 SET TIME=$PIECE($GET(^HLA(BODY,0)),"^")
+3 KILL ^HLA(BODY)
+4 IF (TIME]"")
KILL ^HLA("B",TIME,BODY)
+5 QUIT
+6 ;
KSEARCH(MSG,MSGTYPE,EVENT,SAPP,RAPP,IEN) ;
+1 ;Kills the ^HLB("SEARCH") x-ref
+2 ;
+3 NEW APP
+4 IF MSGTYPE=""
QUIT
+5 IF EVENT=""
QUIT
+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 KILL ^HLB("SEARCH",MSG("DIRECTION"),MSG("DT/TM CREATED"),APP,MSGTYPE,EVENT,IEN)
+10 QUIT
