source: WorldVistAEHR/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLUCM003.m@ 1259

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

initial load of WorldVistAEHR

File size: 7.7 KB
Line 
1HLUCM003 ;CIOFO-O/LJA - HL7/Capacity Mgt API-II ;10/23/01 12:01
2 ;;1.6;HEALTH LEVEL SEVEN;**88,103**;Oct 13, 1995
3 ;
4ADJTIME ; Adjust ^TMP times on basis of unit...
5 N IENPAR
6 S IENPAR=0
7 F S IENPAR=$O(^TMP($J,"HLPARENT",IENPAR)) Q:'IENPAR D
8 . D ADJPAR(+IENPAR)
9 Q
10 ;
11ADJPAR(IENPAR) ; Adjust times for one unit...
12 N BEG,DATA,END,IEN772,NUM,PREVTM,TIME
13 ;
14 S NUM=0,IEN772=0
15 F S IEN772=$O(^TMP($J,"HLPARENT",+IENPAR,IEN772)) Q:'IEN772 D
16 . S NUM=NUM+1
17 ;
18 ; No adjustments necessary if only one message...
19 QUIT:NUM'>1 ;->
20 ;
21 ; Find all times...
22 S IEN772=0
23 F S IEN772=$O(^TMP($J,"HLPARENT",+IENPAR,IEN772)) Q:IEN772'>0 D
24 . S DATA=$P($G(^TMP($J,"HLCHILD",+IEN772)),"~",2,999) QUIT:DATA']"" ;->
25 . S X=$P(DATA,U,4) I X?7N.E S TIME(X)=""
26 . S X=$P(DATA,U,5) I X?7N.E S TIME(X)=""
27 ;
28 S BEG=$O(TIME(0)),END=$O(TIME(":"),-1)
29 ;
30 ; Set 1st time and last time...
31 S IEN772=$O(^TMP($J,"HLPARENT",+IENPAR,0)) Q:IEN772'>0 ;->
32 D CORRECT(+IENPAR,+IEN772,4,BEG)
33 S IEN772=$O(^TMP($J,"HLPARENT",+IENPAR,":"),-1) QUIT:IEN772'>0 ;->
34 D CORRECT(+IENPAR,+IEN772,5,END)
35 ;
36 ; Make other corrections...
37 S IEN772=0,PREVTM=""
38 F S IEN772=$O(^TMP($J,"HLPARENT",+IENPAR,IEN772)) Q:IEN772'>0 D
39 . S DATA=$P($G(^TMP($J,"HLCHILD",+IEN772)),"~",2,999) QUIT:DATA']"" ;->
40 . S TIME(1)=$P(DATA,U,4),TIME(2)=$P(DATA,U,5)
41 .
42 . ; If first time thru...
43 . I PREVTM="" D QUIT ;->
44 . . I TIME(1)=TIME(2) S PREVTM=TIME(2) QUIT ;->
45 . . ; Set 1st entry's time to START=START (0 seconds)
46 . . D CORRECT(+IENPAR,+IEN772,5,TIME(1))
47 . . S PREVTM=TIME(1)
48 .
49 . I TIME(1)'=PREVTM D
50 . . D CORRECT(+IENPAR,+IEN772,4,PREVTM)
51 . . S TIME(1)=PREVTM
52 .
53 . I TIME(1)>TIME(2) D
54 . . D CORRECT(+IENPAR,+IEN772,5,TIME(1))
55 . . S TIME(2)=TIME(1)
56 .
57 . S PREVTM=TIME(2)
58 .
59 Q
60 ;
61CORRECT(PAR,CHLDIEN,PCE,NEW) ; Change CHILD data...
62 N BEG,CHILD,DIFF,END,SEC,STORE
63 ;
64 ; Get CHILD and quit if no changes...
65 S HLCHILD=$G(^TMP($J,"HLCHILD",+CHLDIEN)) QUIT:$P(HLCHILD,U,PCE)=NEW ;->
66 ;
67 ; Put new value into CHILD...
68 S $P(CHILD,U,PCE)=NEW
69 ;
70 ;Calculate SEC difference and set into CHILD...
71 S BEG=$P(CHILD,U,4),END=$P(CHILD,U,5)
72 S DIFF=$$FMDIFF^XLFDT(END,BEG,2)
73 S $P(CHILD,U,3)=DIFF
74 ;
75 ; Store data...
76 S ^TMP($J,"HLCHILD",+CHLDIEN)=HLCHILD
77 ;
78 Q
79 ;
80RECNM(PFX,IEN772,FULLNM,REPNM,SRCE) ; Record where name found...
81 ; PFX - [n] for namespace, and [p] for protocol
82 ; IEN772 - IEN of 772
83 ; FULLNM - What is in entry itself, uninferred...
84 ; REPNM - What is to be reported
85 ; SRCE - Where it was inferred from
86 ;
87 QUIT:$G(^TMP($J,"HLUCM"))'="DEBUG GLOBAL" ;->
88 ;
89 S REPNM=$G(PFX)_REPNM
90 ;
91 S ^TMP($J,"HLRECNM")=$G(^TMP($J,"HLRECNM"))+1
92 S ^TMP($J,"HLRECNM",REPNM)=$G(^TMP($J,"HLRECNM",REPNM))+1
93 S ^TMP($J,"HLRECNM",REPNM,SRCE)=$G(^TMP($J,"HLRECNM",REPNM,SRCE))+1
94 S ^TMP($J,"HLRECNM",REPNM,SRCE,IEN772)=FULLNM
95 ;
96 QUIT
97 ;
98MSHMAIL(IEN772) ;
99 N CT,INOUT,MIEN,NIEN,PCKG,RECNM,TXT,X,XMER,XMPOS,XMRG,XMZ
100 S MIEN=$P($G(^HL(772,+IEN772,0)),U,5) QUIT:MIEN'>0 "" ;->
101 S INOUT=$P(^HL(772,+IEN772,0),U,4)
102 S INOUT=$S(INOUT="I":5,1:3)
103 S CT=0,PCKG="",XMZ=+MIEN,XMER=0
104 F D QUIT:CT>10!(PCKG]"")!($E(TXT,1,3)="MSH")!(XMER'=0)
105 . S CT=CT+1
106 . D REC^XMS3
107 . S TXT=$G(XMRG) QUIT:$E(TXT,1,3)'="MSH" ;->
108 . S X=$E(TXT,4),RECNM=$P(TXT,X,INOUT)
109 . S PCKG=$$PCKGMSH(TXT,INOUT)
110 . D RECNM("[n]",IEN772,RECNM,PCKG,"MAIL")
111 QUIT PCKG
112 ;
113MSH772(IEN772) ; Get PCKG from MSH segment in 772...
114 ; Call here ONLY if can't get MSH segment from 773...
115 N CT,IN,INOUT,PCKG,RECNM,TXT,X
116 S IN=0,CT=0,PCKG=""
117 S INOUT=$$INOUT(+IEN772)
118 F S IN=$O(^HL(772,+IEN772,"IN",IN)) Q:IN'>0!(CT>10)!(PCKG]"") D
119 . S CT=CT+1
120 . S TXT=$G(^HL(772,+IEN772,"IN",+IN,0)) QUIT:TXT']"" ;->
121 . QUIT:$E(TXT,1,3)'="MSH" ;->
122 . S X=$E(TXT,4),RECNM=$P(TXT,X,INOUT)
123 . S PCKG=$$PCKGMSH(TXT,INOUT)
124 . D RECNM("[n]",IEN772,RECNM,PCKG,772)
125 QUIT PCKG
126 ;
127MSH773(IEN772) ; Get PCKG from MSH segment in 773...
128 N IEN773,INOUT,MSH,PCKG,RECNM,X
129 S IEN773=$O(^HLMA("B",IEN772,0)) QUIT:IEN773'>0 "" ;->
130 S INOUT=$$INOUT(IEN772)
131 S MSH=$G(^HLMA(+IEN773,"MSH",1,0)) QUIT:MSH']"" "" ;->
132 S X=$E(MSH,4),RECNM=$P(MSH,X,INOUT)
133 S PCKG=$$PCKGMSH(MSH,INOUT)
134 I PCKG="VAMC" D
135 . N NMSP
136 . S NMSP=PCKG,INOUT=$S(INOUT=5:3,1:3)
137 . S X=$E(MSH,4),RECNM=$P(MSH,X,INOUT)
138 . S PCKG=$$PCKGMSH(MSH,INOUT) QUIT:$$PCKGMSH(MSH,INOUT)]"" ;->
139 . S PCKG=NMSP ; Reset
140 D RECNM("[n]",IEN772,RECNM,PCKG,773)
141 QUIT PCKG
142 ;
143INOUT(IEN772) ;
144 N INOUT
145 S INOUT=$P($G(^HL(772,+IEN772,0)),U,4)
146 S INOUT=$S(INOUT="I":5,1:3) ; Default to O, which is case in HEC error
147 QUIT INOUT
148 ;
149PCKGMSH(MSH,INOUT) ; Extract PCKG namespace from MSH segment
150 N DEL,PFROM
151 S DEL=$E(MSH,4),INOUT=$S($G(INOUT):INOUT,1:3)
152 S PFROM=$P(MSH,DEL,INOUT) QUIT:PFROM']"" "" ;->
153 QUIT $$FIXNMSP^HLUCM003(PFROM)
154 ;
155ERRCHK ; Error checks...
156 ;
157 ; DATE checks...
158 S START=+$G(START),END=+$G(END)
159 I START'?7N&(START'?7N1"."1.N) D ERR^HLUCM("INVALID START TIME")
160 I END'?7N&(END'?7N1"."1.N) D ERR^HLUCM("INVALID END TIME")
161 I '$D(ERRINFO("INVALID START TIME")) D
162 . I '$D(ERRINFO("INVALID END TIME")) D
163 . . I START=END!(START<END) QUIT ;->
164 . . D ERR^HLUCM("END TIME PRECEDES START TIME")
165 ;
166 ; If condition=BOTH, can't be ALL(1/2) and ALL(1/2) or
167 ; ALL(1/2) and SPECIFIC. BOTH can only be SPECIFIC and SPECIFIC.
168 I COND="BOTH" D
169 . N P1,P2,P3
170 . S P1=$S($G(PNMSP)>0:1,1:0) ; namespace 0/1
171 . S P2=$S($G(IEN101)>0:1,1:0) ; protocol 0/1
172 . S P3=P1+P2 QUIT:P3'>0 ;->
173 . D ERR^HLUCM("BOTH NAMESPACES(S) AND PROTOCOL(S) MUST BE PASSED SPECIFICALLY")
174 QUIT
175 ;
176SETMORE ; More defaults...
177 ;
178 ; Check format of PNMSP...
179 ; If not passed by reference...
180 I 'NMSPTYPE D ; Namespace(s) not passed as an array
181 . ; Passed as 1 or 2 or O^NMSP, but is it valid?
182 . I '$$OKPAR^HLUCM002(PNMSP) D
183 . . D ERR^HLUCM("INVALID NAMESPACE PARAMETER")
184 ;
185 ; Check format of IEN101...
186 ; If not passed by reference...
187 I 'PROTYPE D ; Protocol(s) not passed as an array
188 . ; Passed as 1 or 2 or 0^PROT or 0^IEN, but is it valid?
189 . I '$$OKPAR^HLUCM002(IEN101) D ; Check format...
190 . . D ERR^HLUCM("INVALID PROTOCOL PARAMETER")
191 . S IEN101=$$OKPAR101^HLUCM001($G(IEN101)) I IEN101']"" D
192 . . I $D(ERRINFO("INVALID PROTOCOL PARAMETER")) QUIT ;->
193 . . QUIT:IEN101["0^9999999" ;->
194 . . D ERR^HLUCM("CAN'T FIND PROTOCOL")
195 QUIT
196 ;
197FIXNMSP(PCKG,I772) ; First space piece, strip _
198 N APPR,APPS,FACR,FACS,I773,MSH
199 ;
200 S I772=+$G(I772)
201 ;
202 ; Get 773 (or 772)-related information...
203 S I773=$O(^HLMA("B",+I772,0))
204 S MSH=$G(^HLMA(+I773,"MSH",1,0))
205 I MSH']"" S X=$G(^HL(772,+I772,"IN",1,0)) S:$E(X,1,3)=MSH MSH=X
206 S X=$E(MSH,4),APPS=$P(MSH,X,3),FACS=$P(MSH,X,4),APPR=$P(MSH,X,5),FACR=$P(MSH,X,6)
207 ;
208 S PCKG=$$NMSPCHG^HLUCM050(PCKG)
209 ;
210 QUIT $TR($E($P($P(PCKG," "),"-"),1,4),"_ ","") ;->
211 ;
212CTPCKG(PCKG) ; Should entry be counted on basis of package?
213 ; (Might be countable if protocol matches remember.)
214 ; If list of packages passed by reference, is PCKG in array?
215 ; IEN101,NMSPTYPE,PNMSP -- req
216 N CTPCKG
217 ;
218 ; Must count everything...
219 I $G(PNMSP)=1!($G(PNMSP)=2) QUIT 1 ;->
220 ;
221 ; If passed namspace by array, is PCKG in array?
222 I NMSPTYPE=1 QUIT $S($$REFPCKG^HLUCM001(PCKG):1,1:"") ;->
223 ;
224 ; If passed in "0^NAMESPACE" format...
225 I $$OK0CALL^HLUCM002(PNMSP) D QUIT $S(PCKG]"":1,1:"") ;->
226 . I $P(PNMSP,U,2)'=PCKG S PCKG=""
227 ;
228 QUIT ""
229 ;
230CTPROT(PROT) ; Should entry be counted on basis of protocol?
231 ; (Might be countable if package matches remember.)
232 ; IEN,PROTYPE -- req
233 ;
234 N CTPROT
235 ;
236 ; Must count everything...
237 I $G(IEN101)=1!($G(IEN101)=2) QUIT 1 ;->
238 ;
239 ; If passed protocols by array, is PROT in array?
240 I PROTYPE=1 QUIT $S($$REFPROT^HLUCM001(PROT):1,1:"") ;->
241 ;
242 ; If PROT not found, and passed 0^PROTNM or 0^PROTIEN,
243 ; can't do anything more...
244 I $$OK0CALL^HLUCM002(IEN101) D QUIT $S(PROT]"":1,1:"") ;->
245 . N VAL
246 . QUIT:PROT']"" ;->
247 . S VAL=$P(IEN101,U,2)
248 . I $P(PROT,"~")'=VAL&($P(PROT,"~",2)'=VAL) S PROT=""
249 ;
250 QUIT ""
251 ;
252EOR ; HLUCM003 - HL7/Capacity Mgt API-II ;10/23/01 12:01
Note: See TracBrowser for help on using the repository browser.