source: FOIAVistA/trunk/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSULRHL2.m@ 1783

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

initial load of FOIAVistA 6/30/08 version
File size: 5.3 KB
Line 
1PSULRHL2 ;HCIOFO/BH - File real time HL7 messages ; 24 Aug 2005 5:23 PM
2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;**3**;MARCH, 2005
3 ;
4FILE Q ; quit for HLO - ALA
5 ;
6 ; * THIS CODE IS NEVER TO BE INVOKED AT A SITE!!! ***
7 ; * IT SHOULD ONLY BE INSTALLED ON THE CMOP-NAT SERVER ***
8 ;
9 Q
10 ;
11 ;***** parses then files the incoming HL7 message into the message
12 ; global
13 ;
14 ;***** The following are present upon entry to this label
15 ;
16 ; HLNEXT M Code you can use to execute a $O through the segments of
17 ; a message
18 ;
19 ; HLNODE The current segment in the message (initally set to null)
20 ;
21 ; HLQUIT If not greater than zero, indicates there are no more
22 ; segments to $O through
23 ;
24 ;*****
25 ;
26 N FAC,HLCS,HLCSS,HLECH,HLFILE,HLFS,I,I2,ID,IEN,J2
27 K HLFILE,X2
28 ;
29 F I2=1:1 X HLNEXT Q:HLQUIT'>0 D
30 . S HLFILE(I2)=HLNODE,J2=0
31 . F S J2=$O(HLNODE(J2)) Q:'J2 S HLFILE(I2,J2)=HLNODE(J2)
32 ;
33 S HLFILE="HLFILE"
34 ;
35 I $D(@(HLFILE))<10 Q
36 ;
37 ;
38 I '$$PARAMS() Q
39 ;
40 S IEN=$$DEMO() I 'IEN Q
41 ;
42 D WRITE(IEN)
43 ;
44 K X2,HLFILE
45 Q
46 ;
47 ;
48WRITE(IEN) ;--- Find the OBR/OBX segments
49 ;
50 N I,IEN1,IEN2,J,J1,PREV,QUIT,STR,STR1
51 S I=0
52 F S I=$O(@HLFILE@(I)) Q:I="" D
53 . S STR=@HLFILE@(I)
54 . S J=""
55 . F S J=$O(@HLFILE@(I,J)) Q:J="" S STR=STR_@HLFILE@(I,J)
56 . I $E(STR,1,3)="OBR" D
57 . . S IEN1=$$OBR(STR,IEN)
58 . . I 'IEN1 Q
59 . . S QUIT=0
60 . . F Q:QUIT S PREV=I,I=$O(@HLFILE@(I)) Q:I="" D
61 . . . S STR1=@HLFILE@(I)
62 . . . S J1=""
63 . . . F S J1=$O(@HLFILE@(I,J1)) Q:J1="" S STR1=STR1_@HLFILE@(I,J1)
64 . . . I $E(STR1,1,3)'="OBX" S QUIT=1 Q
65 . . . D OBX(STR1,IEN,IEN1)
66 . . S I=PREV
67 Q
68 ;
69 ;
70ERROR(CODE,FAC,MESSAGE) ; Files any errors found within the processing
71 ;
72 ; Input:
73 ;
74 ; CODE Error Code
75 ; FAC Facility number
76 ; MESSAGE Optional parameter to help illustrate the error
77 ;
78 ;
79 N ARR,FDA,STR
80 I CODE=1 S STR=DT_": No patient DFN in the HL7 message ID: "_MESSAGE_" - Facility: "_FAC
81 ;
82 I CODE=2 S STR=DT_": Fileman Update did not work for message ID: "_MESSAGE_" - Facility: "_FAC
83 ;
84 I CODE=3 S STR=DT_": Could not update the OBR segment in message ID "_MESSAGE
85 ;
86 I CODE=4 S STR=DT_": Could not update the OBX segment in message ID "_MESSAGE
87 ;
88 S FDA(99999,"+1,",.01)=FAC
89 S FDA(99999,"+1,",2)=STR
90 D UPDATE^DIE("","FDA",)
91 Q
92 ;
93 ;
94OBX(STR1,IEN,IEN1) ; Extracts required OBX fields and files into
95 ; the global
96 ;
97 N FDA2,IENS,INDEX,LABS,LOCAL,LOINCC,LOINCNME,MSG2,NLTCODE,NLTNAME,OUT2,RANGE,RESULT,UNITS,VALUE
98 ;
99 S LABS=$P(STR1,HLFS,4)
100 F INDEX=3,6,9 D
101 . S VALUE=$P(LABS,HLCS,INDEX)
102 . I VALUE="99LRT" D
103 . . S LOCAL=$P(LABS,HLCS,INDEX-1)
104 . I VALUE="99NLT" D
105 . . S NLTCODE=$P(LABS,HLCS,INDEX-2)
106 . . S NLTNAME=$P(LABS,HLCS,INDEX-1)
107 . I VALUE="99LN" D
108 . . S LOINCC=$P(LABS,HLCS,INDEX-2)
109 . . S LOINCNME=$P(LABS,HLCS,INDEX-1)
110 ;
111 S RESULT=$P(STR1,HLFS,6)
112 I $G(RESULTS)="" Q
113 S UNITS=$P(STR1,HLFS,7)
114 S RANGE=$P(STR1,HLFS,8)
115 ;
116 S IENS="+1,"_IEN1_","_IEN_","
117 S FDA2(99999.11,IENS,.01)=RESULT
118 S FDA2(99999.11,IENS,.02)=$G(NLTCODE)
119 S FDA2(99999.11,IENS,.03)=$G(NLTNAME)
120 S FDA2(99999.11,IENS,.04)=$G(LOINCC)
121 S FDA2(99999.11,IENS,.05)=$G(LOINCNME)
122 S FDA2(99999.11,IENS,.06)=$G(LOCAL)
123 S FDA2(99999.11,IENS,2.01)=UNITS
124 S FDA2(99999.11,IENS,2.02)=RANGE
125 D UPDATE^DIE("","FDA2","OUT2","MSG2")
126 ;
127 ;I $D(MSG2) S ^TMP("PSUTEST",$J)=MSG2 D ERROR(4,FAC,ID_" IENs: "_IENS)
128 I $D(MSG2) D ERROR(4,FAC,ID_" IENs: "_IENS)
129 ;
130 Q
131 ;
132 ;
133 ;
134OBR(STR,IEN) ; Extracts required OBR fields and files into the global
135 N DD,FDA1,MM,MSG1,OUT1,SPEC,SPECDATE,YY
136 S SPECDATE=+$P(STR,HLFS,8)
137 S MM=$E(SPECDATE,5,6),DD=$E(SPECDATE,7,8),YY=$E(SPECDATE,3,4)
138 S YY=$S($E(YY,1,1)=0:"3",1:"2")_YY,SPECDATE=YY_MM_DD
139 S SPEC=$P(STR,HLFS,16)
140 ;
141 S FDA1(99999.01,"+1,"_IEN_",",.01)=SPEC
142 S FDA1(99999.01,"+1,"_IEN_",",.02)=SPECDATE
143 D UPDATE^DIE("","FDA1","OUT1","MSG1")
144 ;
145 I $D(MSG1) D ERROR(3,FAC,ID_" IENs: "_IEN) Q 0
146 ;
147 Q OUT1(1)
148 ;
149 ;
150PARAMS() ; Get HL7 Parameters and facility # from the MSH segment
151 N CNT,J2,QUIT,REC
152 S (QUIT,CNT)=0
153 F S CNT=$O(@HLFILE@(CNT)) Q:'CNT!(QUIT) D
154 . S REC=@HLFILE@(CNT)
155 . S J2=""
156 . F S J2=$O(@HLFILE@(CNT,J2)) Q:J2="" S REC=REC_@HLFILE@(CNT,J2)
157 . I $E(REC,1,3)="MSH" D Q
158 . . S HLFS=$E(REC,4,4)
159 . . S HLECH=$P(REC,HLFS,2)
160 . . S HLCS=$E(HLECH,1,1)
161 . . S HLCSS=$E(HLECH,2,2)
162 . . S FAC=$P(REC,HLFS,4),FAC=$P(FAC,HLCS,1)
163 . . S ID=$P(REC,HLFS,10)
164 . . S QUIT=1
165 I $G(FAC)="" Q 0
166 Q 1
167 ;
168DEMO() ; Get the demographic data and file a zero node entry in the
169 ; message global
170 ;
171 N CNT,DFN,END,FDA,I,ICN,IDSTR,J3,MSG,OUT,QUIT,REC,SUB,SSN
172 S (ICN,SSN,DFN)=""
173 S (QUIT,CNT)=0
174 F S CNT=$O(@HLFILE@(CNT)) Q:'CNT!(QUIT) D
175 . S REC=@HLFILE@(CNT)
176 . S J3=""
177 . F S J3=$O(@HLFILE@(CNT,J3)) Q:J3="" S REC=REC_@HLFILE@(CNT,J3)
178 . I $E(REC,1,3)="PID" D Q
179 . . S IDSTR=$P(REC,HLFS,4),END=0
180 . . ;
181 . . F I=1:1 Q:END D
182 . . . S SUB=$P(IDSTR,HLCSS,I)
183 . . . I SUB="" S END=1 Q
184 . . . I $P(SUB,HLCS,5)="NI" D
185 . . . . I $P(SUB,HLCS,8)'="" Q
186 . . . . S ICN=$P(SUB,HLCS,1),ICN=$P(ICN,"V",1)
187 . . . . ;
188 . . . I $P(SUB,HLCS,5)="SS" D
189 . . . . S SSN=$P(SUB,HLCS,1)
190 . . . . ;
191 . . . I $P(SUB,HLCS,5)="PI" D
192 . . . . S DFN=$P(SUB,HLCS,1)
193 . . S QUIT=1
194 ;
195 I DFN="" D ERROR(1,FAC,ID) Q 0
196 ;
197 K FDA,OUT,MSG
198 ;
199 S FDA(99999,"+1,",.02)=DFN
200 S FDA(99999,"+1,",.04)=ICN
201 S FDA(99999,"+1,",.05)=SSN
202 S FDA(99999,"+1,",.01)=FAC
203 D UPDATE^DIE("","FDA","OUT","MSG")
204 ;
205 I $D(MSG) D ERROR(2,FAC,ID) Q 0
206 ;
207 Q OUT(1)
208 ;
209 ;
210 Q
211 ;
212 ;
Note: See TracBrowser for help on using the repository browser.