- 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 Feb 18, 2025@23:25:29 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