- 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 Feb 19, 2025@00:06:11 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