source: WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT2.m@ 1800

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

revised back to 6/30/08 version
File size: 7.1 KB
Line 
1HLOCLNT2 ;ALB/CJM- Performs message updates for the client - 10/4/94 1pm ;03/09/2007
2 ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,133,134**;Oct 13, 1995;Build 30
3 ;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5GETWORK(WORK) ;
6 ;
7 N OLD,DOLLARJ,SUCCESS,NOW
8 S SUCCESS=0
9 S NOW=$$NOW^XLFDT
10 S (OLD,DOLLARJ)=$G(WORK("DOLLARJ"))
11 F S DOLLARJ=$O(^HLTMP("CLIENT UPDATES",DOLLARJ)) Q:DOLLARJ="" D Q:SUCCESS
12 .L +^HLTMP("CLIENT UPDATES",DOLLARJ):0
13 .Q:'$T
14 .N TIME S TIME=$O(^HLTMP("CLIENT UPDATES",DOLLARJ,""))
15 .I $$FMDIFF^XLFDT(NOW,TIME,2)<2 L -^HLTMP("CLIENT UPDATES",DOLLARJ) Q
16 .S SUCCESS=1
17 ;
18 I OLD'="",'SUCCESS F S DOLLARJ=$O(^HLTMP("CLIENT UPDATES",DOLLARJ)) Q:DOLLARJ="" Q:DOLLARJ>OLD D Q:SUCCESS
19 .L +^HLTMP("CLIENT UPDATES",DOLLARJ):0
20 .Q:'$T
21 .N TIME S TIME=$O(^HLTMP("CLIENT UPDATES",DOLLARJ,""))
22 .I $$FMDIFF^XLFDT(NOW,TIME,2)<2 L -^HLTMP("CLIENT UPDATES",DOLLARJ) Q
23 .S SUCCESS=1
24 S WORK("DOLLARJ")=DOLLARJ,WORK("NOW")=NOW
25 Q $S($L(WORK("DOLLARJ")):1,1:0)
26 ;
27DOWORK(WORK) ;
28 ;
29 N DOLLARJ,TIME,IEN,PARMS,SYSTEM
30 S TIME=""
31 S DOLLARJ=WORK("DOLLARJ")
32 D SYSPARMS^HLOSITE(.SYSTEM)
33 F S TIME=$O(^HLTMP("CLIENT UPDATES",DOLLARJ,TIME)) Q:TIME="" Q:$$FMDIFF^XLFDT(WORK("NOW"),TIME,2)<2 D
34 .S IEN=0
35 .F S IEN=$O(^HLTMP("CLIENT UPDATES",DOLLARJ,TIME,IEN)) Q:'IEN D
36 ..N NODE
37 ..S NODE=$G(^HLTMP("CLIENT UPDATES",DOLLARJ,TIME,IEN))
38 ..S PARMS("LINK")=$P(NODE,"^")
39 ..S PARMS("QUEUE")=$P(NODE,"^",2)
40 ..S PARMS("STATUS")=$P(NODE,"^",3)
41 ..S PARMS("PURGE TYPE")=$P(NODE,"^",4)
42 ..S PARMS("ACK TO IEN")=+$P($P(NODE,"^",4),"-",2)
43 ..S PARMS("ACCEPT ACK")=$P(NODE,"^",5)
44 ..S PARMS("RECEIVING APP")=$P(NODE,"^",6)
45 ..S:PARMS("RECEIVING APP")="" PARMS("RECEIVING APP")="UNKNOWN RECEIVING APPLICATION"
46 ..S PARMS("MSA")=$G(^HLTMP("CLIENT UPDATES",DOLLARJ,TIME,IEN,"MSA"))
47 ..S PARMS("ACTION")=$G(^HLTMP("CLIENT UPDATES",DOLLARJ,TIME,IEN,"ACTION"))
48 ..D UPDATE(IEN,TIME,.PARMS)
49 ..K ^HLTMP("CLIENT UPDATES",DOLLARJ,TIME,IEN)
50 L -^HLTMP("CLIENT UPDATES",DOLLARJ)
51 Q
52 ;
53UPDATE(MSGIEN,TIME,PARMS) ;
54 S:PARMS("STATUS")]"" $P(^HLB(MSGIEN,0),"^",20)=PARMS("STATUS")
55 S:PARMS("STATUS")="SE" ^HLB("ERRORS","SE",PARMS("RECEIVING APP"),TIME,MSGIEN)=""
56 S:PARMS("STATUS")="AE" ^HLB("ERRORS","AE",PARMS("RECEIVING APP"),TIME,MSGIEN_"^")=""
57 I PARMS("STATUS")["E" D COUNT^HLOESTAT("OUT",PARMS("RECEIVING APP"),$$GETSAP(MSGIEN),$$GETMTYPE(MSGIEN))
58 S:PARMS("ACCEPT ACK") $P(^HLB(MSGIEN,0),"^",17)=PARMS("ACCEPT ACK")
59 S $P(^HLB(MSGIEN,0),"^",16)=TIME
60 S:PARMS("MSA")]"" ^HLB(MSGIEN,4)=TIME_"^"_PARMS("MSA")
61 I PARMS("PURGE TYPE"),PARMS("ACTION")="" D
62 .;don't set purge if going on the infiler - let infiler do it
63 .N PTIME
64 .S:(PARMS("PURGE TYPE")=2) PTIME=$$FMADD^XLFDT(TIME,SYSTEM("ERROR PURGE")) ;error purge is in days
65 .S:(PARMS("PURGE TYPE")'=2) PTIME=$$FMADD^XLFDT(TIME,,SYSTEM("NORMAL PURGE")) ;normal purge is in hours
66 .S $P(^HLB(MSGIEN,0),"^",9)=PTIME,^HLB("AD","OUT",PTIME,MSGIEN)=""
67 .I PARMS("ACK TO IEN"),$D(^HLB(PARMS("ACK TO IEN"),0)) S $P(^HLB(PARMS("ACK TO IEN"),0),"^",9)=PTIME,^HLB("AD","OUT",PTIME,PARMS("ACK TO IEN"))=""
68 D:PARMS("ACTION")]""
69 .N PURGE
70 .S PURGE=$S(PARMS("PURGE TYPE"):1,1:0)
71 .S:PARMS("ACK TO IEN") PURGE("ACKTOIEN")=PARMS("ACK TO IEN")
72 .D INQUE^HLOQUE(PARMS("LINK"),PARMS("QUEUE"),MSGIEN,PARMS("ACTION"),.PURGE)
73 Q
74 ;
75GETMSG(IEN,MSG) ;
76 ;
77 ;Description: given the message ien=MSGIEN (required), it returns the MSG array containing information about the message, defined below.
78 ;Input:
79 ; IEN - the ien of the message in file 778
80 ;Output:
81 ; Function returns 1 on success, 0 on failure
82 ; MSG (pass by reference, required) These are the subscripts returned:
83 ; "ACCEPT ACK RESPONSE" - if the sending app requested notification of the accept ack, this is the routine to perform
84 ; "ACKTOIEN" - if this is an app ack to a message not in a batch, this is the ien of the original message
85 ; "BATCH" = 1 if this is a batch message, 0 if not
86 ; "CURRENT MESSAGE" - defined only for batch messages - a counterused during building and parsing messages to indicate the current message. It will be set to 0 initially.
87 ; "BODY" - ptr to file 778 which contains the body of the message.
88 ; "LINE COUNT" - a counter used during writing of the
89 ; messages to indicate the current line. For
90 ; batch messages where each message within the batch is stored
91 ; separately, this field indicates the position within the current
92 ; individual message
93 ; "HDR" at these lower subscripts:
94 ; 1 - components 1-6
95 ; 2 - components 7-end
96 ; "ACCEPT ACK TYPE" = "AL" or "NE"
97 ; "APP ACK TYPE" = "AL" or "NE"
98 ; "MESSAGE CONTROL ID" - defined if NOT batch
99 ; "BATCH CONTROL ID" - defined if batch
100 ;
101 ; "ID" - message id from the header
102 ; "IEN" - ien, file 778
103 ;
104 K MSG
105 Q:'$G(IEN) 0
106 N NODE,FS,CS,REP,SUBCOMP,ESCAPE
107 S MSG("IEN")=IEN
108 S NODE=$G(^HLB(IEN,0))
109 S MSG("BODY")=$P(NODE,"^",2)
110 S MSG("ID")=$P(NODE,"^")
111 Q:'MSG("BODY") 0
112 S MSG("STATUS","ACCEPTED")=$P(NODE,"^",17)
113 S MSG("DT/TM")=$P(NODE,"^",16)
114 S MSG("STATUS","QUEUE")=$P(NODE,"^",6)
115 I MSG("STATUS","QUEUE")="" S MSG("STATUS","QUEUE")="DEFAULT"
116 S MSG("ACCEPT ACK RESPONSE")=$P(NODE,"^",12,13)
117 I MSG("ACCEPT ACK RESPONSE")="^" S MSG("ACCEPT ACK RESPONSE")=""
118 ;
119 S MSG("BATCH")=+$P($G(^HLA(MSG("BODY"),0)),"^",2)
120 I MSG("BATCH") D
121 .S MSG("BATCH","CURRENT MESSAGE")=0
122 E D
123 .N ACKTO
124 .S ACKTO=$P(NODE,"^",3)
125 .I ACKTO]"" S ACKTO=$$ACKTOIEN^HLOMSG1(MSG("ID"),ACKTO)
126 .I ACKTO,+ACKTO=ACKTO S MSG("ACK TO IEN")=ACKTO
127 S MSG("LINE COUNT")=0
128 S MSG("HDR",1)=$G(^HLB(IEN,1))
129 S MSG("HDR",2)=$G(^HLB(IEN,2))
130 S FS=$E(MSG("HDR",1),4)
131 S CS=$E(MSG("HDR",1),5)
132 S REP=$E(MSG("HDR",1),6)
133 S ESCAPE=$E(MSG("HDR",1),7)
134 S SUBCOMP=$E(MSG("HDR",1),8)
135 S MSG("HDR","FIELD SEPARATOR")=FS
136 S MSG("HDR","SENDING APPLICATION")=$$DESCAPE^HLOPRS1($P($P(MSG("HDR",1),FS,3),CS),FS,CS,SUBCOMP,REP,ESCAPE)
137 S MSG("HDR","RECEIVING APPLICATION")=$$DESCAPE^HLOPRS1($P($P(MSG("HDR",1),FS,5),CS),FS,CS,SUBCOMP,REP,ESCAPE)
138 I 'MSG("BATCH") D
139 .S MSG("HDR","MESSAGE TYPE")=$P($P(MSG("HDR",2),FS,4),CS)
140 .S MSG("HDR","EVENT")=$P($P(MSG("HDR",2),FS,4),CS,2)
141 .S MSG("HDR","ACCEPT ACK TYPE")=$E($P(MSG("HDR",2),FS,10),1,2)
142 .S MSG("HDR","APP ACK TYPE")=$E($P(MSG("HDR",2),FS,11),1,2)
143 .S MSG("HDR","MESSAGE CONTROL ID")=MSG("ID")
144 E D
145 .S MSG("HDR","BATCH CONTROL ID")=MSG("ID")
146 .S MSG("HDR","ACCEPT ACK TYPE")=$E($P($P(MSG("HDR",2),FS,4),"ACCEPT ACK TYPE=",2),1,2)
147 .S MSG("HDR","APP ACK TYPE")=$E($P($P(MSG("HDR",2),FS,4),"APP ACK TYPE=",2),1,2)
148 Q 1
149 ;
150GETMTYPE(MSGIEN) ;returns <message type>~<event> OR "BATCH"
151 Q:'$G(MSGIEN) "UNKNOWN"
152 N FS,CS,HDR1,HDR2
153 S HDR1=$G(^HLB(IEN,1))
154 I $E(HDR1,1,3)="BHS" Q "BATCH"
155 S HDR2=$G(^HLB(IEN,2))
156 S FS=$E(HDR1,4)
157 S CS=$E(HDR1,5)
158 Q $P($P(HDR2,FS,4),CS)_"~"_$P($P(HDR2,FS,4),CS,2)
159 ;
160GETEVENT(MSGIEN) ; returns event if not a batch message
161 Q:'$G(MSGIEN) ""
162 N FS,CS,HDR1,HDR2
163 S HDR1=$G(^HLB(MSGIEN,1))
164 I $E(HDR1,1,3)="BHS" Q ""
165 S HDR2=$G(^HLB(MSGIEN,2))
166 S FS=$E(HDR1,4)
167 S CS=$E(HDR1,5)
168 Q $P($P(HDR2,FS,4),CS,2)
169 ;
170GETSAP(MSGIEN) ;
171 ;
172 ;
173 Q:'$G(MSGIEN) "UNKNOWN"
174 N FS,CS,HDR1,REP,ESCAPE,SUBCOMP
175 S HDR1=$G(^HLB(MSGIEN,1))
176 S FS=$E(HDR1,4)
177 S CS=$E(HDR1,5)
178 S REP=$E(HDR1,6)
179 S ESCAPE=$E(HDR1,7)
180 S SUBCOMP=$E(HDR1,8)
181 Q $$DESCAPE^HLOPRS1($P($P(HDR1,FS,3),CS),FS,CS,SUBCOMP,REP,ESCAPE)
Note: See TracBrowser for help on using the repository browser.