source: WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOPURGE.m@ 619

Last change on this file since 619 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 5.1 KB
RevLine 
[613]1HLOPURGE ;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 ;
5GETWORK(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 ;
14DOWORK(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
29OLD778 ;
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
68OLD777 ;
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 ;
85DELETE(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 ;
145KILL777(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 ;
153KSEARCH(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
Note: See TracBrowser for help on using the repository browser.