RAORDC ;HISC/CAH,FPT,GJC,DAD AISC/RMO-Check Request Status against Exam Status ;4/9/97 12:06
;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
;
;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))
I $D(RASN),(RASN="EXAMINED") D ^RAORDU:RAOSTS=6 ;IHS/ITSC/CLS 12/31/2003 sends an HL7 message at examined
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.
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 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 allow order to be deleted or canceled
. N RAESTAT S RAESTAT=$$EN1^RASETU(RAOIFN,RADFN)
. Q:+$P(RAESTAT,"^",3) ; all other exams have been cancelled
. 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
W !!,"Do you want to cancel the request associated with this exam" S %=2 D YN^DICN S RAOSTS=$S(%=1:1,%=2:3,1:0) I 'RAOSTS W !!,"Required, enter 'YES' if the request should be cancelled or 'NO' to put",!,"it on hold." G ASKCAN
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
I RAOSTS=3 S (DIE,DIC)="^RAO(75.1,",DIC(0)="AEQM",DA=RAOIFN,DR="25" W ! D ^DIE K DIE,DIC,DA,DR
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
RAORDC ;HISC/CAH,FPT,GJC,DAD AISC/RMO-Check Request Status against Exam Status ;4/9/97 12:06
+1 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
+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 ;IHS/ITSC/CLS 12/31/2003 sends an HL7 message at examined
IF $DATA(RASN)
IF (RASN="EXAMINED")
IF RAOSTS=6
DO ^RAORDU
+12 IF $PIECE($GET(RAORDB4),"^",5)=2
IF (RAOSTS'=2)
Begin DoDot:1
+13 ; Prior request status complete ($P(RAORDB4,"^",5)=2), new request
+14 ; status (RAOSTS) not complete & OE/RR version not less than 3 issue
+15 ; roll back message
+16 IF $$ORVR^RAORDU()'<3
DO EN2^RAO7CH(RAOIFN)
+17 ; Delete 'V' file pointers if PCE installed & outpatient
+18 IF $PIECE(RAEXM0,"^",6)]""
IF ($PIECE(^DIC(42,$PIECE(RAEXM0,"^",6),0),"^",3)'="D")
QUIT
+19 IF $$PCE^RAWORK()
DO UNCOMPL^RAPCE1(RADFN,RADTI,RACNI)
+20 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 NEW RAXIT
SET RAXIT=0
+2 SET RAOREA=$SELECT($DATA(RAOREA):RAOREA,1:$ORDER(^RA(75.2,"B",$SELECT($DATA(RADELFLG):"EXAM DELETED",1:"EXAM CANCELLED"),0)))
+3 ;
ASKCAN SET RA=$ORDER(^RADPT("AO",RAOIFN,RADFN,RADTI,0))
+1 IF RA
IF $ORDER(^RADPT("AO",RAOIFN,RADFN,RADTI,RA))
Begin DoDot:1
+2 ; If # descendents > 1 do not allow order to be deleted or canceled
+3 NEW RAESTAT
SET RAESTAT=$$EN1^RASETU(RAOIFN,RADFN)
+4 ; all other exams have been cancelled
IF +$PIECE(RAESTAT,"^",3)
QUIT
+5 ; if ramaining xams complete -or- at least one of the other
SET RAXIT=1
+6 ; xams not cancelled, take appropriate action, quit EXMCAN
+7 ; all xams complete
IF +RAESTAT=9
SET RAOSTS=2
DO ^RAORDU
SET RAOSTS=0
QUIT
+8 WRITE !!?5,"Please note, however, that more than one procedure is associated"
+9 WRITE !?5,"with the procedure's Parent request. The Parent request will not"
+10 WRITE !?5,"be canceled or put or hold unless all the registered descendent"
+11 WRITE !?5,"procedures are canceled or deleted.",!,$CHAR(7)
+12 QUIT
End DoDot:1
IF RAXIT
QUIT
+13 WRITE !!,"Do you want to cancel the request associated with this exam"
SET %=2
DO YN^DICN
SET RAOSTS=$SELECT(%=1:1,%=2:3,1:0)
IF 'RAOSTS
WRITE !!,"Required, enter 'YES' if the request should be cancelled or 'NO' to put",!,"it on hold."
GOTO ASKCAN
+14 IF RAOSTS=1
IF $DATA(RADELFLG)
Begin DoDot:1
+15 ; Remove EXAM SET flag if parent order deleted
+16 NEW DA,DIE,DR
+17 SET DIE="^RADPT("_RADFN_",""DT"","
SET DA(1)=RADFN
SET DA=RADTI
SET DR="5///@"
+18 DO ^DIE
+19 QUIT
End DoDot:1
+20 IF RAOSTS=3
SET (DIE,DIC)="^RAO(75.1,"
SET DIC(0)="AEQM"
SET DA=RAOIFN
SET DR="25"
WRITE !
DO ^DIE
KILL DIE,DIC,DA,DR
+21 DO ^RAORDU
WRITE !?10,"...request status updated to ",$SELECT(RAOSTS=1:"discontinued",1:"hold"),"."
+22 QUIT
+23 ;
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
