RASTREQ1 ;HISC/CAH,GJC AISC/MJK-Cont. of RASTREQ status reqmts ck ;5/29/97 12:52
;;5.0;Radiology/Nuclear Medicine;**34,85**;Mar 16, 1998;Build 4
;
; STUFF -- Called from UP1^RAUTL1 for editing an exam
; LOOP -- Called from RASTREQ for status tracking
; and from RASTREQ for cancel an exam
;
;Determine whether exam status can be updated to next higher status
;After this subrtn is executed, the following variables will exist:
; RAOR= order seq no., = -1 if not eligible for an update
; RASN= new status external format (or same status if not updateable)
; RASTI= ien of new status if updateable
;This subrtn does not write any data to the status field, it only
;checks to see what the next status would be
;RABEFORE = status level BEFORE change
;RAAFTER = status level AFTER change
;
; 06/11/2007 BAY/KAM RA*5*85 Remedy Call 174790 Change exam cancel
; to allow only descendent with stub/images
;
STUFF ; initialize RAOR=-1 to assume NO change if early quit
S RAJ=$G(^RADPT(DA(2),"DT",DA(1),"P",DA,0)),RAOR=-1
S RABEFORE=$P($G(^RA(72,+$P(RAJ,U,3),0)),U,3)
S RAORDIFN=+$P(RAJ,"^",11),RACS=$P(RAJ,"^",24),RAPRIT=$P(RAJ,"^",2)
I $D(^RA(72,+$P(RAJ,"^",3),0)) S RASN=$P(^(0),"^") Q:$P(^(0),"^",3)'>0
I $P(RAJ,"^",6)]"" S RAF5=$P(RAJ,"^",6)
S RAIMGTYI=$P($G(^RADPT(DA(2),"DT",DA(1),0)),U,2),RAIMGTYJ=$P(^RA(79.2,RAIMGTYI,0),U)
; set RAOR, RASN, RASTI to lowest level's, to allow event when
; none of the levels meet all the requirements for that level
LOOP S RAOR=$S($O(^RA(72,"AA",RAIMGTYJ,0))>0:$O(^(0)),1:1)
S RASTI=+$O(^RA(72,"AA",RAIMGTYJ,RAOR,0)),RASN=$P($G(^RA(72,+RASTI,0)),U)
;
N RA
F K=0:0 S K=$O(^RA(72,"AA",RAIMGTYJ,K)) Q:K'>0 D
. S X="",E=+$O(^RA(72,"AA",RAIMGTYJ,K,0)) Q:E'>0
. I $D(^RA(72,E,0)) D
.. S RA(0)=$G(^RA(72,E,0)),N=$P(RA(0),"^"),RAS=$G(^RA(72,E,.1))
.. I '$L(RAS) S RAS="N"
.. D HELP1^RASTREQ I $D(X),K>RAOR S RAOR=K,RASTI=E,RASN=N
.. Q
. Q
S RAAFTER=RAOR
I $D(RASTI),RASTI=$P(RAJ,"^",3) S RAOR=-1
K RAZ,RAK,RAE,RAIMGTYI,RAIMGTYJ,E,RAS,RAJ,RAJ1,N,K,FL
Q
CANCEL ; cancel an exam
S RAOR=0,RASTI=RAXX,RASN=$P($G(^RA(72,RAXX,0)),"^")
S RAAFTER=RAOR
Q:$D(RAOPT("DELETEXAM")) ; 1st chk skip, 2nd chk done already<-- delxam
; check again: 'allow cancelling' and if report exists
; in case Fileman enter/edit was used directly on the EXAM STATUS field
; if either check fails, set RAAFTER=RABEFORE so status can't change
I $D(^RA(72,+$P(RAJ,U,3),0)),$P(^(0),"^",6)'="y" W !,"This exam is in the '",$P(^(0),"^"),"' status and cannot be 'CANCELLED'" S RAAFTER=RABEFORE Q
; ok to cancel descendent exam w images if stub rpt and user has RA MGR key
; 06/11/2007 *85 Added descendent check to next line
I $P(RAJ,U,17)'="",$$STUB^RAEDCN1($P(RAJ,U,17)),($$PSET^RAEDCN1(RADFN,RADTI,RACNI)),$D(^XUSEC("RA MGR",+$G(DUZ))) Q
; can't cancel exam if report isn't stub
I $P(RAJ,U,17)'="" W !,"A report has been filed for this case. Therefore cancellation is not allowed !" S RAAFTER=RABEFORE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRASTREQ1 3038 printed Oct 16, 2024@18:40:30 Page 2
RASTREQ1 ;HISC/CAH,GJC AISC/MJK-Cont. of RASTREQ status reqmts ck ;5/29/97 12:52
+1 ;;5.0;Radiology/Nuclear Medicine;**34,85**;Mar 16, 1998;Build 4
+2 ;
+3 ; STUFF -- Called from UP1^RAUTL1 for editing an exam
+4 ; LOOP -- Called from RASTREQ for status tracking
+5 ; and from RASTREQ for cancel an exam
+6 ;
+7 ;Determine whether exam status can be updated to next higher status
+8 ;After this subrtn is executed, the following variables will exist:
+9 ; RAOR= order seq no., = -1 if not eligible for an update
+10 ; RASN= new status external format (or same status if not updateable)
+11 ; RASTI= ien of new status if updateable
+12 ;This subrtn does not write any data to the status field, it only
+13 ;checks to see what the next status would be
+14 ;RABEFORE = status level BEFORE change
+15 ;RAAFTER = status level AFTER change
+16 ;
+17 ; 06/11/2007 BAY/KAM RA*5*85 Remedy Call 174790 Change exam cancel
+18 ; to allow only descendent with stub/images
+19 ;
STUFF ; initialize RAOR=-1 to assume NO change if early quit
+1 SET RAJ=$GET(^RADPT(DA(2),"DT",DA(1),"P",DA,0))
SET RAOR=-1
+2 SET RABEFORE=$PIECE($GET(^RA(72,+$PIECE(RAJ,U,3),0)),U,3)
+3 SET RAORDIFN=+$PIECE(RAJ,"^",11)
SET RACS=$PIECE(RAJ,"^",24)
SET RAPRIT=$PIECE(RAJ,"^",2)
+4 IF $DATA(^RA(72,+$PIECE(RAJ,"^",3),0))
SET RASN=$PIECE(^(0),"^")
if $PIECE(^(0),"^",3)'>0
QUIT
+5 IF $PIECE(RAJ,"^",6)]""
SET RAF5=$PIECE(RAJ,"^",6)
+6 SET RAIMGTYI=$PIECE($GET(^RADPT(DA(2),"DT",DA(1),0)),U,2)
SET RAIMGTYJ=$PIECE(^RA(79.2,RAIMGTYI,0),U)
+7 ; set RAOR, RASN, RASTI to lowest level's, to allow event when
+8 ; none of the levels meet all the requirements for that level
LOOP SET RAOR=$SELECT($ORDER(^RA(72,"AA",RAIMGTYJ,0))>0:$ORDER(^(0)),1:1)
+1 SET RASTI=+$ORDER(^RA(72,"AA",RAIMGTYJ,RAOR,0))
SET RASN=$PIECE($GET(^RA(72,+RASTI,0)),U)
+2 ;
+3 NEW RA
+4 FOR K=0:0
SET K=$ORDER(^RA(72,"AA",RAIMGTYJ,K))
if K'>0
QUIT
Begin DoDot:1
+5 SET X=""
SET E=+$ORDER(^RA(72,"AA",RAIMGTYJ,K,0))
if E'>0
QUIT
+6 IF $DATA(^RA(72,E,0))
Begin DoDot:2
+7 SET RA(0)=$GET(^RA(72,E,0))
SET N=$PIECE(RA(0),"^")
SET RAS=$GET(^RA(72,E,.1))
+8 IF '$LENGTH(RAS)
SET RAS="N"
+9 DO HELP1^RASTREQ
IF $DATA(X)
IF K>RAOR
SET RAOR=K
SET RASTI=E
SET RASN=N
+10 QUIT
End DoDot:2
+11 QUIT
End DoDot:1
+12 SET RAAFTER=RAOR
+13 IF $DATA(RASTI)
IF RASTI=$PIECE(RAJ,"^",3)
SET RAOR=-1
+14 KILL RAZ,RAK,RAE,RAIMGTYI,RAIMGTYJ,E,RAS,RAJ,RAJ1,N,K,FL
+15 QUIT
CANCEL ; cancel an exam
+1 SET RAOR=0
SET RASTI=RAXX
SET RASN=$PIECE($GET(^RA(72,RAXX,0)),"^")
+2 SET RAAFTER=RAOR
+3 ; 1st chk skip, 2nd chk done already<-- delxam
if $DATA(RAOPT("DELETEXAM"))
QUIT
+4 ; check again: 'allow cancelling' and if report exists
+5 ; in case Fileman enter/edit was used directly on the EXAM STATUS field
+6 ; if either check fails, set RAAFTER=RABEFORE so status can't change
+7 IF $DATA(^RA(72,+$PIECE(RAJ,U,3),0))
IF $PIECE(^(0),"^",6)'="y"
WRITE !,"This exam is in the '",$PIECE(^(0),"^"),"' status and cannot be 'CANCELLED'"
SET RAAFTER=RABEFORE
QUIT
+8 ; ok to cancel descendent exam w images if stub rpt and user has RA MGR key
+9 ; 06/11/2007 *85 Added descendent check to next line
+10 IF $PIECE(RAJ,U,17)'=""
IF $$STUB^RAEDCN1($PIECE(RAJ,U,17))
IF ($$PSET^RAEDCN1(RADFN,RADTI,RACNI))
IF $DATA(^XUSEC("RA MGR",+$GET(DUZ)))
QUIT
+11 ; can't cancel exam if report isn't stub
+12 IF $PIECE(RAJ,U,17)'=""
WRITE !,"A report has been filed for this case. Therefore cancellation is not allowed !"
SET RAAFTER=RABEFORE
+13 QUIT
