source: FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLUCM002.m@ 1410

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

initial load of FOIAVistA 6/30/08 version
File size: 8.7 KB
Line 
1HLUCM002 ;CIOFO-O/LJA - HL7/Capacity Mgt API ;2/27/01 10:15
2 ;;1.6;HEALTH LEVEL SEVEN;**79,88,103**;Oct 13, 1995
3 ;
4PRINTREG ; Print data in ^TMP(SUB,...) to screen
5 ; SUB,JOBN -- req
6 N DEB,GBL,IOINHI,IOINORM,JOBN,SUB,TOT,WAY,X,XTMPGBL
7 ;
8 S X="IOINHI;IOINORM" D ENDR^%ZISS
9 ;
10 W @IOF,$$CJ^XLFSTR("Print Totals Report & Debug Data to Screen",IOM)
11 W !,$$REPEAT^XLFSTR("=",IOM)
12 ;
13 S XTMPGBL=""
14 ;
15 ; What is the SUB for the Totals Report...
16 S SUB=$$SUB
17 I SUB']"" W !!,"OK! No ^TMP(TOTALS,$J) totals report will be printed..."
18 I SUB]"" D PTOT
19 ;
20 ; Debug data...
21 I '$D(^TMP($J,"HLUCMSTORE")) D
22 . W !!,"No ^TMP($J,""HLUCMSTORE"") debug data exists..."
23 I $D(^TMP($J,"HLUCMSTORE")) D PSTORE
24 ;
25 I SUB']"",'$D(^TMP($J,"HLUCMSTORE")) D QUIT ;->
26 . S X=$$BTE^HLCSMON("Press RETURN to exit... ",1)
27 ;
28 QUIT:$$BTE^HLCSMON("Press RETURN to restart, or '^' to exit... ",1) ;->
29 ;
30 G PRINTREG ;->
31 ;
32PSTORE ;
33 W !!,$$CJ^XLFSTR("----------- "_IOINHI_"Debug Data from ^TMP($J,""HLUCMSTORE"")"_IOINORM_" -----------",IOM)
34 R !!,"Print raw DEBUG DATA (Y/N): Yes// ",X:999 S:X="" X="Y" S DEB=$$UP^XLFSTR($E(X_" ")) Q:'$T!(DEB[U) ;->
35 I DEB="Y" D PRINTDBG^HLUCM090
36 ;
37 R !!,"Print filtered DEBUG DATA (Y/N): Yes// ",X:999 S:X="" X="Y" S DEB=$$UP^XLFSTR($E(X_" ")) Q:'$T!(DEB[U) ;->
38 I DEB="Y" D LOOPU^HLUCM004
39 Q
40 ;
41PTOT ;
42 W !!,"You will be allowed to print report totals (from ^TMP(TOTALS,$J), and/or you"
43 W !,"may print the debug data (in ^TMP($J,""HLUCMSTORE"")."
44 W !!,$$CJ^XLFSTR("------------ "_IOINHI_"Report Totals from ^TMP("""_SUB_""",$J)"_IOINORM_" ------------",IOM)
45 R !!,"Print REPORT TOTALS (Y/N): Yes// ",X:999 S:X="" X="Y" S TOT=$$UP^XLFSTR($E(X_" ")) Q:'$T!(TOT[U) ;->
46 I TOT="Y" D
47 . S SUB="TOT",JOBN=$J
48 . I '$D(^TMP(SUB,JOBN)) S SUB="KMPDH"
49 . R !,"Include subtotals (Y/N): NO// ",WAY:999 QUIT:'$T!(WAY[U) ;->
50 . S:WAY']"" WAY="N"
51 . S WAY=$$UP^XLFSTR($E(WAY_" ")),WAY=$S(WAY="N":0,1:1)
52 . S X=$$XTMPGBL^HLUCM004(0) I X]"" S (GBL,XTMPGBL)=X W !!,"Printing from ",XTMPGBL,"..."
53 . D PRINT1
54 Q
55 ;
56SUB() ; What subscript holds the ^TMP(SUB,$J) data?
57 N SUB
58 I $D(^TMP("KMPDH",$J)) QUIT "KMPDH" ;->
59 I $D(^TMP("TOT",$J)) QUIT "TOT" ;->
60 R !!,"Enter subscript holding the ^TMP(TOTALS,$J) data: ",SUB:999 Q:SUB[U!(SUB']"") "" ;->
61 Q SUB
62 ;
63PRINT(SUB,JOBN,WAY) ; Print data in ^TMP(SUB,...) to screen
64 ; WAY -- 0 = No totals
65 ; 1 = Totals for every section
66 N L1,L2,L3
67 ;
68 S WAY=$S($G(WAY)'>0:0,$G(WAY)=1:1,1:0)
69 ;
70 S:$G(JOBN)'>0 JOBN=$J
71 I $G(SUB)']"" D QUIT ;->
72 . W !!,"You must pass in the initial subscript and $JOB number..."
73 . W !
74PRINT1 D PRINT1^HLUCM090
75 ;
76 S GBL=$NA(^TMP($J,"HLUCMSTORE","T"))
77 S L1=0 F L2="CCX","CXC","CXX","XCC","XCX","XXC","XXX" I $D(@GBL@(L2)) S L1=1
78 QUIT:'L1 ;->
79 ;
80 W !!,"Some entries were not included in the totals. There are 3 possible reasons"
81 W !,"for entries being excluded: (1) The beginning time of a message or unit is"
82 W !,"before the report's start time, (2) The number of seconds to transmit the"
83 W !,"message is over 1799 seconds, and (3) The protocol or namespace doesn't meet"
84 W !,"the search criteria."
85 W !!,"Failure Reason",?30,"#Characters",?42,"#Msg/Units",?54,"#Seconds"
86 W !,$$REPEAT^XLFSTR("=",IOM)
87 ;
88 F LAST="CCX","CXC","CXX","XCC","XCX","XXC","XXX" I $G(@GBL@(LAST))]"" Q
89 ;
90 S TYP="XXX",DATA=$G(@GBL@(TYP)) I DATA]"" D
91 . D SHOW("Beginning time too early",DATA)
92 . D SHOW("Excessive xmit time")
93 . D SHOW("Prot/Nmsp mismatch","",1)
94 S TYP="XXC",DATA=$G(@GBL@("XXC")) I DATA]"" D
95 . D SHOW("Beginning time too early",DATA)
96 . D SHOW("Excessive xmit time","",1)
97 S TYP="XCX",DATA=$G(@GBL@("XCX")) I DATA]"" D
98 . D SHOW("Beginning time too early",DATA)
99 . D SHOW("Prot/Nmsp mismatch","",1)
100 S TYP="XCC",DATA=$G(@GBL@("XCC")) I DATA]"" D
101 . D SHOW("Beginning time too early",DATA,1)
102 S TYP="CXX",DATA=$G(@GBL@("CXX")) I DATA]"" D
103 . D SHOW("Excessive xmit time",DATA)
104 . D SHOW("Prot/Nmsp mismatch","",1)
105 S TYP="CXC",DATA=$G(@GBL@("CXC")) I DATA]"" D
106 . D SHOW("Excessive xmit time",DATA,1)
107 S TYP="CCX",DATA=$G(@GBL@("CCX")) I DATA]"" D
108 . D SHOW("Prot/Nmsp mismatch",DATA,1)
109 I L1!L2!L3 W !,$$REPEAT^XLFSTR("=",IOM),!,"Totals:",?30,$J(L1,7),?42,$J(L2,7),?54,$J(L3,7)
110 ;
111 Q
112 ;
113SHOW(REA,DATA,LINE) ;
114 ; LAST,TYP -- req
115 S DATA=$G(DATA),LINE=$G(LINE)
116 W !,REA
117 I $G(DATA)]"" W ?30,$J($P(DATA,U),7),?42,$J($P(DATA,U,2),7),?54,$J($P(DATA,U,3),7)
118 I $G(LINE),TYP'=LAST W !,$$REPEAT^XLFSTR("-",IOM)
119 S L1=$G(L1)+$P(DATA,U),L2=$G(L2)+$P(DATA,U,2),L3=$G(L3)+$P(DATA,U,3)
120 QUIT
121 ;
122ADD(TL) ; Add to TOT...
123 S $P(TOT,U)=$P(TOT,U)+$P(TL,U)
124 S $P(TOT,U,2)=$P(TOT,U,2)+$P(TL,U,2)
125 S $P(TOT,U,3)=$P(TOT,U,3)+$P(TL,U,3)
126 Q
127 ;
128OKPAR(PAR) ; Is namespace or protocol OK?
129 S PAR=$G(PAR)
130 I PAR=1!(PAR=2) QUIT 1 ;->
131 I $$OK0CALL(PAR) QUIT 1 ;->
132 QUIT ""
133 ;
134OK0CALL(PAR) ; Correct 0^IEN or 0^NAME call format?
135 I $E(PAR,1,2)="0^"&($E(PAR,3)]"") QUIT 1 ;->
136 QUIT ""
137 ;
138TYPETMO(IEN772) ; Is this TCP, Mail (via TCP), or Other?
139 N D772,I773,MIEN
140 ;
141 ; RELATED MAILMAN MESSAGE field (0;5) in 772...
142 S D772=$G(^HL(772,+IEN772,0)) ; Get node
143 S MIEN=$P(D772,U,5) ; get Mailman IEN from field...
144 I MIEN QUIT "M" ;-> Mailman via TCP
145 ;
146 ; There are rare instances when RELATED MAILMAN MESSAGE field is
147 ; not filled in, but the LLP TYPE in 870 is Mailman. So, the next
148 ; check is needed...
149 ;
150 ; Get related 870 and check it's LLP TYPE...
151 I $P($G(^HLCS(870,+$$IEN870^HLUCM009(+IEN772),0)),U,3)=1 QUIT "M" ;->
152 ;
153 ; OK. Let's give up on proving this 772 entry a Mailman entry.
154 ; But, is it TCP?
155 ;
156 ; Check if TCP by 773 link...
157 S I773=$O(^HLMA("B",+IEN772,0))
158 I I773>0 QUIT "T" ;->
159 ;
160 QUIT "U" ; Other...
161 ;
162TYPEIO(IEN772) ; Is this Input or Output or Unknown?
163 N D772,HLIO
164 S D772=$G(^HL(772,+IEN772,0))
165 S HLIO=$E($P(D772,U,4)_" ")
166 QUIT $S("IO"[HLIO:HLIO,1:"U")
167 ;
168PROTNMSP(IEN772) ; Return PROT~NMSP value to store in ^TMP.
169 ; COND,IEN101,PNMSP -- req
170 N CT,FAIL,PCKG,CTPROT,PCKG,PROT
171 ;
172 S IEN101=$G(IEN101),PNMSP=$G(PNMSP)
173 ;
174 ; ======================== PROTOCOL ============================
175 ; Get actual protocol in IEN772 if not supposed to "lump"...
176 S PROT=$S(IEN101'=2:$$GETPROT^HLUCM050(+IEN772),1:"ZZZ")
177 ;
178 ; Don't lose count if supposed to check everything...
179 I IEN101=1!(IEN101=2) D
180 . I PROT']"" S PROT="ZZZ" QUIT ;->
181 . I IEN101=2 S PROT="ZZZ"
182 ;
183 ; Is the protocol countable? (Must also check namespace)
184 S CTPROT=$$CTPROT^HLUCM003(PROT)
185 ;
186 ; ======================== NAMESPACE ============================
187 ; Set package here and now...
188 S PCKG=$S(PNMSP'=2:$$GETNMSP^HLUCM050(+IEN772),1:"ZZZ")
189 ;
190 I PNMSP=1!(PNMSP=2) D
191 . I PCKG']"" S PCKG="ZZZ" QUIT ;->
192 . I PNMSP=2 S PCKG="ZZZ"
193 ;
194 S CTPCKG=$$CTPCKG^HLUCM003(PCKG)
195 ;
196 ;
197 ; Set up what should be returned...
198 S PROT=$S(PROT=2:"ZZZ",1:PROT),PCKG=$S(PCKG=2:"ZZZ",1:PCKG)
199 ; If MIXED make sure the ALL side of things is set to something
200 ; so the ALL side doesn't squelch a SPECIFIC match...
201 I $$MIXED D
202 . I $G(PNMSP)=1!($G(PNMSP)=2) D
203 . . QUIT:PROT]"" ;->
204 . . QUIT:'CTPROT ;-> Not to be counted anyway...
205 . . S PROT="ZZZ~0"
206 . I $G(IEN101)=1!($G(IEN101)=2) D
207 . . QUIT:PCKG]"" ;->
208 . . QUIT:'CTPCKG ;-> Not to be counted anyway...
209 . . S PCKG="ZZZ"
210 I '$$MIXED,COND="EITHER" D
211 . QUIT:$$ALL($G(PNMSP),$G(IEN101)) ;-> All 1s or 2s...
212 . I NMSPTYPE'=1 D ; Asked specifically...
213 . . QUIT:PROT]"" ;->
214 . . S PROT="ZZZ~0"
215 . I PROTYPE'=1 D ; Asked specifically...
216 . . QUIT:PCKG]"" ;->
217 . . S PCKG="ZZZ"
218 ;
219 ; If neither should be counted, don't...
220 I 'CTPROT&('CTPCKG) QUIT U ;->
221 ;
222 ; Either namespace or protocol matches, or both match...
223 ;
224 ; If BOTH namespace and protocol are required to match, don't count if one isn't a match...
225 I COND="BOTH" I 'CTPROT!('CTPCKG) QUIT U ;->
226 ;
227 ; If 1/2 & SPECIFIC (i.e., MIXED), then SPECIFIC trumps 1/2...
228 ; (If SPECIFIC not matched, it is not counted)
229 I $$MIXED D QUIT:FAIL U ;->
230 . S FAIL=1
231 . ; If ALL NMSPs to be counted, but specific PROT fails... BAD!
232 . I $G(PNMSP)=1!($G(PNMSP)=2) QUIT:'CTPROT ;->
233 . ; If ALL PROTs to be counted, but specific PCKG fails... BAD!
234 . I $G(IEN101)=1!($G(IEN101)=2) QUIT:'CTPCKG ;->
235 . S FAIL=0
236 ;
237 QUIT PROT_U_PCKG
238 ;
239ALL(V1,V2) ; Are both 1 or 2?
240 S V1=$G(V1),V2=$G(V2)
241 QUIT:V1'=1&(V1'=2) "" ;->
242 QUIT:V2'=1&(V2'=2) "" ;->
243 QUIT 1
244 ;
245MIXED() ; Is one 1/2 and the other SPECIFIC?
246 N V3
247 S V1=$G(PNMSP),V1=$S(V1]"":$S(V1=1!(V1=2):1,1:0),1:0)
248 S V2=$G(IEN101),V2=$S(V2]"":$S(V2=1!(V2=2):1,1:0),1:0)
249 S V1=$S(V1=1!(V1=2):1,1:0)
250 S V2=$S(V2=1!(V2=2):1,1:0)
251 S V3=V1+V2
252 QUIT $S(V3=1:1,1:"")
253 ;
254PROT101(IEN772) ; Return 101 information...
255 N IEN,MIEN,NM
256 ;
257 ; Get normal protocol information
258 S IEN=$P($G(^HL(772,IEN772,0)),U,10)
259 S NM=$P($G(^ORD(101,+IEN,0)),U)
260 ;
261 ; Maybe this is a Mailman ptr only...
262 I NM']"",IEN'>0 D
263 . S MIEN=$P($G(^HL(772,+IEN772,0)),U,5) QUIT:MIEN'>0 ;->
264 . S NM="XMB",IEN=9999999
265 ;
266 QUIT $S(NM]""!(IEN>0):NM_"~"_IEN,1:"")
267 ;
268EOR ; HLUCM002 - HL7/Capacity Mgt API ;2/27/01 10:15
Note: See TracBrowser for help on using the repository browser.