Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: HLOPURGE

HLOPURGE.m

Go to the documentation of this file.
  1. 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
  1. ;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;
  1. GETWORK(WORK) ;
  1. ;
  1. N OK
  1. S OK=0
  1. I $G(WORK)]"" L -HLPURGE(WORK)
  1. 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
  1. I 'OK K WORK("DONE") S WORK=""
  1. Q OK
  1. ;
  1. DOWORK(WORK) ;
  1. I WORK="OLD778" D OLD778
  1. I WORK="OLD777" D OLD777
  1. I (WORK="IN")!(WORK="OUT") D
  1. .N TIME,NOW
  1. .S NOW=$$NOW^XLFDT
  1. .S TIME=0
  1. .F S TIME=$O(^HLB("AD",WORK,TIME)) Q:TIME="" Q:TIME>NOW D
  1. ..N MSGIEN
  1. ..S MSGIEN=0
  1. ..F S MSGIEN=$O(^HLB("AD",WORK,TIME,MSGIEN)) Q:'MSGIEN D
  1. ...K ^HLB("AD",WORK,TIME,MSGIEN)
  1. ...D DELETE(MSGIEN)
  1. L -HLPURGE(WORK)
  1. Q
  1. OLD778 ;
  1. N OLD,START,END,APP,TYPE,TODAY,PARMS
  1. S TODAY=$$DT^XLFDT
  1. S OLD=$$FMADD^XLFDT(TODAY,-$$OLDPURGE^HLOSITE)
  1. F START=0,100000000000,200000000000,300000000000 D
  1. .S END=(START+100000000000)-1
  1. .N MSGIEN,QUIT
  1. .S QUIT=0
  1. .S MSGIEN=START
  1. .F S MSGIEN=$O(^HLB(MSGIEN)) Q:'MSGIEN Q:(MSGIEN>END) D Q:QUIT
  1. ..N WHEN,BODY,NODE
  1. ..S NODE=$G(^HLB(MSGIEN,0))
  1. ..S WHEN=$P(NODE,"^",16)
  1. ..I WHEN,WHEN<OLD,$P(NODE,"^",9)<TODAY D DELETE(MSGIEN) Q
  1. ..I 'WHEN D
  1. ...S BODY=$P(NODE,"^",2)
  1. ...Q:'BODY
  1. ...S WHEN=+$G(^HLA(BODY,0))
  1. ...I WHEN,WHEN<OLD D Q
  1. ....;I've seen messages sitting on outgoing queues forever, but it should never happen for incoming
  1. ....I $E($P(NODE,"^",4))="O",$P(NODE,"^",5)]"",$P(NODE,"^",6)]"" D
  1. .....N FROM
  1. .....S FROM=$P(NODE,"^",5)
  1. .....I $P(NODE,"^",8) S FROM=FROM_":"_$P(NODE,"^",8)
  1. .....Q:'$D(^HLB("QUEUE","OUT",FROM,$P(NODE,"^",6),MSGIEN))
  1. .....D DEQUE^HLOQUE(FROM,$P(NODE,"^",6),"OUT",MSGIEN)
  1. ....D DELETE(MSGIEN) Q
  1. ...;stop looking for old records?
  1. ...I WHEN,WHEN>OLD S QUIT=1
  1. ;
  1. ;also kill old errors left lying around
  1. D SYSPARMS^HLOSITE(.PARMS)
  1. S OLD=$$FMADD^XLFDT($$DT^XLFDT,-PARMS("ERROR PURGE"))
  1. S APP=""
  1. F S APP=$O(^HLB("ERRORS",APP)) Q:APP="" D
  1. .N TIME
  1. .S TIME=0
  1. .F S TIME=$O(^HLB("ERRORS",APP,TIME)) Q:'TIME Q:TIME>OLD K ^HLB("ERRORS",APP,TIME)
  1. Q
  1. OLD777 ;
  1. N OLD,TIME,TODAY
  1. S TODAY=$$DT^XLFDT
  1. S OLD=$$FMADD^XLFDT(TODAY,-$$OLDPURGE^HLOSITE)
  1. S TIME=0
  1. F S TIME=$O(^HLA("B",TIME)) Q:'TIME Q:TIME>OLD D
  1. .N MSGIEN
  1. .S MSGIEN=0
  1. .F S MSGIEN=$O(^HLA("B",TIME,MSGIEN)) Q:'MSGIEN D
  1. ..N IEN778,STOP
  1. ..S (STOP,IEN778)=0
  1. ..F S IEN778=$O(^HLB("C",MSGIEN,IEN778)) Q:'IEN778 D
  1. ...I $P($G(^HLB(IEN778,0)),"^",9)>TODAY S STOP=1 Q
  1. ...D DELETE(IEN778,1)
  1. ..K:'STOP ^HLB("C",MSGIEN),^HLA("B",TIME,MSGIEN),^HLA(MSGIEN)
  1. Q
  1. ;
  1. DELETE(MSGIEN,FLAG) ;
  1. ;Input:
  1. ; MSGIEN - IEN, file 778
  1. ; FLAG - if $G(FLAG), will not delete the pointed to record in file 777
  1. N AC,SUBIEN,RAPP,SAPP,FS,CS,MSG
  1. I '$$GETMSG^HLOMSG(MSGIEN,.MSG) ;MSG is corrupted, but there sill may be nodes to delete
  1. S (RAPP,SAPP)=""
  1. D
  1. .; ** Begin HL*1.6*143 changes
  1. .;S FS=$E(MSG("HDR",1),4)
  1. .S FS=$E($G(MSG("HDR",1)),4)
  1. .;Q:FS=""
  1. .;S CS=$E($G(MSG("HDR",1)),5)
  1. .S CS=$E($G(MSG("HDR",1)),5)
  1. .; .S SAPP=$P($P(MSG("HDR",1),FS,3),CS)
  1. .S SAPP=$P($P($G(MSG("HDR",1)),FS,3),CS)
  1. .I SAPP="" S SAPP="UNKNOWN"
  1. .;.S RAPP=$P($P(MSG("HDR",1),FS,5),CS)
  1. .S RAPP=$P($P($G(MSG("HDR",1)),FS,5),CS)
  1. .; ** End HL*1.6*143 changes
  1. .I RAPP="" S RAPP="UNKNOWN"
  1. ;
  1. I 'MSG("BATCH") D KSEARCH(.MSG,MSG("MESSAGE TYPE"),MSG("EVENT"),SAPP,RAPP,MSGIEN)
  1. ;if an error status,take care of the "ERRORS" x-ref
  1. I MSG("STATUS")'="",MSG("STATUS")'="SU",MSG("BODY") D
  1. .K ^HLB("ERRORS",RAPP,MSG("DT/TM CREATED"),MSGIEN)
  1. .I MSG("STATUS")="ER" D
  1. ..N SUB
  1. ..S SUB=MSGIEN_"^"
  1. ..K ^HLB("ERRORS",RAPP,MSG("DT/TM CREATED"),SUB)
  1. ..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)
  1. ;
  1. ;kill the whole-file xrefs for the message ien within a batch
  1. S SUBIEN=0
  1. F S SUBIEN=$O(^HLB(MSGIEN,3,SUBIEN)) Q:'SUBIEN D
  1. .N MSGID
  1. .I FS]"" D
  1. ..N VALUE,HDR2,MSGTYPE,EVENT
  1. ..S HDR2=$G(^HLB(MSGIEN,3,SUBIEN,2))
  1. ..S VALUE=$P(HDR2,FS,4)
  1. ..S MSGTYPE=$P(VALUE,CS)
  1. ..S EVENT=$P(VALUE,CS,2)
  1. ..D KSEARCH(.MSG,MSGTYPE,EVENT,SAPP,RAPP,MSGIEN_"^"_SUBIEN)
  1. .S MSGID=$P($G(^HLB(MSGIEN,3,SUBIEN,0)),"^",2)
  1. .I MSGID]"" K ^HLB("AE",MSGID,MSGIEN_"^"_SUBIEN)
  1. ;
  1. I MSG("DIRECTION")="IN" D
  1. .Q:FS=""
  1. .N VALUE,HDR
  1. .S HDR("SENDING APPLICATION")=$P(MSG("HDR",1),FS,3)
  1. .S VALUE=$P(MSG("HDR",1),FS,4)
  1. .S HDR("SENDING FACILITY",1)=$P(VALUE,CS)
  1. .S HDR("SENDING FACILITY",2)=$P(VALUE,CS,2)
  1. .S HDR("SENDING FACILITY",3)=$P(VALUE,CS,3)
  1. .S AC=$S(HDR("SENDING FACILITY",2)]"":HDR("SENDING FACILITY",2),1:HDR("SENDING FACILITY",1))_HDR("SENDING APPLICATION")_MSG("ID")
  1. K ^HLB(MSGIEN)
  1. I MSG("STATUS","PURGE"),MSG("DIRECTION")'="" K ^HLB("AD",MSG("DIRECTION"),MSG("STATUS","PURGE"),MSGIEN)
  1. K:(MSG("ID")]"") ^HLB("B",MSG("ID"),MSGIEN)
  1. I MSG("DIRECTION")="IN" D
  1. .K:($G(AC)]"") ^HLB("AC",AC,MSGIEN)
  1. .I MSG("BODY"),'$G(FLAG) D KILL777(MSG("BODY"))
  1. I MSG("DIRECTION")="OUT" D
  1. .K ^HLB("C",+MSG("BODY"),MSGIEN)
  1. .I '$G(FLAG),'$O(^HLB("C",+MSG("BODY"),0)) D KILL777(MSG("BODY"))
  1. Q
  1. ;
  1. KILL777(BODY) ;
  1. Q:'$G(BODY)
  1. N TIME
  1. S TIME=$P($G(^HLA(BODY,0)),"^")
  1. K ^HLA(BODY)
  1. K:(TIME]"") ^HLA("B",TIME,BODY)
  1. Q
  1. ;
  1. KSEARCH(MSG,MSGTYPE,EVENT,SAPP,RAPP,IEN) ;
  1. ;Kills the ^HLB("SEARCH") x-ref
  1. ;
  1. N APP
  1. S:MSGTYPE="" MSGTYPE="<none>"
  1. S:EVENT="" EVENT="<none>"
  1. Q:'MSG("DT/TM CREATED")
  1. I MSG("DIRECTION")'="IN",MSG("DIRECTION")'="OUT" Q
  1. S APP=$S(MSG("DIRECTION")="IN":RAPP,1:SAPP)
  1. Q:APP=""
  1. K ^HLB("SEARCH",MSG("DIRECTION"),MSG("DT/TM CREATED"),APP,MSGTYPE,EVENT,IEN)
  1. Q