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

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

initial load of FOIAVistA 6/30/08 version

File size: 6.3 KB
Line 
1RGHOUT ;CAIRO/DKM-HL7 message generation utilities ;14-Oct-1998
2 ;;1.0; CLINICAL INFO RESOURCE NETWORK ;;30 Apr 99
3 ;=================================================================
4 ; Initialize
5INIT(RGEP,HL,RGD,RGERR,RGSB) ;
6 K HL,RGD
7 D INIT^HLFNC2(RGEP,.HL)
8 I $G(HL) S RGERR=$P(HL,U,2) Q +HL
9 S RGD(1)=HL("FS"),HL("RGSB")=$G(RGSB,"HLS")
10 F RGD=2:1:5 S RGD(RGD)=$E(HL("ECH"),RGD-1)
11 K ^TMP("HLS",$J)
12 Q 0
13 ; Hand off completed message
14SEND(RGEP,HL,RGERR) ;
15 N RGZ
16 D GENERATE^HLMA(RGEP,"GM",1,.RGZ,"",.HL)
17 K ^TMP("HLS",$J)
18 S:$P($G(RGZ),U,2) RGERR=$P(RGZ,U,3)
19 Q
20 ; Send acknowledgment
21ACK(RGEP,RGCL,RGMSG,RGERR) ;
22 N RGZ
23 D GENACK^HLMA1($$PROIEN(RGEP),RGMSG,$$PROIEN(RGCL),"GM",1,.RGZ)
24 K ^TMP("HLA",$J)
25 S:$G(RGZ) RGERR=$P(RGZ,U,$L(RGZ,U))
26 Q
27 ; Build a segment from a local array and add to stream.
28 ; This code makes heavy use of naked reference to output global.
29SEG(RGTYPE,RGSEG,RGK) ;
30 N RGPC,RGPC0,RGPC1,RGPC2,RGF,RGN,RGS
31 S RGS=RGTYPE,RGF=1,RGN=+$O(^TMP($G(HL("RGSB"),"HLS"),$J,""),-1)
32 F RGPC0=1:1:$O(RGSEG($C(1)),-1) D
33 .S RGPC=RGPC0
34 .F D Q:RGPC\1'=RGPC0
35 ..D SEGA("RGSEG(RGPC)",$S(RGPC0=RGPC:1,1:3),0)
36 ..D:$D(RGSEG(RGPC))>9 SEG1
37 ..S RGPC=$O(RGSEG(RGPC))
38 D:$L(RGS) SEGX("",0,1)
39 K:$G(RGK) RGSEG
40 Q
41SEG1 F RGPC1=1:1:$O(RGSEG(RGPC,$C(1)),-1) D
42 .D SEGA("RGSEG(RGPC,RGPC1)",2,RGPC1=1)
43 .D:$D(RGSEG(RGPC,RGPC1))>9 SEG2
44 Q
45SEG2 F RGPC2=1:1:$O(RGSEG(RGPC,RGPC1,$C(1)),-1) D
46 .D SEGA("RGSEG(RGPC,RGPC1,RGPC2)",5,RGPC2=1)
47 Q
48SEGA(RGG,RGP,RGT) ;
49 D SEGX($G(@RGG),RGP,RGT)
50 F RGP=0:0 S RGP=$O(@RGG@(0,RGP)) Q:'RGP D SEGX(@RGG@(0,RGP),1,1)
51 Q
52SEGX(RGX,RGP,RGT) ;
53 S:'RGT RGX=RGD(RGP)_RGX
54 S RGT=200-$L(RGS),RGS=RGS_$E(RGX,1,RGT),RGX=$E(RGX,RGT+1,99999)
55 I $L(RGX)!'RGP D
56 .S RGN=RGN+1,^TMP($G(HL("RGSB"),"HLS"),$J,RGN)=RGS,RGS="" S:RGF RGF=0,RGN=+$O(^(RGN,0))
57 .D:RGP SEGX(RGX,1,1)
58 Q
59 ; Build brief PID segment
60PID(RGDFN) ;
61 N RGPID,RGS,RGZ,RGZ1,RGZ2
62 S RGZ=^DPT(RGDFN,0),RGZ2=$P(RGZ,U),RGZ1=$P(RGZ2,","),RGZ2=$P(RGZ2,",",2)
63 S RGPID(5,1)=RGZ1,RGPID(5,2)=$P(RGZ2," "),RGPID(5,3)=$P(RGZ2," ",2,99)
64 S RGPID(7)=$$DTFH^RGHLUT($P(RGZ,U,3))
65 S RGPID(19)=$P(RGZ,U,9)
66 S RGZ=$$GETICN^RGHLUT(RGDFN)
67 S:RGZ'<0 RGPID(2,1)=+RGZ,RGPID(2,2)=$P(RGZ,"V",2)
68 D SEG("PID",.RGPID)
69 Q
70 ; Build PV1 segment from visit IEN
71PV1(RGV,RGDFN,RGF) ;
72 N RGSEG,RGZ,RGZ1,RGZ2,RGSC
73 Q:'RGV
74 L +^AUPNVSIT(RGV):10 I '$T Q
75 I '$$FIND1^DIC(9000010,,"X","`"_RGV) D UNLCK Q
76 K RGZ
77 S RGZ(1)=+$$GET1^DIQ(9000010,RGV,.01,"I")
78 S RGZ(5)=$$GET1^DIQ(9000010,RGV,.05,"I")
79 S RGZ(6)=$$GET1^DIQ(9000010,RGV,.06,"I")
80 S RGZ(18)=$$GET1^DIQ(9000010,RGV,.18,"I")
81 S RGZ(150,2)=$$GET1^DIQ(9000010,RGV,15002,"I")
82 S RGZ(150,3)=$$GET1^DIQ(9000010,RGV,15003,"I")
83 I $G(RGDFN),RGZ(5)'=RGDFN D UNLCK Q
84 S RGZ=$$GET1^DIQ(9000010,RGV,.12,"I")
85 I RGZ,RGZ'=RGV D PV1(RGZ,.RGDFN) D UNLCK Q
86 Q:RGZ(150,3)'="P"
87 S RGSEG(50)=$$GET1^DIQ(9000010,RGV,15001,"I")
88 I $G(RGF) D SEG("PV1",.RGSEG) D UNLCK Q
89 S RGSC=+$$GET1^DIQ(9000010,RGV,.22,"I")
90 S RGSEG(2)=$S($G(RGZ(150,2)):"I",1:"O")
91 S RGSEG(3,1)=$$GET1^DIQ(44,RGSC_",",.01)
92 S RGSEG(3,4)=$$GET1^DIQ(4,RGZ(6)_",",99)
93 S RGSEG(44)=$$DTFH^RGHLUT(RGZ(1),1)
94 S RGSEG(45)=$$DTFH^RGHLUT(RGZ(18),1)
95 S RGZ2=0
96 F RGZ=0:0 S RGZ=$O(^AUPNVPRV("AD",RGV,RGZ)) Q:'RGZ D
97 .S RGZ1(1)=$$GET1^DIQ(9000010.06,RGZ,.01,"I")
98 .S RGZ1(3)=$$GET1^DIQ(9000010.06,RGZ,.03,"I")
99 .S RGZ1(4)=$$GET1^DIQ(9000010.06,RGZ,.04,"I")
100 .Q:RGZ1(3)'=RGV
101 .I RGZ1(4)="P",'$D(RGSEG(7)) S RGSEG(7)=$$PRV(+RGZ1(1))
102 .E S RGSEG(9+RGZ2)=$$PRV(+RGZ1(1)),RGZ2=RGZ2+.00001
103 D SEG("PV1",.RGSEG,1)
104 I RGSC D
105 .I $T(CODE^RGHOMAP)]"" S RGSEG(2)=$TR($$CODE^RGHOMAP(44,RGSC),U,RGD(2))
106 .D:$L(RGSEG(2)) SEG("PV2",.RGSEG)
107UNLCK L -^AUPNVSIT(RGV)
108 Q
109 ; Build ORC segment
110ORC(RGODAT,RGPRV,RGSTATUS,RGINST) ;
111 N RGORC
112 S RGORC(5)=$G(RGSTATUS)
113 S RGORC(9)=$$DTFH^RGHLUT(RGODAT,1)
114 S RGORC(12)=$$PRV(.RGPRV)
115 S:$G(RGINST) RGORC(17)=$$INST(RGINST)
116 D SEG("ORC",.RGORC)
117 Q
118 ; Build OBR segment
119OBR(RGODAT,RGSRC,RGPRV,RGNS,RGFON,RGUDAT) ;
120 N RGOBR
121 S:$G(RGFON)'="" RGOBR(3,1)=RGFON
122 S:$G(RGNS)'="" RGOBR(3,2)=RGNS
123 S:$G(RGODAT) RGOBR(7)=$$DTFH^RGHLUT(RGODAT,1)
124 S:$G(RGSRC) RGOBR(15)=$$SNM(RGSRC,61)
125 S:$G(RGPRV) RGOBR(16)=$$PRV(.RGPRV)
126 S:$G(RGUDAT) RGOBR(22)=$$DTFH^RGHLUT(RGUDAT,1)
127 D SEG("OBR",.RGOBR)
128 Q
129 ; Build OBX segment
130OBX(RGCODE,RGVAL,RGUNITS,RGSTAT,RGSEQ,RGSID,RGLO,RGHI,RGFLG) ;
131 Q:RGVAL=""
132 N RGOBX
133 S RGOBX(1)=$G(RGSEQ)
134 S RGOBX(2)=$S(RGVAL[RGD(2):"CE",RGVAL=+RGVAL:"NM",1:"ST")
135 S RGOBX(3)=$TR(RGCODE,U,RGD(2)),RGOBX(4)=$G(RGSID),RGOBX(5)=RGVAL
136 S:$G(RGUNITS)'="" RGOBX(6)=RGUNITS
137 S:$G(RGFLG)'="" RGOBX(8)=RGFLG
138 S:$G(RGSTAT)'="" RGOBX(11)=RGSTAT
139 S:$G(RGLO)'="" RGOBX(7)=RGLO
140 S:$G(RGHI)'="" $P(RGOBX(7),"-",2)=RGHI
141 D SEG("OBX",.RGOBX)
142 Q
143 ; Convert imbedded reserved characters to escape format
144ESCAPE(RGTXT) ;
145 N RGZ,RGZ1,RGX,RGC,RGA,RGRTN
146 S (RGX,RGRTN)=""
147 F RGZ=1:1:5 S RGX=RGX_RGD(RGZ)
148 F RGZ=1:1:$L(RGTXT) D
149 .S RGC=$E(RGTXT,RGZ),RGA=$A(RGC),RGZ1=$F(RGX,RGC)-1
150 .I RGZ1>0 S RGRTN=RGRTN_RGD(4)_$E("FSRET",RGZ1)_RGD(4)
151 .E I RGA>31,RGA<127 S RGRTN=RGRTN_RGC
152 .E S RGRTN=RGRTN_RGD(4)_"X"_$$BASE^RGRSUTL2(RGA,16,2)_RGD(4)
153 Q RGRTN
154 ; Get routing info for domain/institution
155LINK(RGDI,RGCL,RGF) ;
156 N RGZ,RGLL
157 D LINK^HLUTIL3(RGDI,.RGLL,.RGF)
158 S RGZ=$O(HLL("LINKS",$C(1)),-1)
159 F RGLL=0:0 S RGLL=$O(RGLL(RGLL)) Q:'RGLL S RGZ=RGZ+1,HLL("LINKS",RGZ)=RGCL_U_RGLL(RGLL)
160 Q
161 ; Get protocol IEN
162PROIEN(RGPR) ;
163 Q $S(RGPR="":0,RGPR=+RGPR:RGPR,1:$O(^ORD(101,"B",RGPR,0)))
164 ; Universal provider ID
165PRV(RGPRV) ;
166 N RGID,RGZ,USR
167 D GETS^DIQ(200,RGPRV,".01;9","I","USR")
168 I $D(USR(200,RGPRV_",",.01,"I")) D
169 .S RGZ=USR(200,RGPRV_",",.01,"I"),RGID=USR(200,RGPRV_",",9,"I")
170 .S RGID=RGID_RGD(2)_$P(RGZ,",")_RGD(2)
171 .S RGZ=$P(RGZ,",",2,99)
172 .S RGID=RGID_$P(RGZ," ")_RGD(2)_$P(RGZ," ",2)_RGD(2)_$P(RGZ," ",3,99)
173 Q $G(RGID)
174 ; SNOMED pointer --> HL7 CE format
175SNM(RGSNM,RGFN) ;
176 S RGSNM=$G(^LAB(RGFN,+RGSNM,0))
177 Q $S($P(RGSNM,U,2)="":"",1:$E("TMEFDPJ",RGFN-61*10+1)_"-"_$P(RGSNM,U,2)_RGD(2)_$P(RGSNM,U)_RGD(2)_"SNM")
178 ; Return CPT4 coded element with optional subid attached
179CPT(RGCPT,RGID) ;
180 N RGZ
181 S RGZ=$$CPT^ICPTCOD(+RGCPT)
182 Q $S(+RGZ<1:"",1:$$SFX($P(RGZ,U)_RGD(2)_$P(RGZ,U,2)_RGD(2)_"C4",.RGID))
183 ; Return institution in CE format
184INST(RGINST) ;
185 Q $S(RGINST:$$GET1^DIQ(4,+RGINST_",",99)_RGD(2)_$$GET1^DIQ(4,+RGINST_",",.01)_RGD(2)_99002,1:"")
186 ; Add a suffix to a code
187SFX(RGCODE,RGSFX) ;
188 Q $S(RGCODE="":"",$G(RGSFX)="":RGCODE,1:$P(RGCODE,RGD(2))_RGD(5)_RGSFX_RGD(2)_$P(RGCODE,RGD(2),2,99))
189 ; Format line from WP field
190WP(RGTXT) ;
191 F Q:RGTXT'["|" S RGTXT=$P(RGTXT,"|")_$P(RGTXT,"|",3,999)
192 Q $$ESCAPE(RGTXT)
Note: See TracBrowser for help on using the repository browser.