source: FOIAVistA/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGADTP.m@ 1245

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

initial load of FOIAVistA 6/30/08 version
File size: 9.5 KB
Line 
1RGADTP ;BIR/DLR-ADT PROCESSOR TO RETRIGGER A08 or A04 MESSAGES WITH AL/AL (COMMIT/APPLICATION) ACKNOWLEDGEMENTS ;5/28/02
2 ;;1.0;CLINICAL INFO RESOURCE NETWORK;**26,27,20,34,35,40,45,44,47**;30 Apr 99;Build 10
3 ;
4 ;Reference to BLDEVN^VAFCQRY and BLDPID^VAFCQRY supported by IA #3630
5 ;Reference to EN1^VAFHLZEL is supported by IA #752
6 ;Reference to Patient file (#2) PREFERRED FACILITY (#27.02) is supported by IA #1850
7 ;Reference to $$PV2, $$PHARA, $$LABE, $$RADE ^VAFCSB is supported by IA #4921
8 ;
9INIT ;
10 N RGER,RGSITE,ARRAY,MSH,RGLOCAL,RGEVNT,REP,DIC,DR,DIE,DA,DLAYGO
11 S RGER=""
12 D IN
13 D PROCIN
14 D GENACK
15 Q
16PROC ;processing entry point
17 N HLA,RGADT,PV1,DIC,ARRAY,RGEVNT,RGLOCAL,REP,ICN,RGSITE
18 S RGEVNT=HL("ETN")
19 I $G(HL("MID"))'="" S RGADT=HL("MID")
20 I $G(HL("MID"))="" S RGADT=999
21 D IN
22 S ICN=$G(ARRAY("ICN"))
23 I +$G(ICN)<1 Q ;quit if no ICN
24 I $E($G(ICN),1,3)=$P($$SITE^VASITE,"^",3) Q ;quit if ICN is a local
25 S ZTSAVE("DFN")="",ZTSAVE("RGEVNT")="",ZTSAVE("HLA(""HLS"",")="",ZTRTN="SEND^RGADTPC",ZTDESC="Sending HL7 Patient Update...",ZTIO="RG QUEUE",ZTDTH=$H D ^%ZTLOAD
26 K ZTSAVE,ZTRTN,ZTDESC,ZTIO,ZTDTH
27 Q
28IN ;Process in the ADT A04/A08 (routing logic)
29 N RGI,MSG,RG,SG,DFN,EVN,SITE,RGC,RGJ,DIC,PV1,PID,COMP,ENT,EN,THLA,LAB,RAD,PHARM,TMP
30 S ENT=1,REP=$E(HL("ECH"),2),COMP=$E(HL("ECH"),1)
31 ;set local flag to indicate the processing of an outbound for reformatting
32 I $P($G(HL("SAF")),COMP)=$P($$SITE^VASITE,"^",3) S RGLOCAL=1
33 I $P($G(HL("SAF")),COMP)'=$P($$SITE^VASITE,"^",3) S RGLOCAL=0
34 S RGC=$E($G(HL("ECH")),1)
35 F RGI=1:1 X HLNEXT Q:HLQUIT'>0 S MSG=HLNODE,SG=$E(HLNODE,1,3) D
36 .S RGJ=0 F S RGJ=$O(HLNODE(RGJ)) Q:'RGJ S MSG(RGJ)=HLNODE(RGJ)
37 .D:SG?2A1(1A,1N) PICK
38 ;if message MSH sending facility matches the PID assigning authority update
39 S ENT=0,EN=1 F S ENT=$O(THLA("HLS",ENT)) Q:ENT="" D
40 .S HLA("HLS",EN)=THLA("HLS",ENT),EN=EN+1
41 .I $E($G(THLA("HLS",ENT)),1,3)="PID"!($E($G(THLA("HLS",ENT)),1,3)="ZEL") D
42 ..;**47 handle if ZEL is over 245 as well
43 ..I $O(THLA("HLS",ENT,""))'="" D
44 ...S CNT="" F S CNT=$O(THLA("HLS",ENT,CNT)) Q:CNT="" S HLA("HLS",EN-1,CNT)=THLA("HLS",ENT,CNT)
45 .I $E($G(THLA("HLS",ENT)),1,3)="PV1" I RGLOCAL S TMP=$$PV2B I TMP'="" S HLA("HLS",EN)=$$PV2B,EN=EN+1 ;**47
46 .I $E($G(THLA("HLS",ENT)),1,3)="ZPD" I RGLOCAL D
47 ..S RAD=$$RADE I RAD'="" S HLA("HLS",EN)=RAD,EN=EN+1
48 ..S LAB=$$LABE I LAB'="" S HLA("HLS",EN)=LAB,EN=EN+1
49 ..S PHARM=$$PHARA I PHARM'="" S HLA("HLS",EN)=PHARM,EN=EN+1
50QUIT Q
51ROUTE ;
52 N RGERR
53 I $G(RGEVNT)="" S RGEVNT=$G(HL("ETN"))
54 N MPI S MPI=$$MPILINK^MPIFAPI() D
55 .I $P($G(MPI),U)'=-1 S HLL("LINKS",1)="RG ADT-"_HL("ETN")_" 2.4 CLIENT^"_MPI
56 .I $P($G(MPI),U)=-1 D
57 ..N RGLOG,RGMTXT D START^RGHLLOG(HLMTIEN,"","") S RGMTXT="for DFN#"_$G(DFN)
58 ..D EXC^RGHLLOG(224,"No MPI link identified"_RGMTXT,$G(DFN)) S RGERR=1
59 I $G(RGERR)'=1 S ^XTMP("RG"_HL("ETN")_"%"_DFN,0)=$$FMADD^XLFDT(DT,5)_"^"_DT_"^"_"RG"_HL("ETN")_" msg to MPI for DFN "_DFN S ^XTMP("RG"_HL("ETN")_"%"_DFN,"MPI",0)="A"
60 Q
61RESP ;
62 N RGER,RGSITE,ARRAY,MSH,RGLOCAL,RGEVNT,RGI,MSG,RG,SG,DFN,EVN,SITE,RGC,RGJ,DIC,PV1,PID
63 D IN
64 Q
65PICK ;check routine for segment entry point
66 I $T(@SG)]"" D @SG
67 I $T(@SG)="" Q
68 Q
69MSA ;process the MSA segment
70 N ARRAY,CNT,DFN,EXIT,HLCOMP,RGAA,RGERR,RGEVNT,RGMSG,RETURN,RGX,RGY,RGCODE
71 I RGLOCAL S THLA("HLS",ENT)=MSG,ENT=ENT+1
72 S RGAA=MSG,EXIT=0,RGCODE=$P(RGAA,HL("FS"),2),RGMSG=$P(RGAA,HL("FS"),3),RGERR=$P(RGAA,HL("FS"),4),RGMSG=$$MSG^HLCSUTL(RGMSG,"RETURN(1)") K RGMSG
73 S CNT=1,RGX=0 F S RGX=$O(RETURN(1,RGX)) Q:'RGX!(EXIT=1) D
74 .I RETURN(1,RGX)'="" D
75 ..I $D(RGMSG) S RGMSG(CNT)=RETURN(1,RGX),CNT=CNT+1
76 ..I '$D(RGMSG) S RGMSG=RETURN(1,RGX),RGY=RGX
77 .I RETURN(1,RGX)="" D S CNT=1 K RGMSG
78 ..I $E(RETURN(1,RGY),1,3)="MSH" D MSH
79 ..I $E(RETURN(1,RGY),1,3)="PID" D PIDP^RGADTP1(.RGMSG,.ARRAY,.HL) S EXIT=1
80 S DFN=$G(ARRAY("DFN"))
81 ;**45 Log Exception ONLY if AR is returned in MSA segment
82 I RGCODE="AR" D
83 .D START^RGHLLOG(HLMTIEN,"","")
84 .D EXC^RGHLLOG(234,RGERR,DFN) ;**44
85 .D STOP^RGHLLOG(0)
86 I $D(^XTMP("RG"_HL("ETN")_"%"_DFN,0)) K ^XTMP("RG"_HL("ETN")_"%"_DFN)
87 Q
88MSH ;
89 S MSH=1
90 I RGLOCAL S THLA("HLS",ENT)=MSG,ENT=ENT+1
91 I 'RGLOCAL S RGC=$E(HL("ECH"),1)
92 S RGSITE=$P($P(MSG,HL("FS"),4),RGC),RGEVNT=$P($P(MSG,HL("FS"),9),RGC,2)
93 Q
94PV2 ;processor of PV2 segment ;**47
95 Q
96PV2B() ;builder of PV2 segment ;**47
97 N RET S RET=""
98 I 'RGLOCAL Q RET
99 N X S X="VAFCSB" X ^%ZOSF("TEST") Q:'$T RET
100 ;**45 VAFCSB coming in with DG*5.3*707
101 Q $$PV2^VAFCSB
102PHARA() ;build obx to show active prescriptions
103 N RET S RET=""
104 I 'RGLOCAL Q RET
105 I '$$PATCH^XPDUTL("PSS*1.0*101") Q RET
106 N X S X="VAFCSB" X ^%ZOSF("TEST") Q:'$T RET
107 ;**45 VAFCSB coming in with DG*5.3*707
108 Q $$PHARA^VAFCSB
109LABE() ;BUILD OBX FOR LAST LAB TEST DATE
110 N RET S RET=""
111 I 'RGLOCAL Q RET
112 I '$$PATCH^XPDUTL("LR*5.2*295") Q RET
113 N X S X="VAFCSB" X ^%ZOSF("TEST") Q:'$T RET
114 ;**45 VAFCSB coming in with DG*5.3*707
115 Q $$LABE^VAFCSB
116RADE() ;BUILD OBX FOR LAST RADIOLOGY TEST DATE
117 N RET S RET=""
118 I 'RGLOCAL Q RET
119 I '$$PATCH^XPDUTL("RA*5.0*76") Q RET
120 N X S X="VAFCSB" X ^%ZOSF("TEST") Q:'$T RET
121 ;**45 VAFCSB coming in with DG*5.3*707
122 Q $$RADE^VAFCSB
123EVN ;;
124 N CNT,ERR S EVN=RGI
125 I RGLOCAL S (EVN(1),THLA("HLS",ENT))=MSG,ENT=ENT+1
126 I 'RGLOCAL D
127 .S ARRAY("EVR")=$P(MSG,HL("FS"),2),ARRAY("DLT")=$$FMDATE^HLFNC($P(MSG,HL("FS"),3))
128 .S ARRAY("EVNAME")=$$FMNAME^XLFNAME($P(MSG,HL("FS"),2),"",$E(HL("ECH"),1)),ARRAY("SENDING SITE")=$P(MSG,HL("FS"),8)
129 Q
130EVNP ;
131 N EVNX
132 I $G(DFN)'="" D BLDEVN^VAFCQRY(DFN,"1,2,4,5,6,7",.EVN,.HL,$G(HL("ETN")),.ERR) S CNT=0,EVNX=0 F S EVNX=$O(EVN(EVNX)) Q:'EVNX D
133 .I CNT>0 S THLA("HLS",EVN,CNT)=EVN(EVNX),CNT=CNT+1
134 .I CNT'>0 S THLA("HLS",EVN)=EVN(EVNX),CNT=CNT+1
135 Q
136PID ;;
137 N CNT,PIDX
138 I RGLOCAL D
139 .N HLCOMP S HLCOMP=$E(HL("ECH"),1),THLA("HLS",ENT)=MSG,DFN=$P($P(MSG,HL("FS"),4),HLCOMP) ;**45 REMOVED +
140 .D EVNP
141 .D BLDPID^VAFCQRY(DFN,1,"ALL",.PID,.HL)
142 .;get ICN value in the PID segment
143 .S ARRAY("ICN")=+$P($P(PID(1),HL("FS"),4),HLCOMP)
144 .S CNT=0,PIDX=0 F S PIDX=$O(PID(PIDX)) Q:'PIDX D
145 ..I CNT>0 S THLA("HLS",ENT,CNT)=PID(PIDX),CNT=CNT+1
146 ..I CNT'>0 S THLA("HLS",ENT)=PID(PIDX),CNT=CNT+1
147 .S ENT=ENT+1
148 I 'RGLOCAL D PIDP^RGADTP1(.MSG,.ARRAY,.HL)
149 Q
150PD1 ;SET PD1 SEQ 3 TO BE PREFERRED FACILITY INSTEAD OF CMOR PATCH **45
151 N PD1
152 I RGLOCAL D
153 .;S PD1=$$PD1^VAFCSB
154 .;I PD1'="" S THLA("HLS",ENT)=PD1,ENT=ENT+1
155 I 'RGLOCAL S (ARRAY(991.03),ARRAY("CMOR"))=$P($P(MSG,HL("FS"),4),RGC) ;PUTTING BACK TO DO NEED FOR PATCH 40 ON MPI SIDE
156 ;- NO LONGER DEALING WITH CMOR
157 Q
158PV1 ;;
159 I RGLOCAL S THLA("HLS",ENT)=MSG,ENT=ENT+1
160 Q
161OBX ;;
162 N COMP,SSNV S COMP=$E(HL("ECH"),1)
163 I RGLOCAL S THLA("HLS",ENT)=MSG,ENT=ENT+1
164 I 'RGLOCAL D:$$FREE^RGRSPARS($P($P(MSG,HL("FS"),4),RGC,2))="SECURITY LEVEL"
165 .S ARRAY("SENSITIVITY")=$$SENSTIVE^RGRSPARS($P(MSG,HL("FS"),6),COMP),ARRAY("SENSITIVITY DATE")=$$FREE^RGRSPARS($$FMDATE^HLFNC($P(MSG,HL("FS"),15)))
166 .S ARRAY("SENSITIVITY USER")=$$FREE^RGRSPARS($P($P(MSG,HL("FS"),17),RGC,2))_","_$$FREE^RGRSPARS($P($P(MSG,HL("FS"),17),RGC,3))
167 ;**45 Get SSN VERIFICATION STATUS out of OBX if message is from the MPI
168 ;I 'RGLOCAL,$P(HL("SFN"),COMP)="200M" I $P($P(MSG,HL("FS"),4),RGC)="SSN VERIFICATION STATUS" S SSNV=$P($P(MSG,HL("FS"),6),RGC,2),ARRAY(.0907)=$S(SSNV="VERIFIED":4,SSNV="INVALID":2,1:"@")
169 ;**47 use SSN Verification status code and not words since they have changed since this code was first written
170 ;only update values to valid or invalid other statuses aren't stored in VistA
171 I 'RGLOCAL,$P(HL("SFN"),COMP)="200M" I $P($P(MSG,HL("FS"),4),RGC)="SSN VERIFICATION STATUS" S SSNV=$P($P(MSG,HL("FS"),6),RGC,1),ARRAY(.0907)=$S(SSNV=4:4,SSNV=2:2,1:"@")
172 Q
173ZPD ;;
174 I RGLOCAL S THLA("HLS",ENT)=$$EN1^VAFHLZPD(DFN,"1,17,21,34"),ENT=ENT+1 ;**45 to build new ZPD
175 I 'RGLOCAL S ARRAY(.0906)=$P(MSG,HL("FS"),35) I ARRAY(.0906)=HL("Q") S ARRAY(.0906)="@" ;**45 Pull out pseudo ssn reason
176 Q
177ZSP ;;
178 I RGLOCAL S THLA("HLS",ENT)=MSG,ENT=ENT+1
179 I 'RGLOCAL S ARRAY(.301)=$$YESNO^RGRSPARS($P(MSG,HL("FS"),3)),ARRAY(.302)=$$FREE^RGRSPARS($P(MSG,HL("FS"),4)),ARRAY(.323)=$$POS^RGRSPARS($P(MSG,HL("FS"),5))
180 Q
181ZEL ;;
182 I RGLOCAL D
183 .;**40 to rebuild ZEL segment
184 .I '$D(DFN) S THLA("HLS",ENT)=MSG,ENT=ENT+1 Q ;don't know DFN pass back original ZEL segment
185 .N VAFZEL D EN1^VAFHLZEL(DFN,"1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22",2,.VAFZEL) ;build a complete ZEL segment
186 .;need to take into account may be more than 1 array entry and that each entry could go over 245 so there would be another subscript
187 .N CNT,ZELX S (CNT,ZELX)=0 F S ZELX=$O(VAFZEL(ZELX)) Q:'ZELX D
188 ..I CNT>0 S THLA("HLS",ENT,CNT)=VAFZEL(ZELX),CNT=CNT+1
189 ..I CNT'>0 S THLA("HLS",ENT)=VAFZEL(ZELX),ENT=ENT+1
190 I 'RGLOCAL D
191 . S ARRAY(.361)=$$ELIG^RGRSPARS($P(MSG,HL("FS"),3)),ARRAY(.3612)=$$FREE^RGRSPARS($P(MSG,HL("FS"),12))
192 . S ARRAY(.3615)=$$FREE^RGRSPARS($P(MSG,HL("FS"),14)),ARRAY(391)=$$TYPE^RGRSPARS($P(MSG,HL("FS"),10)),ARRAY(1901)=$$VETERAN^RGRSPARS($P(MSG,HL("FS"),9))
193 Q
194ZCT ;;
195 I RGLOCAL S THLA("HLS",ENT)=MSG,ENT=ENT+1
196 I 'RGLOCAL S ARRAY(.211)=$$FREE^RGRSPARS($P(MSG,HL("FS"),4)),ARRAY(.219)=$$FREE^RGRSPARS($P(MSG,HL("FS"),7))
197 Q
198ZEM ;;
199 I RGLOCAL S THLA("HLS",ENT)=MSG,ENT=ENT+1
200 I 'RGLOCAL S ARRAY(.31115)=$$EMP^RGRSPARS($P(MSG,HL("FS"),4))
201 Q
202ZFF ;;
203 I RGLOCAL S THLA("HLS",ENT)=MSG,ENT=ENT+1
204 I 'RGLOCAL S ARRAY("FLD")=$P(MSG,HL("FS"),3)
205 Q
206PROCIN ;
207 D PROCIN^RGADTP2(.ARRAY,.RGLOCAL,.RGER,.DFN,.HL)
208 Q
209GENACK ;
210 N RGCNT,IEN,RG
211 I $G(ARRAY("DFN"))'>0 S RGER="-1^Unknown ICN#"_$G(ARRAY("ICN"))_" and SSN#"_$G(ARRAY(.09))
212 S RGCNT=1,HLA("HLA",RGCNT)="MSA"_HL("FS")_"AA"_HL("FS")_HL("MID")_HL("FS")_$S(+$G(RGER)<0:$P(RGER,"^",2,3),1:""),RGCNT=RGCNT+1
213 S RGSITE=$$LKUP^XUAF4(RGSITE)
214 D LINK^HLUTIL3(RGSITE,.RG) S IEN=$O(RG(0)) S HLL("LINKS",1)="^"_RG(IEN)
215 D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.HLRESLTA,"",.HL)
216 K HLA
217 Q
218RSP ;
219 Q
Note: See TracBrowser for help on using the repository browser.