RAO7CMP ;HISC/FPT,GJC-Completed Request from Rad to OE/RR! ; Aug 18, 2020@15:35:45
;;5.0;Radiology/Nuclear Medicine;**10,18,26,28,160**;Mar 16, 1998;Build 4
;Last modification for P18 by SS, JULY 6, 2000
EN1(RAOIFN) ; 'RAOIFN' is the ien in file 75.1
; New vars & define the following variables: RAECH, RAECH array & RAHLFS
N A,DFN,RA,RA0,RA70,RA74,RABNORM,RACNT,RACPT,RACTIVDT,RADFN,RADTI,RAECH
N RAEXAM,RAHLFS,RAOBDT,RAPRIOR,RAPROC,RAPRVPHY,RAR,RARXAM,RATAB,RAVAR
N RAXSET
N RA18PROC ;P18 procedure ien
S RATAB=1 D EN1^RAO7UTL S RA0=$G(^RAO(75.1,RAOIFN,0)) Q:RA0']""
D SETVAR S RAR=$G(^RAO(75.1,RAOIFN,"R"))
S RAVAR="RATMP(",RAVARBLE="RATMP"
; msh
S @(RAVAR_RATAB_")")=$$MSH^RAO7UTL("ORU^R01") ;P18 Event type
; pid
S RATAB=RATAB+1,@(RAVAR_RATAB_")")=$$PID^RAO7UTL(RA0)
; orc
S RATAB=RATAB+1,@(RAVAR_RATAB_")")="ORC"_RAHLFS_"RE"_RAHLFS_$P(RA0,U,7)_RAECH(1)_"OR"_RAHLFS_RAOIFN_RAECH(2)_RADTI_RAECH(2)_$S(RAXSET:"",1:RAEXAM)_RAECH(1)_"RA"_$$STR^RAO7UTL(4)_RA("ORC",7)_$$STR^RAO7UTL(5)_$P(RA0,U,14)
; obr
I RAXSET D ; Exam is part of a set, check all others.
. S RABNORM=$$ABNOR^RAO7UTL1(RAOIFN,RADFN,RADTI)
. Q
E S RABNORM=$$DIAG^RAO7UTL(RADFN,RADTI,RAEXAM)
S RA("OBR",4)=$P(RACPT(0),U)_U_$P(RACPT(0),U,2)_U_"CPT4"_U_RA18PROC_U_$P(RAPROC(0),U)_"^99RAP" ;P18
S RA("STATUS")="F" ; Results Status
I 'RAXSET D
. S RAPRVPHY=$P(RA74(0),"^",9) ; Verifying Physician
. I RAPRVPHY="" D
.. S RAPRVPHY=$P(RA70(0),"^",15) ; Prim. Stf.
.. S:RAPRVPHY="" RAPRVPHY=$P(RA70(0),"^",12) ; Prim. Res.
.. Q
. Q
S RACTIVDT=$$HLDATE^HLFNC($P(RA0,"^",18),"TS") ; Status Update D/T
S RATAB=RATAB+1,@(RAVAR_RATAB_")")="OBR"_$$STR^RAO7UTL(4)_RA("OBR",4)_$$STR^RAO7UTL(3)_RAOBDT_$$STR^RAO7UTL(15)_RACTIVDT_$$STR^RAO7UTL(3)_RA("STATUS")_$$STR^RAO7UTL(7)_$G(RAPRVPHY)
; obx
; set abnormal flag, if found
I 'RAXSET D ; Not part of a set
. I +$O(^RARPT(RA70(17),"I",0)) D
.. S (A,RACNT)=0 F S A=$O(^RARPT(RA70(17),"I",A)) Q:A'>0 D
... S RACNT=RACNT+1,RATAB=RATAB+1
... S @(RAVAR_RATAB_")")="OBX"_RAHLFS_RACNT_RAHLFS_"TX"_RAHLFS_"I^Impression^L"_RAHLFS_"1"_RAHLFS_$G(^RARPT(RA70(17),"I",A,0))_$$STR^RAO7UTL(3)_$S(RACNT=1:RABNORM,1:"")
... Q
.. Q
. E D
.. S RACNT=1,RATAB=RATAB+1
.. S @(RAVAR_RATAB_")")="OBX"_RAHLFS_RACNT_RAHLFS_"TX"_RAHLFS_"I^Impression^L"_RAHLFS_"1"_$$STR^RAO7UTL(4)_RABNORM
.. Q
. Q
E D ; Part of a set
. S RACNT=1,RATAB=RATAB+1
. S @(RAVAR_RATAB_")")="OBX"_RAHLFS_RACNT_RAHLFS_"TX"_RAHLFS_"I^Impression^L"_RAHLFS_"1"_RAHLFS_"Part of a set - see individual procedures"_$$STR^RAO7UTL(3)_RABNORM
. Q
K VA,VADM,VAERR
D MSG^RAO7UTL("RA EVSEND OR",.@RAVARBLE)
Q
SETVAR ; Setup exam specific variables
S RADFN=+RA0,RADTI=+$O(^RADPT("AO",RAOIFN,RADFN,0)) ;P18
S RAEXAM=+$O(^RADPT("AO",RAOIFN,RADFN,RADTI,0)) ;P26
S RA70(0)=$G(^RADPT(RADFN,"DT",RADTI,"P",RAEXAM,0)) ;P26
;if CPRS patch not installed always take procedure ien from 75.1
;if not - then in case of Parent procedure take it from 75.1,otherwise-from 70
I '$$PATCH^XPDUTL("OR*3.0*92") S RA18PROC=+$P(RA0,U,2) ;P18
;gjc p160 $G on the procedure zero node to prevent hard error
E S RA18PROC=$S($P($G(^RAMIS(71,+$P(RA0,U,2),0)),U,6)="P":+$P(RA0,U,2),1:+$P(RA70(0),U,2)) ;P18;P26;P31
S RAPROC(0)=$G(^RAMIS(71,RA18PROC,0)),RAPROC(9)=+$P(RAPROC(0),U,9) ;P18
S RACPT(0)=$$NAMCODE^RACPTMSC(RAPROC(9),DT)
S RAPRIOR=$P(RA0,U,6)
S RAPRIOR=$S(RAPRIOR=1:"S",RAPRIOR=2:"A",RAPRIOR=9:"R",1:"")
S RA("ORC",7)="^^^^^"_RAPRIOR
S RARXAM(0)=$G(^RADPT(RADFN,"DT",RADTI,0))
S RAXSET=+$P(RARXAM(0),"^",5) ; '1' if part of xam set
S RAOBDT=$$HLDATE^HLFNC((9999999.9999-RADTI),"TS")
S RA70(17)=+$P(RA70(0),"^",17),RA74(0)=$G(^RARPT(RA70(17),0))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAO7CMP 3716 printed Dec 13, 2024@02:37:40 Page 2
RAO7CMP ;HISC/FPT,GJC-Completed Request from Rad to OE/RR! ; Aug 18, 2020@15:35:45
+1 ;;5.0;Radiology/Nuclear Medicine;**10,18,26,28,160**;Mar 16, 1998;Build 4
+2 ;Last modification for P18 by SS, JULY 6, 2000
EN1(RAOIFN) ; 'RAOIFN' is the ien in file 75.1
+1 ; New vars & define the following variables: RAECH, RAECH array & RAHLFS
+2 NEW A,DFN,RA,RA0,RA70,RA74,RABNORM,RACNT,RACPT,RACTIVDT,RADFN,RADTI,RAECH
+3 NEW RAEXAM,RAHLFS,RAOBDT,RAPRIOR,RAPROC,RAPRVPHY,RAR,RARXAM,RATAB,RAVAR
+4 NEW RAXSET
+5 ;P18 procedure ien
NEW RA18PROC
+6 SET RATAB=1
DO EN1^RAO7UTL
SET RA0=$GET(^RAO(75.1,RAOIFN,0))
if RA0']""
QUIT
+7 DO SETVAR
SET RAR=$GET(^RAO(75.1,RAOIFN,"R"))
+8 SET RAVAR="RATMP("
SET RAVARBLE="RATMP"
+9 ; msh
+10 ;P18 Event type
SET @(RAVAR_RATAB_")")=$$MSH^RAO7UTL("ORU^R01")
+11 ; pid
+12 SET RATAB=RATAB+1
SET @(RAVAR_RATAB_")")=$$PID^RAO7UTL(RA0)
+13 ; orc
+14 SET RATAB=RATAB+1
SET @(RAVAR_RATAB_")")="ORC"_RAHLFS_"RE"_RAHLFS_$PIECE(RA0,U,7)_RAECH(1)_"OR"_RAHLFS_RAOIFN_RAECH(2)_RADTI_RAECH(2)_$SELECT(RAXSET:"",1:RAEXAM)_RAECH(1)_"RA"_$$STR^RAO7UTL(4)_RA("ORC",7)_$$STR^RAO7UTL(5)_$PIECE(RA0,U,14)
+15 ; obr
+16 ; Exam is part of a set, check all others.
IF RAXSET
Begin DoDot:1
+17 SET RABNORM=$$ABNOR^RAO7UTL1(RAOIFN,RADFN,RADTI)
+18 QUIT
End DoDot:1
+19 IF '$TEST
SET RABNORM=$$DIAG^RAO7UTL(RADFN,RADTI,RAEXAM)
+20 ;P18
SET RA("OBR",4)=$PIECE(RACPT(0),U)_U_$PIECE(RACPT(0),U,2)_U_"CPT4"_U_RA18PROC_U_$PIECE(RAPROC(0),U)_"^99RAP"
+21 ; Results Status
SET RA("STATUS")="F"
+22 IF 'RAXSET
Begin DoDot:1
+23 ; Verifying Physician
SET RAPRVPHY=$PIECE(RA74(0),"^",9)
+24 IF RAPRVPHY=""
Begin DoDot:2
+25 ; Prim. Stf.
SET RAPRVPHY=$PIECE(RA70(0),"^",15)
+26 ; Prim. Res.
if RAPRVPHY=""
SET RAPRVPHY=$PIECE(RA70(0),"^",12)
+27 QUIT
End DoDot:2
+28 QUIT
End DoDot:1
+29 ; Status Update D/T
SET RACTIVDT=$$HLDATE^HLFNC($PIECE(RA0,"^",18),"TS")
+30 SET RATAB=RATAB+1
SET @(RAVAR_RATAB_")")="OBR"_$$STR^RAO7UTL(4)_RA("OBR",4)_$$STR^RAO7UTL(3)_RAOBDT_$$STR^RAO7UTL(15)_RACTIVDT_$$STR^RAO7UTL(3)_RA("STATUS")_$$STR^RAO7UTL(7)_$GET(RAPRVPHY)
+31 ; obx
+32 ; set abnormal flag, if found
+33 ; Not part of a set
IF 'RAXSET
Begin DoDot:1
+34 IF +$ORDER(^RARPT(RA70(17),"I",0))
Begin DoDot:2
+35 SET (A,RACNT)=0
FOR
SET A=$ORDER(^RARPT(RA70(17),"I",A))
if A'>0
QUIT
Begin DoDot:3
+36 SET RACNT=RACNT+1
SET RATAB=RATAB+1
+37 SET @(RAVAR_RATAB_")")="OBX"_RAHLFS_RACNT_RAHLFS_"TX"_RAHLFS_"I^Impression^L"_RAHLFS_"1"_RAHLFS_$GET(^RARPT(RA70(17),"I",A,0))_$$STR^RAO7UTL(3)_$SELECT(RACNT=1:RABNORM,1:"")
+38 QUIT
End DoDot:3
+39 QUIT
End DoDot:2
+40 IF '$TEST
Begin DoDot:2
+41 SET RACNT=1
SET RATAB=RATAB+1
+42 SET @(RAVAR_RATAB_")")="OBX"_RAHLFS_RACNT_RAHLFS_"TX"_RAHLFS_"I^Impression^L"_RAHLFS_"1"_$$STR^RAO7UTL(4)_RABNORM
+43 QUIT
End DoDot:2
+44 QUIT
End DoDot:1
+45 ; Part of a set
IF '$TEST
Begin DoDot:1
+46 SET RACNT=1
SET RATAB=RATAB+1
+47 SET @(RAVAR_RATAB_")")="OBX"_RAHLFS_RACNT_RAHLFS_"TX"_RAHLFS_"I^Impression^L"_RAHLFS_"1"_RAHLFS_"Part of a set - see individual procedures"_$$STR^RAO7UTL(3)_RABNORM
+48 QUIT
End DoDot:1
+49 KILL VA,VADM,VAERR
+50 DO MSG^RAO7UTL("RA EVSEND OR",.@RAVARBLE)
+51 QUIT
SETVAR ; Setup exam specific variables
+1 ;P18
SET RADFN=+RA0
SET RADTI=+$ORDER(^RADPT("AO",RAOIFN,RADFN,0))
+2 ;P26
SET RAEXAM=+$ORDER(^RADPT("AO",RAOIFN,RADFN,RADTI,0))
+3 ;P26
SET RA70(0)=$GET(^RADPT(RADFN,"DT",RADTI,"P",RAEXAM,0))
+4 ;if CPRS patch not installed always take procedure ien from 75.1
+5 ;if not - then in case of Parent procedure take it from 75.1,otherwise-from 70
+6 ;P18
IF '$$PATCH^XPDUTL("OR*3.0*92")
SET RA18PROC=+$PIECE(RA0,U,2)
+7 ;gjc p160 $G on the procedure zero node to prevent hard error
+8 ;P18;P26;P31
IF '$TEST
SET RA18PROC=$SELECT($PIECE($GET(^RAMIS(71,+$PIECE(RA0,U,2),0)),U,6)="P":+$PIECE(RA0,U,2),1:+$PIECE(RA70(0),U,2))
+9 ;P18
SET RAPROC(0)=$GET(^RAMIS(71,RA18PROC,0))
SET RAPROC(9)=+$PIECE(RAPROC(0),U,9)
+10 SET RACPT(0)=$$NAMCODE^RACPTMSC(RAPROC(9),DT)
+11 SET RAPRIOR=$PIECE(RA0,U,6)
+12 SET RAPRIOR=$SELECT(RAPRIOR=1:"S",RAPRIOR=2:"A",RAPRIOR=9:"R",1:"")
+13 SET RA("ORC",7)="^^^^^"_RAPRIOR
+14 SET RARXAM(0)=$GET(^RADPT(RADFN,"DT",RADTI,0))
+15 ; '1' if part of xam set
SET RAXSET=+$PIECE(RARXAM(0),"^",5)
+16 SET RAOBDT=$$HLDATE^HLFNC((9999999.9999-RADTI),"TS")
+17 SET RA70(17)=+$PIECE(RA70(0),"^",17)
SET RA74(0)=$GET(^RARPT(RA70(17),0))
+18 QUIT
