- 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 Jan 18, 2025@03:38: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 ;