source: FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLUTIL2.m@ 897

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

initial load of FOIAVistA 6/30/08 version

File size: 5.7 KB
Line 
1HLUTIL2 ;ALB/MFK/MTC/JC - VARIOUS HL7 UTILITIES ;01/13/2006 16:06
2 ;;1.6;HEALTH LEVEL SEVEN;**19,43,57,59,120**;;Build 12
3ITEM(IEN,ROUTINE) ; Return data from ITEM multiple in protocol file
4 ; INPUT : IEN - Internal Entry Number for 101 (Protocol) file.
5 ; ROUTINE - name of a routine to run (either PTR or TYPE)
6 ;OUTPUT : HLARY - Array of IENs from ITEM multiple
7 ; HLARY is of the form:
8 ; HLARY(0)=Total number of items found
9 ; HLARY(IEN)=Results from function
10 N ITEM,LINE,MSG,PTR
11 S IEN=$G(IEN)
12 Q:(IEN="")
13 S ROUTINE=$G(ROUTINE)
14 S ROUTINE=$S(ROUTINE="PTR":1,ROUTINE="TYPE":2,ROUTINE=1:1,ROUTINE=2:2,1:"")
15 Q:(ROUTINE="")
16 S ITEM="",MSG=0
17 ; Loop through IENs within Subscriber multiple
18 F S ITEM=$O(^ORD(101,IEN,775,ITEM)) Q:(ITEM="") D
19 .S PTR=$P($G(^ORD(101,IEN,775,ITEM,0)),"^",1)
20 .; Call type to get info on that item
21 .S:(ROUTINE=1) LINE=$$PTR(PTR)
22 .S:(ROUTINE=2) LINE=$$TYPE(PTR)
23 .; Make sure LINE isn't error code
24 .I ((+LINE)>(-1)) S MSG=MSG+1 S HLARY(PTR)=LINE
25 S HLARY(0)=MSG
26 K ROUTINE
27 Q
28PTR(IEN) ; Return pointer information if subscriber
29 ; INPUT - IEN: IEN of protocol file
30 ;OUTPUT - Line from ^ORD(101,IEN,770):
31 ; CLIENT^LOGICAL_LINK (both pointers)
32 N RETURN,LINE,TYPE
33 S IEN=$G(IEN)
34 Q:(IEN="") "-1"
35 ; Make sure this is a subscriber type
36 S TYPE=$P($G(^ORD(101,IEN,0)),"^",4)
37 Q:(TYPE'="S") "-2"
38 S LINE=$G(^ORD(101,IEN,770))
39 S RETURN=$P(LINE,"^",2)_"^"_$P(LINE,"^",7)
40 Q RETURN
41TYPE(IEN) ; Return portions of protocol file
42 ; INPUT - IEN: IEN of protocol file
43 ;OUTPUT - Line containing the following information from the protocol
44 ; file (#101)
45 ;
46 ; Client ^ Message Type Received ^ Event Type ^ Message Structure ^
47 ; Processing ID ^ Logical Link Pointer ^ Accept Ack ^
48 ; Application Ack ^ Version ^ Message Type Generated
49 ;
50 N RETURN,CLP,MTPR,ETP,LINE,TYPE,CLIENT,EVENT,MTPEVP
51 N ACCACK,APPACK,VERID,VERIDP,ACKP,ACKTYP,MTPG,MTNEVN
52 ;-- check if ien was passed in
53 S IEN=$G(IEN)
54 Q:(IEN="") "-1"
55 ;
56 ; Null any variables in case they don't exist
57 S (CLIENT,TYPE,EVENT,ACCACK,APPACK,VERID,MTPG,MTNEVN)=""
58 ; Get line from protocol file
59 S LINE=$G(^ORD(101,IEN,770))
60 ;
61 ;-- get client (application that will receive the message
62 S CLP=$P(LINE,U,2)
63 S:(CLP) CLIENT=$P($G(^HL(771,CLP,0)),U,1)
64 ;
65 ;-- get message type received & generated
66 S MTPR=$P(LINE,U,3)
67 S MTPG=$P(LINE,U,11)
68 S:(MTPR) MTPR=$P($G(^HL(771.2,MTPR,0)),U,1)
69 S:(MTPG) MTPG=$P($G(^HL(771.2,MTPG,0)),U,1)
70 ;
71 ;-- get event type
72 S ETP=$P(LINE,U,4)
73 S:(ETP) EVENT=$P($G(^HL(779.001,ETP,0)),U,1)
74 ;
75 ;-- get message structure code
76 S MTPEVP=$P(LINE,U,5)
77 S:(MTPEVP) MTNEVN=$P($G(^HL(779.005,MTPEVP,0)),U,1)
78 ;
79 ;-- accept acknowledgement
80 S ACKP=$P(LINE,U,8)
81 S:(ACKP) ACCACK=$P($G(^HL(779.003,ACKP,0)),U,1)
82 ;
83 ;-- application acknowledgement
84 S ACKTYP=$P(LINE,U,9)
85 S:(ACKTYP) APPACK=$P($G(^HL(779.003,ACKTYP,0)),U,1)
86 ;
87 ;-- version of HL7
88 S VERIDP=$P(LINE,U,10)
89 S:(VERIDP) VERID=$P($G(^HL(771.5,VERIDP,0)),U,1)
90 ;
91 ;-- build return string
92 S RETURN=CLIENT_U_MTPR_U_EVENT
93 ;-- 6 processing id, 7 logical link pointer
94 S RETURN=RETURN_U_MTNEVN_U_$P(LINE,U,6)_U_$P(LINE,U,7)
95 S RETURN=RETURN_U_ACCACK_U_APPACK_U_VERID_U_MTPG
96 Q RETURN
97 ;
98MSGADM(IEN) ; RETURN DATE/TIME ENTERED AND MSGID FROM FILE 773
99 N X
100 Q:'$G(^HLMA(+$G(IEN),0)) "-1" S X=^(0)
101 Q $P($G(^HL(772,+X,0)),"^")_"^"_$P(X,"^",2)
102 ;
103APPPRM(IEN) ; RETURN DATA FROM THE APPLICATION PARAMETER FILE
104 N LINE,COUNTRYP,COUNTRY
105 S IEN=$G(IEN)
106 Q:(IEN="")
107 S LINE=$G(^HL(771,IEN,0))
108 S COUNTRYP=$P(LINE,"^",7),COUNTRY=""
109 ;
110 ; patch HL*1.6*120 - for deleting "US" entry from #779.004
111 ; I COUNTRYP]"" S COUNTRY=$P(^HL(779.004,COUNTRYP,0),"^",1)
112 I COUNTRYP]"" S COUNTRY=$P($G(^HL(779.004,COUNTRYP,0)),"^",1)
113 ;
114 S APPPRM(IEN,0)=$P(LINE,"^",1)_"^"_$P(LINE,"^",3)_"^"_COUNTRY
115 S APPPRM(IEN,"EC")=$G(^HL(771,IEN,"EC"))
116 S:(APPPRM(IEN,"EC")="") APPPRM(IEN,"EC")="~|\&"
117 S APPPRM(IEN,"FS")=$G(^HL(771,IEN,"FS"))
118 S:(APPPRM(IEN,"FS")="") APPPRM(IEN,"FS")="^"
119 Q
120CLRQUE ; Clear a queue by menu option
121 N DIC,DIR,DIRUT,HLDIR,HLERR,HLIEN,HLL,HLLTC,X,Y
122 S DIC="^HLCS(870,",DIC(0)="AEQMZ"
123 D ^DIC Q:Y<0
124 K DIC S HLIEN=+Y,HLL=$P(Y(0),U,3)
125 L +^HLCS(870,HLIEN):1 E W !!,"Couldn't Lock Record, Try later.",! Q
126 S DIR(0)="S^B:BOTH QUEUES;I:IN QUEUE;O:OUT QUEUE",DIR("?")="Select the queue (in, out, or both) you would like cleared"
127 S DIR("A")="Enter which queue to clear",DIR("B")="B"
128 D ^DIR K DIR
129 S HLDIR=$S(Y="I":"IN",Y="O":"OUT",Y="B":"BOTH",1:1)
130 I HLDIR=1!$D(DIRUT) L -^HLCS(870,HLIEN) Q
131 ;HLLTC= TCP service type
132 S:HLL HLLTC=$P($G(^HLCS(870,HLIEN,400)),U,3)
133 ;TCP link
134 I $G(HLLTC)]"" D L -^HLCS(870,HLIEN) Q
135 . ;multiple server, set STATE and SHUTDOWN LLP?
136 . S:HLLTC="M" X=^HLCS(870,HLIEN,0),$P(X,U,5)="0 server",$P(X,U,15)=0,^(0)=X
137 . I HLDIR="BOTH" D Q
138 .. F X="IN","OUT" D CLRQUET(X)
139 . ;do one que
140 . D CLRQUET(HLDIR)
141 ;
142 I HLDIR="BOTH" D
143 . S HLERR=$$CLEARQUE^HLCSQUE(HLIEN,"OUT")
144 . I HLERR W !,"Error in clearing out queue:",$P(HLERR,"^",2)
145 . S HLERR=$$CLEARQUE^HLCSQUE(HLIEN,"IN")
146 . I HLERR W !,"Error in clearing in queue:",$P(HLERR,"^",2)
147 I HLDIR'="BOTH" S HLERR=$$CLEARQUE^HLCSQUE(HLIEN,HLDIR)
148 L -^HLCS(870,HLIEN)
149 Q
150CLRQUET(Y) ;subroutine for TCP links, Y=IN or OUT
151 Q:Y'="IN"&(Y'="OUT")
152 N C,N,X
153 S N=$E(Y),X=0
154 ;get count of what is pending
155 F C=0:1 S X=$O(^HLMA("AC",N,HLIEN,X)) Q:'X
156 ;reset counters for messages
157 S ^HLCS(870,HLIEN,Y_" QUEUE BACK POINTER")=C,^(Y_" QUEUE FRONT POINTER")=0
158 Q
159 ;
160SHGLLP ; Show Gross LLP Error
161 N DIC,IEN,ERR
162 S DIC="^HLCS(870,"
163 S DIC(0)="AEQM"
164 D ^DIC K DIC
165 S IEN=$P(Y,"^",1)
166 S ERR=$P($G(^HLCS(870,IEN,0)),"^",19)
167 W:(ERR'="") !,"Error: "_$P($G(^HL(771.7,ERR,0)),"^",1),!
168 W:(ERR="") !,"No Gross LLP error found",!
169 Q
170CLGLLP ; Clear Gross LLP error
171 N DIC,IEN,ERR,DA,DR
172 S DIC="^HLCS(870,"
173 S DIC(0)="AEQM"
174 D ^DIC K DIC
175 S IEN=$P(Y,"^",1)
176 Q:(IEN<0)
177 S DIE="^HLCS(870,"
178 S DA=IEN
179 S DR="18///@"
180 D ^DIE K DIE
181 Q
Note: See TracBrowser for help on using the repository browser.