RAO7RO ;HISC/GJC,FPT - Request message from OE/RR. ; Jan 06, 2022@14:01:35
;;5.0;Radiology/Nuclear Medicine;**1,2,13,15,75,145,169,185**;Mar 16, 1998;Build 1
;
;ICR# referenced IA reference type
;------------------------------------------------------
;10103 $$DOW^XLFDT Supported
;10038 ^HOLIDAY Supported
;
;
;------------------------- Variable List -------------------------------
; RAFLG=flag indicates ORC reached RAHLFS="|"
; RAMSG=HL7 message passed in RAORD=ORC-1 (Order control)
; RAPLCHLD=Tracks place holder values for adding entries to sub-files
; in the Rad/Nuc Med Orders file.
; RASEG=specific HL7 node X=subscript of HL7 node
; ----------------------------------------------------------------------
;
EN1(RAMSG) ; Pass in the message from OE/RR. Decipher information.
; new variables for RAO7RO processing
N A,AAH,ARR,CHAR,CNT,DFN,ERR,FLG,GMTSTYP,I,J,L,LEN,MSG,RA,RA0
N RA7003,RA71,RA713,RA783,RAA,RAB,RAC,RACLIN,RACMCODE,RACMNOR
N RACNT,RACOST,RACPT,RACPTIEN,RAD0,RADATA,RADBS,RADC,RADFN,RADUZ
N RAECH,RAEMSG,RAERR,RAFDA,RAFLG,RAFNAME,RAFNUM,RAHDR,RAHLFS
N RAIEN71,RAIL,RAIMGAB,RAIMGTYI,RAINCR,RAION,RAIT,RALDT,RALINEX,RALOC
N RAMFE,RAMODIEN,RAMSH3,RAMULT,RANEW,RANOW,RANSTAT,RAOBR18,RAOBR19
N RAOBR30,RAOBR4,RAOBX2,RAOBX3,RAOBX5,RAOIFN,RAORC1,RAORC10,RAORC11
N RAORC12,RAORC15,RAORC16,RAORC2,RAORC3,RAORC7,RAORC7D,RAORC7P
N RAORD,RAPGE,RAPLCHLD,RAPREG,RAPHYAP,RAPID3,RAPID5,RAPRCTY
N RAPV119,RAPV12,RAPV13,RAREA,RARMBED,RASEG,RASTATUS,RASUB
N RATSTMP,RAVAR,RAWARD,RAWP,RAX,RAXIT,RAXT71,RAY,RAZ,T1,T2,T3
N VAIP,X,Y,Y1,Y2,Y3,Y4,Y5,Z,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
S X=^%ZOSF("ERRTN"),@^%ZOSF("TRAP")
S (RAFLG,X)=0,RAPLCHLD=1
D EN1^RAO7UTL ; setup field seperator data (see var list)
S RALDT=$$NOW^XLFDT() ; setup 'Last Activity Date/Time'
F S X=$O(RAMSG(X)) Q:X'>0 D Q:RAFLG
. S RASEG=$G(RAMSG(X)) Q:$P(RASEG,RAHLFS)'="ORC" ; quit if not ORC
. S RAORD=$P(RASEG,RAHLFS,2),RAFLG=1
. Q
I RAORD'="NW"&(RAORD'="DC")&(RAORD'="NA")&(RAORD'="DE")&(RAORD'="Z@") D BRKOUT^RAO7UTL1,REJ^RAO7OKS("OC","Missing/Invalid Order Control") Q
I RAORD="NW" D EN1^RAO7RON(.RAMSG) D
.I $G(RAERR) D Q
..S RAERR1="" I RAERR=35 I $G(RANOW) S RAERR1="Now="_RANOW
..I RAERR=35 S RAERR1=RAERR1_" Req Entered Dt="_$G(RAORC15)
..S RAERR=$$EN1^RAO7RO1(RAERR)_" "_$G(RAERR1) K RAERR1
..D REJ^RAO7OKS("OC",RAERR) Q
.;if CLINICAL HISTORY was passed from CPRS and it failed the CLINICAL HISTORY data
.;requirements, reject the message
.I $P(RACLIN,U)=1,$P(RACLIN,U,2)'=1 S RAERR=$$EN1^RAO7RO1(15) D REJ^RAO7OKS("OC",RAERR) Q
.K ERR
.; Update 'REQUEST STATUS TIMES' multiple if parameter dictates!
.I "Yy"[RADIV(.119) D
..; make sure that the activity log place holders differ from the
..; modifiers place holders
..S RAPLCHLD=RAPLCHLD+1
..S RANEW(75.12,"+"_RAPLCHLD_",+1,",.01)=RALDT
..S RANEW(75.12,"+"_RAPLCHLD_",+1,",2)=5
..S RANEW(75.12,"+"_RAPLCHLD_",+1,",3)=+RAORC10
..Q
.D UPDATE^DIE("","RANEW","RAORC3","ERR") S RAORC3=+$G(RAORC3(1))
.S RAORC3=$G(RAORC3)_"^RA"
.I $D(ERR) S RAERR=$$EN1^RAO7RO1(21) D REJ^RAO7OKS("OC",RAERR) Q
.D WP^DIE(75.1,+RAORC3_",",400,"K","^TMP(""RAWP"",$J)","ERR")
.D ACC^RAO7OKS("OK","","","","")
.; Prt request on im'g loc req prtr; if no im'g loc on the HL7 msg
.; check for prtr on first entry in Im'g Loc file; if no prtr on
.; first entry, don't print request
. S RAO751=$G(^RAO(75.1,+RAORC3,0))
. D:$P(RAO751,"^",6)=1!($P(RAO751,"^",6)=2) OENO^RAUTL19(+RAORC3)
. K RAO751 ; fire off 'stat' or 'urgent' alert if order qualifies
. ; print the request
. I +RAOBR19(3)>0 D ARPTR ;p185 - check alternate printer first
. I +RAOBR19(3)>0 D S:RAION="" RAION=$P($G(^RA(79.1,+RAOBR19(3),0)),U,16)
. ;I +RAOBR19(3)=0 S RAION=$P($G(^RA(79.1,+$O(^RA(79.1,0)),0)),U,16)
. I +RAOBR19(3)=0 D S:RAION="" RAION=$P($G(^RA(79.1,+$O(^RA(79.1,0)),0)),U,16)
.. S (RALOC,RAION)=""
.. ; Get Imaging Type of Procedure..
.. S RAIMGTYI=$P(^RAMIS(71,RAOBR4(4),0),U,12) Q:RAIMGTYI=""
.. F S RALOC=$O(^RA(79.1,"BIMG",RAIMGTYI,RALOC)) Q:RALOC="" D Q:RAION]""
... ; Find Imaging Location within Imaging Type with Request device..
... Q:$P(^RA(79.1,RALOC,0),U,16)=""
...; p.145 MWA missing "DIV" node causes error added $G()
... Q:$G(^RA(79.1,RALOC,"DIV"))'=+$$KSP^XUPARAM("INST")
... S RAION=$P(^RA(79.1,RALOC,0),U,16)
. I RAION]"" D
.. D PSETUP Q:RAION']""
.. S ZTDTH=$H,ZTRTN="PRHS^RAO7RO",ZTIO=RAION
.. S ZTDESC="Rad/Nuc Med Request print - frontdoor (CPRS)"
.. D ^%ZTLOAD,HOME^%ZIS
.. K ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
.. Q
. Q
;
I RAORD="Z@" N RAPUROK D EN2^RAO7PURG(.RAMSG) D ; RAPUROK set in
. ; EN2^RAO7PURG. If RAPUROK=1 send ok msg, else send reject msg
. I $G(RAERR) D REJ^RAO7OKS("ZU","") Q
. D:'RAPUROK REJ^RAO7OKS("ZU","")
. D:RAPUROK ACC^RAO7OKS("ZR","","","","")
. Q
I RAORD="DC" D EN1^RAO7RCH(.RAMSG) D
.I $G(RAERR) S RAERR=$$EN1^RAO7RO1(RAERR) D REJ^RAO7OKS("UD",RAERR) Q
.K ERR D FILE^DIE("K","RANEW","ERR")
.I $D(ERR) S RAERR=$$EN1^RAO7RO1(37) D REJ^RAO7OKS("UD",RAERR) Q
.D OE3^RABUL(+RAORC3) ; rad/nuc med request cancelled bulletin
.I "Yy"[RADIV(.119) D Q:$G(RAERR)
..N ERR
..S ERR=$$EN5^RAO7VLD(+RAORC3,1,+RAORC10,"")
..I +$G(ERR) S RAERR=$$EN1^RAO7RO1(30) D REJ^RAO7OKS("UD",RAERR) Q
..Q
.D ACC^RAO7OKS("DR","","","","")
.; print out the cancelled request
.S RAIMJLOC=+$P($G(^RAO(75.1,+RAORC3,0)),"^",20)
.I RAIMJLOC>0 S RAION=$P($G(^RA(79.1,RAIMJLOC,0)),U,24)
.I RAIMJLOC=0 S RAION=$P($G(^RA(79.1,+$O(^RA(79.1,0)),0)),U,24)
.I RAION]"" D
..D PSETUP Q:RAION']""
..S RACRHD="" ; set the cancelled request flag
..S ZTDESC="Rad/Nuc Med Cancelled Request print - frontdoor (CPRS)"
..S ZTIO=RAION,ZTDTH=$H,ZTRTN="PRHS^RAO7RO",ZTSAVE("RACRHD")=""
..D ^%ZTLOAD,HOME^%ZIS
..K RACRHD,RAIMJLOC,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
..Q
.Q
;
;For an order control of: 'NA', we error if one of these three
;conditions are true:
;1) if the ien of the Rad/Nuc Med Order is not valid
;2) patient file pointer (PID3) evaluates to a different
; patient name than the PID5 value
;3) cannot file oerr order ien into file 75.1
;
I RAORD="NA" D EN1^RAO7OKR(.RAMSG) I $G(RAERR) D
. N RATXT S RATXT="Error for order control: 'NA'"
. S:RAERR'?1N.N RAERR="error not found in our error table"
. S:RAERR?1N.N RAERR=$$EN1^RAO7RO1(RAERR)
. S:$D(XQY0)#2 RAVAR("XQY0")="" S RAVAR("RAERR")=""
. D ERR^RAO7UTL(RATXT,.RAMSG,.RAVAR)
. Q
;
;an order control of 'DE' means that CPRS rejected the backdoor order. the
;RIS must update the radiology order correctly (REQUEST STATUS = 'CANCELLED')
;RA5P169
I RAORD="DE" DO EN1^RAO7ROCN(.RAMSG)
;purge DBS specific variables before exiting
;
PURGE ; kill & quit
D CLEAN^DILF
K ^TMP("RAWP",$J)
Q
PRHS ; print request and/or health summary
U IO D ^RAORD5 ; print the request
S:'$D(RACRHD) GMTSTYP=$P($G(^RAMIS(71,+$G(RAOBR4(4)),0)),U,13)
I +$G(GMTSTYP) D ; don't print Health Summary with cancelled requests
. W:$Y @IOF D ENX^GMTSDVR(RADFN,GMTSTYP)
. Q
W ! D CLOSE^RAUTL
Q
PSETUP ; Define the variables needed to print cancelled and non-cancelled
; requests from the frontdoor (CPRS).
I RAION'?1N.N S RAION=$O(^%ZIS(1,"B",RAION,0)) Q:RAION']""
S RAION=$P($G(^%ZIS(1,RAION,0)),"^") Q:RAION']""
S RAOIFN=+RAORC3,RAPAGE=0,RAX="",RADFN=RAPID3
N RAFOERR S RAFOERR="" ; flag to indicate entry from frontdoor (CPRS)
F RAI="RADFN","RAOIFN","RAX","RAPGE","RAOBR4(","RAFOERR" S ZTSAVE(RAI)=""
S:$D(RAIL) ZTSAVE("RAIL")=""
Q
ARPTR ;p185/KLM Determine if After Hours request printer should be used
N RAF,RAHP,RART,RADOW,RARU S RAF=0
;Get alternate request printer parameters
S RAHP=$G(^RA(79.1,+RAOBR19(3),"ARP")) Q:'$D(RAHP)
;Is there an alternate printer defined?
S RAION=$P($G(RAHP),U) Q:RAION=""
;What is the printer usage? After Hours or Alternate?
S RARU=$P($G(RAHP),U,2) Q:'RARU
I RARU=1 D ARP1 Q
I RARU=2 D ARP2 Q
Q
ARP1 ;usage is after hours printing - check time etc
;Time of the request
S RART=$E($P(RALDT,".",2),1,4)_"00"
;Is it after hours?
I RART>$P(RAHP,U,3)!(RART<$P(RAHP,U,4)) S RAF=1
;Is it the weekend? IA10103
I RAF=0,$P(RAHP,U,5)="Y" S RADOW=$$DOW^XLFDT(RALDT) S:(RADOW["Saturday")!(RADOW["Sunday") RAF=1
;Is it a holiday? IA10038
I RAF=0,$P(RAHP,U,6)="Y",$$FIND1^DIC(40.5,"","X",$P(RALDT,"."))>0 S RAF=1
;Category of request (I/O/A)
I RAF=1 S:($P(RAHP,U,7)'="A")&($P(RAHP,U,7)'=RAPV12) RAF=0
;Not after hours, remove alt printer
I RAF=0 S RAION=""
Q
ARP2 ;Not for afterhours printing, check req location and pt class
I $O(^RA(79.1,+RAOBR19(3),"ARPL","B",RAPV13,0)) Q
;Category of request to print? RAPV12 is patient class passed from CPRS
I ($P(RAHP,U,7)="A")!(($P(RAHP,U,7))=RAPV12) Q
S RAION="" ;not alternate print candidate - remove alt printer
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAO7RO 8979 printed Dec 13, 2024@02:37:52 Page 2
RAO7RO ;HISC/GJC,FPT - Request message from OE/RR. ; Jan 06, 2022@14:01:35
+1 ;;5.0;Radiology/Nuclear Medicine;**1,2,13,15,75,145,169,185**;Mar 16, 1998;Build 1
+2 ;
+3 ;ICR# referenced IA reference type
+4 ;------------------------------------------------------
+5 ;10103 $$DOW^XLFDT Supported
+6 ;10038 ^HOLIDAY Supported
+7 ;
+8 ;
+9 ;------------------------- Variable List -------------------------------
+10 ; RAFLG=flag indicates ORC reached RAHLFS="|"
+11 ; RAMSG=HL7 message passed in RAORD=ORC-1 (Order control)
+12 ; RAPLCHLD=Tracks place holder values for adding entries to sub-files
+13 ; in the Rad/Nuc Med Orders file.
+14 ; RASEG=specific HL7 node X=subscript of HL7 node
+15 ; ----------------------------------------------------------------------
+16 ;
EN1(RAMSG) ; Pass in the message from OE/RR. Decipher information.
+1 ; new variables for RAO7RO processing
+2 NEW A,AAH,ARR,CHAR,CNT,DFN,ERR,FLG,GMTSTYP,I,J,L,LEN,MSG,RA,RA0
+3 NEW RA7003,RA71,RA713,RA783,RAA,RAB,RAC,RACLIN,RACMCODE,RACMNOR
+4 NEW RACNT,RACOST,RACPT,RACPTIEN,RAD0,RADATA,RADBS,RADC,RADFN,RADUZ
+5 NEW RAECH,RAEMSG,RAERR,RAFDA,RAFLG,RAFNAME,RAFNUM,RAHDR,RAHLFS
+6 NEW RAIEN71,RAIL,RAIMGAB,RAIMGTYI,RAINCR,RAION,RAIT,RALDT,RALINEX,RALOC
+7 NEW RAMFE,RAMODIEN,RAMSH3,RAMULT,RANEW,RANOW,RANSTAT,RAOBR18,RAOBR19
+8 NEW RAOBR30,RAOBR4,RAOBX2,RAOBX3,RAOBX5,RAOIFN,RAORC1,RAORC10,RAORC11
+9 NEW RAORC12,RAORC15,RAORC16,RAORC2,RAORC3,RAORC7,RAORC7D,RAORC7P
+10 NEW RAORD,RAPGE,RAPLCHLD,RAPREG,RAPHYAP,RAPID3,RAPID5,RAPRCTY
+11 NEW RAPV119,RAPV12,RAPV13,RAREA,RARMBED,RASEG,RASTATUS,RASUB
+12 NEW RATSTMP,RAVAR,RAWARD,RAWP,RAX,RAXIT,RAXT71,RAY,RAZ,T1,T2,T3
+13 NEW VAIP,X,Y,Y1,Y2,Y3,Y4,Y5,Z,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
+14 SET X=^%ZOSF("ERRTN")
SET @^%ZOSF("TRAP")
+15 SET (RAFLG,X)=0
SET RAPLCHLD=1
+16 ; setup field seperator data (see var list)
DO EN1^RAO7UTL
+17 ; setup 'Last Activity Date/Time'
SET RALDT=$$NOW^XLFDT()
+18 FOR
SET X=$ORDER(RAMSG(X))
if X'>0
QUIT
Begin DoDot:1
+19 ; quit if not ORC
SET RASEG=$GET(RAMSG(X))
if $PIECE(RASEG,RAHLFS)'="ORC"
QUIT
+20 SET RAORD=$PIECE(RASEG,RAHLFS,2)
SET RAFLG=1
+21 QUIT
End DoDot:1
if RAFLG
QUIT
+22 IF RAORD'="NW"&(RAORD'="DC")&(RAORD'="NA")&(RAORD'="DE")&(RAORD'="Z@")
DO BRKOUT^RAO7UTL1
DO REJ^RAO7OKS("OC","Missing/Invalid Order Control")
QUIT
+23 IF RAORD="NW"
DO EN1^RAO7RON(.RAMSG)
Begin DoDot:1
+24 IF $GET(RAERR)
Begin DoDot:2
+25 SET RAERR1=""
IF RAERR=35
IF $GET(RANOW)
SET RAERR1="Now="_RANOW
+26 IF RAERR=35
SET RAERR1=RAERR1_" Req Entered Dt="_$GET(RAORC15)
+27 SET RAERR=$$EN1^RAO7RO1(RAERR)_" "_$GET(RAERR1)
KILL RAERR1
+28 DO REJ^RAO7OKS("OC",RAERR)
QUIT
End DoDot:2
QUIT
+29 ;if CLINICAL HISTORY was passed from CPRS and it failed the CLINICAL HISTORY data
+30 ;requirements, reject the message
+31 IF $PIECE(RACLIN,U)=1
IF $PIECE(RACLIN,U,2)'=1
SET RAERR=$$EN1^RAO7RO1(15)
DO REJ^RAO7OKS("OC",RAERR)
QUIT
+32 KILL ERR
+33 ; Update 'REQUEST STATUS TIMES' multiple if parameter dictates!
+34 IF "Yy"[RADIV(.119)
Begin DoDot:2
+35 ; make sure that the activity log place holders differ from the
+36 ; modifiers place holders
+37 SET RAPLCHLD=RAPLCHLD+1
+38 SET RANEW(75.12,"+"_RAPLCHLD_",+1,",.01)=RALDT
+39 SET RANEW(75.12,"+"_RAPLCHLD_",+1,",2)=5
+40 SET RANEW(75.12,"+"_RAPLCHLD_",+1,",3)=+RAORC10
+41 QUIT
End DoDot:2
+42 DO UPDATE^DIE("","RANEW","RAORC3","ERR")
SET RAORC3=+$GET(RAORC3(1))
+43 SET RAORC3=$GET(RAORC3)_"^RA"
+44 IF $DATA(ERR)
SET RAERR=$$EN1^RAO7RO1(21)
DO REJ^RAO7OKS("OC",RAERR)
QUIT
+45 DO WP^DIE(75.1,+RAORC3_",",400,"K","^TMP(""RAWP"",$J)","ERR")
+46 DO ACC^RAO7OKS("OK","","","","")
+47 ; Prt request on im'g loc req prtr; if no im'g loc on the HL7 msg
+48 ; check for prtr on first entry in Im'g Loc file; if no prtr on
+49 ; first entry, don't print request
+50 SET RAO751=$GET(^RAO(75.1,+RAORC3,0))
+51 if $PIECE(RAO751,"^",6)=1!($PIECE(RAO751,"^",6)=2)
DO OENO^RAUTL19(+RAORC3)
+52 ; fire off 'stat' or 'urgent' alert if order qualifies
KILL RAO751
+53 ; print the request
+54 ;p185 - check alternate printer first
IF +RAOBR19(3)>0
DO ARPTR
+55 IF +RAOBR19(3)>0
Begin DoDot:2
End DoDot:2
if RAION=""
SET RAION=$PIECE($GET(^RA(79.1,+RAOBR19(3),0)),U,16)
+56 ;I +RAOBR19(3)=0 S RAION=$P($G(^RA(79.1,+$O(^RA(79.1,0)),0)),U,16)
+57 IF +RAOBR19(3)=0
Begin DoDot:2
+58 SET (RALOC,RAION)=""
+59 ; Get Imaging Type of Procedure..
+60 SET RAIMGTYI=$PIECE(^RAMIS(71,RAOBR4(4),0),U,12)
if RAIMGTYI=""
QUIT
+61 FOR
SET RALOC=$ORDER(^RA(79.1,"BIMG",RAIMGTYI,RALOC))
if RALOC=""
QUIT
Begin DoDot:3
+62 ; Find Imaging Location within Imaging Type with Request device..
+63 if $PIECE(^RA(79.1,RALOC,0),U,16)=""
QUIT
+64 ; p.145 MWA missing "DIV" node causes error added $G()
+65 if $GET(^RA(79.1,RALOC,"DIV"))'=+$$KSP^XUPARAM("INST")
QUIT
+66 SET RAION=$PIECE(^RA(79.1,RALOC,0),U,16)
End DoDot:3
if RAION]""
QUIT
End DoDot:2
if RAION=""
SET RAION=$PIECE($GET(^RA(79.1,+$ORDER(^RA(79.1,0)),0)),U,16)
+67 IF RAION]""
Begin DoDot:2
+68 DO PSETUP
if RAION']""
QUIT
+69 SET ZTDTH=$HOROLOG
SET ZTRTN="PRHS^RAO7RO"
SET ZTIO=RAION
+70 SET ZTDESC="Rad/Nuc Med Request print - frontdoor (CPRS)"
+71 DO ^%ZTLOAD
DO HOME^%ZIS
+72 KILL ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
+73 QUIT
End DoDot:2
+74 QUIT
End DoDot:1
+75 ;
+76 ; RAPUROK set in
IF RAORD="Z@"
NEW RAPUROK
DO EN2^RAO7PURG(.RAMSG)
Begin DoDot:1
+77 ; EN2^RAO7PURG. If RAPUROK=1 send ok msg, else send reject msg
+78 IF $GET(RAERR)
DO REJ^RAO7OKS("ZU","")
QUIT
+79 if 'RAPUROK
DO REJ^RAO7OKS("ZU","")
+80 if RAPUROK
DO ACC^RAO7OKS("ZR","","","","")
+81 QUIT
End DoDot:1
+82 IF RAORD="DC"
DO EN1^RAO7RCH(.RAMSG)
Begin DoDot:1
+83 IF $GET(RAERR)
SET RAERR=$$EN1^RAO7RO1(RAERR)
DO REJ^RAO7OKS("UD",RAERR)
QUIT
+84 KILL ERR
DO FILE^DIE("K","RANEW","ERR")
+85 IF $DATA(ERR)
SET RAERR=$$EN1^RAO7RO1(37)
DO REJ^RAO7OKS("UD",RAERR)
QUIT
+86 ; rad/nuc med request cancelled bulletin
DO OE3^RABUL(+RAORC3)
+87 IF "Yy"[RADIV(.119)
Begin DoDot:2
+88 NEW ERR
+89 SET ERR=$$EN5^RAO7VLD(+RAORC3,1,+RAORC10,"")
+90 IF +$GET(ERR)
SET RAERR=$$EN1^RAO7RO1(30)
DO REJ^RAO7OKS("UD",RAERR)
QUIT
+91 QUIT
End DoDot:2
if $GET(RAERR)
QUIT
+92 DO ACC^RAO7OKS("DR","","","","")
+93 ; print out the cancelled request
+94 SET RAIMJLOC=+$PIECE($GET(^RAO(75.1,+RAORC3,0)),"^",20)
+95 IF RAIMJLOC>0
SET RAION=$PIECE($GET(^RA(79.1,RAIMJLOC,0)),U,24)
+96 IF RAIMJLOC=0
SET RAION=$PIECE($GET(^RA(79.1,+$ORDER(^RA(79.1,0)),0)),U,24)
+97 IF RAION]""
Begin DoDot:2
+98 DO PSETUP
if RAION']""
QUIT
+99 ; set the cancelled request flag
SET RACRHD=""
+100 SET ZTDESC="Rad/Nuc Med Cancelled Request print - frontdoor (CPRS)"
+101 SET ZTIO=RAION
SET ZTDTH=$HOROLOG
SET ZTRTN="PRHS^RAO7RO"
SET ZTSAVE("RACRHD")=""
+102 DO ^%ZTLOAD
DO HOME^%ZIS
+103 KILL RACRHD,RAIMJLOC,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
+104 QUIT
End DoDot:2
+105 QUIT
End DoDot:1
+106 ;
+107 ;For an order control of: 'NA', we error if one of these three
+108 ;conditions are true:
+109 ;1) if the ien of the Rad/Nuc Med Order is not valid
+110 ;2) patient file pointer (PID3) evaluates to a different
+111 ; patient name than the PID5 value
+112 ;3) cannot file oerr order ien into file 75.1
+113 ;
+114 IF RAORD="NA"
DO EN1^RAO7OKR(.RAMSG)
IF $GET(RAERR)
Begin DoDot:1
+115 NEW RATXT
SET RATXT="Error for order control: 'NA'"
+116 if RAERR'?1N.N
SET RAERR="error not found in our error table"
+117 if RAERR?1N.N
SET RAERR=$$EN1^RAO7RO1(RAERR)
+118 if $DATA(XQY0)#2
SET RAVAR("XQY0")=""
SET RAVAR("RAERR")=""
+119 DO ERR^RAO7UTL(RATXT,.RAMSG,.RAVAR)
+120 QUIT
End DoDot:1
+121 ;
+122 ;an order control of 'DE' means that CPRS rejected the backdoor order. the
+123 ;RIS must update the radiology order correctly (REQUEST STATUS = 'CANCELLED')
+124 ;RA5P169
+125 IF RAORD="DE"
DO EN1^RAO7ROCN(.RAMSG)
+126 ;purge DBS specific variables before exiting
+127 ;
PURGE ; kill & quit
+1 DO CLEAN^DILF
+2 KILL ^TMP("RAWP",$JOB)
+3 QUIT
PRHS ; print request and/or health summary
+1 ; print the request
USE IO
DO ^RAORD5
+2 if '$DATA(RACRHD)
SET GMTSTYP=$PIECE($GET(^RAMIS(71,+$GET(RAOBR4(4)),0)),U,13)
+3 ; don't print Health Summary with cancelled requests
IF +$GET(GMTSTYP)
Begin DoDot:1
+4 if $Y
WRITE @IOF
DO ENX^GMTSDVR(RADFN,GMTSTYP)
+5 QUIT
End DoDot:1
+6 WRITE !
DO CLOSE^RAUTL
+7 QUIT
PSETUP ; Define the variables needed to print cancelled and non-cancelled
+1 ; requests from the frontdoor (CPRS).
+2 IF RAION'?1N.N
SET RAION=$ORDER(^%ZIS(1,"B",RAION,0))
if RAION']""
QUIT
+3 SET RAION=$PIECE($GET(^%ZIS(1,RAION,0)),"^")
if RAION']""
QUIT
+4 SET RAOIFN=+RAORC3
SET RAPAGE=0
SET RAX=""
SET RADFN=RAPID3
+5 ; flag to indicate entry from frontdoor (CPRS)
NEW RAFOERR
SET RAFOERR=""
+6 FOR RAI="RADFN","RAOIFN","RAX","RAPGE","RAOBR4(","RAFOERR"
SET ZTSAVE(RAI)=""
+7 if $DATA(RAIL)
SET ZTSAVE("RAIL")=""
+8 QUIT
ARPTR ;p185/KLM Determine if After Hours request printer should be used
+1 NEW RAF,RAHP,RART,RADOW,RARU
SET RAF=0
+2 ;Get alternate request printer parameters
+3 SET RAHP=$GET(^RA(79.1,+RAOBR19(3),"ARP"))
if '$DATA(RAHP)
QUIT
+4 ;Is there an alternate printer defined?
+5 SET RAION=$PIECE($GET(RAHP),U)
if RAION=""
QUIT
+6 ;What is the printer usage? After Hours or Alternate?
+7 SET RARU=$PIECE($GET(RAHP),U,2)
if 'RARU
QUIT
+8 IF RARU=1
DO ARP1
QUIT
+9 IF RARU=2
DO ARP2
QUIT
+10 QUIT
ARP1 ;usage is after hours printing - check time etc
+1 ;Time of the request
+2 SET RART=$EXTRACT($PIECE(RALDT,".",2),1,4)_"00"
+3 ;Is it after hours?
+4 IF RART>$PIECE(RAHP,U,3)!(RART<$PIECE(RAHP,U,4))
SET RAF=1
+5 ;Is it the weekend? IA10103
+6 IF RAF=0
IF $PIECE(RAHP,U,5)="Y"
SET RADOW=$$DOW^XLFDT(RALDT)
if (RADOW["Saturday")!(RADOW["Sunday")
SET RAF=1
+7 ;Is it a holiday? IA10038
+8 IF RAF=0
IF $PIECE(RAHP,U,6)="Y"
IF $$FIND1^DIC(40.5,"","X",$PIECE(RALDT,"."))>0
SET RAF=1
+9 ;Category of request (I/O/A)
+10 IF RAF=1
if ($PIECE(RAHP,U,7)'="A")&($PIECE(RAHP,U,7)'=RAPV12)
SET RAF=0
+11 ;Not after hours, remove alt printer
+12 IF RAF=0
SET RAION=""
+13 QUIT
ARP2 ;Not for afterhours printing, check req location and pt class
+1 IF $ORDER(^RA(79.1,+RAOBR19(3),"ARPL","B",RAPV13,0))
QUIT
+2 ;Category of request to print? RAPV12 is patient class passed from CPRS
+3 IF ($PIECE(RAHP,U,7)="A")!(($PIECE(RAHP,U,7))=RAPV12)
QUIT
+4 ;not alternate print candidate - remove alt printer
SET RAION=""
+5 QUIT
