Index: WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOPURGE.m
===================================================================
--- WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOPURGE.m	(revision 613)
+++ WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOPURGE.m	(revision 623)
@@ -1,164 +1,165 @@
-HLOPURGE	;IRMFO-ALB/CJM - Purging Old Messages;03/24/2004  14:43 ;07/25/2007
-	;;1.6;HEALTH LEVEL SEVEN;**126,134,136,137**;Oct 13, 1995;Build 21
-	;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,-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
-	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,-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
-	.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
+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
