MAGJRT ;WIRMFO/JHC VistaRad RPC calls for Demand Routing ; 13 Jan 2004 11:00 AM
;;3.0;IMAGING;**9,22,11,18**;Mar 07, 2006
;; +---------------------------------------------------------------+
;; | Property of the US Government. |
;; | No permission to copy or redistribute this software is given. |
;; | Use of unreleased versions of this software requires the user |
;; | to execute a written test agreement with the VistA Imaging |
;; | Development Office of the Department of Veterans Affairs, |
;; | telephone (301) 734-0100. |
;; | |
;; | The Food and Drug Administration classifies this software as |
;; | a medical device. As such, it may not be changed in any way. |
;; | Modifications to this software may result in an adulterated |
;; | medical device under 21CFR820, the use of which is considered |
;; | to be a violation of US Federal Statutes. |
;; +---------------------------------------------------------------+
;;
Q
; Entry Points:
; RTENA -- Determine whether user has Security Key required to use Demand Routing
; RTREQ -- Build message to create Demand Routing Request form on the W/S
; RTEXAM -- Queue images to route according to input requests
;
ERR N ERR S ERR=$$EC^%ZOSV S @MAGGRY@(0)="0^4~"_ERR
D @^%ZOSF("ERRTN")
Q:$Q 1 Q
;
RTENA(MAGGRY,DATA) ; RPC: MAGJ ROUTE ENABLE
; Enable if: 1) User has applicable security key and, 2) Routing Loc'n has usable entries
N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGJRT"
S MAGGRY="FALSE"
I '$D(MAGJOB("KEYS")) D USERKEYS^MAGJUTL3
F X="MAGJ DEMAND ROUTE","MAGJ DEMAND ROUTE DICOM" I $D(MAGJOB("KEYS",X)) D Q
. N OK,DUM
. S OK=0 D RTLOCS1(.DUM,.OK) I +OK!+$P(OK,U,2) S MAGGRY="TRUE"
Q
;
RTREQ(MAGGRY,DATA) ; RPC: MAGJ ROUTE REQUEST
; request to route exams; info returned in MAGGRY
; input in DATA(1:n): RADFN ^ RADTI ^ RACNI ^ RARPT
; - RADFN^RADTI^RACNI input to specify case of interest
; Returns: Exam Info for routable exams in ^TMP($J,"MAGJROUTE",1:N)
; Followed by Prompts for Routing Locations & Priority
; Then error messages, if any
;
; MAGGRY holds $NA reference to ^TMP where Broker return message is assembled;
; all references to MAGGRY use subscript indirection
;
N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGJRT"
N RARPT,RADFN,RADTI,RACNI
N DAYCASE,REPLY,CT,MAGS,STARTNOD,DATAOUT,RADATA,MAGSTRT,MAGEND,NEXAM,DIQUIET
N IDATA,NOGO
S DIQUIET=1 D DT^DICRW
S CT=0,NEXAM=0,DATAOUT="",DAYCASE=""
S NOGO(0)=0 ; array for reply for exams unable to process
S MAGLST="MAGJROUTE",STARTNOD=1
K MAGGRY S MAGGRY=$NA(^TMP($J,MAGLST)) K @MAGGRY ; assign MAGGRY value
S IDATA=""
F S IDATA=$O(DATA(IDATA)) Q:IDATA="" S DATA=DATA(IDATA) D EXDAT("RTGET")
I NEXAM D ; have some exams eligible to be routed
. S @MAGGRY@(STARTNOD)="^Case #^Patient^Procedure^Image Date/Time^Status^Modality"
. S CT=CT+1,@MAGGRY@(CT+STARTNOD)="*END"
. S REPLY="1~Route Exams to Selected Locations"
. D RTLOCS(.CT) D RTPRIOR(.CT)
E D
. S REPLY="0~Unable to Route any Exams"
RTREQZ I NOGO(0) D NOGO("Routed",.CT)
S @MAGGRY@(0)=NEXAM_U_REPLY
Q
;
;
EXDAT(GET) ; Put routable exam info in output file, non-routable in NOGO(n)
S NOGO=0,RARPT=+$P(DATA,U,4)
S RADFN=$P(DATA,U),RADTI=$P(DATA,U,2),RACNI=$P(DATA,U,3),X=0
I RADFN,RADTI,RACNI D GETEXAM2^MAGJUTL1(RADFN,RADTI,RACNI,"",.X)
I 'X S NOGO="1~Request has Invalid Case Pointer ("_RADFN_U_RADTI_U_RACNI_U_RARPT_")." G EXDATZ
S RADATA=$G(^TMP($J,"MAGRAEX",1,1)) K ^TMP($J,"MAGRAEX")
S RARPT=$P(RADATA,U,10),DAYCASE=$P(RADATA,U,12)
S DATAOUT="" D @GET
EXDATZ I NOGO D
. S NOGO(0)=NOGO(0)+1,NOGO(NOGO(0))=$P(NOGO,"~",2,99)
E D
. S DATAOUT=U_DATAOUT_"|"_RADFN_U_RADTI_U_RACNI_U_RARPT_"||"
. S NEXAM=NEXAM+1,CT=CT+1,@MAGGRY@(CT+STARTNOD)=DATAOUT
Q
;
RTGET ;GET code for Demand Routing function
; get data for exams (DATAOUT), or reason for error (NOGO)
N IMAG,MAGIEN,MDL,MAGS
S X=$$JBFETCH^MAGJUTL2(RARPT,.MAGS) ; ? route only if NOT on Jukebox
I +X S NOGO="2~Case #"_DAYCASE_"--Images have been requested from Jukebox; try again later." Q
I '$P(X,U,2) S NOGO="3~Case #"_DAYCASE_"--No Images exist for exam." Q
F IMAG=1:1 S MAGIEN=$P($G(MAGS(IMAG)),U,4) Q:MAGIEN="" D Q:MDL]""
. S MDL=$P(MAGS(IMAG),U,3)
. I MDL="DR" S MDL="CR" ; for now, hard code cx of non-standard code
; Contents of DATAOUT=
; DAYCASE ^ Pt Name ^ Proc. Name ^ Exam Date/Time ^ Status ^ MDL
S DATAOUT=DAYCASE_U_$P(RADATA,U,4)_U_$P(RADATA,U,9)
S DATAOUT=DATAOUT_U_$$DTTIM($P(RADATA,U,6))_U_$P(RADATA,U,14)_U_MDL
Q
;
DTTIM(X) ; Format Image Date/Time
N T S T=$L(X," "),X=$P(X," ",1,T-1)_"@"_$P(X," ",T)
Q X
;
RTLOCS(CT) ; define prompts for Routing Locations
;DROP-Down List, Default=[Do Not Route], Enable Auto-fill (if>1 exam)
N AUTOFILL,T,X,OK,TMP
S AUTOFILL=$S($G(NEXAM)>1:"AUTOFILL",1:"")
S CT=CT+1,@MAGGRY@(CT+STARTNOD)="*PROMPT"
S CT=CT+1,@MAGGRY@(CT+STARTNOD)="DROP^Route To^"_AUTOFILL_"^[Do Not Route]"
S T=0
S CT=CT+1,@MAGGRY@(CT+STARTNOD)="0^[Do Not Route]"
K TMP S TMP=0 D RTLOCS1(.TMP,.OK)
F I=1:1:TMP S CT=CT+1,@MAGGRY@(CT+STARTNOD)=TMP(I)
S CT=CT+1,@MAGGRY@(CT+STARTNOD)="*END"
Q
;
RTLOCS1(RET,OK) ; return:
; RET = array of loc'ns screened by sec key
; OK = Non-dcm ^ dcm Truth value for user may route respective routing types
S RET=0,OK=""
I $D(MAGJOB("KEYS","MAGJ DEMAND ROUTE")) D
. N T S T=0
. F S T=$O(^MAG(2005.2,T)) Q:'T S X=$G(^(T,0)) I X]"" D
.. Q:'$P(X,U,9) ; Not a routable location
.. Q:'$P(X,U,6) ; OPERATIONAL STATUS not On-Line
.. Q:'($P(X,U,7)="MAG") ; Storage Type not Magnetic
.. S X=$P(X,U),OK=OK+1
.. S RET=RET+1,RET(RET)=T_U_X
; dicom destinations: assume that all are "active"
I $D(MAGJOB("KEYS","MAGJ DEMAND ROUTE DICOM")) D
. N DCM
. D DCMLIST^MAGBRTUT(.DCM,DUZ(2))
. I +$G(DCM(1)) S $P(OK,U,2)=+$G(DCM(1))
. I F I=2:1:DCM(1)+1 S X=DCM(I),RET=RET+1,RET(RET)=$P(X,U,2)_"DCM"_U_"dcm "_$P(X,U)
Q
;
RTPRIOR(CT) ; define prompts for Routing Priorities
;DROP-Down List, Default=Medium, Enable Auto-fill (if>1 exam)
N AUTOFILL
S AUTOFILL=$S($G(NEXAM)>1:"AUTOFILL",1:"")
S CT=CT+1,@MAGGRY@(CT+STARTNOD)="*PROMPT"
S CT=CT+1,@MAGGRY@(CT+STARTNOD)="DROP^Priority^"_AUTOFILL_"^Medium"
S CT=CT+1,@MAGGRY@(CT+STARTNOD)="900^STAT"
S CT=CT+1,@MAGGRY@(CT+STARTNOD)="750^High"
S CT=CT+1,@MAGGRY@(CT+STARTNOD)="500^Medium"
S CT=CT+1,@MAGGRY@(CT+STARTNOD)="250^Low"
S CT=CT+1,@MAGGRY@(CT+STARTNOD)="*END"
Q
;
NOGO(HDR,CT) ; output error msgs for exams
Q:'NOGO(0)
S CT=CT+1,@MAGGRY@(CT+STARTNOD)="*ERROR"
S CT=CT+1,@MAGGRY@(CT+STARTNOD)=NOGO(0)_" Exams Not Able to be "_HDR
F I=1:1:NOGO(0) S CT=CT+1,@MAGGRY@(CT+STARTNOD)=NOGO(I)
S CT=CT+1,@MAGGRY@(CT+STARTNOD)="*END"
Q
;
; 1 RADFN RADTI RACNI RANME RASSN <-- from GETEXAM
; 6 RADATE RADTE RACN RAPRC RARPT (=RADATA)
; 11 RAST DAYCASE RAELOC RASTP RASTORD
; 16 RADTPRT RACPT
;
RTEXAM(MAGGRY,DATA) ; RPC: MAGJ ROUTE EXAMS
; queue images to route according to input requests
; input in DATA(1:n), list of exams to route:
; Destination Network Loc'n ^ Priority | RADFN ^ RADTI ^ RACNI ^ RARPT
; Returns: Reply status in ^TMP($J,"MAGJROUTE",1:N)
; Then error messages for each exam if applicable
;
; MAGGRY holds $NA reference to ^TMP where Broker return message is assembled;
; all references to MAGGRY use subscript indirection
;
; MAGS = # Images stored for the case
; MAGS(1:n) = 1/0 ^ FULL/BIG ^ Mod ^ ien ^ Series ^ Routed-to Locations
; (1=Image is on Magnetic Disk)
;
N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGJRT"
N IEXAM,RTLOC,RTPRI,RARPT,IDATA,REPLY,CT,MAGS,STARTNOD,NEXAM,NOGO
N IMAG,MAGLST,MAGIEN,RTTYP,DIQUIET
S DIQUIET=1 D DT^DICRW
K NOGO S NOGO(0)=0 ; array for reply for exams unable to process
S MAGLST="MAGJROUTE",CT=0,STARTNOD=0,NEXAM=0
K MAGGRY S MAGGRY=$NA(^TMP($J,MAGLST)) K @MAGGRY ; assign MAGGRY value
S IDATA=""
F S IDATA=$O(DATA(IDATA)) Q:IDATA="" D
. S X=DATA(IDATA),DATA=$P(X,"|",2),X=$P(X,"|"),RTLOC=$P(X,U),RTPRI=$P(X,U,2)
. S RTTYP=$S(RTLOC=+RTLOC:1,1:2),RTLOC=+RTLOC ; 1=DOS; 2=Dicom
. I 'RTLOC Q ; routing cancelled for this exam
. S RARPT=$P(DATA,U,4) I 'RARPT D Q
. . S NOGO(0)=NOGO(0)+1,NOGO(NOGO(0))="Exam not queued: Missing exam pointer information for exam ("_DATA(IDATA)_")"
. S X=$$JBFETCH^MAGJUTL2(RARPT,.MAGS)
. F IMAG=1:1 S MAGIEN=$P($G(MAGS(IMAG)),U,4) Q:MAGIEN="" D
. . D SEND^MAGBRTUT(MAGIEN,RTLOC,RTPRI,RTTYP)
. I IMAG>1 S NEXAM=NEXAM+1
. E S NOGO(0)=NOGO(0)+1,NOGO(NOGO(0))="Exam not queued: No images found ("_DATA(IDATA)_")"
I NEXAM S REPLY=1_"~"_NEXAM_" Exam"_$S(NEXAM-1:"s",1:"")_" were queued to be routed."
E S REPLY="0~Unable to queue any exams for routing."
RTEXAMZ I NOGO(0) D NOGO("Queued",.CT)
S @MAGGRY@(0)=$S(NOGO(0):CT,1:0)_U_REPLY
Q
;
END Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGJRT 9113 printed Sep 23, 2025@19:43:12 Page 2
MAGJRT ;WIRMFO/JHC VistaRad RPC calls for Demand Routing ; 13 Jan 2004 11:00 AM
+1 ;;3.0;IMAGING;**9,22,11,18**;Mar 07, 2006
+2 ;; +---------------------------------------------------------------+
+3 ;; | Property of the US Government. |
+4 ;; | No permission to copy or redistribute this software is given. |
+5 ;; | Use of unreleased versions of this software requires the user |
+6 ;; | to execute a written test agreement with the VistA Imaging |
+7 ;; | Development Office of the Department of Veterans Affairs, |
+8 ;; | telephone (301) 734-0100. |
+9 ;; | |
+10 ;; | The Food and Drug Administration classifies this software as |
+11 ;; | a medical device. As such, it may not be changed in any way. |
+12 ;; | Modifications to this software may result in an adulterated |
+13 ;; | medical device under 21CFR820, the use of which is considered |
+14 ;; | to be a violation of US Federal Statutes. |
+15 ;; +---------------------------------------------------------------+
+16 ;;
+17 QUIT
+18 ; Entry Points:
+19 ; RTENA -- Determine whether user has Security Key required to use Demand Routing
+20 ; RTREQ -- Build message to create Demand Routing Request form on the W/S
+21 ; RTEXAM -- Queue images to route according to input requests
+22 ;
ERR NEW ERR
SET ERR=$$EC^%ZOSV
SET @MAGGRY@(0)="0^4~"_ERR
+1 DO @^%ZOSF("ERRTN")
+2 if $QUIT
QUIT 1
QUIT
+3 ;
RTENA(MAGGRY,DATA) ; RPC: MAGJ ROUTE ENABLE
+1 ; Enable if: 1) User has applicable security key and, 2) Routing Loc'n has usable entries
+2 NEW $ETRAP,$ESTACK
SET $ETRAP="D ERR^MAGJRT"
+3 SET MAGGRY="FALSE"
+4 IF '$DATA(MAGJOB("KEYS"))
DO USERKEYS^MAGJUTL3
+5 FOR X="MAGJ DEMAND ROUTE","MAGJ DEMAND ROUTE DICOM"
IF $DATA(MAGJOB("KEYS",X))
Begin DoDot:1
+6 NEW OK,DUM
+7 SET OK=0
DO RTLOCS1(.DUM,.OK)
IF +OK!+$PIECE(OK,U,2)
SET MAGGRY="TRUE"
End DoDot:1
QUIT
+8 QUIT
+9 ;
RTREQ(MAGGRY,DATA) ; RPC: MAGJ ROUTE REQUEST
+1 ; request to route exams; info returned in MAGGRY
+2 ; input in DATA(1:n): RADFN ^ RADTI ^ RACNI ^ RARPT
+3 ; - RADFN^RADTI^RACNI input to specify case of interest
+4 ; Returns: Exam Info for routable exams in ^TMP($J,"MAGJROUTE",1:N)
+5 ; Followed by Prompts for Routing Locations & Priority
+6 ; Then error messages, if any
+7 ;
+8 ; MAGGRY holds $NA reference to ^TMP where Broker return message is assembled;
+9 ; all references to MAGGRY use subscript indirection
+10 ;
+11 NEW $ETRAP,$ESTACK
SET $ETRAP="D ERR^MAGJRT"
+12 NEW RARPT,RADFN,RADTI,RACNI
+13 NEW DAYCASE,REPLY,CT,MAGS,STARTNOD,DATAOUT,RADATA,MAGSTRT,MAGEND,NEXAM,DIQUIET
+14 NEW IDATA,NOGO
+15 SET DIQUIET=1
DO DT^DICRW
+16 SET CT=0
SET NEXAM=0
SET DATAOUT=""
SET DAYCASE=""
+17 ; array for reply for exams unable to process
SET NOGO(0)=0
+18 SET MAGLST="MAGJROUTE"
SET STARTNOD=1
+19 ; assign MAGGRY value
KILL MAGGRY
SET MAGGRY=$NAME(^TMP($JOB,MAGLST))
KILL @MAGGRY
+20 SET IDATA=""
+21 FOR
SET IDATA=$ORDER(DATA(IDATA))
if IDATA=""
QUIT
SET DATA=DATA(IDATA)
DO EXDAT("RTGET")
+22 ; have some exams eligible to be routed
IF NEXAM
Begin DoDot:1
+23 SET @MAGGRY@(STARTNOD)="^Case #^Patient^Procedure^Image Date/Time^Status^Modality"
+24 SET CT=CT+1
SET @MAGGRY@(CT+STARTNOD)="*END"
+25 SET REPLY="1~Route Exams to Selected Locations"
+26 DO RTLOCS(.CT)
DO RTPRIOR(.CT)
End DoDot:1
+27 IF '$TEST
Begin DoDot:1
+28 SET REPLY="0~Unable to Route any Exams"
End DoDot:1
RTREQZ IF NOGO(0)
DO NOGO("Routed",.CT)
+1 SET @MAGGRY@(0)=NEXAM_U_REPLY
+2 QUIT
+3 ;
+4 ;
EXDAT(GET) ; Put routable exam info in output file, non-routable in NOGO(n)
+1 SET NOGO=0
SET RARPT=+$PIECE(DATA,U,4)
+2 SET RADFN=$PIECE(DATA,U)
SET RADTI=$PIECE(DATA,U,2)
SET RACNI=$PIECE(DATA,U,3)
SET X=0
+3 IF RADFN
IF RADTI
IF RACNI
DO GETEXAM2^MAGJUTL1(RADFN,RADTI,RACNI,"",.X)
+4 IF 'X
SET NOGO="1~Request has Invalid Case Pointer ("_RADFN_U_RADTI_U_RACNI_U_RARPT_")."
GOTO EXDATZ
+5 SET RADATA=$GET(^TMP($JOB,"MAGRAEX",1,1))
KILL ^TMP($JOB,"MAGRAEX")
+6 SET RARPT=$PIECE(RADATA,U,10)
SET DAYCASE=$PIECE(RADATA,U,12)
+7 SET DATAOUT=""
DO @GET
EXDATZ IF NOGO
Begin DoDot:1
+1 SET NOGO(0)=NOGO(0)+1
SET NOGO(NOGO(0))=$PIECE(NOGO,"~",2,99)
End DoDot:1
+2 IF '$TEST
Begin DoDot:1
+3 SET DATAOUT=U_DATAOUT_"|"_RADFN_U_RADTI_U_RACNI_U_RARPT_"||"
+4 SET NEXAM=NEXAM+1
SET CT=CT+1
SET @MAGGRY@(CT+STARTNOD)=DATAOUT
End DoDot:1
+5 QUIT
+6 ;
RTGET ;GET code for Demand Routing function
+1 ; get data for exams (DATAOUT), or reason for error (NOGO)
+2 NEW IMAG,MAGIEN,MDL,MAGS
+3 ; ? route only if NOT on Jukebox
SET X=$$JBFETCH^MAGJUTL2(RARPT,.MAGS)
+4 IF +X
SET NOGO="2~Case #"_DAYCASE_"--Images have been requested from Jukebox; try again later."
QUIT
+5 IF '$PIECE(X,U,2)
SET NOGO="3~Case #"_DAYCASE_"--No Images exist for exam."
QUIT
+6 FOR IMAG=1:1
SET MAGIEN=$PIECE($GET(MAGS(IMAG)),U,4)
if MAGIEN=""
QUIT
Begin DoDot:1
+7 SET MDL=$PIECE(MAGS(IMAG),U,3)
+8 ; for now, hard code cx of non-standard code
IF MDL="DR"
SET MDL="CR"
End DoDot:1
if MDL]""
QUIT
+9 ; Contents of DATAOUT=
+10 ; DAYCASE ^ Pt Name ^ Proc. Name ^ Exam Date/Time ^ Status ^ MDL
+11 SET DATAOUT=DAYCASE_U_$PIECE(RADATA,U,4)_U_$PIECE(RADATA,U,9)
+12 SET DATAOUT=DATAOUT_U_$$DTTIM($PIECE(RADATA,U,6))_U_$PIECE(RADATA,U,14)_U_MDL
+13 QUIT
+14 ;
DTTIM(X) ; Format Image Date/Time
+1 NEW T
SET T=$LENGTH(X," ")
SET X=$PIECE(X," ",1,T-1)_"@"_$PIECE(X," ",T)
+2 QUIT X
+3 ;
RTLOCS(CT) ; define prompts for Routing Locations
+1 ;DROP-Down List, Default=[Do Not Route], Enable Auto-fill (if>1 exam)
+2 NEW AUTOFILL,T,X,OK,TMP
+3 SET AUTOFILL=$SELECT($GET(NEXAM)>1:"AUTOFILL",1:"")
+4 SET CT=CT+1
SET @MAGGRY@(CT+STARTNOD)="*PROMPT"
+5 SET CT=CT+1
SET @MAGGRY@(CT+STARTNOD)="DROP^Route To^"_AUTOFILL_"^[Do Not Route]"
+6 SET T=0
+7 SET CT=CT+1
SET @MAGGRY@(CT+STARTNOD)="0^[Do Not Route]"
+8 KILL TMP
SET TMP=0
DO RTLOCS1(.TMP,.OK)
+9 FOR I=1:1:TMP
SET CT=CT+1
SET @MAGGRY@(CT+STARTNOD)=TMP(I)
+10 SET CT=CT+1
SET @MAGGRY@(CT+STARTNOD)="*END"
+11 QUIT
+12 ;
RTLOCS1(RET,OK) ; return:
+1 ; RET = array of loc'ns screened by sec key
+2 ; OK = Non-dcm ^ dcm Truth value for user may route respective routing types
+3 SET RET=0
SET OK=""
+4 IF $DATA(MAGJOB("KEYS","MAGJ DEMAND ROUTE"))
Begin DoDot:1
+5 NEW T
SET T=0
+6 FOR
SET T=$ORDER(^MAG(2005.2,T))
if 'T
QUIT
SET X=$GET(^(T,0))
IF X]""
Begin DoDot:2
+7 ; Not a routable location
if '$PIECE(X,U,9)
QUIT
+8 ; OPERATIONAL STATUS not On-Line
if '$PIECE(X,U,6)
QUIT
+9 ; Storage Type not Magnetic
if '($PIECE(X,U,7)="MAG")
QUIT
+10 SET X=$PIECE(X,U)
SET OK=OK+1
+11 SET RET=RET+1
SET RET(RET)=T_U_X
End DoDot:2
End DoDot:1
+12 ; dicom destinations: assume that all are "active"
+13 IF $DATA(MAGJOB("KEYS","MAGJ DEMAND ROUTE DICOM"))
Begin DoDot:1
+14 NEW DCM
+15 DO DCMLIST^MAGBRTUT(.DCM,DUZ(2))
+16 IF +$GET(DCM(1))
SET $PIECE(OK,U,2)=+$GET(DCM(1))
+17 IF $TEST
FOR I=2:1:DCM(1)+1
SET X=DCM(I)
SET RET=RET+1
SET RET(RET)=$PIECE(X,U,2)_"DCM"_U_"dcm "_$PIECE(X,U)
End DoDot:1
+18 QUIT
+19 ;
RTPRIOR(CT) ; define prompts for Routing Priorities
+1 ;DROP-Down List, Default=Medium, Enable Auto-fill (if>1 exam)
+2 NEW AUTOFILL
+3 SET AUTOFILL=$SELECT($GET(NEXAM)>1:"AUTOFILL",1:"")
+4 SET CT=CT+1
SET @MAGGRY@(CT+STARTNOD)="*PROMPT"
+5 SET CT=CT+1
SET @MAGGRY@(CT+STARTNOD)="DROP^Priority^"_AUTOFILL_"^Medium"
+6 SET CT=CT+1
SET @MAGGRY@(CT+STARTNOD)="900^STAT"
+7 SET CT=CT+1
SET @MAGGRY@(CT+STARTNOD)="750^High"
+8 SET CT=CT+1
SET @MAGGRY@(CT+STARTNOD)="500^Medium"
+9 SET CT=CT+1
SET @MAGGRY@(CT+STARTNOD)="250^Low"
+10 SET CT=CT+1
SET @MAGGRY@(CT+STARTNOD)="*END"
+11 QUIT
+12 ;
NOGO(HDR,CT) ; output error msgs for exams
+1 if 'NOGO(0)
QUIT
+2 SET CT=CT+1
SET @MAGGRY@(CT+STARTNOD)="*ERROR"
+3 SET CT=CT+1
SET @MAGGRY@(CT+STARTNOD)=NOGO(0)_" Exams Not Able to be "_HDR
+4 FOR I=1:1:NOGO(0)
SET CT=CT+1
SET @MAGGRY@(CT+STARTNOD)=NOGO(I)
+5 SET CT=CT+1
SET @MAGGRY@(CT+STARTNOD)="*END"
+6 QUIT
+7 ;
+8 ; 1 RADFN RADTI RACNI RANME RASSN <-- from GETEXAM
+9 ; 6 RADATE RADTE RACN RAPRC RARPT (=RADATA)
+10 ; 11 RAST DAYCASE RAELOC RASTP RASTORD
+11 ; 16 RADTPRT RACPT
+12 ;
RTEXAM(MAGGRY,DATA) ; RPC: MAGJ ROUTE EXAMS
+1 ; queue images to route according to input requests
+2 ; input in DATA(1:n), list of exams to route:
+3 ; Destination Network Loc'n ^ Priority | RADFN ^ RADTI ^ RACNI ^ RARPT
+4 ; Returns: Reply status in ^TMP($J,"MAGJROUTE",1:N)
+5 ; Then error messages for each exam if applicable
+6 ;
+7 ; MAGGRY holds $NA reference to ^TMP where Broker return message is assembled;
+8 ; all references to MAGGRY use subscript indirection
+9 ;
+10 ; MAGS = # Images stored for the case
+11 ; MAGS(1:n) = 1/0 ^ FULL/BIG ^ Mod ^ ien ^ Series ^ Routed-to Locations
+12 ; (1=Image is on Magnetic Disk)
+13 ;
+14 NEW $ETRAP,$ESTACK
SET $ETRAP="D ERR^MAGJRT"
+15 NEW IEXAM,RTLOC,RTPRI,RARPT,IDATA,REPLY,CT,MAGS,STARTNOD,NEXAM,NOGO
+16 NEW IMAG,MAGLST,MAGIEN,RTTYP,DIQUIET
+17 SET DIQUIET=1
DO DT^DICRW
+18 ; array for reply for exams unable to process
KILL NOGO
SET NOGO(0)=0
+19 SET MAGLST="MAGJROUTE"
SET CT=0
SET STARTNOD=0
SET NEXAM=0
+20 ; assign MAGGRY value
KILL MAGGRY
SET MAGGRY=$NAME(^TMP($JOB,MAGLST))
KILL @MAGGRY
+21 SET IDATA=""
+22 FOR
SET IDATA=$ORDER(DATA(IDATA))
if IDATA=""
QUIT
Begin DoDot:1
+23 SET X=DATA(IDATA)
SET DATA=$PIECE(X,"|",2)
SET X=$PIECE(X,"|")
SET RTLOC=$PIECE(X,U)
SET RTPRI=$PIECE(X,U,2)
+24 ; 1=DOS; 2=Dicom
SET RTTYP=$SELECT(RTLOC=+RTLOC:1,1:2)
SET RTLOC=+RTLOC
+25 ; routing cancelled for this exam
IF 'RTLOC
QUIT
+26 SET RARPT=$PIECE(DATA,U,4)
IF 'RARPT
Begin DoDot:2
+27 SET NOGO(0)=NOGO(0)+1
SET NOGO(NOGO(0))="Exam not queued: Missing exam pointer information for exam ("_DATA(IDATA)_")"
End DoDot:2
QUIT
+28 SET X=$$JBFETCH^MAGJUTL2(RARPT,.MAGS)
+29 FOR IMAG=1:1
SET MAGIEN=$PIECE($GET(MAGS(IMAG)),U,4)
if MAGIEN=""
QUIT
Begin DoDot:2
+30 DO SEND^MAGBRTUT(MAGIEN,RTLOC,RTPRI,RTTYP)
End DoDot:2
+31 IF IMAG>1
SET NEXAM=NEXAM+1
+32 IF '$TEST
SET NOGO(0)=NOGO(0)+1
SET NOGO(NOGO(0))="Exam not queued: No images found ("_DATA(IDATA)_")"
End DoDot:1
+33 IF NEXAM
SET REPLY=1_"~"_NEXAM_" Exam"_$SELECT(NEXAM-1:"s",1:"")_" were queued to be routed."
+34 IF '$TEST
SET REPLY="0~Unable to queue any exams for routing."
RTEXAMZ IF NOGO(0)
DO NOGO("Queued",.CT)
+1 SET @MAGGRY@(0)=$SELECT(NOGO(0):CT,1:0)_U_REPLY
+2 QUIT
+3 ;
END QUIT
+1 ;
