Changeset 623 for WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOPURGE.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOPURGE.m
r613 r623 1 HLOPURGE ;IRMFO-ALB/CJM - Purging Old Messages;03/24/2004 14:43 ;07/25/2007 2 ;;1.6;HEALTH LEVEL SEVEN;**126,134,136,137**;Oct 13, 1995;Build 21 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 GETWORK(WORK) ; 6 ; 7 N OK 8 S OK=0 9 I $G(WORK)]"" L -HLPURGE(WORK) 10 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 11 I 'OK K WORK("DONE") S WORK="" 12 Q OK 13 ; 14 DOWORK(WORK) ; 15 I WORK="OLD778" D OLD778 16 I WORK="OLD777" D OLD777 17 I (WORK="IN")!(WORK="OUT") D 18 .N TIME,NOW 19 .S NOW=$$NOW^XLFDT 20 .S TIME=0 21 .F S TIME=$O(^HLB("AD",WORK,TIME)) Q:TIME="" Q:TIME>NOW D 22 ..N MSGIEN 23 ..S MSGIEN=0 24 ..F S MSGIEN=$O(^HLB("AD",WORK,TIME,MSGIEN)) Q:'MSGIEN D 25 ...K ^HLB("AD",WORK,TIME,MSGIEN) 26 ...D DELETE(MSGIEN) 27 L -HLPURGE(WORK) 28 Q 29 OLD778 ; 30 N OLD,START,END,APP,TYPE,TODAY,PARMS 31 S TODAY=$$DT^XLFDT 32 S OLD=$$FMADD^XLFDT(TODAY,-45) 33 F START=0,100000000000,200000000000,300000000000 D 34 .S END=(START+100000000000)-1 35 .N MSGIEN,QUIT 36 .S QUIT=0 37 .S MSGIEN=START 38 .F S MSGIEN=$O(^HLB(MSGIEN)) Q:'MSGIEN Q:(MSGIEN>END) D Q:QUIT 39 ..N WHEN,BODY,NODE 40 ..S NODE=$G(^HLB(MSGIEN,0)) 41 ..S WHEN=$P(NODE,"^",16) 42 ..I WHEN,WHEN<OLD,$P(NODE,"^",9)<TODAY D DELETE(MSGIEN) Q 43 ..I 'WHEN D 44 ...S BODY=$P(NODE,"^",2) 45 ...Q:'BODY 46 ...S WHEN=+$G(^HLA(BODY,0)) 47 ...I WHEN,WHEN<OLD D Q 48 ....;I've seen messages sitting on outgoing queues forever, but it should never happen for incoming 49 ....I $E($P(NODE,"^",4))="O",$P(NODE,"^",5)]"",$P(NODE,"^",6)]"" D 50 .....N FROM 51 .....S FROM=$P(NODE,"^",5) 52 .....I $P(NODE,"^",8) S FROM=FROM_":"_$P(NODE,"^",8) 53 .....Q:'$D(^HLB("QUEUE","OUT",FROM,$P(NODE,"^",6),MSGIEN)) 54 .....D DEQUE^HLOQUE(FROM,$P(NODE,"^",6),"OUT",MSGIEN) 55 ....D DELETE(MSGIEN) Q 56 ...;stop looking for old records? 57 ...I WHEN,WHEN>OLD S QUIT=1 58 ; 59 ;also kill old errors left lying around 60 D SYSPARMS^HLOSITE(.PARMS) 61 S OLD=$$FMADD^XLFDT($$DT^XLFDT,-PARMS("ERROR PURGE")) 62 S APP="" 63 F S APP=$O(^HLB("ERRORS",APP)) Q:APP="" D 64 .N TIME 65 .S TIME=0 66 .F S TIME=$O(^HLB("ERRORS",APP,TIME)) Q:'TIME Q:TIME>OLD K ^HLB("ERRORS",APP,TIME) 67 Q 68 OLD777 ; 69 N OLD,TIME,TODAY 70 S TODAY=$$DT^XLFDT 71 S OLD=$$FMADD^XLFDT(TODAY,-45) 72 S TIME=0 73 F S TIME=$O(^HLA("B",TIME)) Q:'TIME Q:TIME>OLD D 74 .N MSGIEN 75 .S MSGIEN=0 76 .F S MSGIEN=$O(^HLA("B",TIME,MSGIEN)) Q:'MSGIEN D 77 ..N IEN778,STOP 78 ..S (STOP,IEN778)=0 79 ..F S IEN778=$O(^HLB("C",MSGIEN,IEN778)) Q:'IEN778 D 80 ...I $P($G(^HLB(IEN778,0)),"^",9)>TODAY S STOP=1 Q 81 ...D DELETE(IEN778,1) 82 ..K:'STOP ^HLB("C",MSGIEN),^HLA("B",TIME,MSGIEN),^HLA(MSGIEN) 83 Q 84 ; 85 DELETE(MSGIEN,FLAG) ; 86 ;Input: 87 ; MSGIEN - IEN, file 778 88 ; FLAG - if $G(FLAG), will not delete the pointed to record in file 777 89 N AC,SUBIEN,RAPP,SAPP,FS,CS,MSG 90 I '$$GETMSG^HLOMSG(MSGIEN,.MSG) ;MSG is corrupted, but there sill may be nodes to delete 91 S (RAPP,SAPP)="" 92 D 93 .S FS=$E(MSG("HDR",1),4) 94 .Q:FS="" 95 .S CS=$E(MSG("HDR",1),5) 96 .S SAPP=$P($P(MSG("HDR",1),FS,3),CS) 97 .I SAPP="" S SAPP="UNKNOWN" 98 .S RAPP=$P($P(MSG("HDR",1),FS,5),CS) 99 .I RAPP="" S RAPP="UNKNOWN" 100 ; 101 I 'MSG("BATCH") D KSEARCH(.MSG,MSG("MESSAGE TYPE"),MSG("EVENT"),SAPP,RAPP,MSGIEN) 102 ;if an error status,take care of the "ERRORS" x-ref 103 I MSG("STATUS")'="",MSG("STATUS")'="SU",MSG("BODY") D 104 .K ^HLB("ERRORS",RAPP,MSG("DT/TM CREATED"),MSGIEN) 105 .I MSG("STATUS")="ER" D 106 ..N SUB 107 ..S SUB=MSGIEN_"^" 108 ..K ^HLB("ERRORS",RAPP,MSG("DT/TM CREATED"),SUB) 109 ..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) 110 ; 111 ;kill the whole-file xrefs for the message ien within a batch 112 S SUBIEN=0 113 F S SUBIEN=$O(^HLB(MSGIEN,3,SUBIEN)) Q:'SUBIEN D 114 .N MSGID 115 .I FS]"" D 116 ..N VALUE,HDR2,MSGTYPE,EVENT 117 ..S HDR2=$G(^HLB(MSGIEN,3,SUBIEN,2)) 118 ..S VALUE=$P(HDR2,FS,4) 119 ..S MSGTYPE=$P(VALUE,CS) 120 ..S EVENT=$P(VALUE,CS,2) 121 ..D KSEARCH(.MSG,MSGTYPE,EVENT,SAPP,RAPP,MSGIEN_"^"_SUBIEN) 122 .S MSGID=$P($G(^HLB(MSGIEN,3,SUBIEN,0)),"^",2) 123 .I MSGID]"" K ^HLB("AE",MSGID,MSGIEN_"^"_SUBIEN) 124 ; 125 I MSG("DIRECTION")="IN" D 126 .Q:FS="" 127 .N VALUE,HDR 128 .S HDR("SENDING APPLICATION")=$P(MSG("HDR",1),FS,3) 129 .S VALUE=$P(MSG("HDR",1),FS,4) 130 .S HDR("SENDING FACILITY",1)=$P(VALUE,CS) 131 .S HDR("SENDING FACILITY",2)=$P(VALUE,CS,2) 132 .S HDR("SENDING FACILITY",3)=$P(VALUE,CS,3) 133 .S AC=$S(HDR("SENDING FACILITY",2)]"":HDR("SENDING FACILITY",2),1:HDR("SENDING FACILITY",1))_HDR("SENDING APPLICATION")_MSG("ID") 134 K ^HLB(MSGIEN) 135 I MSG("STATUS","PURGE"),MSG("DIRECTION")'="" K ^HLB("AD",MSG("DIRECTION"),MSG("STATUS","PURGE"),MSGIEN) 136 K:(MSG("ID")]"") ^HLB("B",MSG("ID"),MSGIEN) 137 I MSG("DIRECTION")="IN" D 138 .K:($G(AC)]"") ^HLB("AC",AC,MSGIEN) 139 .I MSG("BODY"),'$G(FLAG) D KILL777(MSG("BODY")) 140 I MSG("DIRECTION")="OUT" D 141 .K ^HLB("C",+MSG("BODY"),MSGIEN) 142 .I '$G(FLAG),'$O(^HLB("C",+MSG("BODY"),0)) D KILL777(MSG("BODY")) 143 Q 144 ; 145 KILL777(BODY) ; 146 Q:'$G(BODY) 147 N TIME 148 S TIME=$P($G(^HLA(BODY,0)),"^") 149 K ^HLA(BODY) 150 K:(TIME]"") ^HLA("B",TIME,BODY) 151 Q 152 ; 153 KSEARCH(MSG,MSGTYPE,EVENT,SAPP,RAPP,IEN) ; 154 ;Kills the ^HLB("SEARCH") x-ref 155 ; 156 N APP 157 S:MSGTYPE="" MSGTYPE="<none>" 158 S:EVENT="" EVENT="<none>" 159 Q:'MSG("DT/TM CREATED") 160 I MSG("DIRECTION")'="IN",MSG("DIRECTION")'="OUT" Q 161 S APP=$S(MSG("DIRECTION")="IN":RAPP,1:SAPP) 162 Q:APP="" 163 K ^HLB("SEARCH",MSG("DIRECTION"),MSG("DT/TM CREATED"),APP,MSGTYPE,EVENT,IEN) 164 Q 1 HLOPURGE ;IRMFO-ALB/CJM - Purging Old Messages;03/24/2004 14:43 ;04/30/2007 2 ;;1.6;HEALTH LEVEL SEVEN;**126,134,136**;Oct 13, 1995;Build 9 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 GETWORK(WORK) ; 6 ; 7 N OK 8 S OK=0 9 I $G(WORK)]"" L -HLPURGE(WORK) 10 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 11 I 'OK K WORK("DONE") S WORK="" 12 Q OK 13 ; 14 DOWORK(WORK) ; 15 I WORK="OLD778" D OLD778 16 I WORK="OLD777" D OLD777 17 I (WORK="IN")!(WORK="OUT") D 18 .N TIME,NOW 19 .S NOW=$$NOW^XLFDT 20 .S TIME=0 21 .F S TIME=$O(^HLB("AD",WORK,TIME)) Q:TIME="" Q:TIME>NOW D 22 ..N MSGIEN 23 ..S MSGIEN=0 24 ..F S MSGIEN=$O(^HLB("AD",WORK,TIME,MSGIEN)) Q:'MSGIEN D 25 ...K ^HLB("AD",WORK,TIME,MSGIEN) 26 ...D DELETE(MSGIEN) 27 L -HLPURGE(WORK) 28 Q 29 OLD778 ; 30 N OLD,START,END,APP,TYPE,TODAY 31 S TODAY=$$DT^XLFDT 32 S OLD=$$FMADD^XLFDT(TODAY,-45) 33 F START=0,100000000000,200000000000,300000000000 D 34 .S END=(START+100000000000)-1 35 .N MSGIEN,QUIT 36 .S QUIT=0 37 .S MSGIEN=START 38 .F S MSGIEN=$O(^HLB(MSGIEN)) Q:'MSGIEN Q:(MSGIEN>END) D Q:QUIT 39 ..N WHEN,BODY,NODE 40 ..S NODE=$G(^HLB(MSGIEN,0)) 41 ..S WHEN=$P(NODE,"^",16) 42 ..I WHEN,WHEN<OLD,$P(NODE,"^",9)<TODAY D DELETE(MSGIEN) Q 43 ..I 'WHEN D 44 ...S BODY=$P(NODE,"^",2) 45 ...Q:'BODY 46 ...S WHEN=+$G(^HLA(BODY,0)) 47 ...I WHEN,WHEN<OLD D Q 48 ....;I've seen messages sitting on outgoing queues forever, but it should never happen for incoming 49 ....I $E($P(NODE,"^",4))="O",$P(NODE,"^",5)]"",$P(NODE,"^",6)]"" D 50 .....N FROM 51 .....S FROM=$P(NODE,"^",5) 52 .....I $P(NODE,"^",8) S FROM=FROM_":"_$P(NODE,"^",8) 53 .....Q:'$D(^HLB("QUEUE","OUT",FROM,$P(NODE,"^",6),MSGIEN)) 54 .....D DEQUE^HLOQUE(FROM,$P(NODE,"^",6),"OUT",MSGIEN) 55 ....D DELETE(MSGIEN) Q 56 ...;stop looking for old records? 57 ...I WHEN,WHEN>OLD S QUIT=1 58 ; 59 ;also kill old errors left lying around 60 F TYPE="TF","AE","SE" S APP="" F S APP=$O(^HLB("ERRORS",TYPE,APP)) Q:APP="" D 61 .N TIME,PARMS 62 .D SYSPARMS^HLOSITE(.PARMS) 63 .S OLD=$$FMADD^XLFDT($$DT^XLFDT,-PARMS("ERROR PURGE")) 64 .S TIME=0 65 .F S TIME=$O(^HLB("ERRORS",TYPE,APP,TIME)) Q:'TIME Q:TIME>OLD K ^HLB("ERRORS",TYPE,APP,TIME) 66 Q 67 OLD777 ; 68 N OLD,TIME,TODAY 69 S TODAY=$$DT^XLFDT 70 S OLD=$$FMADD^XLFDT(TODAY,-45) 71 S TIME=0 72 F S TIME=$O(^HLA("B",TIME)) Q:'TIME Q:TIME>OLD D 73 .N MSGIEN 74 .S MSGIEN=0 75 .F S MSGIEN=$O(^HLA("B",TIME,MSGIEN)) Q:'MSGIEN D 76 ..N IEN778,STOP 77 ..S (STOP,IEN778)=0 78 ..F S IEN778=$O(^HLB("C",MSGIEN,IEN778)) Q:'IEN778 D 79 ...I $P($G(^HLB(IEN778,0)),"^",9)>TODAY S STOP=1 Q 80 ...D DELETE(IEN778,1) 81 ..K:'STOP ^HLB("C",MSGIEN),^HLA("B",TIME,MSGIEN),^HLA(MSGIEN) 82 Q 83 ; 84 DELETE(MSGIEN,FLAG) ; 85 ;Input: 86 ; MSGIEN - IEN, file 778 87 ; FLAG - if $G(FLAG), will not delete the pointed to record in file 777 88 N AC,SUBIEN,RAPP,SAPP,FS,CS,MSG 89 I '$$GETMSG^HLOMSG(MSGIEN,.MSG) ;MSG is corrupted, but there sill may be nodes to delete 90 S (RAPP,SAPP)="" 91 D 92 .S FS=$E(MSG("HDR",1),4) 93 .Q:FS="" 94 .S CS=$E(MSG("HDR",1),5) 95 .S SAPP=$P($P(MSG("HDR",1),FS,3),CS) 96 .I SAPP="" S SAPP="UNKNOWN" 97 .S RAPP=$P($P(MSG("HDR",1),FS,5),CS) 98 .I RAPP="" S RAPP="UNKNOWN" 99 ; 100 I 'MSG("BATCH") D KSEARCH(.MSG,MSG("MESSAGE TYPE"),MSG("EVENT"),SAPP,RAPP,MSGIEN) 101 ;if an error status,take care of the "ERRORS" x-ref 102 I MSG("STATUS")'="",MSG("STATUS")'="SU",MSG("BODY") D 103 .N APP 104 .S APP=$S(MSG("STATUS")="TF":SAPP,1:RAPP) 105 .K ^HLB("ERRORS",MSG("STATUS"),APP,MSG("DT/TM CREATED"),MSGIEN) 106 .I MSG("STATUS")="AE" D 107 ..N SUB 108 ..S SUB=MSGIEN_"^" 109 ..K ^HLB("ERRORS","AE",APP,MSG("DT/TM CREATED"),SUB) 110 ..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) 111 ; 112 ;kill the whole-file xrefs for the message ien within a batch 113 S SUBIEN=0 114 F S SUBIEN=$O(^HLB(MSGIEN,3,SUBIEN)) Q:'SUBIEN D 115 .N MSGID 116 .I FS]"" D 117 ..N VALUE,HDR2,MSGTYPE,EVENT 118 ..S HDR2=$G(^HLB(MSGIEN,3,SUBIEN,2)) 119 ..S VALUE=$P(HDR2,FS,4) 120 ..S MSGTYPE=$P(VALUE,CS) 121 ..S EVENT=$P(VALUE,CS,2) 122 ..D KSEARCH(.MSG,MSGTYPE,EVENT,SAPP,RAPP,MSGIEN_"^"_SUBIEN) 123 .S MSGID=$P($G(^HLB(MSGIEN,3,SUBIEN,0)),"^",2) 124 .I MSGID]"" K ^HLB("AE",MSGID,MSGIEN_"^"_SUBIEN) 125 ; 126 I MSG("DIRECTION")="IN" D 127 .Q:FS="" 128 .N VALUE,HDR 129 .S HDR("SENDING APPLICATION")=$P(MSG("HDR",1),FS,3) 130 .S VALUE=$P(MSG("HDR",1),FS,4) 131 .S HDR("SENDING FACILITY",1)=$P(VALUE,CS) 132 .S HDR("SENDING FACILITY",2)=$P(VALUE,CS,2) 133 .S HDR("SENDING FACILITY",3)=$P(VALUE,CS,3) 134 .S AC=$S(HDR("SENDING FACILITY",2)]"":HDR("SENDING FACILITY",2),1:HDR("SENDING FACILITY",1))_HDR("SENDING APPLICATION")_MSG("ID") 135 K ^HLB(MSGIEN) 136 I MSG("STATUS","PURGE"),MSG("DIRECTION")'="" K ^HLB("AD",MSG("DIRECTION"),MSG("STATUS","PURGE"),MSGIEN) 137 K:(MSG("ID")]"") ^HLB("B",MSG("ID"),MSGIEN) 138 I MSG("DIRECTION")="IN" D 139 .K:($G(AC)]"") ^HLB("AC",AC,MSGIEN) 140 .I MSG("BODY"),'$G(FLAG) D KILL777(MSG("BODY")) 141 I MSG("DIRECTION")="OUT" D 142 .K ^HLB("C",+MSG("BODY"),MSGIEN) 143 .I '$G(FLAG),'$O(^HLB("C",+MSG("BODY"),0)) D KILL777(MSG("BODY")) 144 Q 145 ; 146 KILL777(BODY) ; 147 Q:'$G(BODY) 148 N TIME 149 S TIME=$P($G(^HLA(BODY,0)),"^") 150 K ^HLA(BODY) 151 K:(TIME]"") ^HLA("B",TIME,BODY) 152 Q 153 ; 154 KSEARCH(MSG,MSGTYPE,EVENT,SAPP,RAPP,IEN) ; 155 ;Kills the ^HLB("SEARCH") x-ref 156 ; 157 N APP 158 S:MSGTYPE="" MSGTYPE="<none>" 159 S:EVENT="" EVENT="<none>" 160 Q:'MSG("DT/TM CREATED") 161 I MSG("DIRECTION")'="IN",MSG("DIRECTION")'="OUT" Q 162 S APP=$S(MSG("DIRECTION")="IN":RAPP,1:SAPP) 163 Q:APP="" 164 K ^HLB("SEARCH",MSG("DIRECTION"),MSG("DT/TM CREATED"),APP,MSGTYPE,EVENT,IEN) 165 Q
Note:
See TracChangeset
for help on using the changeset viewer.
