RAUTL21 ;HOIFO/SWM,CRT;list & delete unneeded ^RARPT("ASTF" & "ARES" ;2/12/99 16:01
;;5.0;Radiology/Nuclear Medicine;**26,45**;Mar 16, 1998
;
EN1 N RA1,RA2,RACNT,RAKILREF,RALL,RATOT
S U="^"
S $P(RADL,"=",32)=""
S $P(RASL,"-",26)=""
S RATOT=0 ; total # of superfluous x-refs
S RAKILREF=0 ; flag to control kill of x-refs and display
;
D EN^DDIOL("RAD/NUC MED UTILITY TO LIST/DELETE LEFT-OVER REPORT X-REFS",,"!?3")
D EN^DDIOL(" ",,"!!")
;
S DIR(0)="Y"
S DIR("B")="YES"
S DIR("A")=" Do you want to print a list of left-over x-refs?"
D ^DIR K DIR
I $D(DTOUT)!$D(DUOUT) Q
I Y=1 D
.N %ZIS
.S %ZIS("A")="Select Device: "
.D ^%ZIS I POP K STOUT,DUOUT,POP Q
.U IO
.F RAXREF="ARES","ASTF" D L1
.S:RATOT=0 RATOT=-1
.D ^%ZISC,HOME^%ZIS
;
Q:RATOT<0
D EN^DDIOL(" ",,"!!")
S DIR(0)="Y"
S DIR("A")=" Do you want to clean up the"_$S(RATOT:"se "_RATOT,1:"")_" left-over x-refs?"
S DIR("B")="NO"
D ^DIR K DIR
I $D(DTOUT)!$D(DUOUT) Q
I Y=1 D
.S RAKILREF=1
.F RAXREF="ARES","ASTF" D L1
Q
;
L1 ; Loop through left-over x-refs
;
N WAIT
;
I 'RAKILREF D HEAD
;
S WAIT=""
S RA1=0 F S RA1=$O(^RARPT(RAXREF,RA1)) Q:'RA1 D Q:WAIT="^"
. S RACNT=0
. S RA2=0 F S RA2=$O(^RARPT(RAXREF,RA1,RA2)) Q:'RA2 D Q:WAIT="^"
.. I $D(^RARPT(RA2,0)),$P(^RARPT(RA2,0),U,5)'="V" Q
.. S RACNT=RACNT+1 ; Total for this physician
.. S RATOT=RATOT+1
.. I 'RAKILREF D Q:WAIT="^"
... I $Y>(IOSL-3) D WAIT Q:WAIT="^" S WAIT="" W @IOF D HEAD S RACNT=1
... D EN^DDIOL($S(RACNT=1:$E($P($G(^VA(200,RA1,0)),U),1,30),1:" "),,"!?3")
... D EN^DDIOL($S($D(^RARPT(RA2,0)):$P(^(0),U),1:"Unknown report #"_RA2),,"?40")
.. I RAKILREF D
... D EN^DDIOL("^RARPT("""_RAXREF_""","_RA1_","_RA2_") deleted","","!?3")
... K ^RARPT(RAXREF,RA1,RA2)
Q:WAIT="^"
I RATOT=0 D EN^DDIOL("< There are no left-over """_RAXREF_""" x-refs found. >","","!?10")
Q
;
HEAD ;
D EN^DDIOL("LEFT-OVER ^RARPT("""_RAXREF_""") X-REFS",,"!!?20")
D EN^DDIOL(RADL,,"!?20")
D EN^DDIOL($S(RAXREF="ARES":"RESIDENT",1:"STAFF")_" PHYSICIAN",,"!!?3")
D EN^DDIOL("CASE # OF LEFT-OVER X-REF",,"?40")
D EN^DDIOL($S(RAXREF="ARES":$E(RASL,1,18),1:$E(RASL,1,15)),,"!?3")
D EN^DDIOL(RASL,,"?40")
D EN^DDIOL(" ",,"!")
Q
;
WAIT ;
I $E(IOST,1,2)'="C-" S WAIT="" Q ;Don't prompt if report not to screen
;
N DIR
S DIR(0)="E"
S (DIR("?"),DIR("??"))=""
D ^DIR K DIR
I Y=""!(Y=0) S WAIT="^"
Q
;
CHGPRC(RAOPRC,RANPRC,DA) ;If a procedure is changed during
;exam edits, ensure that CM associations of the "changed to"
;procedure are associated with the exam. If the "changed to"
;procedure does not have CM associations, make sure the exam
;does not have CM associations from the "changed from" procedure.
;
;called from the RA STATUS CHANGE & RA EXAM EDIT input templates
;Input: RAOPRC=the IEN of the "changed from" procedure
; RANPRC=the IEN of the "changed to" procedure
; DA(2)=the IEN of the patient in the PATIENT (#2) file (RADFN)
; DA(1)=the inverse date/time of the exam (RADTI)
; DA=the IEN of case (RACNI)
;
I +$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CM",0)) D
.W !!?3,"Deleting the contrast media with this exam for procedure:",!?3,"'"_$P($G(^RAMIS(71,RAOPRC,0)),U)_"'."
.K ^RADPT(DA(2),"DT",DA(1),"P",DA,"CM") ;kills both data and 'B' xref
.D UPXCM^RAMAINU(.DA,"N") ;set CONTRAST MEDIA USED field to 'no'
.Q
I +$O(^RAMIS(71,RANPRC,"CM",0)) D
.W !!?3,"Adding the contrast media to this exam for procedure:",!?3,"'"_$P($G(^RAMIS(71,RANPRC,0)),U)_"'."
.D STUFCM70^RAMAINU(.DA,RANPRC)
.D UPXCM^RAMAINU(.DA,"Y") ;set CONTRAST MEDIA USED field to 'yes'
.Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAUTL21 3691 printed Sep 23, 2025@20:16:30 Page 2
RAUTL21 ;HOIFO/SWM,CRT;list & delete unneeded ^RARPT("ASTF" & "ARES" ;2/12/99 16:01
+1 ;;5.0;Radiology/Nuclear Medicine;**26,45**;Mar 16, 1998
+2 ;
EN1 NEW RA1,RA2,RACNT,RAKILREF,RALL,RATOT
+1 SET U="^"
+2 SET $PIECE(RADL,"=",32)=""
+3 SET $PIECE(RASL,"-",26)=""
+4 ; total # of superfluous x-refs
SET RATOT=0
+5 ; flag to control kill of x-refs and display
SET RAKILREF=0
+6 ;
+7 DO EN^DDIOL("RAD/NUC MED UTILITY TO LIST/DELETE LEFT-OVER REPORT X-REFS",,"!?3")
+8 DO EN^DDIOL(" ",,"!!")
+9 ;
+10 SET DIR(0)="Y"
+11 SET DIR("B")="YES"
+12 SET DIR("A")=" Do you want to print a list of left-over x-refs?"
+13 DO ^DIR
KILL DIR
+14 IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+15 IF Y=1
Begin DoDot:1
+16 NEW %ZIS
+17 SET %ZIS("A")="Select Device: "
+18 DO ^%ZIS
IF POP
KILL STOUT,DUOUT,POP
QUIT
+19 USE IO
+20 FOR RAXREF="ARES","ASTF"
DO L1
+21 if RATOT=0
SET RATOT=-1
+22 DO ^%ZISC
DO HOME^%ZIS
End DoDot:1
+23 ;
+24 if RATOT<0
QUIT
+25 DO EN^DDIOL(" ",,"!!")
+26 SET DIR(0)="Y"
+27 SET DIR("A")=" Do you want to clean up the"_$SELECT(RATOT:"se "_RATOT,1:"")_" left-over x-refs?"
+28 SET DIR("B")="NO"
+29 DO ^DIR
KILL DIR
+30 IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+31 IF Y=1
Begin DoDot:1
+32 SET RAKILREF=1
+33 FOR RAXREF="ARES","ASTF"
DO L1
End DoDot:1
+34 QUIT
+35 ;
L1 ; Loop through left-over x-refs
+1 ;
+2 NEW WAIT
+3 ;
+4 IF 'RAKILREF
DO HEAD
+5 ;
+6 SET WAIT=""
+7 SET RA1=0
FOR
SET RA1=$ORDER(^RARPT(RAXREF,RA1))
if 'RA1
QUIT
Begin DoDot:1
+8 SET RACNT=0
+9 SET RA2=0
FOR
SET RA2=$ORDER(^RARPT(RAXREF,RA1,RA2))
if 'RA2
QUIT
Begin DoDot:2
+10 IF $DATA(^RARPT(RA2,0))
IF $PIECE(^RARPT(RA2,0),U,5)'="V"
QUIT
+11 ; Total for this physician
SET RACNT=RACNT+1
+12 SET RATOT=RATOT+1
+13 IF 'RAKILREF
Begin DoDot:3
+14 IF $Y>(IOSL-3)
DO WAIT
if WAIT="^"
QUIT
SET WAIT=""
WRITE @IOF
DO HEAD
SET RACNT=1
+15 DO EN^DDIOL($SELECT(RACNT=1:$EXTRACT($PIECE($GET(^VA(200,RA1,0)),U),1,30),1:" "),,"!?3")
+16 DO EN^DDIOL($SELECT($DATA(^RARPT(RA2,0)):$PIECE(^(0),U),1:"Unknown report #"_RA2),,"?40")
End DoDot:3
if WAIT="^"
QUIT
+17 IF RAKILREF
Begin DoDot:3
+18 DO EN^DDIOL("^RARPT("""_RAXREF_""","_RA1_","_RA2_") deleted","","!?3")
+19 KILL ^RARPT(RAXREF,RA1,RA2)
End DoDot:3
End DoDot:2
if WAIT="^"
QUIT
End DoDot:1
if WAIT="^"
QUIT
+20 if WAIT="^"
QUIT
+21 IF RATOT=0
DO EN^DDIOL("< There are no left-over """_RAXREF_""" x-refs found. >","","!?10")
+22 QUIT
+23 ;
HEAD ;
+1 DO EN^DDIOL("LEFT-OVER ^RARPT("""_RAXREF_""") X-REFS",,"!!?20")
+2 DO EN^DDIOL(RADL,,"!?20")
+3 DO EN^DDIOL($SELECT(RAXREF="ARES":"RESIDENT",1:"STAFF")_" PHYSICIAN",,"!!?3")
+4 DO EN^DDIOL("CASE # OF LEFT-OVER X-REF",,"?40")
+5 DO EN^DDIOL($SELECT(RAXREF="ARES":$EXTRACT(RASL,1,18),1:$EXTRACT(RASL,1,15)),,"!?3")
+6 DO EN^DDIOL(RASL,,"?40")
+7 DO EN^DDIOL(" ",,"!")
+8 QUIT
+9 ;
WAIT ;
+1 ;Don't prompt if report not to screen
IF $EXTRACT(IOST,1,2)'="C-"
SET WAIT=""
QUIT
+2 ;
+3 NEW DIR
+4 SET DIR(0)="E"
+5 SET (DIR("?"),DIR("??"))=""
+6 DO ^DIR
KILL DIR
+7 IF Y=""!(Y=0)
SET WAIT="^"
+8 QUIT
+9 ;
CHGPRC(RAOPRC,RANPRC,DA) ;If a procedure is changed during
+1 ;exam edits, ensure that CM associations of the "changed to"
+2 ;procedure are associated with the exam. If the "changed to"
+3 ;procedure does not have CM associations, make sure the exam
+4 ;does not have CM associations from the "changed from" procedure.
+5 ;
+6 ;called from the RA STATUS CHANGE & RA EXAM EDIT input templates
+7 ;Input: RAOPRC=the IEN of the "changed from" procedure
+8 ; RANPRC=the IEN of the "changed to" procedure
+9 ; DA(2)=the IEN of the patient in the PATIENT (#2) file (RADFN)
+10 ; DA(1)=the inverse date/time of the exam (RADTI)
+11 ; DA=the IEN of case (RACNI)
+12 ;
+13 IF +$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CM",0))
Begin DoDot:1
+14 WRITE !!?3,"Deleting the contrast media with this exam for procedure:",!?3,"'"_$PIECE($GET(^RAMIS(71,RAOPRC,0)),U)_"'."
+15 ;kills both data and 'B' xref
KILL ^RADPT(DA(2),"DT",DA(1),"P",DA,"CM")
+16 ;set CONTRAST MEDIA USED field to 'no'
DO UPXCM^RAMAINU(.DA,"N")
+17 QUIT
End DoDot:1
+18 IF +$ORDER(^RAMIS(71,RANPRC,"CM",0))
Begin DoDot:1
+19 WRITE !!?3,"Adding the contrast media to this exam for procedure:",!?3,"'"_$PIECE($GET(^RAMIS(71,RANPRC,0)),U)_"'."
+20 DO STUFCM70^RAMAINU(.DA,RANPRC)
+21 ;set CONTRAST MEDIA USED field to 'yes'
DO UPXCM^RAMAINU(.DA,"Y")
+22 QUIT
End DoDot:1
+23 QUIT
