RAO7RON1 ;HISC/GJC,FPT-Request message from OE/RR. (frontdoor) ;19 Jun 2019 1:36 PM
;;5.0;Radiology/Nuclear Medicine;**69,75,98,129,158**;Mar 16, 1998;Build 2
;
;------------------------- Variable List -------------------------------
; RADATA=HL7 data minus seg. hdr RAHDR=Segment header
; RAHLFS="|" RAMSG=HL7 message passed in
; RAOBR12=danger code RAOBR18=modifier
; RAOBR19=Img. Loc. pntr (79.1) RAOBR30=trans. mode
; RAOBR31=Reason for Study RAOBX2=format of observ. value
; RAOBR4=univ. trans. mode RAOBX5=observ. value
; RAOBX3=observ. ID RAORC10=entered by (200
; RAORC1=order control RAORC15=order effective D/T
; RAORC12=ordering provider (200) RAORC2=placer order #_"^OR"
; RAORC16=order control reason RAORC7=start dt/freq. of service
; RAORC3=filler order #_"^RA" RAPID5=patient name (2)
; RAPID3=patient ID RAPV12=patient class
; RAPV119=visit # RASEG=message seg. including header
; RAPV13=patient location (44)
; ----------------------------------------------------------------------
;
OBR ; breakdown the 'OBR' segment
S RAOBR4=$P(RADATA,RAHLFS,4)
F I=1:1:$L(RAOBR4,RAECH(1)) S RAOBR4(I)=$P(RAOBR4,RAECH(1),I)
I RAOBR4(1)'="" S RACPTIEN=+$O(^ICPT("B",RAOBR4(1),0)) S:'RACPTIEN RAERR=8 Q:RAERR ;RA*5*69
S RAERR=$$EN2^RAO7VLD(71,+RAOBR4(4),RAOBR4(5)) S:RAERR RAERR=8 Q:RAERR
I $$UP^XLFSTR($P($G(^RAMIS(71,+RAOBR4(4),0)),"^",6))="P" D Q:RAERR
. S RAERR=$$EN6^RAO7VLD(+RAOBR4(4)) S:RAERR RAERR=32
. Q
I RAOBR4(1)'="" S:'$D(^RAMIS(71,"D",RACPTIEN,+RAOBR4(4))) RAERR=8 Q:RAERR ;RA*5*69
S RAOBR4(4,"I-TYPE")=+$P($G(^RAMIS(71,+RAOBR4(4),0)),"^",12)
S RANEW(75.1,"+1,",2)=RAOBR4(4)
S RAIT=$P(^RAMIS(71,+RAOBR4(4),0),U,12)
S RAERR=$$EN3^RAO7VLD(79.2,RAIT) Q:RAERR
S RANEW(75.1,"+1,",3)=RAIT
S RAOBR12=$P(RADATA,RAHLFS,12)
S RAOBR12=$S($E(RAOBR12)="":"n","yYiI"[$E(RAOBR12):"y",1:"n")
S RAERR=$$EN1^RAO7VLD(75.1,24,"E",RAOBR12,"RASULT","") S:RAERR RAERR=10 Q:RAERR
S RANEW(75.1,"+1,",24)=RAOBR12
S RAOBR18=$P(RADATA,RAHLFS,18)
N RAIMAG ;RASERIES removed w/RA5P158 by GJC
F I=1:1:$L(RAOBR18,RAECH(2)) S:$L($P(RAOBR18,RAECH(2),I))>0 RAOBR18(I)=$P(RAOBR18,RAECH(2),I)
S I=0 F S I=$O(RAOBR18(I)) Q:I'>0 D Q:RAERR
. S RAMODIEN=+$O(^RAMIS(71.2,"B",RAOBR18(I),0))
. S:'RAMODIEN RAERR=11 Q:RAERR
. S RAIMAG=$P($G(^RAMIS(71,+RAOBR4(4),0)),U,12) ; type of imaging
. S:'$D(^RAMIS(71.2,"AB",RAIMAG,RAMODIEN)) RAERR=33 Q:RAERR
. ;S RASERIES=$S($P($G(^RAMIS(71,+RAOBR4(4),0)),"^",6)="S":1,1:0) RA5P158 by GJC
. ;S:RASERIES&($P($G(^RAMIS(71.2,RAMODIEN,0)),U,2)]"") RAERR=34 Q:RAERR RA5P158 by GJC
. S RAPLCHLD=RAPLCHLD+1
. S RANEW(75.1125,"+"_RAPLCHLD_",+1,",.01)=RAMODIEN
. Q
S RAOBR19=$P(RADATA,RAHLFS,19),RAOBR19(1)=$P(RAOBR19,U,1)
S RAOBR19(2)=$P(RAOBR19,U,2),RAOBR19(3)=+RAOBR19(1)
I RAOBR19(3) D Q:RAERR
. S RAOBR19(3,"I-TYPE")=+$P($G(^RA(79.1,+RAOBR19(3),0)),"^",6)
. I RAOBR4(4,"I-TYPE")'=RAOBR19(3,"I-TYPE") S RAERR=31
. Q
S RANEW(75.1,"+1,",20)=$S(RAOBR19(3)>0:RAOBR19(3),1:"")
S X=$P(RADATA,RAHLFS,30)
S RAOBR30=$S(X="CART":"s",X="PORT":"p",X="WALK":"a",X="WHLC":"w",1:"")
I RAOBR30']"" S RAERR=13
S:'RAERR RAERR=$$EN1^RAO7VLD(75.1,19,"E",RAOBR30,"RASULT","")
S:RAERR RAERR=13 Q:RAERR
S RANEW(75.1,"+1,",19)=RAOBR30
;--- Reason for Study P75 ---
;CPRS will not pass 'Reason for Study' data until OR*3.0*243
;(GUI CPRS V27) is released. Define a default Reason for Study
I '$$PATCH^XPDUTL("OR*3.0*243") S RAOBR31="See Clinical History:"
E D Q:RAERR ;CPRS V27 is installed
.S RAOBR31=$P($P(RADATA,RAHLFS,31),RAECH(1),2)
.S:RAOBR31="" RAERR=38 Q:RAERR
.S RAERR=$$EN1^RAO7VLD(75.1,1.1,"E",RAOBR31,"RASULT","")
.S:RAERR RAERR=39
.Q
D CCS(.RAOBR31) ;P129 - strip CCs
S:'RAERR RANEW(75.1,"+1,",1.1)=RAOBR31
K RAOBR31
Q
OBX ; breakdown the 'OBX' segment
S RAOBX2=$P(RADATA,RAHLFS,2)
S RAERR=$S(RAOBX2="TX":0,RAOBX2="CE":0,RAOBX2="TS":0,1:1) Q:RAERR=17
S RAOBX3=$P(RADATA,RAHLFS,3)
S RAOBX5=$P(RADATA,RAHLFS,5)
F I=1:1:$L(RAOBX3,RAECH(1)) S RAOBX3(I)=$P(RAOBX3,RAECH(1),I)
S X=RAOBX3(2) D UPPER^RAUTL4 S RAOBX3(2)=Y
;
;P75 check to see if CLINICAL HISTORY data is passed. If data is passed, and not yet
;determined if valid continue to check for validity until:
;1-valid data is found
;2-no data left to validate
I RAOBX3(1)=2000.02 D
.;check if a null value is sent for CLINICAL HISTORY which is
.;possible if the CPRS user does not enter a CLINICAL HISTORY
.I RAOBX5="",$P(RACLIN,U)'=1 Q
.;now if data was sent (RAOBX5'="") set the data received from CPRS flag
.S $P(RACLIN,U)=1
.;now that we know the CPRS user intended to send CLINICAL HISTORY data
.;radiology has to validate the format of that data. $$EN4^RAO7VLD(str)
.;returns 1 if the data passed in was valid, else 0. Once we establish
.;that valid data has been sent, all subsequent data is accepted, valid
.;or not.
.S:$$EN4^RAO7VLD(RAOBX5) $P(RACLIN,U,2)=1
.;now, if the current character string or any other character string
.;of data representing the CLINICAL HISTORY has been accepted as valid
.;($P(RACLIN,U,2)=1) save the character string
.I $P(RACLIN,U,2)=1 D
..S RAWP=RAWP+1 D CCS(.RAOBX5) ;P129
..S ^TMP("RAWP",$J,RAWP)=RAOBX5
..Q
;
I RAOBX3(1)=2000.33 D Q:RAERR
.S RAERR=$$EN1^RAO7VLD(75.1,13,"E",RAOBX5,"RASULT","") S:RAERR RAERR=14 Q:RAERR
.S RAPREG=$E(RAOBX5),RAPREG=$S(RAPREG="N"!(RAPREG="n"):"n",RAPREG="Y"!(RAPREG="y"):"y",1:"u")
.S RANEW(75.1,"+1,",13)=RAPREG
I RAOBX3(1)=34!(RAOBX2="CE") D Q:RAERR
.S RAERR=$$EN2^RAO7VLD(34,$P(RAOBX5,RAECH(1)),$P(RAOBX5,RAECH(1),2)) Q:RAERR
.S RANEW(75.1,"+1,",9)=+RAOBX5
I RAOBX3(2)["RESEARCH" D S:RAERR RAERR=18 Q:RAERR
.S RAERR=$$EN1^RAO7VLD(75.1,9.5,"E",RAOBX5,"RASULT","") S:RAERR RAERR=19 Q:RAERR
.S RANEW(75.1,"+1,",9.5)=RAOBX5
I RAOBX3(2)["PRE-OP" D Q:RAERR
.S RAOBX5=$$FMDATE^HLFNC(RAOBX5)
.S RAERR=$$EN1^RAO7VLD(75.1,12,"E",RAOBX5,"RASULT","") S:RAERR RAERR=20 Q:RAERR
.S RANEW(75.1,"+1,",12)=RAOBX5
I $D(RANEW(75.1,"+1,",9))&($D(RANEW(75.1,"+1,",9.5))) S RAERR=29
Q
;
CCS(RAX) ;does a string have unprintable
; control characters? If 'yes' strip them out.
;
;'RAX' the string checked for CCs (by reference)
;
I RAX?.e1.c.e D Q
.D SCC ;'RAX' is changed!
.Q
Q
;
SCC ;strip out unprintable CCs.
;
;'RAX' the string w/unprintable CCs
;'RAE' is each character of 'RAX'
K RAE,RAI S RAXX=""
F RAI=1:1:$L(RAX) D
.S RAE=$E(RAX,RAI)
.S:RAE'?1C RAXX=RAXX_RAE K RAE
.Q
S RAX=RAXX
K RAI,RAXX
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAO7RON1 6651 printed Dec 13, 2024@02:37:55 Page 2
RAO7RON1 ;HISC/GJC,FPT-Request message from OE/RR. (frontdoor) ;19 Jun 2019 1:36 PM
+1 ;;5.0;Radiology/Nuclear Medicine;**69,75,98,129,158**;Mar 16, 1998;Build 2
+2 ;
+3 ;------------------------- Variable List -------------------------------
+4 ; RADATA=HL7 data minus seg. hdr RAHDR=Segment header
+5 ; RAHLFS="|" RAMSG=HL7 message passed in
+6 ; RAOBR12=danger code RAOBR18=modifier
+7 ; RAOBR19=Img. Loc. pntr (79.1) RAOBR30=trans. mode
+8 ; RAOBR31=Reason for Study RAOBX2=format of observ. value
+9 ; RAOBR4=univ. trans. mode RAOBX5=observ. value
+10 ; RAOBX3=observ. ID RAORC10=entered by (200
+11 ; RAORC1=order control RAORC15=order effective D/T
+12 ; RAORC12=ordering provider (200) RAORC2=placer order #_"^OR"
+13 ; RAORC16=order control reason RAORC7=start dt/freq. of service
+14 ; RAORC3=filler order #_"^RA" RAPID5=patient name (2)
+15 ; RAPID3=patient ID RAPV12=patient class
+16 ; RAPV119=visit # RASEG=message seg. including header
+17 ; RAPV13=patient location (44)
+18 ; ----------------------------------------------------------------------
+19 ;
OBR ; breakdown the 'OBR' segment
+1 SET RAOBR4=$PIECE(RADATA,RAHLFS,4)
+2 FOR I=1:1:$LENGTH(RAOBR4,RAECH(1))
SET RAOBR4(I)=$PIECE(RAOBR4,RAECH(1),I)
+3 ;RA*5*69
IF RAOBR4(1)'=""
SET RACPTIEN=+$ORDER(^ICPT("B",RAOBR4(1),0))
if 'RACPTIEN
SET RAERR=8
if RAERR
QUIT
+4 SET RAERR=$$EN2^RAO7VLD(71,+RAOBR4(4),RAOBR4(5))
if RAERR
SET RAERR=8
if RAERR
QUIT
+5 IF $$UP^XLFSTR($PIECE($GET(^RAMIS(71,+RAOBR4(4),0)),"^",6))="P"
Begin DoDot:1
+6 SET RAERR=$$EN6^RAO7VLD(+RAOBR4(4))
if RAERR
SET RAERR=32
+7 QUIT
End DoDot:1
if RAERR
QUIT
+8 ;RA*5*69
IF RAOBR4(1)'=""
if '$DATA(^RAMIS(71,"D",RACPTIEN,+RAOBR4(4)))
SET RAERR=8
if RAERR
QUIT
+9 SET RAOBR4(4,"I-TYPE")=+$PIECE($GET(^RAMIS(71,+RAOBR4(4),0)),"^",12)
+10 SET RANEW(75.1,"+1,",2)=RAOBR4(4)
+11 SET RAIT=$PIECE(^RAMIS(71,+RAOBR4(4),0),U,12)
+12 SET RAERR=$$EN3^RAO7VLD(79.2,RAIT)
if RAERR
QUIT
+13 SET RANEW(75.1,"+1,",3)=RAIT
+14 SET RAOBR12=$PIECE(RADATA,RAHLFS,12)
+15 SET RAOBR12=$SELECT($EXTRACT(RAOBR12)="":"n","yYiI"[$EXTRACT(RAOBR12):"y",1:"n")
+16 SET RAERR=$$EN1^RAO7VLD(75.1,24,"E",RAOBR12,"RASULT","")
if RAERR
SET RAERR=10
if RAERR
QUIT
+17 SET RANEW(75.1,"+1,",24)=RAOBR12
+18 SET RAOBR18=$PIECE(RADATA,RAHLFS,18)
+19 ;RASERIES removed w/RA5P158 by GJC
NEW RAIMAG
+20 FOR I=1:1:$LENGTH(RAOBR18,RAECH(2))
if $LENGTH($PIECE(RAOBR18,RAECH(2),I))>0
SET RAOBR18(I)=$PIECE(RAOBR18,RAECH(2),I)
+21 SET I=0
FOR
SET I=$ORDER(RAOBR18(I))
if I'>0
QUIT
Begin DoDot:1
+22 SET RAMODIEN=+$ORDER(^RAMIS(71.2,"B",RAOBR18(I),0))
+23 if 'RAMODIEN
SET RAERR=11
if RAERR
QUIT
+24 ; type of imaging
SET RAIMAG=$PIECE($GET(^RAMIS(71,+RAOBR4(4),0)),U,12)
+25 if '$DATA(^RAMIS(71.2,"AB",RAIMAG,RAMODIEN))
SET RAERR=33
if RAERR
QUIT
+26 ;S RASERIES=$S($P($G(^RAMIS(71,+RAOBR4(4),0)),"^",6)="S":1,1:0) RA5P158 by GJC
+27 ;S:RASERIES&($P($G(^RAMIS(71.2,RAMODIEN,0)),U,2)]"") RAERR=34 Q:RAERR RA5P158 by GJC
+28 SET RAPLCHLD=RAPLCHLD+1
+29 SET RANEW(75.1125,"+"_RAPLCHLD_",+1,",.01)=RAMODIEN
+30 QUIT
End DoDot:1
if RAERR
QUIT
+31 SET RAOBR19=$PIECE(RADATA,RAHLFS,19)
SET RAOBR19(1)=$PIECE(RAOBR19,U,1)
+32 SET RAOBR19(2)=$PIECE(RAOBR19,U,2)
SET RAOBR19(3)=+RAOBR19(1)
+33 IF RAOBR19(3)
Begin DoDot:1
+34 SET RAOBR19(3,"I-TYPE")=+$PIECE($GET(^RA(79.1,+RAOBR19(3),0)),"^",6)
+35 IF RAOBR4(4,"I-TYPE")'=RAOBR19(3,"I-TYPE")
SET RAERR=31
+36 QUIT
End DoDot:1
if RAERR
QUIT
+37 SET RANEW(75.1,"+1,",20)=$SELECT(RAOBR19(3)>0:RAOBR19(3),1:"")
+38 SET X=$PIECE(RADATA,RAHLFS,30)
+39 SET RAOBR30=$SELECT(X="CART":"s",X="PORT":"p",X="WALK":"a",X="WHLC":"w",1:"")
+40 IF RAOBR30']""
SET RAERR=13
+41 if 'RAERR
SET RAERR=$$EN1^RAO7VLD(75.1,19,"E",RAOBR30,"RASULT","")
+42 if RAERR
SET RAERR=13
if RAERR
QUIT
+43 SET RANEW(75.1,"+1,",19)=RAOBR30
+44 ;--- Reason for Study P75 ---
+45 ;CPRS will not pass 'Reason for Study' data until OR*3.0*243
+46 ;(GUI CPRS V27) is released. Define a default Reason for Study
+47 IF '$$PATCH^XPDUTL("OR*3.0*243")
SET RAOBR31="See Clinical History:"
+48 ;CPRS V27 is installed
IF '$TEST
Begin DoDot:1
+49 SET RAOBR31=$PIECE($PIECE(RADATA,RAHLFS,31),RAECH(1),2)
+50 if RAOBR31=""
SET RAERR=38
if RAERR
QUIT
+51 SET RAERR=$$EN1^RAO7VLD(75.1,1.1,"E",RAOBR31,"RASULT","")
+52 if RAERR
SET RAERR=39
+53 QUIT
End DoDot:1
if RAERR
QUIT
+54 ;P129 - strip CCs
DO CCS(.RAOBR31)
+55 if 'RAERR
SET RANEW(75.1,"+1,",1.1)=RAOBR31
+56 KILL RAOBR31
+57 QUIT
OBX ; breakdown the 'OBX' segment
+1 SET RAOBX2=$PIECE(RADATA,RAHLFS,2)
+2 SET RAERR=$SELECT(RAOBX2="TX":0,RAOBX2="CE":0,RAOBX2="TS":0,1:1)
if RAERR=17
QUIT
+3 SET RAOBX3=$PIECE(RADATA,RAHLFS,3)
+4 SET RAOBX5=$PIECE(RADATA,RAHLFS,5)
+5 FOR I=1:1:$LENGTH(RAOBX3,RAECH(1))
SET RAOBX3(I)=$PIECE(RAOBX3,RAECH(1),I)
+6 SET X=RAOBX3(2)
DO UPPER^RAUTL4
SET RAOBX3(2)=Y
+7 ;
+8 ;P75 check to see if CLINICAL HISTORY data is passed. If data is passed, and not yet
+9 ;determined if valid continue to check for validity until:
+10 ;1-valid data is found
+11 ;2-no data left to validate
+12 IF RAOBX3(1)=2000.02
Begin DoDot:1
+13 ;check if a null value is sent for CLINICAL HISTORY which is
+14 ;possible if the CPRS user does not enter a CLINICAL HISTORY
+15 IF RAOBX5=""
IF $PIECE(RACLIN,U)'=1
QUIT
+16 ;now if data was sent (RAOBX5'="") set the data received from CPRS flag
+17 SET $PIECE(RACLIN,U)=1
+18 ;now that we know the CPRS user intended to send CLINICAL HISTORY data
+19 ;radiology has to validate the format of that data. $$EN4^RAO7VLD(str)
+20 ;returns 1 if the data passed in was valid, else 0. Once we establish
+21 ;that valid data has been sent, all subsequent data is accepted, valid
+22 ;or not.
+23 if $$EN4^RAO7VLD(RAOBX5)
SET $PIECE(RACLIN,U,2)=1
+24 ;now, if the current character string or any other character string
+25 ;of data representing the CLINICAL HISTORY has been accepted as valid
+26 ;($P(RACLIN,U,2)=1) save the character string
+27 IF $PIECE(RACLIN,U,2)=1
Begin DoDot:2
+28 ;P129
SET RAWP=RAWP+1
DO CCS(.RAOBX5)
+29 SET ^TMP("RAWP",$JOB,RAWP)=RAOBX5
+30 QUIT
End DoDot:2
End DoDot:1
+31 ;
+32 IF RAOBX3(1)=2000.33
Begin DoDot:1
+33 SET RAERR=$$EN1^RAO7VLD(75.1,13,"E",RAOBX5,"RASULT","")
if RAERR
SET RAERR=14
if RAERR
QUIT
+34 SET RAPREG=$EXTRACT(RAOBX5)
SET RAPREG=$SELECT(RAPREG="N"!(RAPREG="n"):"n",RAPREG="Y"!(RAPREG="y"):"y",1:"u")
+35 SET RANEW(75.1,"+1,",13)=RAPREG
End DoDot:1
if RAERR
QUIT
+36 IF RAOBX3(1)=34!(RAOBX2="CE")
Begin DoDot:1
+37 SET RAERR=$$EN2^RAO7VLD(34,$PIECE(RAOBX5,RAECH(1)),$PIECE(RAOBX5,RAECH(1),2))
if RAERR
QUIT
+38 SET RANEW(75.1,"+1,",9)=+RAOBX5
End DoDot:1
if RAERR
QUIT
+39 IF RAOBX3(2)["RESEARCH"
Begin DoDot:1
+40 SET RAERR=$$EN1^RAO7VLD(75.1,9.5,"E",RAOBX5,"RASULT","")
if RAERR
SET RAERR=19
if RAERR
QUIT
+41 SET RANEW(75.1,"+1,",9.5)=RAOBX5
End DoDot:1
if RAERR
SET RAERR=18
if RAERR
QUIT
+42 IF RAOBX3(2)["PRE-OP"
Begin DoDot:1
+43 SET RAOBX5=$$FMDATE^HLFNC(RAOBX5)
+44 SET RAERR=$$EN1^RAO7VLD(75.1,12,"E",RAOBX5,"RASULT","")
if RAERR
SET RAERR=20
if RAERR
QUIT
+45 SET RANEW(75.1,"+1,",12)=RAOBX5
End DoDot:1
if RAERR
QUIT
+46 IF $DATA(RANEW(75.1,"+1,",9))&($DATA(RANEW(75.1,"+1,",9.5)))
SET RAERR=29
+47 QUIT
+48 ;
CCS(RAX) ;does a string have unprintable
+1 ; control characters? If 'yes' strip them out.
+2 ;
+3 ;'RAX' the string checked for CCs (by reference)
+4 ;
+5 IF RAX?.e1.c.e
Begin DoDot:1
+6 ;'RAX' is changed!
DO SCC
+7 QUIT
End DoDot:1
QUIT
+8 QUIT
+9 ;
SCC ;strip out unprintable CCs.
+1 ;
+2 ;'RAX' the string w/unprintable CCs
+3 ;'RAE' is each character of 'RAX'
+4 KILL RAE,RAI
SET RAXX=""
+5 FOR RAI=1:1:$LENGTH(RAX)
Begin DoDot:1
+6 SET RAE=$EXTRACT(RAX,RAI)
+7 if RAE'?1C
SET RAXX=RAXX_RAE
KILL RAE
+8 QUIT
End DoDot:1
+9 SET RAX=RAXX
+10 KILL RAI,RAXX
+11 QUIT
+12 ;
