RAORDQ ;HISC/CAH,FPT AISC/RMO-Queue Exam Request ;8/1/97 14:57
;;5.0;Radiology/Nuclear Medicine;**13,15**;Mar 16, 1998
;S RALOC=$S($D(RALOCFLG):+$P(RAORD0,"^",20),1:+$O(^RA(79,+RADIV,"L",0)))
S:$D(RALOCFLG) RALOC=+$P(RAORD0,"^",20)
; Find 1st Imaging Location for Imaging Type, or default to 1st on file.
I '$D(RALOCFLG) D S:RALOC="" RALOC=+$O(^RA(79,+RADIV,"L",0))
.S RALOC=""
.F S RALOC=$O(^RA(79.1,"BIMG",RAIMGTYI,RALOC)) Q:RALOC="" I $P(^RA(79.1,RALOC,0),U,16)]"",^RA(79.1,RALOC,"DIV")=+RADIV Q
S RAREQPRT=$S($D(^RA(79.1,+RALOC,0)):$P(^(0),"^",16),1:"")
Q:RAREQPRT']""
S RAREQPRT=$P($G(^%ZIS(1,RAREQPRT,0)),"^") Q:RAREQPRT']""
S RAGMTS=+$P($G(^RAMIS(71,+$P($G(^RAO(75.1,RAOIFN,0)),"^",2),0)),"^",13)
S RAHSMULT(RAGMTS,RADFN)=+$G(RAHSMULT(RAGMTS,RADFN))+1
S ION=RAREQPRT,IOP="Q;"_ION,ZTSAVE("RADFN")="",ZTSAVE("RAOIFN")=""
S ZTSAVE("RALOC")="",ZTSAVE("RAGMTS")="",ZTSAVE("RAHSMULT(")=""
S:$D(RAOPT) ZTSAVE("RAOPT(")="" S:$D(RAFOERR) ZTSAVE("RAFOERR")=""
S ZTDTH=$H,ZTRTN="PRTORD^RAORDQ"
S:'$D(RAMES) RAMES="W !?5,""...request has been submitted to "",ION,""."",!"
D ZIS^RAUTL K IOP,RALOC,RAREQPRT
Q
;
PRTORD ; Print Health Summary if applicable
; RAORD0 is defined in RAORD5
U IO S RAX="",RAPGE=0 D ^RAORD5
S GMTSTYP=RAGMTS
I GMTSTYP>0,($G(RAHSMULT(RAGMTS,RADFN))'>1) D
. W:$Y>0 @IOF D ENX^GMTSDVR(RADFN,GMTSTYP)
. Q
K RAOIFN,RAPGE,RAX
I GMTSTYP>0,($G(RAHSMULT(RAGMTS,RADFN))'>1) K GMTSTYP,RADFN Q
K GMTSTYP,RADFN W ! D CLOSE^RAUTL
Q
OERR ;OERR ENTRY POINT TO PRINT/DISPLAY A RAD/NUC MED REPORT
F RAI=0:0 S RAI=$O(RADUP(RAI)) Q:RAI'>0 S X=^TMP($J,"RAEX",RAI),RADUP(RAI)=$P(X,"^",10)_"^"_$P(X,"^",8)
S ZTSAVE("RADUP(")="",ZTRTN="DQ^RAORDQ",ZTDESC="Print Rad/Nuc Med Reports" D ZIS^RAUTL G Q:RAPOP I IO=IO(0) D OERR^RART1 G Q
DQ U IO F RAI1=0:0 S RAI1=$O(RADUP(RAI1)) Q:RAI1'>0 S RARPT=+RADUP(RAI1),RACN=$P(RADUP(RAI1),"^",2) D CHK^RART1 D:$D(RARPT) ^RARTR
Q I $D(RAMIE) F RAI1=0:0 S RAI1=$O(^RA(78.7,RAI1)) Q:RAI1'>0 I $D(^(RAI1,0)) K @$P(^(0),"^",5)
K RAI1,RADUP,RACN,RARPT,RAPOP D:'$D(RAMIE) CLOSE^RAUTL Q
RAORDQ ;HISC/CAH,FPT AISC/RMO-Queue Exam Request ;8/1/97 14:57
+1 ;;5.0;Radiology/Nuclear Medicine;**13,15**;Mar 16, 1998
+2 ;S RALOC=$S($D(RALOCFLG):+$P(RAORD0,"^",20),1:+$O(^RA(79,+RADIV,"L",0)))
+3 IF $DATA(RALOCFLG)
SET RALOC=+$PIECE(RAORD0,"^",20)
+4 ; Find 1st Imaging Location for Imaging Type, or default to 1st on file.
+5 IF '$DATA(RALOCFLG)
Begin DoDot:1
+6 SET RALOC=""
+7 FOR
SET RALOC=$ORDER(^RA(79.1,"BIMG",RAIMGTYI,RALOC))
IF RALOC=""
QUIT
IF $PIECE(^RA(79.1,RALOC,0),U,16)]""
IF ^RA(79.1,RALOC,"DIV")=+RADIV
QUIT
End DoDot:1
IF RALOC=""
SET RALOC=+$ORDER(^RA(79,+RADIV,"L",0))
+8 SET RAREQPRT=$SELECT($DATA(^RA(79.1,+RALOC,0)):$PIECE(^(0),"^",16),1:"")
+9 IF RAREQPRT']""
QUIT
+10 SET RAREQPRT=$PIECE($GET(^%ZIS(1,RAREQPRT,0)),"^")
IF RAREQPRT']""
QUIT
+11 SET RAGMTS=+$PIECE($GET(^RAMIS(71,+$PIECE($GET(^RAO(75.1,RAOIFN,0)),"^",2),0)),"^",13)
+12 SET RAHSMULT(RAGMTS,RADFN)=+$GET(RAHSMULT(RAGMTS,RADFN))+1
+13 SET ION=RAREQPRT
SET IOP="Q;"_ION
SET ZTSAVE("RADFN")=""
SET ZTSAVE("RAOIFN")=""
+14 SET ZTSAVE("RALOC")=""
SET ZTSAVE("RAGMTS")=""
SET ZTSAVE("RAHSMULT(")=""
+15 IF $DATA(RAOPT)
SET ZTSAVE("RAOPT(")=""
IF $DATA(RAFOERR)
SET ZTSAVE("RAFOERR")=""
+16 SET ZTDTH=$HOROLOG
SET ZTRTN="PRTORD^RAORDQ"
+17 IF '$DATA(RAMES)
SET RAMES="W !?5,""...request has been submitted to "",ION,""."",!"
+18 DO ZIS^RAUTL
KILL IOP,RALOC,RAREQPRT
+19 QUIT
+20 ;
PRTORD ; Print Health Summary if applicable
+1 ; RAORD0 is defined in RAORD5
+2 USE IO
SET RAX=""
SET RAPGE=0
DO ^RAORD5
+3 SET GMTSTYP=RAGMTS
+4 IF GMTSTYP>0
IF ($GET(RAHSMULT(RAGMTS,RADFN))'>1)
Begin DoDot:1
+5 IF $Y>0
WRITE @IOF
DO ENX^GMTSDVR(RADFN,GMTSTYP)
+6 QUIT
End DoDot:1
+7 KILL RAOIFN,RAPGE,RAX
+8 IF GMTSTYP>0
IF ($GET(RAHSMULT(RAGMTS,RADFN))'>1)
KILL GMTSTYP,RADFN
QUIT
+9 KILL GMTSTYP,RADFN
WRITE !
DO CLOSE^RAUTL
+10 QUIT
OERR ;OERR ENTRY POINT TO PRINT/DISPLAY A RAD/NUC MED REPORT
+1 FOR RAI=0:0
SET RAI=$ORDER(RADUP(RAI))
IF RAI'>0
QUIT
SET X=^TMP($JOB,"RAEX",RAI)
SET RADUP(RAI)=$PIECE(X,"^",10)_"^"_$PIECE(X,"^",8)
+2 SET ZTSAVE("RADUP(")=""
SET ZTRTN="DQ^RAORDQ"
SET ZTDESC="Print Rad/Nuc Med Reports"
DO ZIS^RAUTL
IF RAPOP
GOTO Q
IF IO=IO(0)
DO OERR^RART1
GOTO Q
DQ USE IO
FOR RAI1=0:0
SET RAI1=$ORDER(RADUP(RAI1))
IF RAI1'>0
QUIT
SET RARPT=+RADUP(RAI1)
SET RACN=$PIECE(RADUP(RAI1),"^",2)
DO CHK^RART1
IF $DATA(RARPT)
DO ^RARTR
Q IF $DATA(RAMIE)
FOR RAI1=0:0
SET RAI1=$ORDER(^RA(78.7,RAI1))
IF RAI1'>0
QUIT
IF $DATA(^(RAI1,0))
KILL @$PIECE(^(0),"^",5)
+1 KILL RAI1,RADUP,RACN,RARPT,RAPOP
IF '$DATA(RAMIE)
DO CLOSE^RAUTL
QUIT
