- 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
- 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
