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

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

initial load of WorldVistAEHR
File size: 8.9 KB
RevLine 
[613]1HLEVX000 ;O-OIFO/LJA - VistA HL7 Event Monitor Code ;02/04/2004 15:25
2 ;;1.6;HEALTH LEVEL SEVEN;**109**;Oct 13, 1995
3 ;
4 ; Event Types - 870-DINUM, 870-SKIP, 870-STUB
5 ;
6CHK870 ; Search for various file 870 problems...
7 ;
8 ; {01/16/04 - See call to REPDINUM below.}
9 ;
10 N CT870,CTERR,CTNO,CTSTUB,DATA,DATABEF,IEN870,LINKNM,MIEN870
11 N NOW,STATUS,TXT,VAR,WAY,XTMPBEF,XTMPNOW
12 ;
13 ; Call event monitor...
14 KILL VAR
15 ; Variables can be defined prior to passing into START by reference...
16 F VAR="CT870","CTDINUM","CTERR" S VAR(VAR)="" ; #1-Indiv array elements
17 S VAR="CTNO^CTSKIP^CTSTUB" ; #2-Parsed from string
18 D START^HLEVAPI(.VAR)
19 ; Even D START^HLEVAPI(VAR) would work...
20 ;
21 KILL ^TMP($J,"HLREP"),^TMP($J,"HLEV REP"),^TMP($J,"HLMAIL")
22 ;
23 ; Set current XTMP subscript and create zero node...
24 S NOW=$$NOW^XLFDT,XTMPNOW="HLEV STUB "_NOW
25 S ^XTMP(XTMPNOW,0)=$$FMADD^XLFDT(NOW,2)_U_NOW_U_"HLEV Stub Record Search"
26 ;
27 ; Has there been a prior run? If so, set XTMPBEF. If not, set to null
28 S XTMPBEF=$O(^XTMP(XTMPNOW),-1),XTMPBEF=$S(XTMPBEF["HLEV STUB ":XTMPBEF,1:"")
29 ;
30 ; Find current stub entries...
31 S (CT870,CTDINUM,CTERR,CTNO,CTSKIP,CTSTUB)=0,IEN870=0,CTNO=0
32 F S IEN870=$O(^HLCS(870,IEN870)) Q:IEN870'>0 D
33 . D CHECKIN^HLEVAPI
34 . S CT870=CT870+1
35 . S LINKNM=$P($G(^HLCS(870,+IEN870,0)),U)
36 . S LINKNM=$S(LINKNM]"":LINKNM_"["_IEN870_"]",1:"IEN ["_IEN870_"]")
37 . ; 1=IN QUEUE 2=OUT QUEUE
38 . F WAY=1,2 D
39 . . S WAY(1)=$S(WAY=1:"I",1:"O")
40 . . D CHECKIN^HLEVAPI
41 . . S MIEN870=$O(^HLCS(870,+IEN870,WAY,0)) ; First entry...
42 . . S MIEN870(1)=$O(^HLCS(870,+IEN870,WAY,":"),-1) ; Last entry...
43 . . Q:MIEN870'>0!(MIEN870(1)'>0) ;->
44 . . F MIEN870=MIEN870:1:MIEN870(1) D
45 . . . S CTNO=CTNO+1
46 . . . I '(CTNO#500) D CHECKIN^HLEVAPI
47 . . . D CHECKS(IEN870,WAY,MIEN870)
48 ;
49 D CHECKIN^HLEVAPI ; To store final values of variables
50 D CHECKOUT^HLEVAPI ; To finalize fields...
51 ;
52 S ^XTMP(XTMPNOW,0,0)=CT870_U_CTNO_"~"_CTERR_"~"_CTDINUM_U_CTSKIP_U_CTSTUB
53 ;
54 ; Create report and put in text...
55 QUIT:'$D(^TMP($J,"HLEV REP")) ;->
56 ;
57 ; Create report text...
58 D GENREP^HLEVUTI0($NA(^TMP($J,"HLEV REP")),$NA(^TMP($J,"HLEVREP")),4,1)
59 ;
60 ; Load report text in 776 message text...
61 D MSGTEXT^HLEVAPI1($NA(^TMP($J,"HLEVREP")))
62 ;
63 ; Mail report...
64 S HLEVTXT(1)="MESSAGETEXT"
65 D MAILIT^HLEVAPI
66 ;
67 ; Report DINUM problems, using report text...
68 D REPDINUM^HLEVX003 ; {01/16/04}
69 ;
70 ; Clean out ^TMP data...
71 KILL ^TMP($J,"HLREP"),^TMP($J,"HLEV REP"),^TMP($J,"HLMAIL")
72 ;
73 Q
74 ;
75SITE S SITE=$$SITE^VASITE,SITE=$P(SITE,U,2)_" ["_$P(SITE,U,3)_"]"
76 D ADD("Run site: "_SITE)
77 D ADD("")
78 ;
79EXPL D ADD("Some stub entries exist in the HL Logical Link file (#870) that")
80 D ADD("appear to be ""stuck"". Someone at the site needs to check out")
81 D ADD("and possibly change their status to DONE.")
82 ;
83HDR D ADD("")
84 D ADD("Link In/Out IENs")
85 D ADD($$REPEAT^XLFSTR("-",74))
86 ;
87 ; Send report...
88REP S LINKNM=""
89 F S LINKNM=$O(^TMP($J,"HLEV REP",LINKNM)) Q:LINKNM']"" D
90 . S TXT=$E(LINKNM_" ",1,15)
91 . S WAY="",CTNO=0
92 . F S WAY=$O(^TMP($J,"HLEV REP",LINKNM,WAY)) Q:WAY']"" D
93 . . S TXT=$E(TXT_" "_$S(WAY="I":"IN",1:"OUT")_$$REPEAT^XLFSTR(" ",80),1,25)
94 . . S MIEN870=0
95 . . F S MIEN870=$O(^TMP($J,"HLEV REP",LINKNM,WAY,MIEN870)) Q:MIEN870'>0 D
96 . . . S CTNO=CTNO+1
97 . . . I ($L(TXT)+$L(MIEN870)+2)>74 D QUIT ;->
98 . . . . D ADD(TXT)
99 . . . . S TXT=$$REPEAT^XLFSTR(" ",25)
100 . . . S TXT=TXT_$S($L(TXT)>25:",",1:"")_MIEN870
101 . . I $TR(TXT," ","")]"" D ADD(TXT)
102 . . S TXT=$$REPEAT^XLFSTR(" ",15)
103 . I TXT]"" D ADD(TXT) S TXT=""
104 I TXT]"" D ADD(TXT) S TXT=""
105 ;
106 D MSGTEXT^HLEVAPI1($NA(^TMP($J,"HLMAIL")))
107 ;
108 KILL ^TMP($J,"HLEV REP"),^TMP($J,"HLMAIL")
109 ;
110 S HLEVTXT(1)="MESSAGE TEXT"
111 D MAILIT^HLEVAPI
112 ;
113 Q
114 ;
115ADD(TXT) ; Add to global for moving into report
116 N NO
117 S NO=$O(^TMP($J,"HLMAIL",":"),-1)+1
118 S ^TMP($J,"HLMAIL",+NO)=TXT
119 Q
120 ;
121MSG(TXT) ; Generic text displayer...
122 W !!,TXT
123 W ! ; Always put at least one blank row in place
124 F Q:($Y+3)>IOSL W !
125 S X=$$BTE^HLCSMON("Press RETURN to exit... ")
126 Q
127 ;
128CHECKS(IEN870,WAY,MIEN870) ; Perform various checks on queue entry...
129 ; CTDINUM,CTSKIP,CTSTUB -- req
130 QUIT:'$$DATA870(IEN870,WAY,MIEN870) ;->
131 D CHKSTUB(IEN870,WAY,MIEN870)
132 D CHKDINUM(IEN870,WAY,MIEN870)
133 Q
134 ;
135DATA870(IEN870,WAY,MIEN870) ; Does record exist?
136 ; CTSKIP,LINKNM -- req
137 ;
138 ; Check for existence of data here...
139 QUIT:$G(^HLCS(870,+IEN870,WAY,+MIEN870,0))]"" 1 ;->
140 ;
141 S WAY(1)=$S(WAY=1:"INCOMING",1:"OUTGOING")
142 ;
143 ; Has this problem already been logged?
144 QUIT:'$$LOG^HLEVAPI2("870-SKIP","IEN870^WAY^MIEN870") "" ;->
145 ;
146 D RECORD("SKIP",LINKNM,WAY(1),MIEN870)
147 S CTSKIP=CTSKIP+1,CTERR=CTERR+1
148 ;
149 Q ""
150 ;
151CHKSTUB(IEN870,WAY,MIEN870) ; Check if a stub record that "hangs around"
152 ; CTSTUB,LINKNM -- req
153 N DATABEF,STATUS
154 S STATUS=$P($G(^HLCS(870,+IEN870,+WAY,+MIEN870,0)),U,2)
155 QUIT:STATUS'="S" ;-> Stub record
156 S WAY(1)=$S(WAY=1:"INCOMING",1:"OUTGOING")
157 S DATABEF=$S(XTMPBEF']"":"",1:$S($D(^XTMP(XTMPBEF,+IEN870,WAY(1),+MIEN870)):1,1:""))
158 S ^XTMP(XTMPNOW,+IEN870,WAY(1),+MIEN870)=DATABEF
159 QUIT:'DATABEF ;-> Stub entry didn't exist before...
160 ;
161 ; Has this problem already been logged?
162 QUIT:'$$LOG^HLEVAPI2("870-STUB","IEN870^WAY^MIEN870") ;->
163 ;
164 D RECORD("STUB",LINKNM,WAY(1),MIEN870)
165 S CTSTUB=CTSTUB+1,CTERR=CTERR+1
166 ;
167 Q
168 ;
169CHKDINUM(IEN870,WAY,MIEN870) ; Check for records not DINUMd for log link
170 ; CTDINUM,LINKNM -- req
171 ;
172 ; {01/16/04 - Call to $$LOG^HLEVAPI2 removed. See REPDINUM call.}
173 ;
174 N IEN
175 ;
176 ; DINUM check here...
177 S IEN=+$G(^HLCS(870,+IEN870,WAY,+MIEN870,0)) QUIT:IEN=MIEN870 ;->
178 ;
179 S WAY(1)=$S(WAY=1:"INCOMING",1:"OUTGOING")
180 ;
181 ; New occurence, so record error...
182 D RECORD("DINUM",LINKNM,WAY(1),MIEN870)
183 S CTDINUM=CTDINUM+1,CTERR=CTERR+1
184 ;
185 Q
186 ;
187RECORD(PROBL,LINKNM,WAY,MIEN870) ; Record for later inclusion in report
188 ;
189 ; Required: At least two levels passed...
190 S PROBL=$G(PROBL) QUIT:PROBL']"" ;->
191 S LINKNM=$G(LINKNM) QUIT:LINKNM']"" ;->
192 S LEVEL=2
193 S WAY=$G(WAY) I WAY]"" S LEVEL=3
194 S MIEN870=$G(MIEN870) I MIEN870]"" S LEVEL=4
195 ;
196 ; Data level set...
197 I LEVEL=4 S ^TMP($J,"HLEV REP",PROBL,LINKNM,WAY,MIEN870)=""
198 I LEVEL=3 S ^TMP($J,"HLEV REP",PROBL,LINKNM,WAY)=""
199 I LEVEL=2 S ^TMP($J,"HLEV REP",PROBL,LINKNM)=""
200 ;
201 ; Total level sets...
202 I LEVEL=4 S ^TMP($J,"HLEV REP",PROBL,LINKNM,WAY)=$G(^TMP($J,"HLEV REP",PROBL,LINKNM,WAY))+1
203 I LEVEL=3 S ^TMP($J,"HLEV REP",PROBL,LINKNM)=$G(^TMP($J,"HLEV REP",PROBL,LINKNM))+1
204 S ^TMP($J,"HLEV REP",PROBL)=$G(^TMP($J,"HLEV REP",PROBL))+1
205 S ^TMP($J,"HLEV REP")=$G(^TMP($J,"HLEV REP"))+1
206 ;
207 Q
208 ;
209 ; ====================================================================
210 ;
211CORRECT ; Correct a stub entry in HLCS(870)...
212 N IEN870,MIEN870,WAY
213 D HD,EX
214 S WAY=$$WAY I WAY']"" D QUIT ;->
215 . D MSG("Exiting... ")
216 W !
217 S IEN870=$$LINK I IEN870']"" D QUIT ;->
218 . D MSG("No link selected. Start again... ")
219CONT W !
220 S MIEN870=$$MIEN870(IEN870,WAY) I MIEN870'>0 D QUIT ;->
221 . D MSG("No stub entry exists for link.")
222 W !!,"Stub record# ",MIEN870," found. It's status is about to be changed to DONE..."
223 W !
224 QUIT:'$$YN^HLCSRPT4("OK to correct","Yes") ;->
225 D FIX(IEN870,WAY,MIEN870,"D")
226 W " fixed... "
227 W !
228 QUIT:$$BTE^HLCSMON("Press RETURN to continue searching... ") ;->
229 G CONT ;->
230 ;
231FIX(IEN870,WAY,MIEN870,STAT) ; Fix stub record...
232 N DA,DIE,DR,SUBDD
233 S DIE="^HLCS(870,"_IEN870_","_WAY_","
234 S DA(1)=IEN870,DA=+MIEN870
235 S DR=$S($G(STAT)]"":"1///"_STAT,1:1)
236 D ^DIE
237 Q
238 ;
239WAY() ; In or Out?
240 N DIR,DIRUT,DTOUT,DUOUT,X,Y
241 S DIR(0)="SO^1:Search the IN QUEUE;2:Search the OUT QUEUE"
242 S DIR("A")="Select the QUEUE to search"
243 D ^DIR
244 QUIT:$D(DIRUT)!($D(DTOUT))!($D(DUOUT)) "" ;->
245 Q $S(+Y:+Y,1:"")
246 ;
247LINK() ; Which 870 entry?
248 N DIC,X,Y
249 S DIC=870,DIC(0)="AEMQ",DIC("A")="Select LOGICAL LINK: "
250 D ^DIC
251 Q $S(+Y:+Y,1:"")
252 ;
253MIEN870(IEN870,WAY) ; Search for stub record...
254 N CT,IEN,IOINHI,IOINORM,MIEN870,STATUS,X
255 ;
256 S X="IOINHI;IOINORM" D ENDR^%ZISS
257 ;
258 W !,IOINHI,"Searching for stub records...",IOINORM
259 S CT=0,IEN=0,MIEN870=0
260 F S IEN=$O(^HLCS(870,+IEN870,WAY,IEN)) Q:IEN'>0!(MIEN870) D
261 . S CT=CT+1 W:'(CT#500) "."
262 . S DATA=$G(^HLCS(870,+IEN870,WAY,IEN,0)) QUIT:$P(DATA,U,2)'="S" ;->
263 . H 15 ; If not hung, and is a proper stub entry, it will disappear
264 . S DATA=$G(^HLCS(870,+IEN870,WAY,IEN,0)) QUIT:$P(DATA,U,2)'="S" ;->
265 . S MIEN870=IEN
266 ;
267 Q MIEN870
268 ;
269HD W @IOF,$$CJ^XLFSTR("Stub Record Correction",IOM)
270 W !,$$REPEAT^XLFSTR("=",IOM)
271 QUIT
272 ;
273EX N I,T F I=1:1 S T=$T(EX+I) QUIT:T'[";;" W !,$P(T,";;",2,99)
274 ;;Occasionally, entry's in the IN QUEUE and the OUT QUEUE of the HL Logical
275 ;;Link file (#870) get stuck in the STUB status. (Stub records have the STATUS
276 ;;field set to STUB.) When this occurs, no further processing of the queue
277 ;;occurs.
278 ;;
279 ;;This utility loops through the IN QUEUE or the OUT QUEUE of a logical link
280 ;;looking for stub records. (Stub records have the STATUS field set to STUB.)
281 ;;When it finds a stub record it requests permission to set the STATUS field to
282 ;;DONE.
283 QUIT
284 ;
285EOR ;HLEVX000 - VistA HL7 Event Monitor Code ;5/30/03 15:25
Note: See TracBrowser for help on using the repository browser.