- 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 Feb 18, 2025@23:08:22 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)