- RAORDQ ;HISC/CAH,FPT AISC/RMO-Queue Exam Request ; Jun 30, 2023@10:36:10
- ;;5.0;Radiology/Nuclear Medicine;**13,15,169,205**;Mar 16, 1998;Build 1
- ;
- ;w/RA*5.0*169 backdoor orders rejected by CPRS still prints
- ;a request (the RIS files pending before CPRS returns the
- ;cancellation) quitting on $D(RADERR) will prevent the print.
- I $D(RADERR)#2 K RADERR Q ;gjc RA5P169
- S:$D(RALOCFLG) RALOC=+$P(RAORD0,"^",20)
- ; Find 1st Imaging Location for Imaging Type, or default to 1st on file.
- ;
- ;*** P205/GJC from: ^RA(79.1,RALOC,"DIV")=+RADIV ***
- ;*** to: $G(^RA(79.1,RALOC,"DIV"))=+RADIV ***
- ;
- 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)]"",$G(^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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAORDQ 2400 printed Jan 18, 2025@03:39:17 Page 2
- RAORDQ ;HISC/CAH,FPT AISC/RMO-Queue Exam Request ; Jun 30, 2023@10:36:10
- +1 ;;5.0;Radiology/Nuclear Medicine;**13,15,169,205**;Mar 16, 1998;Build 1
- +2 ;
- +3 ;w/RA*5.0*169 backdoor orders rejected by CPRS still prints
- +4 ;a request (the RIS files pending before CPRS returns the
- +5 ;cancellation) quitting on $D(RADERR) will prevent the print.
- +6 ;gjc RA5P169
- IF $DATA(RADERR)#2
- KILL RADERR
- QUIT
- +7 if $DATA(RALOCFLG)
- SET RALOC=+$PIECE(RAORD0,"^",20)
- +8 ; Find 1st Imaging Location for Imaging Type, or default to 1st on file.
- +9 ;
- +10 ;*** P205/GJC from: ^RA(79.1,RALOC,"DIV")=+RADIV ***
- +11 ;*** to: $G(^RA(79.1,RALOC,"DIV"))=+RADIV ***
- +12 ;
- +13 IF '$DATA(RALOCFLG)
- Begin DoDot:1
- +14 SET RALOC=""
- +15 FOR
- SET RALOC=$ORDER(^RA(79.1,"BIMG",RAIMGTYI,RALOC))
- if RALOC=""
- QUIT
- IF $PIECE(^RA(79.1,RALOC,0),U,16)]""
- IF $GET(^RA(79.1,RALOC,"DIV"))=+RADIV
- QUIT
- End DoDot:1
- if RALOC=""
- SET RALOC=+$ORDER(^RA(79,+RADIV,"L",0))
- +16 SET RAREQPRT=$SELECT($DATA(^RA(79.1,+RALOC,0)):$PIECE(^(0),"^",16),1:"")
- +17 if RAREQPRT']""
- QUIT
- +18 SET RAREQPRT=$PIECE($GET(^%ZIS(1,RAREQPRT,0)),"^")
- if RAREQPRT']""
- QUIT
- +19 SET RAGMTS=+$PIECE($GET(^RAMIS(71,+$PIECE($GET(^RAO(75.1,RAOIFN,0)),"^",2),0)),"^",13)
- +20 SET RAHSMULT(RAGMTS,RADFN)=+$GET(RAHSMULT(RAGMTS,RADFN))+1
- +21 SET ION=RAREQPRT
- SET IOP="Q;"_ION
- SET ZTSAVE("RADFN")=""
- SET ZTSAVE("RAOIFN")=""
- +22 SET ZTSAVE("RALOC")=""
- SET ZTSAVE("RAGMTS")=""
- SET ZTSAVE("RAHSMULT(")=""
- +23 if $DATA(RAOPT)
- SET ZTSAVE("RAOPT(")=""
- if $DATA(RAFOERR)
- SET ZTSAVE("RAFOERR")=""
- +24 SET ZTDTH=$HOROLOG
- SET ZTRTN="PRTORD^RAORDQ"
- +25 if '$DATA(RAMES)
- SET RAMES="W !?5,""...request has been submitted to "",ION,""."",!"
- +26 DO ZIS^RAUTL
- KILL IOP,RALOC,RAREQPRT
- +27 QUIT
- +28 ;
- 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