RAORDC ;HISC/CAH,FPT,GJC,DAD AISC/RMO-Check Request Status against Exam Status ; Mar 24, 2020@11:52:36
;;5.0;Radiology/Nuclear Medicine;**113,124,162,166**;Mar 16, 1998;Build 2
;
;The variables RADFN, RADTI and RACNI must be defined. The variable
;RADELFLG is set when the exam is being deleted. This routine is
;called after an exam status is updated, to update the order status.
;Called from RAEDCN after exam cancel or delete, from RAESO after
;override single exam to complete, from RASTED after exam status is
;updated successfully, and from RAUTL1 after exam status update.
G Q:'$D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) S RAEXM0=^(0),RAEXOR=$S($D(RADELFLG):0,$D(^RA(72,+$P(RAEXM0,"^",3),0)):$P(^(0),"^",3),1:""),RAOIFN=+$P(RAEXM0,"^",11) G Q:'$D(^RAO(75.1,RAOIFN,0)) S (RAORD0,RAORDB4)=^(0)
S RAOSTS=$S(RAEXOR=0:0,RAEXOR>0&(RAEXOR<9):6,RAEXOR=9:2,1:"") D EXMCAN:RAOSTS=0,EXMCOM:RAOSTS=2,^RAORDU:RAOSTS=6&(RAOSTS'=$P(RAORD0,"^",5))
;
;Check for studies that are COMPLETE (w/order=9). May be single studies,
;multiple studies per patient event: examsets, printsets, add exams to
;last visit get radiation dose data if the proper conditions are met.
I RAOSTS=2!(RAOSTS=6) D ; ACTIVE (6) or COMPLETE (2)
.N RAIT,RAY2,RAY3 S RAY2=$G(^RADPT(RADFN,"DT",RADTI,0))
.S RAIT=$P($G(^RA(79.2,+$P(RAY2,U,2),0)),U,3)
.I RAIT'="RAD",(RAIT'="CT") Q
.S RAIT=$S(RAIT="RAD":"FLUORO",1:"CT") ;MAG requires "FLUORO"
.S RAY3=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
.Q:$P($G(^RA(72,+$P(RAY3,U,3),0)),U,3)'=9 ;must be COMPLETE
.D GETDOSE^RADUTL ;RA*5.0*113 w/MAG*3.0*137
.Q
;
I $P($G(RAORDB4),"^",5)=2,(RAOSTS'=2) D
. ; Prior request status complete ($P(RAORDB4,"^",5)=2), new request
. ; status (RAOSTS) not complete & OE/RR version not less than 3 issue
. ; roll back message
. D:$$ORVR^RAORDU()'<3 EN2^RAO7CH(RAOIFN)
. ; Delete 'V' file pointers if PCE installed & outpatient
. I $P(RAEXM0,"^",6)]"",($P(^DIC(42,$P(RAEXM0,"^",6),0),"^",3)'="D") Q
. D:$$PCE^RAWORK() UNCOMPL^RAPCE1(RADFN,RADTI,RACNI)
. Q
Q K RABLNK,RACAT,RAEXM0,RAEXOR,RAILP,RAMIFN,RAMOD,RAMODA,RAMODD,RAOIFN,RAORD0,RAORDB4,RAOSTS,RAPRC,RARSH,RASHA,X
I '$D(N)!($D(RAOREA)<10) K RAOREA Q
I $D(RAOREA)>1,$G(N) K RAOREA(N) I $D(RAOREA)<10 K RAOREA
Q
;
EXMCAN ; Update request status to cancel or hold.
;This logic is called based on changes for RA5P124.
;RA5P124 comments will be added where necessary.
N RAXIT S RAXIT=0
S RAOREA=$S($D(RAOREA):RAOREA,1:$O(^RA(75.2,"B",$S($D(RADELFLG):"EXAM DELETED",1:"EXAM CANCELLED"),0)))
;
ASKCAN ;logic to determine whether studies tied to the order meet the criteria
;to discontinue or hold the order. At this point RAOIFN, RADFN, RADTI, RACNI
;RAY2 (70.02 node), RAY3 (70.03) node and RACAN124 are set.
;
;check for descendents
S RA=$O(^RADPT("AO",RAOIFN,RADFN,RADTI,0))
I RA,$O(^RADPT("AO",RAOIFN,RADFN,RADTI,RA)) D Q:RAXIT
. ; If # descendents > 1 do not assume the order is to be deleted or canceled
. N RAESTAT S RAESTAT=$$EN1^RASETU(RAOIFN,RADFN)
. ;RAESTAT = min ORDER number value for all descendents_"^"_max ORDER number value for all descendents
. ; _"^"_$S(All_desc ORDER number values=0:1,1:0)
. Q:+$P(RAESTAT,"^",3) ; all other exams have been canceled
. S RAXIT=1 ; if ramaining xams complete -or- at least one of the other
. ; xams not cancelled, take appropriate action, quit EXMCAN
. I +RAESTAT=9 S RAOSTS=2 D ^RAORDU S RAOSTS=0 Q ; all xams complete
. W !!?5,"Please note, however, that more than one procedure is associated"
. W !?5,"with the procedure's Parent request. The Parent request will not"
. W !?5,"be canceled or put or hold unless all the registered descendent"
. W !?5,"procedures are canceled or deleted.",!,$C(7)
. Q
;
;RA5P166
;RAUSUNXF set in RAORDC, killed in RAEDCN1
W ! S (RAOSTS,RAUSUNXF)=$$YNCAN() Q:RAOSTS=-1
;RA5P166
;W ! S RAOSTS=$$YNCAN() Q:RAOSTS=-1 ORIGINAL LINE
I RAOSTS=1,$D(RADELFLG) D
. ; Remove EXAM SET flag if parent order deleted
. N DA,DIE,DR
. S DIE="^RADPT("_RADFN_",""DT"",",DA(1)=RADFN,DA=RADTI,DR="5///@"
. D ^DIE
. Q
;// new w/P162 keep the default reason (order) //
;// unless the user selects another reason //
I RAOSTS=1 D
.N RAS S RAS=$$REASON(RAOSTS) S:+RAS>0 RAOREA=+RAS
.Q
I RAOSTS=3 D
.N RAS S RAS=$$REASON(RAOSTS) S:+RAS>0 RAOREA=+RAS
.S (DIE,DIC)="^RAO(75.1,",DIC(0)="AEQM",DA=RAOIFN,DR="25" W ! D ^DIE K DIE,DIC,DA,DR
.Q
;// end P162 mods //
D ^RAORDU W !?10,"...request status updated to ",$S(RAOSTS=1:"discontinued",1:"hold"),"."
Q
;
EXMCOM ; Code moved to EXMCOM^RAORDC1 to save on space. To update request
; statuses for complete exams.
D EXMCOM^RAORDC1 Q
;
DELMOD S DA(1)=RAOIFN,DA=RAMIFN,DIK="^RAO(75.1,"_DA(1)_",""M""," D ^DIK K DA,DIK S RAMODD=""
Q
;
ADDMOD S X=$S($D(^RAMIS(71.2,RAILP,0)):$P(^(0),"^"),1:"") I X'="" S:'$D(^RAO(75.1,RAOIFN,"M",0)) ^(0)="^75.1125PA^^" S DIC(0)="L",DLAYGO=75.1,DA(1)=RAOIFN,DIC="^RAO(75.1,RAOIFN,""M""," D ^DIC K DA,DIC S RAMODA=""
Q
;
YNCAN() ;ask if the order is to be canceled
;DIR returns:
; X - Unprocessed user response
; Y - Processed user response.
N %,DIR,DIROUT,DIRUT,DTOUT,DUOUT
S DIR(0)="Y",DIR("B")="No"
S DIR("?",1)="Required, enter 'YES' If the request should be cancelled or 'NO' to put"
S DIR("?")="it on hold."
S DIR("A")="Do you want to cancel the request associated with this exam"
D ^DIR
;Yes/No: Y=1 for yes/cancel; else Y=0 for no/hold
;
Q $S(Y=1:1,Y=0:3,1:-1)
;
REASON(RAOSTS) ;cancel/hold reason using DIR
; RAOSTS - the request status selected by the user.
; 1 = discontinued/cancel; 3 = hold
; return: IEN^.01 of IEN
; -1^ (if nothing selected, timeout or up arrow)
N %,DIR,DIRUT,DTOUT,DUOUT,RAREAY,X,Y
S DIR(0)="POA^75.2:EZ"
S DIR("A")="Select the '"_$S(RAOSTS=1:"cancel",1:"hold")_"' reason for this order: "
S DIR("S")="I $P(^(0),U,2)=RAOSTS!($P(^(0),U,2)=9)" W ! D ^DIR
I $D(DIRUT)#2 D Q RAREAY
.S RAREAY="-1^"
.Q
E S RAREAY=Y
Q RAREAY
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAORDC 6059 printed Oct 16, 2024@18:38:48 Page 2
RAORDC ;HISC/CAH,FPT,GJC,DAD AISC/RMO-Check Request Status against Exam Status ; Mar 24, 2020@11:52:36
+1 ;;5.0;Radiology/Nuclear Medicine;**113,124,162,166**;Mar 16, 1998;Build 2
+2 ;
+3 ;The variables RADFN, RADTI and RACNI must be defined. The variable
+4 ;RADELFLG is set when the exam is being deleted. This routine is
+5 ;called after an exam status is updated, to update the order status.
+6 ;Called from RAEDCN after exam cancel or delete, from RAESO after
+7 ;override single exam to complete, from RASTED after exam status is
+8 ;updated successfully, and from RAUTL1 after exam status update.
+9 if '$DATA(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
GOTO Q
SET RAEXM0=^(0)
SET RAEXOR=$SELECT($DATA(RADELFLG):0,$DATA(^RA(72,+$PIECE(RAEXM0,"^",3),0)):$PIECE(^(0),"^",3),1:"")
SET RAOIFN=+$PIECE(RAEXM0,"^",11)
if '$DATA(^RAO(75.1,RAOIFN,0))
GOTO Q
SET (RAORD0,RAORDB4)=^(0)
+10 SET RAOSTS=$SELECT(RAEXOR=0:0,RAEXOR>0&(RAEXOR<9):6,RAEXOR=9:2,1:"")
if RAOSTS=0
DO EXMCAN
if RAOSTS=2
DO EXMCOM
if RAOSTS=6&(RAOSTS'=$PIECE(RAORD0,"^",5))
DO ^RAORDU
+11 ;
+12 ;Check for studies that are COMPLETE (w/order=9). May be single studies,
+13 ;multiple studies per patient event: examsets, printsets, add exams to
+14 ;last visit get radiation dose data if the proper conditions are met.
+15 ; ACTIVE (6) or COMPLETE (2)
IF RAOSTS=2!(RAOSTS=6)
Begin DoDot:1
+16 NEW RAIT,RAY2,RAY3
SET RAY2=$GET(^RADPT(RADFN,"DT",RADTI,0))
+17 SET RAIT=$PIECE($GET(^RA(79.2,+$PIECE(RAY2,U,2),0)),U,3)
+18 IF RAIT'="RAD"
IF (RAIT'="CT")
QUIT
+19 ;MAG requires "FLUORO"
SET RAIT=$SELECT(RAIT="RAD":"FLUORO",1:"CT")
+20 SET RAY3=$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
+21 ;must be COMPLETE
if $PIECE($GET(^RA(72,+$PIECE(RAY3,U,3),0)),U,3)'=9
QUIT
+22 ;RA*5.0*113 w/MAG*3.0*137
DO GETDOSE^RADUTL
+23 QUIT
End DoDot:1
+24 ;
+25 IF $PIECE($GET(RAORDB4),"^",5)=2
IF (RAOSTS'=2)
Begin DoDot:1
+26 ; Prior request status complete ($P(RAORDB4,"^",5)=2), new request
+27 ; status (RAOSTS) not complete & OE/RR version not less than 3 issue
+28 ; roll back message
+29 if $$ORVR^RAORDU()'<3
DO EN2^RAO7CH(RAOIFN)
+30 ; Delete 'V' file pointers if PCE installed & outpatient
+31 IF $PIECE(RAEXM0,"^",6)]""
IF ($PIECE(^DIC(42,$PIECE(RAEXM0,"^",6),0),"^",3)'="D")
QUIT
+32 if $$PCE^RAWORK()
DO UNCOMPL^RAPCE1(RADFN,RADTI,RACNI)
+33 QUIT
End DoDot:1
Q KILL RABLNK,RACAT,RAEXM0,RAEXOR,RAILP,RAMIFN,RAMOD,RAMODA,RAMODD,RAOIFN,RAORD0,RAORDB4,RAOSTS,RAPRC,RARSH,RASHA,X
+1 IF '$DATA(N)!($DATA(RAOREA)<10)
KILL RAOREA
QUIT
+2 IF $DATA(RAOREA)>1
IF $GET(N)
KILL RAOREA(N)
IF $DATA(RAOREA)<10
KILL RAOREA
+3 QUIT
+4 ;
EXMCAN ; Update request status to cancel or hold.
+1 ;This logic is called based on changes for RA5P124.
+2 ;RA5P124 comments will be added where necessary.
+3 NEW RAXIT
SET RAXIT=0
+4 SET RAOREA=$SELECT($DATA(RAOREA):RAOREA,1:$ORDER(^RA(75.2,"B",$SELECT($DATA(RADELFLG):"EXAM DELETED",1:"EXAM CANCELLED"),0)))
+5 ;
ASKCAN ;logic to determine whether studies tied to the order meet the criteria
+1 ;to discontinue or hold the order. At this point RAOIFN, RADFN, RADTI, RACNI
+2 ;RAY2 (70.02 node), RAY3 (70.03) node and RACAN124 are set.
+3 ;
+4 ;check for descendents
+5 SET RA=$ORDER(^RADPT("AO",RAOIFN,RADFN,RADTI,0))
+6 IF RA
IF $ORDER(^RADPT("AO",RAOIFN,RADFN,RADTI,RA))
Begin DoDot:1
+7 ; If # descendents > 1 do not assume the order is to be deleted or canceled
+8 NEW RAESTAT
SET RAESTAT=$$EN1^RASETU(RAOIFN,RADFN)
+9 ;RAESTAT = min ORDER number value for all descendents_"^"_max ORDER number value for all descendents
+10 ; _"^"_$S(All_desc ORDER number values=0:1,1:0)
+11 ; all other exams have been canceled
if +$PIECE(RAESTAT,"^",3)
QUIT
+12 ; if ramaining xams complete -or- at least one of the other
SET RAXIT=1
+13 ; xams not cancelled, take appropriate action, quit EXMCAN
+14 ; all xams complete
IF +RAESTAT=9
SET RAOSTS=2
DO ^RAORDU
SET RAOSTS=0
QUIT
+15 WRITE !!?5,"Please note, however, that more than one procedure is associated"
+16 WRITE !?5,"with the procedure's Parent request. The Parent request will not"
+17 WRITE !?5,"be canceled or put or hold unless all the registered descendent"
+18 WRITE !?5,"procedures are canceled or deleted.",!,$CHAR(7)
+19 QUIT
End DoDot:1
if RAXIT
QUIT
+20 ;
+21 ;RA5P166
+22 ;RAUSUNXF set in RAORDC, killed in RAEDCN1
+23 WRITE !
SET (RAOSTS,RAUSUNXF)=$$YNCAN()
if RAOSTS=-1
QUIT
+24 ;RA5P166
+25 ;W ! S RAOSTS=$$YNCAN() Q:RAOSTS=-1 ORIGINAL LINE
+26 IF RAOSTS=1
IF $DATA(RADELFLG)
Begin DoDot:1
+27 ; Remove EXAM SET flag if parent order deleted
+28 NEW DA,DIE,DR
+29 SET DIE="^RADPT("_RADFN_",""DT"","
SET DA(1)=RADFN
SET DA=RADTI
SET DR="5///@"
+30 DO ^DIE
+31 QUIT
End DoDot:1
+32 ;// new w/P162 keep the default reason (order) //
+33 ;// unless the user selects another reason //
+34 IF RAOSTS=1
Begin DoDot:1
+35 NEW RAS
SET RAS=$$REASON(RAOSTS)
if +RAS>0
SET RAOREA=+RAS
+36 QUIT
End DoDot:1
+37 IF RAOSTS=3
Begin DoDot:1
+38 NEW RAS
SET RAS=$$REASON(RAOSTS)
if +RAS>0
SET RAOREA=+RAS
+39 SET (DIE,DIC)="^RAO(75.1,"
SET DIC(0)="AEQM"
SET DA=RAOIFN
SET DR="25"
WRITE !
DO ^DIE
KILL DIE,DIC,DA,DR
+40 QUIT
End DoDot:1
+41 ;// end P162 mods //
+42 DO ^RAORDU
WRITE !?10,"...request status updated to ",$SELECT(RAOSTS=1:"discontinued",1:"hold"),"."
+43 QUIT
+44 ;
EXMCOM ; Code moved to EXMCOM^RAORDC1 to save on space. To update request
+1 ; statuses for complete exams.
+2 DO EXMCOM^RAORDC1
QUIT
+3 ;
DELMOD SET DA(1)=RAOIFN
SET DA=RAMIFN
SET DIK="^RAO(75.1,"_DA(1)_",""M"","
DO ^DIK
KILL DA,DIK
SET RAMODD=""
+1 QUIT
+2 ;
ADDMOD SET X=$SELECT($DATA(^RAMIS(71.2,RAILP,0)):$PIECE(^(0),"^"),1:"")
IF X'=""
if '$DATA(^RAO(75.1,RAOIFN,"M",0))
SET ^(0)="^75.1125PA^^"
SET DIC(0)="L"
SET DLAYGO=75.1
SET DA(1)=RAOIFN
SET DIC="^RAO(75.1,RAOIFN,""M"","
DO ^DIC
KILL DA,DIC
SET RAMODA=""
+1 QUIT
+2 ;
YNCAN() ;ask if the order is to be canceled
+1 ;DIR returns:
+2 ; X - Unprocessed user response
+3 ; Y - Processed user response.
+4 NEW %,DIR,DIROUT,DIRUT,DTOUT,DUOUT
+5 SET DIR(0)="Y"
SET DIR("B")="No"
+6 SET DIR("?",1)="Required, enter 'YES' If the request should be cancelled or 'NO' to put"
+7 SET DIR("?")="it on hold."
+8 SET DIR("A")="Do you want to cancel the request associated with this exam"
+9 DO ^DIR
+10 ;Yes/No: Y=1 for yes/cancel; else Y=0 for no/hold
+11 ;
+12 QUIT $SELECT(Y=1:1,Y=0:3,1:-1)
+13 ;
REASON(RAOSTS) ;cancel/hold reason using DIR
+1 ; RAOSTS - the request status selected by the user.
+2 ; 1 = discontinued/cancel; 3 = hold
+3 ; return: IEN^.01 of IEN
+4 ; -1^ (if nothing selected, timeout or up arrow)
+5 NEW %,DIR,DIRUT,DTOUT,DUOUT,RAREAY,X,Y
+6 SET DIR(0)="POA^75.2:EZ"
+7 SET DIR("A")="Select the '"_$SELECT(RAOSTS=1:"cancel",1:"hold")_"' reason for this order: "
+8 SET DIR("S")="I $P(^(0),U,2)=RAOSTS!($P(^(0),U,2)=9)"
WRITE !
DO ^DIR
+9 IF $DATA(DIRUT)#2
Begin DoDot:1
+10 SET RAREAY="-1^"
+11 QUIT
End DoDot:1
QUIT RAREAY
+12 IF '$TEST
SET RAREAY=Y
+13 QUIT RAREAY
+14 ;
