RAORDU ;HISC/CAH - AISC/RMO-Update Request Status ; Nov 08, 2022@12:44:16
;;5.0;Radiology/Nuclear Medicine;**18,41,57,133,192,196**;Mar 16, 1998;Build 1
; last modif JULY 5,00
;The variables RAOIFN and RAOSTS must be defined. The variable
;RAOREA is set when Canceling and Holding a request. The
;variable RAOSCH is set when Scheduling a request.
; RAOSTS=request status of exam
; RAESTAT=min stat exams same dt/tm^max stat^1(if stat found) 0(else)
N RAESTAT
I RAOSTS=2,($$PARNT^RASETU(RAOIFN,RADFN)),($P($G(RAEXM0),"^",25)) D Q:RAOSTS=6
. S RAESTAT=$$EN1^RASETU(RAOIFN,RADFN)
. S RAOSTS=$S((+RAESTAT'<1)&(+RAESTAT'>8):6,1:RAOSTS)
. K:RAOSTS=6 ORIFN,ORETURN
. I '$D(RAF1),(+RAESTAT=9),($$CICHO^RAORDC1()=1) D ;p192
.. W !?3,"...will now designate request status as 'COMPLETE'..."
.. W !?10,"...request status successfully updated."
.. Q
. Q
I $D(ORSTS),ORSTS=11,$P(^RAO(75.1,RAOIFN,0),"^",5)=11 S ORIFN=+$P(^(0),"^",7),ORSTS="K",DA=RAOIFN,DIK="^RAO(75.1," D DELETE,^DIK K DIK D:ORIFN ST^ORX K ORSTS Q
K N I $D(RAOREA)>1 S N=$S($D(RAOIFN):RAOIFN,$D(ORPK):ORPK,1:1) I '$D(RAOREA(N)) S N=$O(RAOREA(0))
S DA=RAOIFN,DIE="^RAO(75.1,",DR="10///"_$S($D(RAOREA)&(RAOSTS=1!(RAOSTS=3)):"/^S X="_$S($D(N):RAOREA(N),1:RAOREA),'$D(^RAO(75.1,RAOIFN,0)):"",$P(^(0),"^",10):"@",1:"")_";I 1;5///^S X="_RAOSTS
I $D(RAVSTFLG),$D(RAVLEDTI) S DR=DR_";17///^S X="_(9999999.9999-RAVLEDTI)
I $D(RAOPT("CCR")),RAOSTS=3 S DR=DR_";201///1" ;p196 set referral flag
S DR=DR_";18///^S X=""NOW"";23///"_$S($D(RAOSCH)&(RAOSTS=8):"^S X="_RAOSCH,'$D(^RAO(75.1,RAOIFN,0)):"",$P(^(0),"^",23):"@",1:"")
S RADIV=$$SITE(),RADIV=$S($D(^RA(79,RADIV,0)):RADIV,1:$O(^RA(79,0)))
I $D(^RA(79,+RADIV,.1)),$P(^(.1),"^",19)="y" D SETLOG
D ^DIE K DE,DQ,DIE,DR I $$ORVR^RAORDU()=2.5 S ORIFN=$S($D(^RAO(75.1,RAOIFN,0)):+$P(^(0),"^",7),1:0),ORETURN("ORSTS")=RAOSTS D:ORIFN RETURN^ORX K ORIFN,ORETURN
;
; if oe/rr v.3 or greater do the following
; .send a discontinue or hold message to oe/rr if request status in file
; 75.1 is discontinued (1) or hold (3).
; .send a complete message to oe/rr if request status in file 75.1 is
; complete.
; .send a scheduled message to oe/rr if request status is active (6) or
; scheduled (8) AND the request was not a rollback from a status of
; complete.
;
I $$ORVR^RAORDU()'<3 D
. D:(RAOSTS=1)!(RAOSTS=3) EN1^RAO7CH(RAOIFN)
. D:RAOSTS=2 EN1^RAO7CMP(RAOIFN)
. I (RAOSTS=6) Q:$G(RA18PCHG,0)=1 ;P18 quit if procedure was changed - do not send "SC" message,because "XX" have been sent already
. I ((RAOSTS=6)!(RAOSTS=8))&($P($G(RAORDB4),"^",5)'=2) D
.. D EN1^RAO7SCH(RAOIFN)
.. Q
. Q
; ***** PCE changes follow *****
I $$PCE^RAWORK(),(RAOSTS=2),$G(RASAVDR)'="[RA OVERRIDE]" D
. N RA7003 S RA7003=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
. Q:$P(RA7003,"^",24)="Y" ; quit if clinic stop credited
. ;BILLING AWARE PHASE II, NO LONGER SENDING TO PTF
. ;I $P(RA7003,"^",6)]"",($P(^DIC(42,$P(RA7003,"^",6),0),"^",3)'="D") Q
. ;omit quit since both inpatient and outpatient data are sent to PCE
. D COMPLETE^RAPCE(RADFN,RADTI,RACNI)
. Q
; PFSS 1B project. If the request status is discontinue then send the delete event to IBB
I RAOSTS=1 D DC^RABWIBB(RAOIFN) ; Requirement 8
Q
;
SETLOG K N I $D(RAOREA)>1 S N=$S($D(RAOIFN):RAOIFN,$D(ORPK):ORPK,1:1) I '$D(RAOREA(N)) S N=$O(RAOREA(0))
S DR=DR_";75///^S X=$$NOW^XLFDT()",DR(2,75.12)="2////^S X="_RAOSTS_";3////^S X="_$S($G(RADUZ):RADUZ,1:DUZ)_";4///"_$S($D(RAOREA)&(RAOSTS=1!(RAOSTS=3)):"/^S X="_$S($D(N):RAOREA(N),1:RAOREA),1:"")
Q
SETORD ;Create request in OE/RR file and add OE/RR order number to file 75.1
; if oe/rr v.3 or greater send an hl7 message when creating a new request/order.
I $$ORVR^RAORDU()'<3 D EN1^RAO7NEW(RAOIFN) Q
Q:$$ORVR^RAORDU()'=2.5
N RAPRGST S RAPRGST=$P(RAORD0,"^",13)
K RAMOD S $P(RABLNK," ",41)="" F I=0:0 S I=$O(^RAO(75.1,RAOIFN,"M","B",I)) Q:'I I $D(^RAMIS(71.2,+I,0)) S RAMOD=$S('$D(RAMOD):$P(^(0),"^"),1:RAMOD_", "_$P(^(0),"^"))
I $$ORVR^RAORDU()=2.5 S (RAPRCD,ORTX(1))=$P($G(^RAMIS(71,+$P(RAORD0,"^",2),0)),"^")_"," D
.I $D(RAMOD) S ORTX(2)="Modifiers: "_$E(RAMOD,1,80)_","
.S ORTX(3)="Urgency: "_$S($P(RAORD0,"^",6)=1:"STAT",$P(RAORD0,"^",6)=2:"URGENT",1:"ROUTINE")_","
.I $P(RAORD0,"^",19)]"" S X=$P(RAORD0,"^",19),ORTX(3)=ORTX(3)_" Transport: "_$S(X="a":"AMBULATORY",X="p":"PORTABLE",X="s":"STRETCHER",1:"WHEELCHAIR")_","
.I $D(RASEX),RASEX'="M" S ORTX(3)=ORTX(3)_" Pregnant: "_$S(RAPRGST="n":"NO",RAPRGST="y":"YES",RAPRGST="u":"UNKNOWN",1:"")
S ORIT=$P(RAORD0,"^",2)_";RAMIS(71,"
S DIC="^RA(79.2,",DIC(0)="N",X=+$P(^RAMIS(71,+$P(RAORD0,"^",2),0),"^",12) D ^DIC K DIC,RABLNK,RAMOD,RAPRCD S ORPURG=$S(Y<0:30,$D(^RA(79.2,+Y,.1)):+$P(^(.1),"^",6),1:30)
S ORVP=RADFN_";DPT(",ORL=RALIFN_";SC(",ORNP=RAPIFN S ORPCL=$O(^ORD(101,"B","RA OERR EXAM",0))_";ORD(101,",ORPK=RAOIFN,ORSTS=$P(RAORD0,"^",5),ORSTRT=$P(RAORD0,"^",21) D FILE^ORX
I $D(ORIFN),ORIFN]"" S DA=RAOIFN,DIE="^RAO(75.1,",DR="7////^S X="_ORIFN D ^DIE K DE,DQ,DIE,DR
Q
OERR ;Set ^XUTL("OR",$J,"RA",IFN of oerr,IFN of Rad/Nuc Med order)
I $D(ORIFN),ORIFN,$D(RAOIFN),RAOIFN S ^XUTL("OR",$J,"RA",ORIFN,RAOIFN)=RADIV
K RADR1 Q
DELETE W:'$D(ZTQUEUED) !,"Since this order has not been released will delete instead of cancel...",!
Q
;
ORVR() ;returns version number of OE/RR
;returns 0 if OE/RR is not installed
;
;Q 3.0 ;for testing purposes
Q $S('$D(^ORD(100.99,0)):0,'$D(^DD(100,0,"VR")):0,1:^("VR"))
;
ORQUIK() ;returns 1 if CPRS Order Dialogue file 101.41 exists
;this means the quick order conversion to file 101.41 has been
;done and users should no longer be allowed to edit quick order
;parameters in the Common Procedure file 71.3. The quick order
;conversion can be done prior to installing 3.0
Q $S('$D(^ORD(101.41,0)):0,1:1)
;
SITE() ; Determine the value of RADIV
; +$P(RA1,"^",22)=Requesting Location
; +$P(RA2,"^",15)=Division (pntr to 40.8)
Q:$D(RADIV)#2 RADIV
N RA1,RA2,RADIVSON
S RA1=$G(^RAO(75.1,RAOIFN,0))
S RA2=$G(^SC(+$P(RA1,"^",22),0))
S RADIVSON=+$$SITE^VASITE(DT,+$P(RA2,"^",15))
Q $S(RADIVSON<0:0,1:RADIVSON)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAORDU 6157 printed Dec 13, 2024@02:38:22 Page 2
RAORDU ;HISC/CAH - AISC/RMO-Update Request Status ; Nov 08, 2022@12:44:16
+1 ;;5.0;Radiology/Nuclear Medicine;**18,41,57,133,192,196**;Mar 16, 1998;Build 1
+2 ; last modif JULY 5,00
+3 ;The variables RAOIFN and RAOSTS must be defined. The variable
+4 ;RAOREA is set when Canceling and Holding a request. The
+5 ;variable RAOSCH is set when Scheduling a request.
+6 ; RAOSTS=request status of exam
+7 ; RAESTAT=min stat exams same dt/tm^max stat^1(if stat found) 0(else)
+8 NEW RAESTAT
+9 IF RAOSTS=2
IF ($$PARNT^RASETU(RAOIFN,RADFN))
IF ($PIECE($GET(RAEXM0),"^",25))
Begin DoDot:1
+10 SET RAESTAT=$$EN1^RASETU(RAOIFN,RADFN)
+11 SET RAOSTS=$SELECT((+RAESTAT'<1)&(+RAESTAT'>8):6,1:RAOSTS)
+12 if RAOSTS=6
KILL ORIFN,ORETURN
+13 ;p192
IF '$DATA(RAF1)
IF (+RAESTAT=9)
IF ($$CICHO^RAORDC1()=1)
Begin DoDot:2
+14 WRITE !?3,"...will now designate request status as 'COMPLETE'..."
+15 WRITE !?10,"...request status successfully updated."
+16 QUIT
End DoDot:2
+17 QUIT
End DoDot:1
if RAOSTS=6
QUIT
+18 IF $DATA(ORSTS)
IF ORSTS=11
IF $PIECE(^RAO(75.1,RAOIFN,0),"^",5)=11
SET ORIFN=+$PIECE(^(0),"^",7)
SET ORSTS="K"
SET DA=RAOIFN
SET DIK="^RAO(75.1,"
DO DELETE
DO ^DIK
KILL DIK
if ORIFN
DO ST^ORX
KILL ORSTS
QUIT
+19 KILL N
IF $DATA(RAOREA)>1
SET N=$SELECT($DATA(RAOIFN):RAOIFN,$DATA(ORPK):ORPK,1:1)
IF '$DATA(RAOREA(N))
SET N=$ORDER(RAOREA(0))
+20 SET DA=RAOIFN
SET DIE="^RAO(75.1,"
SET DR="10///"_$SELECT($DATA(RAOREA)&(RAOSTS=1!(RAOSTS=3)):"/^S X="_$SELECT($DATA(N):RAOREA(N),1:RAOREA),'$DATA(^RAO(75.1,RAOIFN,0)):"",$PIECE(^(0),"^",10):"@",1:"")_";I 1;5///^S X="_RAOSTS
+21 IF $DATA(RAVSTFLG)
IF $DATA(RAVLEDTI)
SET DR=DR_";17///^S X="_(9999999.9999-RAVLEDTI)
+22 ;p196 set referral flag
IF $DATA(RAOPT("CCR"))
IF RAOSTS=3
SET DR=DR_";201///1"
+23 SET DR=DR_";18///^S X=""NOW"";23///"_$SELECT($DATA(RAOSCH)&(RAOSTS=8):"^S X="_RAOSCH,'$DATA(^RAO(75.1,RAOIFN,0)):"",$PIECE(^(0),"^",23):"@",1:"")
+24 SET RADIV=$$SITE()
SET RADIV=$SELECT($DATA(^RA(79,RADIV,0)):RADIV,1:$ORDER(^RA(79,0)))
+25 IF $DATA(^RA(79,+RADIV,.1))
IF $PIECE(^(.1),"^",19)="y"
DO SETLOG
+26 DO ^DIE
KILL DE,DQ,DIE,DR
IF $$ORVR^RAORDU()=2.5
SET ORIFN=$SELECT($DATA(^RAO(75.1,RAOIFN,0)):+$PIECE(^(0),"^",7),1:0)
SET ORETURN("ORSTS")=RAOSTS
if ORIFN
DO RETURN^ORX
KILL ORIFN,ORETURN
+27 ;
+28 ; if oe/rr v.3 or greater do the following
+29 ; .send a discontinue or hold message to oe/rr if request status in file
+30 ; 75.1 is discontinued (1) or hold (3).
+31 ; .send a complete message to oe/rr if request status in file 75.1 is
+32 ; complete.
+33 ; .send a scheduled message to oe/rr if request status is active (6) or
+34 ; scheduled (8) AND the request was not a rollback from a status of
+35 ; complete.
+36 ;
+37 IF $$ORVR^RAORDU()'<3
Begin DoDot:1
+38 if (RAOSTS=1)!(RAOSTS=3)
DO EN1^RAO7CH(RAOIFN)
+39 if RAOSTS=2
DO EN1^RAO7CMP(RAOIFN)
+40 ;P18 quit if procedure was changed - do not send "SC" message,because "XX" have been sent already
IF (RAOSTS=6)
if $GET(RA18PCHG,0)=1
QUIT
+41 IF ((RAOSTS=6)!(RAOSTS=8))&($PIECE($GET(RAORDB4),"^",5)'=2)
Begin DoDot:2
+42 DO EN1^RAO7SCH(RAOIFN)
+43 QUIT
End DoDot:2
+44 QUIT
End DoDot:1
+45 ; ***** PCE changes follow *****
+46 IF $$PCE^RAWORK()
IF (RAOSTS=2)
IF $GET(RASAVDR)'="[RA OVERRIDE]"
Begin DoDot:1
+47 NEW RA7003
SET RA7003=$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
+48 ; quit if clinic stop credited
if $PIECE(RA7003,"^",24)="Y"
QUIT
+49 ;BILLING AWARE PHASE II, NO LONGER SENDING TO PTF
+50 ;I $P(RA7003,"^",6)]"",($P(^DIC(42,$P(RA7003,"^",6),0),"^",3)'="D") Q
+51 ;omit quit since both inpatient and outpatient data are sent to PCE
+52 DO COMPLETE^RAPCE(RADFN,RADTI,RACNI)
+53 QUIT
End DoDot:1
+54 ; PFSS 1B project. If the request status is discontinue then send the delete event to IBB
+55 ; Requirement 8
IF RAOSTS=1
DO DC^RABWIBB(RAOIFN)
+56 QUIT
+57 ;
SETLOG KILL N
IF $DATA(RAOREA)>1
SET N=$SELECT($DATA(RAOIFN):RAOIFN,$DATA(ORPK):ORPK,1:1)
IF '$DATA(RAOREA(N))
SET N=$ORDER(RAOREA(0))
+1 SET DR=DR_";75///^S X=$$NOW^XLFDT()"
SET DR(2,75.12)="2////^S X="_RAOSTS_";3////^S X="_$SELECT($GET(RADUZ):RADUZ,1:DUZ)_";4///"_$SELECT($DATA(RAOREA)&(RAOSTS=1!(RAOSTS=3)):"/^S X="_$SELECT($DATA(N):RAOREA(N),1:RAOREA),1:"")
+2 QUIT
SETORD ;Create request in OE/RR file and add OE/RR order number to file 75.1
+1 ; if oe/rr v.3 or greater send an hl7 message when creating a new request/order.
+2 IF $$ORVR^RAORDU()'<3
DO EN1^RAO7NEW(RAOIFN)
QUIT
+3 if $$ORVR^RAORDU()'=2.5
QUIT
+4 NEW RAPRGST
SET RAPRGST=$PIECE(RAORD0,"^",13)
+5 KILL RAMOD
SET $PIECE(RABLNK," ",41)=""
FOR I=0:0
SET I=$ORDER(^RAO(75.1,RAOIFN,"M","B",I))
if 'I
QUIT
IF $DATA(^RAMIS(71.2,+I,0))
SET RAMOD=$SELECT('$DATA(RAMOD):$PIECE(^(0),"^"),1:RAMOD_", "_$PIECE(^(0),"^"))
+6 IF $$ORVR^RAORDU()=2.5
SET (RAPRCD,ORTX(1))=$PIECE($GET(^RAMIS(71,+$PIECE(RAORD0,"^",2),0)),"^")_","
Begin DoDot:1
+7 IF $DATA(RAMOD)
SET ORTX(2)="Modifiers: "_$EXTRACT(RAMOD,1,80)_","
+8 SET ORTX(3)="Urgency: "_$SELECT($PIECE(RAORD0,"^",6)=1:"STAT",$PIECE(RAORD0,"^",6)=2:"URGENT",1:"ROUTINE")_","
+9 IF $PIECE(RAORD0,"^",19)]""
SET X=$PIECE(RAORD0,"^",19)
SET ORTX(3)=ORTX(3)_" Transport: "_$SELECT(X="a":"AMBULATORY",X="p":"PORTABLE",X="s":"STRETCHER",1:"WHEELCHAIR")_","
+10 IF $DATA(RASEX)
IF RASEX'="M"
SET ORTX(3)=ORTX(3)_" Pregnant: "_$SELECT(RAPRGST="n":"NO",RAPRGST="y":"YES",RAPRGST="u":"UNKNOWN",1:"")
End DoDot:1
+11 SET ORIT=$PIECE(RAORD0,"^",2)_";RAMIS(71,"
+12 SET DIC="^RA(79.2,"
SET DIC(0)="N"
SET X=+$PIECE(^RAMIS(71,+$PIECE(RAORD0,"^",2),0),"^",12)
DO ^DIC
KILL DIC,RABLNK,RAMOD,RAPRCD
SET ORPURG=$SELECT(Y<0:30,$DATA(^RA(79.2,+Y,.1)):+$PIECE(^(.1),"^",6),1:30)
+13 SET ORVP=RADFN_";DPT("
SET ORL=RALIFN_";SC("
SET ORNP=RAPIFN
SET ORPCL=$ORDER(^ORD(101,"B","RA OERR EXAM",0))_";ORD(101,"
SET ORPK=RAOIFN
SET ORSTS=$PIECE(RAORD0,"^",5)
SET ORSTRT=$PIECE(RAORD0,"^",21)
DO FILE^ORX
+14 IF $DATA(ORIFN)
IF ORIFN]""
SET DA=RAOIFN
SET DIE="^RAO(75.1,"
SET DR="7////^S X="_ORIFN
DO ^DIE
KILL DE,DQ,DIE,DR
+15 QUIT
OERR ;Set ^XUTL("OR",$J,"RA",IFN of oerr,IFN of Rad/Nuc Med order)
+1 IF $DATA(ORIFN)
IF ORIFN
IF $DATA(RAOIFN)
IF RAOIFN
SET ^XUTL("OR",$JOB,"RA",ORIFN,RAOIFN)=RADIV
+2 KILL RADR1
QUIT
DELETE if '$DATA(ZTQUEUED)
WRITE !,"Since this order has not been released will delete instead of cancel...",!
+1 QUIT
+2 ;
ORVR() ;returns version number of OE/RR
+1 ;returns 0 if OE/RR is not installed
+2 ;
+3 ;Q 3.0 ;for testing purposes
+4 QUIT $SELECT('$DATA(^ORD(100.99,0)):0,'$DATA(^DD(100,0,"VR")):0,1:^("VR"))
+5 ;
ORQUIK() ;returns 1 if CPRS Order Dialogue file 101.41 exists
+1 ;this means the quick order conversion to file 101.41 has been
+2 ;done and users should no longer be allowed to edit quick order
+3 ;parameters in the Common Procedure file 71.3. The quick order
+4 ;conversion can be done prior to installing 3.0
+5 QUIT $SELECT('$DATA(^ORD(101.41,0)):0,1:1)
+6 ;
SITE() ; Determine the value of RADIV
+1 ; +$P(RA1,"^",22)=Requesting Location
+2 ; +$P(RA2,"^",15)=Division (pntr to 40.8)
+3 if $DATA(RADIV)#2
QUIT RADIV
+4 NEW RA1,RA2,RADIVSON
+5 SET RA1=$GET(^RAO(75.1,RAOIFN,0))
+6 SET RA2=$GET(^SC(+$PIECE(RA1,"^",22),0))
+7 SET RADIVSON=+$$SITE^VASITE(DT,+$PIECE(RA2,"^",15))
+8 QUIT $SELECT(RADIVSON<0:0,1:RADIVSON)
