RGHOUT ;CAIRO/DKM-HL7 message generation utilities ;14-Oct-1998
;;1.0; CLINICAL INFO RESOURCE NETWORK ;;30 Apr 99
;=================================================================
; Initialize
INIT(RGEP,HL,RGD,RGERR,RGSB) ;
K HL,RGD
D INIT^HLFNC2(RGEP,.HL)
I $G(HL) S RGERR=$P(HL,U,2) Q +HL
S RGD(1)=HL("FS"),HL("RGSB")=$G(RGSB,"HLS")
F RGD=2:1:5 S RGD(RGD)=$E(HL("ECH"),RGD-1)
K ^TMP("HLS",$J)
Q 0
; Hand off completed message
SEND(RGEP,HL,RGERR) ;
N RGZ
D GENERATE^HLMA(RGEP,"GM",1,.RGZ,"",.HL)
K ^TMP("HLS",$J)
S:$P($G(RGZ),U,2) RGERR=$P(RGZ,U,3)
Q
; Send acknowledgment
ACK(RGEP,RGCL,RGMSG,RGERR) ;
N RGZ
D GENACK^HLMA1($$PROIEN(RGEP),RGMSG,$$PROIEN(RGCL),"GM",1,.RGZ)
K ^TMP("HLA",$J)
S:$G(RGZ) RGERR=$P(RGZ,U,$L(RGZ,U))
Q
; Build a segment from a local array and add to stream.
; This code makes heavy use of naked reference to output global.
SEG(RGTYPE,RGSEG,RGK) ;
N RGPC,RGPC0,RGPC1,RGPC2,RGF,RGN,RGS
S RGS=RGTYPE,RGF=1,RGN=+$O(^TMP($G(HL("RGSB"),"HLS"),$J,""),-1)
F RGPC0=1:1:$O(RGSEG($C(1)),-1) D
.S RGPC=RGPC0
.F D Q:RGPC\1'=RGPC0
..D SEGA("RGSEG(RGPC)",$S(RGPC0=RGPC:1,1:3),0)
..D:$D(RGSEG(RGPC))>9 SEG1
..S RGPC=$O(RGSEG(RGPC))
D:$L(RGS) SEGX("",0,1)
K:$G(RGK) RGSEG
Q
SEG1 F RGPC1=1:1:$O(RGSEG(RGPC,$C(1)),-1) D
.D SEGA("RGSEG(RGPC,RGPC1)",2,RGPC1=1)
.D:$D(RGSEG(RGPC,RGPC1))>9 SEG2
Q
SEG2 F RGPC2=1:1:$O(RGSEG(RGPC,RGPC1,$C(1)),-1) D
.D SEGA("RGSEG(RGPC,RGPC1,RGPC2)",5,RGPC2=1)
Q
SEGA(RGG,RGP,RGT) ;
D SEGX($G(@RGG),RGP,RGT)
F RGP=0:0 S RGP=$O(@RGG@(0,RGP)) Q:'RGP D SEGX(@RGG@(0,RGP),1,1)
Q
SEGX(RGX,RGP,RGT) ;
S:'RGT RGX=RGD(RGP)_RGX
S RGT=200-$L(RGS),RGS=RGS_$E(RGX,1,RGT),RGX=$E(RGX,RGT+1,99999)
I $L(RGX)!'RGP D
.S RGN=RGN+1,^TMP($G(HL("RGSB"),"HLS"),$J,RGN)=RGS,RGS="" S:RGF RGF=0,RGN=+$O(^(RGN,0))
.D:RGP SEGX(RGX,1,1)
Q
; Build brief PID segment
PID(RGDFN) ;
N RGPID,RGS,RGZ,RGZ1,RGZ2
S RGZ=^DPT(RGDFN,0),RGZ2=$P(RGZ,U),RGZ1=$P(RGZ2,","),RGZ2=$P(RGZ2,",",2)
S RGPID(5,1)=RGZ1,RGPID(5,2)=$P(RGZ2," "),RGPID(5,3)=$P(RGZ2," ",2,99)
S RGPID(7)=$$DTFH^RGHLUT($P(RGZ,U,3))
S RGPID(19)=$P(RGZ,U,9)
S RGZ=$$GETICN^RGHLUT(RGDFN)
S:RGZ'<0 RGPID(2,1)=+RGZ,RGPID(2,2)=$P(RGZ,"V",2)
D SEG("PID",.RGPID)
Q
; Build PV1 segment from visit IEN
PV1(RGV,RGDFN,RGF) ;
N RGSEG,RGZ,RGZ1,RGZ2,RGSC
Q:'RGV
L +^AUPNVSIT(RGV):10 I '$T Q
I '$$FIND1^DIC(9000010,,"X","`"_RGV) D UNLCK Q
K RGZ
S RGZ(1)=+$$GET1^DIQ(9000010,RGV,.01,"I")
S RGZ(5)=$$GET1^DIQ(9000010,RGV,.05,"I")
S RGZ(6)=$$GET1^DIQ(9000010,RGV,.06,"I")
S RGZ(18)=$$GET1^DIQ(9000010,RGV,.18,"I")
S RGZ(150,2)=$$GET1^DIQ(9000010,RGV,15002,"I")
S RGZ(150,3)=$$GET1^DIQ(9000010,RGV,15003,"I")
I $G(RGDFN),RGZ(5)'=RGDFN D UNLCK Q
S RGZ=$$GET1^DIQ(9000010,RGV,.12,"I")
I RGZ,RGZ'=RGV D PV1(RGZ,.RGDFN) D UNLCK Q
Q:RGZ(150,3)'="P"
S RGSEG(50)=$$GET1^DIQ(9000010,RGV,15001,"I")
I $G(RGF) D SEG("PV1",.RGSEG) D UNLCK Q
S RGSC=+$$GET1^DIQ(9000010,RGV,.22,"I")
S RGSEG(2)=$S($G(RGZ(150,2)):"I",1:"O")
S RGSEG(3,1)=$$GET1^DIQ(44,RGSC_",",.01)
S RGSEG(3,4)=$$GET1^DIQ(4,RGZ(6)_",",99)
S RGSEG(44)=$$DTFH^RGHLUT(RGZ(1),1)
S RGSEG(45)=$$DTFH^RGHLUT(RGZ(18),1)
S RGZ2=0
F RGZ=0:0 S RGZ=$O(^AUPNVPRV("AD",RGV,RGZ)) Q:'RGZ D
.S RGZ1(1)=$$GET1^DIQ(9000010.06,RGZ,.01,"I")
.S RGZ1(3)=$$GET1^DIQ(9000010.06,RGZ,.03,"I")
.S RGZ1(4)=$$GET1^DIQ(9000010.06,RGZ,.04,"I")
.Q:RGZ1(3)'=RGV
.I RGZ1(4)="P",'$D(RGSEG(7)) S RGSEG(7)=$$PRV(+RGZ1(1))
.E S RGSEG(9+RGZ2)=$$PRV(+RGZ1(1)),RGZ2=RGZ2+.00001
D SEG("PV1",.RGSEG,1)
I RGSC D
.I $T(CODE^RGHOMAP)]"" S RGSEG(2)=$TR($$CODE^RGHOMAP(44,RGSC),U,RGD(2))
.D:$L(RGSEG(2)) SEG("PV2",.RGSEG)
UNLCK L -^AUPNVSIT(RGV)
Q
; Build ORC segment
ORC(RGODAT,RGPRV,RGSTATUS,RGINST) ;
N RGORC
S RGORC(5)=$G(RGSTATUS)
S RGORC(9)=$$DTFH^RGHLUT(RGODAT,1)
S RGORC(12)=$$PRV(.RGPRV)
S:$G(RGINST) RGORC(17)=$$INST(RGINST)
D SEG("ORC",.RGORC)
Q
; Build OBR segment
OBR(RGODAT,RGSRC,RGPRV,RGNS,RGFON,RGUDAT) ;
N RGOBR
S:$G(RGFON)'="" RGOBR(3,1)=RGFON
S:$G(RGNS)'="" RGOBR(3,2)=RGNS
S:$G(RGODAT) RGOBR(7)=$$DTFH^RGHLUT(RGODAT,1)
S:$G(RGSRC) RGOBR(15)=$$SNM(RGSRC,61)
S:$G(RGPRV) RGOBR(16)=$$PRV(.RGPRV)
S:$G(RGUDAT) RGOBR(22)=$$DTFH^RGHLUT(RGUDAT,1)
D SEG("OBR",.RGOBR)
Q
; Build OBX segment
OBX(RGCODE,RGVAL,RGUNITS,RGSTAT,RGSEQ,RGSID,RGLO,RGHI,RGFLG) ;
Q:RGVAL=""
N RGOBX
S RGOBX(1)=$G(RGSEQ)
S RGOBX(2)=$S(RGVAL[RGD(2):"CE",RGVAL=+RGVAL:"NM",1:"ST")
S RGOBX(3)=$TR(RGCODE,U,RGD(2)),RGOBX(4)=$G(RGSID),RGOBX(5)=RGVAL
S:$G(RGUNITS)'="" RGOBX(6)=RGUNITS
S:$G(RGFLG)'="" RGOBX(8)=RGFLG
S:$G(RGSTAT)'="" RGOBX(11)=RGSTAT
S:$G(RGLO)'="" RGOBX(7)=RGLO
S:$G(RGHI)'="" $P(RGOBX(7),"-",2)=RGHI
D SEG("OBX",.RGOBX)
Q
; Convert imbedded reserved characters to escape format
ESCAPE(RGTXT) ;
N RGZ,RGZ1,RGX,RGC,RGA,RGRTN
S (RGX,RGRTN)=""
F RGZ=1:1:5 S RGX=RGX_RGD(RGZ)
F RGZ=1:1:$L(RGTXT) D
.S RGC=$E(RGTXT,RGZ),RGA=$A(RGC),RGZ1=$F(RGX,RGC)-1
.I RGZ1>0 S RGRTN=RGRTN_RGD(4)_$E("FSRET",RGZ1)_RGD(4)
.E I RGA>31,RGA<127 S RGRTN=RGRTN_RGC
.E S RGRTN=RGRTN_RGD(4)_"X"_$$BASE^RGRSUTL2(RGA,16,2)_RGD(4)
Q RGRTN
; Get routing info for domain/institution
LINK(RGDI,RGCL,RGF) ;
N RGZ,RGLL
D LINK^HLUTIL3(RGDI,.RGLL,.RGF)
S RGZ=$O(HLL("LINKS",$C(1)),-1)
F RGLL=0:0 S RGLL=$O(RGLL(RGLL)) Q:'RGLL S RGZ=RGZ+1,HLL("LINKS",RGZ)=RGCL_U_RGLL(RGLL)
Q
; Get protocol IEN
PROIEN(RGPR) ;
Q $S(RGPR="":0,RGPR=+RGPR:RGPR,1:$O(^ORD(101,"B",RGPR,0)))
; Universal provider ID
PRV(RGPRV) ;
N RGID,RGZ,USR
D GETS^DIQ(200,RGPRV,".01;9","I","USR")
I $D(USR(200,RGPRV_",",.01,"I")) D
.S RGZ=USR(200,RGPRV_",",.01,"I"),RGID=USR(200,RGPRV_",",9,"I")
.S RGID=RGID_RGD(2)_$P(RGZ,",")_RGD(2)
.S RGZ=$P(RGZ,",",2,99)
.S RGID=RGID_$P(RGZ," ")_RGD(2)_$P(RGZ," ",2)_RGD(2)_$P(RGZ," ",3,99)
Q $G(RGID)
; SNOMED pointer --> HL7 CE format
SNM(RGSNM,RGFN) ;
S RGSNM=$G(^LAB(RGFN,+RGSNM,0))
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")
; Return CPT4 coded element with optional subid attached
CPT(RGCPT,RGID) ;
N RGZ
S RGZ=$$CPT^ICPTCOD(+RGCPT)
Q $S(+RGZ<1:"",1:$$SFX($P(RGZ,U)_RGD(2)_$P(RGZ,U,2)_RGD(2)_"C4",.RGID))
; Return institution in CE format
INST(RGINST) ;
Q $S(RGINST:$$GET1^DIQ(4,+RGINST_",",99)_RGD(2)_$$GET1^DIQ(4,+RGINST_",",.01)_RGD(2)_99002,1:"")
; Add a suffix to a code
SFX(RGCODE,RGSFX) ;
Q $S(RGCODE="":"",$G(RGSFX)="":RGCODE,1:$P(RGCODE,RGD(2))_RGD(5)_RGSFX_RGD(2)_$P(RGCODE,RGD(2),2,99))
; Format line from WP field
WP(RGTXT) ;
F Q:RGTXT'["|" S RGTXT=$P(RGTXT,"|")_$P(RGTXT,"|",3,999)
Q $$ESCAPE(RGTXT)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRGHOUT 6655 printed Apr 09, 2024@20:46:48 Page 2
RGHOUT ;CAIRO/DKM-HL7 message generation utilities ;14-Oct-1998
+1 ;;1.0; CLINICAL INFO RESOURCE NETWORK ;;30 Apr 99
+2 ;=================================================================
+3 ; Initialize
INIT(RGEP,HL,RGD,RGERR,RGSB) ;
+1 KILL HL,RGD
+2 DO INIT^HLFNC2(RGEP,.HL)
+3 IF $GET(HL)
SET RGERR=$PIECE(HL,U,2)
QUIT +HL
+4 SET RGD(1)=HL("FS")
SET HL("RGSB")=$GET(RGSB,"HLS")
+5 FOR RGD=2:1:5
SET RGD(RGD)=$EXTRACT(HL("ECH"),RGD-1)
+6 KILL ^TMP("HLS",$JOB)
+7 QUIT 0
+8 ; Hand off completed message
SEND(RGEP,HL,RGERR) ;
+1 NEW RGZ
+2 DO GENERATE^HLMA(RGEP,"GM",1,.RGZ,"",.HL)
+3 KILL ^TMP("HLS",$JOB)
+4 if $PIECE($GET(RGZ),U,2)
SET RGERR=$PIECE(RGZ,U,3)
+5 QUIT
+6 ; Send acknowledgment
ACK(RGEP,RGCL,RGMSG,RGERR) ;
+1 NEW RGZ
+2 DO GENACK^HLMA1($$PROIEN(RGEP),RGMSG,$$PROIEN(RGCL),"GM",1,.RGZ)
+3 KILL ^TMP("HLA",$JOB)
+4 if $GET(RGZ)
SET RGERR=$PIECE(RGZ,U,$LENGTH(RGZ,U))
+5 QUIT
+6 ; Build a segment from a local array and add to stream.
+7 ; This code makes heavy use of naked reference to output global.
SEG(RGTYPE,RGSEG,RGK) ;
+1 NEW RGPC,RGPC0,RGPC1,RGPC2,RGF,RGN,RGS
+2 SET RGS=RGTYPE
SET RGF=1
SET RGN=+$ORDER(^TMP($GET(HL("RGSB"),"HLS"),$JOB,""),-1)
+3 FOR RGPC0=1:1:$ORDER(RGSEG($CHAR(1)),-1)
Begin DoDot:1
+4 SET RGPC=RGPC0
+5 FOR
Begin DoDot:2
+6 DO SEGA("RGSEG(RGPC)",$SELECT(RGPC0=RGPC:1,1:3),0)
+7 if $DATA(RGSEG(RGPC))>9
DO SEG1
+8 SET RGPC=$ORDER(RGSEG(RGPC))
End DoDot:2
if RGPC\1'=RGPC0
QUIT
End DoDot:1
+9 if $LENGTH(RGS)
DO SEGX("",0,1)
+10 if $GET(RGK)
KILL RGSEG
+11 QUIT
SEG1 FOR RGPC1=1:1:$ORDER(RGSEG(RGPC,$CHAR(1)),-1)
Begin DoDot:1
+1 DO SEGA("RGSEG(RGPC,RGPC1)",2,RGPC1=1)
+2 if $DATA(RGSEG(RGPC,RGPC1))>9
DO SEG2
End DoDot:1
+3 QUIT
SEG2 FOR RGPC2=1:1:$ORDER(RGSEG(RGPC,RGPC1,$CHAR(1)),-1)
Begin DoDot:1
+1 DO SEGA("RGSEG(RGPC,RGPC1,RGPC2)",5,RGPC2=1)
End DoDot:1
+2 QUIT
SEGA(RGG,RGP,RGT) ;
+1 DO SEGX($GET(@RGG),RGP,RGT)
+2 FOR RGP=0:0
SET RGP=$ORDER(@RGG@(0,RGP))
if 'RGP
QUIT
DO SEGX(@RGG@(0,RGP),1,1)
+3 QUIT
SEGX(RGX,RGP,RGT) ;
+1 if 'RGT
SET RGX=RGD(RGP)_RGX
+2 SET RGT=200-$LENGTH(RGS)
SET RGS=RGS_$EXTRACT(RGX,1,RGT)
SET RGX=$EXTRACT(RGX,RGT+1,99999)
+3 IF $LENGTH(RGX)!'RGP
Begin DoDot:1
+4 SET RGN=RGN+1
SET ^TMP($GET(HL("RGSB"),"HLS"),$JOB,RGN)=RGS
SET RGS=""
if RGF
SET RGF=0
SET RGN=+$ORDER(^(RGN,0))
+5 if RGP
DO SEGX(RGX,1,1)
End DoDot:1
+6 QUIT
+7 ; Build brief PID segment
PID(RGDFN) ;
+1 NEW RGPID,RGS,RGZ,RGZ1,RGZ2
+2 SET RGZ=^DPT(RGDFN,0)
SET RGZ2=$PIECE(RGZ,U)
SET RGZ1=$PIECE(RGZ2,",")
SET RGZ2=$PIECE(RGZ2,",",2)
+3 SET RGPID(5,1)=RGZ1
SET RGPID(5,2)=$PIECE(RGZ2," ")
SET RGPID(5,3)=$PIECE(RGZ2," ",2,99)
+4 SET RGPID(7)=$$DTFH^RGHLUT($PIECE(RGZ,U,3))
+5 SET RGPID(19)=$PIECE(RGZ,U,9)
+6 SET RGZ=$$GETICN^RGHLUT(RGDFN)
+7 if RGZ'<0
SET RGPID(2,1)=+RGZ
SET RGPID(2,2)=$PIECE(RGZ,"V",2)
+8 DO SEG("PID",.RGPID)
+9 QUIT
+10 ; Build PV1 segment from visit IEN
PV1(RGV,RGDFN,RGF) ;
+1 NEW RGSEG,RGZ,RGZ1,RGZ2,RGSC
+2 if 'RGV
QUIT
+3 LOCK +^AUPNVSIT(RGV):10
IF '$TEST
QUIT
+4 IF '$$FIND1^DIC(9000010,,"X","`"_RGV)
DO UNLCK
QUIT
+5 KILL RGZ
+6 SET RGZ(1)=+$$GET1^DIQ(9000010,RGV,.01,"I")
+7 SET RGZ(5)=$$GET1^DIQ(9000010,RGV,.05,"I")
+8 SET RGZ(6)=$$GET1^DIQ(9000010,RGV,.06,"I")
+9 SET RGZ(18)=$$GET1^DIQ(9000010,RGV,.18,"I")
+10 SET RGZ(150,2)=$$GET1^DIQ(9000010,RGV,15002,"I")
+11 SET RGZ(150,3)=$$GET1^DIQ(9000010,RGV,15003,"I")
+12 IF $GET(RGDFN)
IF RGZ(5)'=RGDFN
DO UNLCK
QUIT
+13 SET RGZ=$$GET1^DIQ(9000010,RGV,.12,"I")
+14 IF RGZ
IF RGZ'=RGV
DO PV1(RGZ,.RGDFN)
DO UNLCK
QUIT
+15 if RGZ(150,3)'="P"
QUIT
+16 SET RGSEG(50)=$$GET1^DIQ(9000010,RGV,15001,"I")
+17 IF $GET(RGF)
DO SEG("PV1",.RGSEG)
DO UNLCK
QUIT
+18 SET RGSC=+$$GET1^DIQ(9000010,RGV,.22,"I")
+19 SET RGSEG(2)=$SELECT($GET(RGZ(150,2)):"I",1:"O")
+20 SET RGSEG(3,1)=$$GET1^DIQ(44,RGSC_",",.01)
+21 SET RGSEG(3,4)=$$GET1^DIQ(4,RGZ(6)_",",99)
+22 SET RGSEG(44)=$$DTFH^RGHLUT(RGZ(1),1)
+23 SET RGSEG(45)=$$DTFH^RGHLUT(RGZ(18),1)
+24 SET RGZ2=0
+25 FOR RGZ=0:0
SET RGZ=$ORDER(^AUPNVPRV("AD",RGV,RGZ))
if 'RGZ
QUIT
Begin DoDot:1
+26 SET RGZ1(1)=$$GET1^DIQ(9000010.06,RGZ,.01,"I")
+27 SET RGZ1(3)=$$GET1^DIQ(9000010.06,RGZ,.03,"I")
+28 SET RGZ1(4)=$$GET1^DIQ(9000010.06,RGZ,.04,"I")
+29 if RGZ1(3)'=RGV
QUIT
+30 IF RGZ1(4)="P"
IF '$DATA(RGSEG(7))
SET RGSEG(7)=$$PRV(+RGZ1(1))
+31 IF '$TEST
SET RGSEG(9+RGZ2)=$$PRV(+RGZ1(1))
SET RGZ2=RGZ2+.00001
End DoDot:1
+32 DO SEG("PV1",.RGSEG,1)
+33 IF RGSC
Begin DoDot:1
+34 IF $TEXT(CODE^RGHOMAP)]""
SET RGSEG(2)=$TRANSLATE($$CODE^RGHOMAP(44,RGSC),U,RGD(2))
+35 if $LENGTH(RGSEG(2))
DO SEG("PV2",.RGSEG)
End DoDot:1
UNLCK LOCK -^AUPNVSIT(RGV)
+1 QUIT
+2 ; Build ORC segment
ORC(RGODAT,RGPRV,RGSTATUS,RGINST) ;
+1 NEW RGORC
+2 SET RGORC(5)=$GET(RGSTATUS)
+3 SET RGORC(9)=$$DTFH^RGHLUT(RGODAT,1)
+4 SET RGORC(12)=$$PRV(.RGPRV)
+5 if $GET(RGINST)
SET RGORC(17)=$$INST(RGINST)
+6 DO SEG("ORC",.RGORC)
+7 QUIT
+8 ; Build OBR segment
OBR(RGODAT,RGSRC,RGPRV,RGNS,RGFON,RGUDAT) ;
+1 NEW RGOBR
+2 if $GET(RGFON)'=""
SET RGOBR(3,1)=RGFON
+3 if $GET(RGNS)'=""
SET RGOBR(3,2)=RGNS
+4 if $GET(RGODAT)
SET RGOBR(7)=$$DTFH^RGHLUT(RGODAT,1)
+5 if $GET(RGSRC)
SET RGOBR(15)=$$SNM(RGSRC,61)
+6 if $GET(RGPRV)
SET RGOBR(16)=$$PRV(.RGPRV)
+7 if $GET(RGUDAT)
SET RGOBR(22)=$$DTFH^RGHLUT(RGUDAT,1)
+8 DO SEG("OBR",.RGOBR)
+9 QUIT
+10 ; Build OBX segment
OBX(RGCODE,RGVAL,RGUNITS,RGSTAT,RGSEQ,RGSID,RGLO,RGHI,RGFLG) ;
+1 if RGVAL=""
QUIT
+2 NEW RGOBX
+3 SET RGOBX(1)=$GET(RGSEQ)
+4 SET RGOBX(2)=$SELECT(RGVAL[RGD(2):"CE",RGVAL=+RGVAL:"NM",1:"ST")
+5 SET RGOBX(3)=$TRANSLATE(RGCODE,U,RGD(2))
SET RGOBX(4)=$GET(RGSID)
SET RGOBX(5)=RGVAL
+6 if $GET(RGUNITS)'=""
SET RGOBX(6)=RGUNITS
+7 if $GET(RGFLG)'=""
SET RGOBX(8)=RGFLG
+8 if $GET(RGSTAT)'=""
SET RGOBX(11)=RGSTAT
+9 if $GET(RGLO)'=""
SET RGOBX(7)=RGLO
+10 if $GET(RGHI)'=""
SET $PIECE(RGOBX(7),"-",2)=RGHI
+11 DO SEG("OBX",.RGOBX)
+12 QUIT
+13 ; Convert imbedded reserved characters to escape format
ESCAPE(RGTXT) ;
+1 NEW RGZ,RGZ1,RGX,RGC,RGA,RGRTN
+2 SET (RGX,RGRTN)=""
+3 FOR RGZ=1:1:5
SET RGX=RGX_RGD(RGZ)
+4 FOR RGZ=1:1:$LENGTH(RGTXT)
Begin DoDot:1
+5 SET RGC=$EXTRACT(RGTXT,RGZ)
SET RGA=$ASCII(RGC)
SET RGZ1=$FIND(RGX,RGC)-1
+6 IF RGZ1>0
SET RGRTN=RGRTN_RGD(4)_$EXTRACT("FSRET",RGZ1)_RGD(4)
+7 IF '$TEST
IF RGA>31
IF RGA<127
SET RGRTN=RGRTN_RGC
+8 IF '$TEST
SET RGRTN=RGRTN_RGD(4)_"X"_$$BASE^RGRSUTL2(RGA,16,2)_RGD(4)
End DoDot:1
+9 QUIT RGRTN
+10 ; Get routing info for domain/institution
LINK(RGDI,RGCL,RGF) ;
+1 NEW RGZ,RGLL
+2 DO LINK^HLUTIL3(RGDI,.RGLL,.RGF)
+3 SET RGZ=$ORDER(HLL("LINKS",$CHAR(1)),-1)
+4 FOR RGLL=0:0
SET RGLL=$ORDER(RGLL(RGLL))
if 'RGLL
QUIT
SET RGZ=RGZ+1
SET HLL("LINKS",RGZ)=RGCL_U_RGLL(RGLL)
+5 QUIT
+6 ; Get protocol IEN
PROIEN(RGPR) ;
+1 QUIT $SELECT(RGPR="":0,RGPR=+RGPR:RGPR,1:$ORDER(^ORD(101,"B",RGPR,0)))
+2 ; Universal provider ID
PRV(RGPRV) ;
+1 NEW RGID,RGZ,USR
+2 DO GETS^DIQ(200,RGPRV,".01;9","I","USR")
+3 IF $DATA(USR(200,RGPRV_",",.01,"I"))
Begin DoDot:1
+4 SET RGZ=USR(200,RGPRV_",",.01,"I")
SET RGID=USR(200,RGPRV_",",9,"I")
+5 SET RGID=RGID_RGD(2)_$PIECE(RGZ,",")_RGD(2)
+6 SET RGZ=$PIECE(RGZ,",",2,99)
+7 SET RGID=RGID_$PIECE(RGZ," ")_RGD(2)_$PIECE(RGZ," ",2)_RGD(2)_$PIECE(RGZ," ",3,99)
End DoDot:1
+8 QUIT $GET(RGID)
+9 ; SNOMED pointer --> HL7 CE format
SNM(RGSNM,RGFN) ;
+1 SET RGSNM=$GET(^LAB(RGFN,+RGSNM,0))
+2 QUIT $SELECT($PIECE(RGSNM,U,2)="":"",1:$EXTRACT("TMEFDPJ",RGFN-61*10+1)_"-"_$PIECE(RGSNM,U,2)_RGD(2)_$PIECE(RGSNM,U)_RGD(2)_"SNM")
+3 ; Return CPT4 coded element with optional subid attached
CPT(RGCPT,RGID) ;
+1 NEW RGZ
+2 SET RGZ=$$CPT^ICPTCOD(+RGCPT)
+3 QUIT $SELECT(+RGZ<1:"",1:$$SFX($PIECE(RGZ,U)_RGD(2)_$PIECE(RGZ,U,2)_RGD(2)_"C4",.RGID))
+4 ; Return institution in CE format
INST(RGINST) ;
+1 QUIT $SELECT(RGINST:$$GET1^DIQ(4,+RGINST_",",99)_RGD(2)_$$GET1^DIQ(4,+RGINST_",",.01)_RGD(2)_99002,1:"")
+2 ; Add a suffix to a code
SFX(RGCODE,RGSFX) ;
+1 QUIT $SELECT(RGCODE="":"",$GET(RGSFX)="":RGCODE,1:$PIECE(RGCODE,RGD(2))_RGD(5)_RGSFX_RGD(2)_$PIECE(RGCODE,RGD(2),2,99))
+2 ; Format line from WP field
WP(RGTXT) ;
+1 FOR
if RGTXT'["|"
QUIT
SET RGTXT=$PIECE(RGTXT,"|")_$PIECE(RGTXT,"|",3,999)
+2 QUIT $$ESCAPE(RGTXT)
