166 lines
5.2 KiB
Mathematica
166 lines
5.2 KiB
Mathematica
HLOPURGE ;IRMFO-ALB/CJM - Purging Old Messages;03/24/2004 14:43 ;04/30/2007
|
|
;;1.6;HEALTH LEVEL SEVEN;**126,134,136**;Oct 13, 1995;Build 9
|
|
;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
|
|
S TODAY=$$DT^XLFDT
|
|
S OLD=$$FMADD^XLFDT(TODAY,-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,$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
|
|
F TYPE="TF","AE","SE" S APP="" F S APP=$O(^HLB("ERRORS",TYPE,APP)) Q:APP="" D
|
|
.N TIME,PARMS
|
|
.D SYSPARMS^HLOSITE(.PARMS)
|
|
.S OLD=$$FMADD^XLFDT($$DT^XLFDT,-PARMS("ERROR PURGE"))
|
|
.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,TODAY
|
|
S TODAY=$$DT^XLFDT
|
|
S OLD=$$FMADD^XLFDT(TODAY,-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,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
|
|
.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:($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
|