source: WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLUCM050.m@ 1520

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

initial load of WorldVistAEHR
File size: 9.0 KB
RevLine 
[613]1HLUCM050 ;CIOFO-O/LJA - HL7/Capacity Mgt API-II ;10/23/01 12:01
2 ;;1.6;HEALTH LEVEL SEVEN;**103,114**;Oct 13, 1995
3 ;
4LOADEM(IEN772,HLNMSP) ; Find all related entries, up to 20...
5 ; HLNMSP is passed by reference...
6 ;
7 ; Note! If entry already loaded, it will not be reloaded.
8 ; (Stored ^TMP($J) data will be used instead.)
9 ;
10 N ACKTO,CHARC,CHARP,CT,DATA,DATAC,DATAP,DEF,FAC,HL,HLZZI
11 N HOLDNMSP,I,I772,I773,IEN,IENPAR,LEN,MSGID,MTYPEC
12 N MTYPEP,NMSP,NMSPP,NUM,PIEN,PROT,PROTP,TIME,TIMEBEG
13 N TIMEEND,TMDIFF,TMP,TOT772,TOT773,TOTNUM,X,Y
14 ;
15 KILL HLNMSP
16 ;
17 ; Call already made here?
18 S IENPAR=+$G(^TMP($J,"HLCHILD",+IEN772)) ; Call already made here?
19 ;
20 ; If call already made, just return results...
21 I IENPAR D QUIT $P(HLNMSP("HLPARENT",+IENPAR),U,2) ;->
22 . S HLNMSP("HLPARENT",+IENPAR)=$G(^TMP($J,"HLPARENT",+IENPAR))
23 . ; HL*1.6*114 added TOTNUM to next 3 lines to avoid ALLOC errors...
24 . S IEN772=0,TOTNUM=0
25 . F S IEN772=$O(^TMP($J,"HLPARENT",IENPAR,IEN772)) Q:'IEN772!(TOTNUM>19) D
26 . . S TOTNUM=TOTNUM+1
27 . . S HLNMSP("HLPARENT",+IENPAR,IEN772)=$G(^TMP($J,"HLPARENT",IENPAR,IEN772))
28 . . S HLNMSP("HLCHILD",+IEN772)=$G(^TMP($J,"HLCHILD",+IEN772))
29 ;
30 S HLNMSP(+IEN772)="" ; Seed for engine...
31 ;
32 S (NUM,TOTNUM)=1
33 F D QUIT:NUM'>NUM(1)!(TOTNUM>19)
34 . S NUM(1)=NUM ; Set NUM(1) = # entries found "now"...
35 . KILL HOLDNMSP
36 . S I772=0
37 . F S I772=$O(HLNMSP(I772)) Q:I772'>0!(TOTNUM>19) D
38 . . S DATA=$G(^HL(772,+$G(I772),0)) QUIT:DATA']"" ;->
39 . .
40 . . ; IEN Search...
41 . . S HLZZI=0 F S HLZZI=$O(^HL(772,"AF",I772,HLZZI)) Q:'HLZZI!(TOTNUM>19) I HLZZI'=IEN772 D HOLDTOT(HLZZI)
42 . . ; MSG ID search...
43 . . S MSGID=$P(DATA,U,6)
44 . . I MSGID]"" D
45 . . . S HLZZI=0 F S HLZZI=$O(^HL(772,"C",MSGID,HLZZI)) Q:'HLZZI!(TOTNUM>19) I HLZZI'=IEN772 D HOLDTOT(HLZZI)
46 . . . D MSGID(MSGID)
47 . . ; 773 MSG ID search...
48 . . S I773=+$O(^HLMA("B",I772,0)) I I773 D
49 . . . S MSGID=$P($G(^HLMA(+I773,0)),U,2) QUIT:MSGID']"" ;->
50 . . . S I773(1)=0
51 . . . F S I773(1)=$O(^HLMA("AF",I773,I773(1))) Q:I773(1)'>0!(TOTNUM>19) D
52 . . . . S X=+$G(^HLMA(+I773(1),0)) I X D HOLDTOT(+X)
53 . . . S I773(1)=0
54 . . . F S I773(1)=$O(^HLMA("C",MSGID,I773(1))) Q:I773(1)'>0!(TOTNUM>19) D
55 . . . . S X=+$G(^HLMA(+I773(1),0)) I X D HOLDTOT(+X)
56 . . . KILL I773(1)
57 . . . D MSGID(MSGID)
58 . .
59 . . ;
60 . . ; ACK TO search...
61 . . I $P(DATA,U,7)>0,$P(DATA,U,7)'=IEN772 D
62 . . . D HOLDTOT(+$P(DATA,U,7))
63 . . I I773 D
64 . . . S ACKTO=$P($G(^HLMA(+I773,0)),U,10) QUIT:ACKTO'>0 ;->
65 . . . S X=+$G(^HLMA(+ACKTO,0)) I X D HOLDTOT(+X)
66 . . ;
67 . . ; HLPARENT search...
68 . . I $P(DATA,U,8)>0,$P(DATA,U,8)'=IEN772 D
69 . . . D HOLDTOT(+$P(DATA,U,8))
70 . . I I773 D
71 . . . S PIEN=$P($G(^HLMA(+I773,0)),U,6) QUIT:PIEN'>0 ;->
72 . . . S X=+$G(^HLMA(+PIEN,0)) I X D HOLDTOT(+X)
73 . .
74 . . MERGE HLNMSP=HOLDNMSP
75 . . KILL HOLDNMSP
76 .
77 . S I=0,NUM=0 F S I=$O(HLNMSP(I)) Q:'I S NUM=NUM+1
78 ;
79 I '$$OKALL(.HLNMSP) D QUIT "" ;->
80 . KILL HLNMSP
81 ;
82 S FAC=$$FACILITY^HLUCM090(.HLNMSP) I FAC']"" S FAC="UNKNOWN"
83 S IENPAR=$O(HLNMSP(0))
84 ;
85 ; Find total number characters...
86 KILL TIMEP
87 S IEN772=0,CHARC=0,CHARP=0,CT=0,MTYPEP="",NMSPP="",PROTP="",NUM=0
88 F S IEN772=$O(HLNMSP(IEN772)) Q:'IEN772 D
89 . S CT=CT+1,NUM=NUM+1
90 .
91 . S TMP($J,"HLPARENT",+IENPAR,+IEN772)=$$VAL3(+IEN772,FAC)_U_IENPAR
92 .
93 . S CHARC=$$CHAR(+IEN772)
94 . S DATAC(IEN772)=CHARC
95 . S CHARP=CHARP+CHARC
96 .
97 . S $P(DATAC(IEN772),U,2)=1
98 .
99 . S TIME=$$TIME(+IEN772)
100 . F I=1:1:3 S $P(DATAC(IEN772),U,2+I)=$P(TIME,U,I)
101 . F I=2,3 S X=$P(TIME,U,I) I X?7N.E S TIMEP(X)=""
102 .
103 . S MTYPEC=$$MSGTYPE^HLUCM009(IEN772)
104 . S $P(DATAC(IEN772),U,6)=MTYPEC
105 . S MTYPEP=MTYPEP_$S(MTYPEP]"":"~",1:"")_MTYPEC
106 .
107 . S PROT=$$PROT101^HLUCM002(+IEN772)
108 . S $P(DATAC(IEN772),U,7)=PROT
109 . S:PROT]"" PROTP=PROT
110 .
111 . S NMSP=$$NMSPALL(+IEN772)
112 . S $P(DATAC(IEN772),U,9)=NMSP
113 . I NMSP]"" D
114 . . I NMSPP]"",NMSP="XWB",NMSPP'="XWB" QUIT ;->
115 . . S NMSPP=NMSP
116 .
117 . S $P(DATAC(IEN772),U,11)=FAC
118 ;
119 S TIMEBEG=$O(TIMEP(0)),TIMEEND=$O(TIMEP(":"),-1)
120 S TMDIFF=$$FMDIFF^XLFDT(TIMEEND,TIMEBEG,2)
121 ;
122 S DATAP=CHARP_U_CT_U_TMDIFF_U_TIMEBEG_U_TIMEEND_U_MTYPEP_U_PROTP_U_U_NMSPP_U_U_FAC
123 ;
124 ; Set PARENT node...
125 S IENPAR=$O(HLNMSP(0))
126 S TMP($J,"HLPARENT",+IENPAR)=DATAP
127 ;
128 ; Set CHILD nodes...
129 S IEN772=0
130 F S IEN772=$O(HLNMSP(IEN772)) Q:IEN772'>0 D
131 . S TMP($J,"HLCHILD",+IEN772)=IENPAR_"~"_$G(DATAC(+IEN772))
132 ;
133 KILL HLNMSP
134 MERGE HLNMSP=TMP($J)
135 MERGE ^TMP($J)=TMP($J)
136 ;
137 Q NUM
138 ;
139OKALL(HLNMSP) ; Does every 772 entry have a valid .01 node?
140 N FAIL,I772
141 S FAIL=0,I772=0
142 F S I772=$O(HLNMSP(I772)) Q:'I772!(FAIL) D
143 . QUIT:$P($G(^HL(772,+I772,0)),U)?7N1"."1.N ;->
144 . S FAIL=1
145 Q 'FAIL
146 ;
147VAL3(IEN772,FAC) ; Return sort values...
148 N TYPEHR,TYPEIO,TYPELR
149 S TYPEHR=$$TYPETMO^HLUCM002(+IEN772)
150 S TYPEIO=$$TYPEIO^HLUCM002(+IEN772)
151 ;S TYPELR=$$TYPELR^HLUCM001(+IEN772,FAC)
152 S TYPELR=$S(FAC["~DNS":"R",1:"L")
153 Q TYPEHR_U_TYPEIO_U_TYPELR
154 ;
155TIME(IEN772) ; Times...
156 N CT,DATA,IEN773,TMBEG,TMEND,TMDIFF
157 D TOT772T^HLUCM(+IEN772)
158 S IEN773=0,CT=0
159 F S IEN773=$O(^HLMA("B",+IEN772,IEN773)) Q:'IEN773!(CT>20) D
160 . S CT=CT+1
161 . D TOT773T^HLUCM(+IEN773)
162 D TMDIFF^HLUCM
163 Q DATA("DIFF")_U_DATA("START")_U_DATA("END")
164 ;
165 ;
166CHAR(IEN772) ; Number characters...
167 N CT,DATA,IEN773
168 D TOT772C^HLUCM(+IEN772)
169 S IEN773=0,CT=0
170 F S IEN773=$O(^HLMA("B",+IEN772,IEN773)) Q:'IEN773!(CT>20) D
171 . S CT=CT+1
172 . D TOT773C^HLUCM(+IEN773)
173 Q $G(DATA("CHAR"))
174 ;
175GETNMSP(IEN772) ; The one and only place to ask for NAMESPACE...
176 N HL,NMSP,NUM,PAR,VAL
177 S NUM=$$LOADEM^HLUCM050(+IEN772,.HL) QUIT:NUM'>0 "" ;->
178 S PAR=+$G(HL("HLCHILD",+IEN772))
179 S VAL=$G(HL("HLPARENT",+PAR))
180 Q $P(VAL,U,9)
181 ;
182GETPROT(IEN772) ; One & only place to ask for PROTOCOL...
183 N HL,NMSP,NUM,PAR,VAL
184 S NUM=$$LOADEM^HLUCM050(+IEN772,.HL) QUIT:NUM'>0 "" ;->
185 S PAR=+$G(HL("HLCHILD",+IEN772))
186 S VAL=$G(HL("HLPARENT",+PAR))
187 Q $P(VAL,U,7)
188 ;
189HOLDTOT(X) D HOLDTOT^HLUCM009(X) QUIT
190MSGID(X) D MSGID^HLUCM009(X) QUIT
191 ;
192NMSPALL(IEN772) ;Perform all attempts to find NMSP...
193 N IEN101,IEN94,NMSP
194 ;
195 ; If SPR...
196 S NMSP=$$SPR(+IEN772) QUIT:NMSP]"" $$NMSPCHG(NMSP) ;->
197 ;
198 ; Check MSH segment...
199 S NMSP=$$MSH772^HLUCM003(+IEN772) QUIT:NMSP]"" $$NMSPCHG(NMSP) ;->
200 S NMSP=$$MSHMAIL^HLUCM003(+IEN772) QUIT:NMSP]"" $$NMSPCHG(NMSP) ;->
201 ;
202 ; Get Event Protocol
203 S IEN101=+$P($G(^HL(772,+IEN772,0)),U,10) QUIT:IEN101'>0 "" ;->
204 ;
205 ; Find XEC routines, and try NMSPXRFs...
206 S NMSP=$$NMSPXRF(+IEN101) QUIT:NMSP]"" $$NMSPCHG(NMSP) ;->
207 ;
208 ; Try 9.4 link...
209 S IEN94=$P($G(^ORD(101,+IEN101,0)),U,12)
210 I IEN94 S NMSP=$P($$NMSP94(IEN94),U,2) QUIT:NMSP]"" $$NMSPCHG(NMSP) ;->
211 ;
212 S NMSP=$$MSH773^HLUCM003(+IEN772) QUIT:NMSP]"" $$NMSPCHG(NMSP) ;->
213 ;
214 QUIT ""
215 ;
216NMSP94(IEN94) ; From 9.4 find it's namespace...
217 N D0,DA,DIC,DIQ,DR,NMSP,RET
218 S RET=$G(^TMP($J,"HLNMSP94",+IEN94)) I RET]"" QUIT RET ;->
219 S DIC=9.4,DR=".01;1",DA=IEN94,DIQ="NMSP(",DIQ(0)="E"
220 D EN^DIQ1
221 S RET=$G(NMSP(9.4,+IEN94,.01,"E"))_U_$G(NMSP(9.4,+IEN94,1,"E"))
222 S ^TMP($J,"HLNMSP94",+IEN94)=RET
223 QUIT RET
224 ;
225NMSPCHG(NMSP) ; Some miscellaneous special actions first...
226 N PCKG
227 ;
228 ; Check xref first...
229 D:'$D(^TMP($J,"HLNMSPXRF")) NMSPXRF^HLUCM009
230 S PCKG=$$NMSPFROM(NMSP) QUIT:PCKG]"" PCKG ;->
231 ;
232 S PCKG=NMSP
233 ;
234 ; Other conversions here...
235 I $E(PCKG,1,2)="DG",PCKG'="DG" S PCKG="DG"
236 I $E(PCKG,1,3)="VEI",PCKG'="VEIB" S PCKG="VEIB"
237 I $E(PCKG,1,2)="VA" D
238 . I PCKG["PIMS" S PCKG="DG" QUIT ;->
239 . I $G(APPR)["HEC " S PCKG="HEC" QUIT ;->
240 . I $G(FACR)["HEC " S PCKG="HEC" QUIT ;->
241 I $E(PCKG,1,2)="LA" S PCKG="LA"
242 I $E(PCKG,1,2)="VA",PCKG[" PIMS" S PCKG="DG"
243 I $E(PCKG,1,10)="VAFC ADMIT" S PCKG="DG"
244 I $E(PCKG,1,8)="VAFC ADT" S PCKG="DG"
245 I $E(PCKG,1,8)?1"VAFH A"2N S PCKG="DG"
246 I $E(PCKG,1,15)?1"VAFH CLIENT A"2N S PCKG="DG"
247 I $E(PCKG,1,2)="XM" S PCKG="XM"
248 I $E(PCKG,1,2)="XU" S PCKG="XU"
249 ;
250 QUIT PCKG
251 ;
252NMSPXRF(IEN101) ; Find NMSP from ^TMP($J,"NMSPXRF")
253 N LEN,NMSP,NODE,RTN
254 I '$D(^TMP($J,"HLNMSPXRF")) D NMSPXRF^HLUCM009 ; Build, if not there
255 S NMSP=""
256 F NODE=772,774,771 D QUIT:NMSP]""
257 . S RTN=$E($P($G(^ORD(101,+IEN101,NODE)),U,2),1,4) QUIT:RTN']"" ;->
258 . S NMSP=$$NMSPFROM(RTN)
259 Q NMSP
260 ;
261NMSPFROM(TXT) ; From TXT try to find NMSP...
262 N NMSP
263 QUIT:$G(TXT)']"" "" ;->
264 S NMSP=""
265 F LEN=4:-1:2 D QUIT:NMSP]""
266 . S NMSP=$G(^TMP($J,"HLNMSPXRF",$E(TXT,1,LEN))) QUIT:NMSP]"" ;->
267 I NMSP']"" F LEN=4:-1:2 D QUIT:NMSP]""
268 . ; See Integration Agreement #10048
269 . N D,DIC,X,Y
270 . S DIC="^DIC(9.4,",DIC(0)="FO",D="C",X=$E(TXT,1,LEN)
271 . D MIX^DIC1 QUIT:+Y'>0 ;->
272 . ; Found! So, set into ^TMP...
273 . S NMSP=$E(TXT,1,LEN)
274 . S ^TMP($J,"HLNMSPXRF",NMSP)=NMSP
275 Q NMSP
276 ;
277SPR(IEN772) ; Evaluate SPR segment for RPC for package, possible
278 ; resetting the PCKG variable...
279 ; PCKG -- req
280 N CHAR,DEL,IN,NMSP
281 S IN=$G(^HL(772,+IEN772,"IN",1,0))
282 QUIT:$E(IN,1,4)'="SPR^" "" ;->
283 QUIT:IN'["REMOTE RPC^" "" ;->
284 S DEL=$E(IN,4)
285 S IN=$P(IN,DEL,5) QUIT:IN']"" "" ;->
286 S IN=$P(IN,"003RPC",2) QUIT:IN']"" "" ;->
287 S CHAR=+IN,IN=$TR($E(IN,4,CHAR+4),"&","") QUIT:IN']"" "" ;->
288 I $E(IN,1,2)="IB" QUIT "IB" ;->
289 I $E(IN,1,2)="OR" QUIT "OR" ;->
290 I '$D(^TMP($J,"HLNMSPXRF")) D NMSPXRF^HLUCM009
291 S NMSP=$$NMSPFROM(IN)
292 QUIT NMSP
293 ;
294EOR ; HLUCM050 - HL7/Capacity Mgt API-II ;10/23/01 12:01
Note: See TracBrowser for help on using the repository browser.