RAEDCN ;HISC/CAH,FPT,GJC,SS AISC/MJK,RMO-Edit Exams by Case Number ; Feb 19, 2021@08:08:21
;;5.0;Radiology/Nuclear Medicine;**5,13,10,18,28,31,34,45,85,97,124,175**;Mar 16, 1998;Build 2
;
; 06/11/2007 KAM/BAY RA*5*85 Remedy Call 174790 Change Exam Cancel
; to allow only descendent exams with stub report
;
;last modified by SS JUNE 21,2000 for P18
START D SET^RAPSET1 I $D(XQUIT) K XQUIT,RAFLG,RADR,POP,RAQUICK Q
START1 ;
N RAERR
D ^RACNLU S RAERR=0 G EXIT:X="^"
I RADR="[RA DIAGNOSTIC BY CASE]" D I RAERR R !?5,"Press RETURN to exit:",RAXIT:DTIME G EXIT
.N RAPRTSET,RAMEMARR,RA3,RA7003,RA17
.D EN2^RAUTL20(.RAMEMARR)
.S RA3=99
.; disallow case that is a member of a printset, fld 25 = 2
.I RAPRTSET W ! D WHYMSG2^RASTED S RAERR=1 Q
.S RA7003=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
.S RA17=$P(RA7003,U,17)
.; disallow case that has no report or has stub report
.I 'RA17!($$STUB^RAEDCN1(+RA17)) S RAERR=1 W !?3,$C(7),"No report has been entered yet for this exam, therefore it cannot be edited.",! Q
.; disallow case that has an elec. filed report
.I $P($G(^RARPT(+RA17,0)),U,5)="EF" S RAERR=1 D WARN1 Q
.Q
I $D(^RA(72,"AA",RAIMGTY,9,+RAST)),'$D(^XUSEC("RA MGR",+$G(DUZ))) W !!?3,$C(7),"You do not have the appropriate access privileges to edit completed exams." G START1
I $D(^RA(72,"AA",RAIMGTY,0,+RAST)) W !!?3,$C(7),"Exam has been 'cancelled' therefore it cannot be edited." G START1
I RADR="[RA DIAGNOSTIC BY CASE]",$D(^RARPT(RARPT,0)),$P(^(0),"^",5)="V" W !!?3,$C(7),"A report has been verified for this exam, therefore it cannot be edited.",! G START
S DA=RADFN,DIE("NO^")="OUTOK",DIE="^RADPT(",DR=RADR
I $D(RAFLG("EDIT"))!($D(RAFLG("DIAG"))) D G:+$G(RAXIT) START1
. S RADADA=RADTI,RADIE="^RADPT("_RADFN_",""DT"","
. S RAXIT=$$LOCK^RAUTL12(RADIE,RADADA)
. Q
I RADR="[RA EXAM EDIT]" D
. N RADISPLY
. S RADISPLY=$G(^RAMIS(71,+$P($G(^RADPT(+RADFN,"DT",+RADTI,"P",+RACNI,0)),U,2),0)) ; set $ZR to 71 for prccpt^radd1, not call raprod since diff col
. S RADISPLY=$$PRCCPT^RADD1()
. W !,?24,RADISPLY
.;
.;save 'before' CM data value to compare against the possible 'after'
.;value
.D TRK70CMB^RAMAINU(RADFN,RADTI,RACNI,.RATRKCMB) ;RA*5*45
.;
. Q
D:RADR'="[RA NO PURGE SPECIFICATION]" SVBEFOR^RAO7XX(RADFN,RADTI,RACNI) ;P18 save before edit to compare it in RAUTL1 later
D ^DIE K DIE("NO^"),DE,DQ,DIE,DR,RAZCM
D:RADR'="[RA NO PURGE SPECIFICATION]" UP1^RAUTL1
;
;1) check data consistency between 'CONTRAST MEDIA USED' & 'CONTRAST
;MEDIA'
;2) check 'before' CM data against 'after' CM data, file in audit log
;if necessary. Remember, contrast media asked when in input template:
;RA EXAM EDIT (RA*5*45)
I RADR="[RA EXAM EDIT]" D
.S RACMDA=RACNI,RACMDA(1)=RADTI,RACMDA(2)=RADFN
.D XCMINTEG^RAMAINU1(.RACMDA) ;1
.D TRK70CMA^RAMAINU(RADFN,RADTI,RACNI,RATRKCMB) ;2
.K RACMDA Q
;
I $D(RAFLG("EDIT"))!($D(RAFLG("DIAG"))) D UNLOCK^RAUTL12(RADIE,RADADA)
K RATRKCMB,RADUZ,RAZZ W ! G START1:'+$G(RAXIT)
;
EXIT ;clean up symbol table and exit
K %,%DT,%W,%X,%Y,%Y1,A,C,D0,D1,D2,DA,DIC,DIE,DIV,DK,I,ORIFN,ORVP,POP,RACN,RACNI,RACS,RACT,RADADA,RADATE,RADFN,RADIE,RADIV,RADR,RADTE,RADTI,RAEXFM,RAEXLBLS,RAFIN,RAFL,RAFLG,RAFLH,RAFLHFL,RAHEAD,RAI,RAJ
K RAMES,RANME,RANUM,RAOIFN,RAOR,RAORDIFN,RAOREA,RAORIFN,RAOSEL,RAOSTS,RAPOP,RAPRI,RAPRC,RAQUICK,RAPRIT,RARPT,RARPTZ,RASN,RASSN,RAST,RASTI,RAVW,X,XQUIT,VAINDT,VADMVT,Y,^TMP($J,"RAEX")
K %H,%I,D,D3,DDER,DI,DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,GMRAL,RAEXOR
K J,SDCLST,R1,RA,RACANC,RACN0,RACPT,RACPTNDE,RADA,RAEND,RAFELIG,RAFST
K RAIX,RAN,RAOBR4,RAPRCNDE,RAPROC,RAPROCIT,RAPRV,RAXIT,VA,VADM,VAERR,Z
K DFN,DIPGM,DISYS,DQ,DR,HLN,HLRESLT,HLSAN,RAAFTER,RABEFORE,X0
K DLAYGO,DDH,RADFLTP
Q
;
DIAG N RADIAG,RAXIT
S RAXIT=0,RAFLG("DIAG")="",RADR="[RA DIAGNOSTIC BY CASE]" G START
;
SAVE S RADR="[RA NO PURGE SPECIFICATION]" G START
;
EDIT ; Case No. Exam Edit
N RAEDIT,RAXIT
N RAREM,RANUZD1,RAPSDRUG,RA00,RADIOPH,RALOW,RAHI,RADRAWN,RAASK,RADOSE,RASKMEDS,RAWHICH ;these are used by the edit template
S RAXIT=0,RAFLG("EDIT")="",RAQUICK=1,RADR="[RA EXAM EDIT]" G START
;
CANCEL ;new w/RA5p124
D SET^RAPSET1 ;checks for DUZ if not defined we exit
I $D(XQUIT) K XQUIT Q
;
;check for EXAM CANCELLED ("C") 0 if found, else 1
Q:$$CKREASON^RAEDCN1("C")=1 ;RA5P124
;
;*** this code down to ASKCAN stays w/124 ***
D ^RACNLU G EXIT:X="^" I $D(^RA(72,"AA",RAIMGTY,0,+RAST)) W !?3,$C(7),"This exam has already been cancelled!" G EXIT
I $D(^RA(72,+RAST,0)),$P(^(0),"^",6)'="y" W !?3,$C(7),"This exam is in the '",$P(^(0),"^"),"' status and cannot be 'CANCELLED'." G EXIT
; 06/11/2007 KAM/BAY *85 Added descendent check to next line
ASKIMG I RARPT,($$STUB^RAEDCN1(RARPT)),($$PSET^RAEDCN1(RADFN,RADTI,RACNI)) D G:"Nn"[$E(X) EXIT G:"Yy"[$E(X) ASKCAN W:X'["?" $C(7) W !!?3,"Enter 'YES' to cancel a descendent exam with images, or 'NO' not to." G ASKIMG
. S X=RANME_"'s Case No. "_$E(RADTE,4,7)_$E(RADTE,2,3)_"-"_RACN ;p175
. W !!?10,"----------------------------------",$C(7)
. W !?10,X
. W !?10,"This descendent exam has associated images.",$C(7)
. W !?10,"----------------------------------",$C(7)
. I '$D(^XUSEC("RA MGR",DUZ)) D S X="N" Q
.. W !!?3,"** You do not have the RA MGR key to cancel an exam with images. **",$C(7)
.. R !!?10,"Press RETURN to continue.",X:DTIME
.. Q
. R !!,"Do you really want to cancel this exam with images? NO//",X:DTIME S:'$T!(X="")!(X["^") X="N"
. Q
;
I RARPT W !?3,$C(7),"A report has been filed for this case. Therefore cancellation is not allowed!" G EXIT
;
;is someone editing this patient record? if yes, quit (check moved w/RA5p124)
L +^RADPT(RADFN):1 I '$T W !,$C(7),"Someone else is editing the patient you selected",!,"Please try later" K RADTE,RACN,RAPOP,RADUZ G EXIT
; you set a lock, you must clear it!
;
ASKCAN ;interact with the user use DIR RA5p124
N %,DIR,DIROUT,DIRUT,DTOUT,DUOUT,RAY2,RAY3,X,Y
S DIR(0)="Y",DIR("B")="NO"
S DIR("?")="Enter 'YES' to cancel this exam. or 'NO' not to."
S DIR("A")="Do you wish to cancel this exam now"
D ^DIR
;Yes/No: Y=1 for yes else Y=0 for no
;$D(DIRUT) indicates caret or timeout
I $D(DIRUT)!(Y=0) D Q
.L -^RADPT(RADFN) ;unlock
.D EXIT ;cleanup vars
.Q
;/ end askcan /
;
;When an exam is cancelled & it is associated with data in the Nuc
;Med Exam Data file (70.2) ask the user if this pointer to 70.2 is
;to be deleted. Also delete the flag 'Dosage Ticket Printed?' which
;indicates that the dosage ticket had printed for this exam.
D DELPNT^RAUTL20(RADFN,RADTI,RACNI)
;
;get TECHNOLOGIST COMMENT & REASON FOR CANCELLATION (both optional)
K DIR,DIROUT,DIRUT,DTOUT,DUOUT
S RATCOM=$$GETTCOM^RAUTL11(RADFN,RADTI,RACNI) ;pseudo default
S DIR(0)="70.07,4A",DIR("A")="TECHNOLOGIST COMMENT: "_RATCOM_"//" D ^DIR
I $D(DUOUT)#2!($D(DTOUT)#2) L -^RADPT(RADFN) D EXIT QUIT
S RATCOM=$P(Y,U)
;
;/*** RA5_0P175 begin ***/
K DIR,DIROUT,DIRUT,DTOUT,DUOUT
S DIR(0)="70.03,3.5^^I ""^1^9^""[(U_$P(^(0),U,2)_U)"
S DIR("A")="REASON FOR CANCELLATION" D ^DIR
I $D(DUOUT)#2!($D(DTOUT)#2) L -^RADPT(RADFN) D EXIT QUIT
; Staying true to past functionality, this is not a required
; field. There is no default reason presented to the user.
S RAREASON=$S(+Y>0:+Y,1:$O(^RA(75.2,"B","EXAM CANCELLED","")))
; >>> RA5_0P175 'EXAM CANCELLED' becomes the default reason <<<
;/*** RA5_0P175 end ***/
;
;(we've not canceled the exam just yet)
S RAY2=$G(^RADPT(RADFN,"DT",RADTI,0)) ;70.02
S RAY3=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) ;70.03
S RAOIFN=+$P(RAY3,U,11)
;
;In EXMCAN^RAORDC the logic (EN1^RASETU) is called to check
;if there are multiple studies registered for the same date/time.
;RAEXOR = the ORDER of the exam status for the exam in play
;RAOSTS = is the request status the order will be set to.
S (RAEXOR,RAOSTS)=0 D EXMCAN^RAORDC
;
;check if the user times out or ^'s out (function returns -1)
;when asked if they want to cancel the order in RAORDC.
I RAOSTS=-1 L -^RADPT(RADFN) Q
;
;cancel the exam, update exam status tracking and activity logs
D CANCEL^RAEDCN1
;release the lock
L -^RADPT(RADFN)
;
PACS ;call all RA CANCEL* event drivers only if the order status
;and exam status have been updated! this is a new LOCK series
D CANCEL^RAHLRPC
D EXIT ;cleanup
QUIT
;
;
DUP ; Option: RA FLASH
N RAREGX,RAYN D SET^RAPSET1 I $D(XQUIT) K XQUIT,POP Q
DUP1 D ^RACNLU G EXIT:X="^"
G EXIT:'$D(^RADPT(RADFN,"DT",RADTI,0))
S RAREGX(0)=$G(^RADPT(RADFN,"DT",RADTI,0))
S RAREGX(4)=+$P(RAREGX(0),"^",4)
I +$G(RAMLC)'=RAREGX(4) D I $P(RAYN,"^",2) D EXIT QUIT
. W !!?3,"Your sign-on location is: "
. W $P($G(^SC(+$G(^RA(79.1,+$G(RAMLC),0)),0)),"^")_". The location"
. W !?3,"of case ",RACN," is "
. W $P($G(^SC(+$G(^RA(79.1,RAREGX(4),0)),0)),"^"),".",!
. K DIR,DIROUT,DIRUT,DTOUT,DUOUT S DIR(0)="Y",DIR("B")="Yes"
. S DIR("?")="Enter 'Y'es to switch locations or 'N'o exit the option."
. S DIR("A")="Do you wish to switch Imaging Locations" D ^DIR
. S RAYN=+Y_"^"_$S($D(DIRUT):1,1:0)
. K DIR,DIROUT,DIRUT,DTOUT,DUOUT Q:'+RAYN ; quit if no
. D KILL^RAPSET1,SET^RAPSET1 ; else switch locations
. I $D(XQUIT) S $P(RAYN,"^",2)=1 K XQUIT
. Q
S ION=$P(RAMLC,"^",3) ; imaging location flash card printer (if any)
G EXIT:'$D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) S Y=^(0),Y=$S($D(^RAMIS(71,+$P(Y,"^",2),0)):$P(^(0),"^",3),1:"")
; if Y, then convert the pointer value 'Y' to the .01 value of
; the procedure flash card printer (if any)
I Y]"",$D(^%ZIS(1,+Y,0)) D
. S Y(0)=$$GET1^DIQ(3.5,+Y,.01) ; .01 value for proc flash card printer
. S:Y(0)'=$P(RAMLC,"^",3) ION=Y(0) K Y(0)
. ; if flash card printer for the imaging location differs from
. ; the procedure flash card printer, default (print to) to the flash
. ; card printer for the procedure.
. Q
S RAMES="W !!,""Duplicates queued to print on "",ION,"".""",RAFLH=$S($P(RAMLC,"^",7):$P(RAMLC,"^",7),1:1),RAEXFM=$S($P(RAMLC,"^",9):$P(RAMLC,"^",9),1:1),RAFLHFL=RACNI
FLH ; Flash Cards
R !,"How many flash cards? 1// ",X:DTIME G DUP1:'$T!(X["^") S:X="" X=1 S RANUM=X I '(RANUM?.N)!(RANUM>20) W !?3,$C(7),"Must be a whole number less than 21!" G FLH
EXM ; Exam Labels
R !,"How many exam labels? 1// ",X:DTIME G DUP1:'$T!(X["^") S:X="" X=1 S RAEXLBLS=X I '(RAEXLBLS?.N)!(RAEXLBLS>20) W !?3,$C(7),"Must be a whole number less than 21!" G EXM
S IOP="Q" S:ION]"" RADFLTP=ION
K RAFL D Q^RAFLH,EXIT G DUP1
;
SETVARS ; Setup key Rad/Nuc Med variables
I $O(RACCESS(DUZ,""))="" D SETVARS^RAPSET1(0)
Q:'($D(RACCESS(DUZ))\10) ; user does not have location access
I $G(RAIMGTY)="" D SETVARS^RAPSET1(1) K:$G(RAIMGTY)="" XQUIT
Q
WARN1 W !?3,"An electronically filed report has already been entered for this case.",!?3,"Please use the 'Outside Report Entry/Edit' option to change or enter",!?3,"diagnostic code for this case.",!!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAEDCN 10973 printed Dec 13, 2024@02:34:56 Page 2
RAEDCN ;HISC/CAH,FPT,GJC,SS AISC/MJK,RMO-Edit Exams by Case Number ; Feb 19, 2021@08:08:21
+1 ;;5.0;Radiology/Nuclear Medicine;**5,13,10,18,28,31,34,45,85,97,124,175**;Mar 16, 1998;Build 2
+2 ;
+3 ; 06/11/2007 KAM/BAY RA*5*85 Remedy Call 174790 Change Exam Cancel
+4 ; to allow only descendent exams with stub report
+5 ;
+6 ;last modified by SS JUNE 21,2000 for P18
START DO SET^RAPSET1
IF $DATA(XQUIT)
KILL XQUIT,RAFLG,RADR,POP,RAQUICK
QUIT
START1 ;
+1 NEW RAERR
+2 DO ^RACNLU
SET RAERR=0
if X="^"
GOTO EXIT
+3 IF RADR="[RA DIAGNOSTIC BY CASE]"
Begin DoDot:1
+4 NEW RAPRTSET,RAMEMARR,RA3,RA7003,RA17
+5 DO EN2^RAUTL20(.RAMEMARR)
+6 SET RA3=99
+7 ; disallow case that is a member of a printset, fld 25 = 2
+8 IF RAPRTSET
WRITE !
DO WHYMSG2^RASTED
SET RAERR=1
QUIT
+9 SET RA7003=$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
+10 SET RA17=$PIECE(RA7003,U,17)
+11 ; disallow case that has no report or has stub report
+12 IF 'RA17!($$STUB^RAEDCN1(+RA17))
SET RAERR=1
WRITE !?3,$CHAR(7),"No report has been entered yet for this exam, therefore it cannot be edited.",!
QUIT
+13 ; disallow case that has an elec. filed report
+14 IF $PIECE($GET(^RARPT(+RA17,0)),U,5)="EF"
SET RAERR=1
DO WARN1
QUIT
+15 QUIT
End DoDot:1
IF RAERR
READ !?5,"Press RETURN to exit:",RAXIT:DTIME
GOTO EXIT
+16 IF $DATA(^RA(72,"AA",RAIMGTY,9,+RAST))
IF '$DATA(^XUSEC("RA MGR",+$GET(DUZ)))
WRITE !!?3,$CHAR(7),"You do not have the appropriate access privileges to edit completed exams."
GOTO START1
+17 IF $DATA(^RA(72,"AA",RAIMGTY,0,+RAST))
WRITE !!?3,$CHAR(7),"Exam has been 'cancelled' therefore it cannot be edited."
GOTO START1
+18 IF RADR="[RA DIAGNOSTIC BY CASE]"
IF $DATA(^RARPT(RARPT,0))
IF $PIECE(^(0),"^",5)="V"
WRITE !!?3,$CHAR(7),"A report has been verified for this exam, therefore it cannot be edited.",!
GOTO START
+19 SET DA=RADFN
SET DIE("NO^")="OUTOK"
SET DIE="^RADPT("
SET DR=RADR
+20 IF $DATA(RAFLG("EDIT"))!($DATA(RAFLG("DIAG")))
Begin DoDot:1
+21 SET RADADA=RADTI
SET RADIE="^RADPT("_RADFN_",""DT"","
+22 SET RAXIT=$$LOCK^RAUTL12(RADIE,RADADA)
+23 QUIT
End DoDot:1
if +$GET(RAXIT)
GOTO START1
+24 IF RADR="[RA EXAM EDIT]"
Begin DoDot:1
+25 NEW RADISPLY
+26 ; set $ZR to 71 for prccpt^radd1, not call raprod since diff col
SET RADISPLY=$GET(^RAMIS(71,+$PIECE($GET(^RADPT(+RADFN,"DT",+RADTI,"P",+RACNI,0)),U,2),0))
+27 SET RADISPLY=$$PRCCPT^RADD1()
+28 WRITE !,?24,RADISPLY
+29 ;
+30 ;save 'before' CM data value to compare against the possible 'after'
+31 ;value
+32 ;RA*5*45
DO TRK70CMB^RAMAINU(RADFN,RADTI,RACNI,.RATRKCMB)
+33 ;
+34 QUIT
End DoDot:1
+35 ;P18 save before edit to compare it in RAUTL1 later
if RADR'="[RA NO PURGE SPECIFICATION]"
DO SVBEFOR^RAO7XX(RADFN,RADTI,RACNI)
+36 DO ^DIE
KILL DIE("NO^"),DE,DQ,DIE,DR,RAZCM
+37 if RADR'="[RA NO PURGE SPECIFICATION]"
DO UP1^RAUTL1
+38 ;
+39 ;1) check data consistency between 'CONTRAST MEDIA USED' & 'CONTRAST
+40 ;MEDIA'
+41 ;2) check 'before' CM data against 'after' CM data, file in audit log
+42 ;if necessary. Remember, contrast media asked when in input template:
+43 ;RA EXAM EDIT (RA*5*45)
+44 IF RADR="[RA EXAM EDIT]"
Begin DoDot:1
+45 SET RACMDA=RACNI
SET RACMDA(1)=RADTI
SET RACMDA(2)=RADFN
+46 ;1
DO XCMINTEG^RAMAINU1(.RACMDA)
+47 ;2
DO TRK70CMA^RAMAINU(RADFN,RADTI,RACNI,RATRKCMB)
+48 KILL RACMDA
QUIT
End DoDot:1
+49 ;
+50 IF $DATA(RAFLG("EDIT"))!($DATA(RAFLG("DIAG")))
DO UNLOCK^RAUTL12(RADIE,RADADA)
+51 KILL RATRKCMB,RADUZ,RAZZ
WRITE !
if '+$GET(RAXIT)
GOTO START1
+52 ;
EXIT ;clean up symbol table and exit
+1 KILL %,%DT,%W,%X,%Y,%Y1,A,C,D0,D1,D2,DA,DIC,DIE,DIV,DK,I,ORIFN,ORVP,POP,RACN,RACNI,RACS,RACT,RADADA,RADATE,RADFN,RADIE,RADIV,RADR,RADTE,RADTI,RAEXFM,RAEXLBLS,RAFIN,RAFL,RAFLG,RAFLH,RAFLHFL,RAHEAD,RAI,RAJ
+2 KILL RAMES,RANME,RANUM,RAOIFN,RAOR,RAORDIFN,RAOREA,RAORIFN,RAOSEL,RAOSTS,RAPOP,RAPRI,RAPRC,RAQUICK,RAPRIT,RARPT,RARPTZ,RASN,RASSN,RAST,RASTI,RAVW,X,XQUIT,VAINDT,VADMVT,Y,^TMP($JOB,"RAEX")
+3 KILL %H,%I,D,D3,DDER,DI,DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,GMRAL,RAEXOR
+4 KILL J,SDCLST,R1,RA,RACANC,RACN0,RACPT,RACPTNDE,RADA,RAEND,RAFELIG,RAFST
+5 KILL RAIX,RAN,RAOBR4,RAPRCNDE,RAPROC,RAPROCIT,RAPRV,RAXIT,VA,VADM,VAERR,Z
+6 KILL DFN,DIPGM,DISYS,DQ,DR,HLN,HLRESLT,HLSAN,RAAFTER,RABEFORE,X0
+7 KILL DLAYGO,DDH,RADFLTP
+8 QUIT
+9 ;
DIAG NEW RADIAG,RAXIT
+1 SET RAXIT=0
SET RAFLG("DIAG")=""
SET RADR="[RA DIAGNOSTIC BY CASE]"
GOTO START
+2 ;
SAVE SET RADR="[RA NO PURGE SPECIFICATION]"
GOTO START
+1 ;
EDIT ; Case No. Exam Edit
+1 NEW RAEDIT,RAXIT
+2 ;these are used by the edit template
NEW RAREM,RANUZD1,RAPSDRUG,RA00,RADIOPH,RALOW,RAHI,RADRAWN,RAASK,RADOSE,RASKMEDS,RAWHICH
+3 SET RAXIT=0
SET RAFLG("EDIT")=""
SET RAQUICK=1
SET RADR="[RA EXAM EDIT]"
GOTO START
+4 ;
CANCEL ;new w/RA5p124
+1 ;checks for DUZ if not defined we exit
DO SET^RAPSET1
+2 IF $DATA(XQUIT)
KILL XQUIT
QUIT
+3 ;
+4 ;check for EXAM CANCELLED ("C") 0 if found, else 1
+5 ;RA5P124
if $$CKREASON^RAEDCN1("C")=1
QUIT
+6 ;
+7 ;*** this code down to ASKCAN stays w/124 ***
+8 DO ^RACNLU
if X="^"
GOTO EXIT
IF $DATA(^RA(72,"AA",RAIMGTY,0,+RAST))
WRITE !?3,$CHAR(7),"This exam has already been cancelled!"
GOTO EXIT
+9 IF $DATA(^RA(72,+RAST,0))
IF $PIECE(^(0),"^",6)'="y"
WRITE !?3,$CHAR(7),"This exam is in the '",$PIECE(^(0),"^"),"' status and cannot be 'CANCELLED'."
GOTO EXIT
+10 ; 06/11/2007 KAM/BAY *85 Added descendent check to next line
ASKIMG IF RARPT
IF ($$STUB^RAEDCN1(RARPT))
IF ($$PSET^RAEDCN1(RADFN,RADTI,RACNI))
Begin DoDot:1
+1 ;p175
SET X=RANME_"'s Case No. "_$EXTRACT(RADTE,4,7)_$EXTRACT(RADTE,2,3)_"-"_RACN
+2 WRITE !!?10,"----------------------------------",$CHAR(7)
+3 WRITE !?10,X
+4 WRITE !?10,"This descendent exam has associated images.",$CHAR(7)
+5 WRITE !?10,"----------------------------------",$CHAR(7)
+6 IF '$DATA(^XUSEC("RA MGR",DUZ))
Begin DoDot:2
+7 WRITE !!?3,"** You do not have the RA MGR key to cancel an exam with images. **",$CHAR(7)
+8 READ !!?10,"Press RETURN to continue.",X:DTIME
+9 QUIT
End DoDot:2
SET X="N"
QUIT
+10 READ !!,"Do you really want to cancel this exam with images? NO//",X:DTIME
if '$TEST!(X="")!(X["^")
SET X="N"
+11 QUIT
End DoDot:1
if "Nn"[$EXTRACT(X)
GOTO EXIT
if "Yy"[$EXTRACT(X)
GOTO ASKCAN
if X'["?"
WRITE $CHAR(7)
WRITE !!?3,"Enter 'YES' to cancel a descendent exam with images, or 'NO' not to."
GOTO ASKIMG
+12 ;
+13 IF RARPT
WRITE !?3,$CHAR(7),"A report has been filed for this case. Therefore cancellation is not allowed!"
GOTO EXIT
+14 ;
+15 ;is someone editing this patient record? if yes, quit (check moved w/RA5p124)
+16 LOCK +^RADPT(RADFN):1
IF '$TEST
WRITE !,$CHAR(7),"Someone else is editing the patient you selected",!,"Please try later"
KILL RADTE,RACN,RAPOP,RADUZ
GOTO EXIT
+17 ; you set a lock, you must clear it!
+18 ;
ASKCAN ;interact with the user use DIR RA5p124
+1 NEW %,DIR,DIROUT,DIRUT,DTOUT,DUOUT,RAY2,RAY3,X,Y
+2 SET DIR(0)="Y"
SET DIR("B")="NO"
+3 SET DIR("?")="Enter 'YES' to cancel this exam. or 'NO' not to."
+4 SET DIR("A")="Do you wish to cancel this exam now"
+5 DO ^DIR
+6 ;Yes/No: Y=1 for yes else Y=0 for no
+7 ;$D(DIRUT) indicates caret or timeout
+8 IF $DATA(DIRUT)!(Y=0)
Begin DoDot:1
+9 ;unlock
LOCK -^RADPT(RADFN)
+10 ;cleanup vars
DO EXIT
+11 QUIT
End DoDot:1
QUIT
+12 ;/ end askcan /
+13 ;
+14 ;When an exam is cancelled & it is associated with data in the Nuc
+15 ;Med Exam Data file (70.2) ask the user if this pointer to 70.2 is
+16 ;to be deleted. Also delete the flag 'Dosage Ticket Printed?' which
+17 ;indicates that the dosage ticket had printed for this exam.
+18 DO DELPNT^RAUTL20(RADFN,RADTI,RACNI)
+19 ;
+20 ;get TECHNOLOGIST COMMENT & REASON FOR CANCELLATION (both optional)
+21 KILL DIR,DIROUT,DIRUT,DTOUT,DUOUT
+22 ;pseudo default
SET RATCOM=$$GETTCOM^RAUTL11(RADFN,RADTI,RACNI)
+23 SET DIR(0)="70.07,4A"
SET DIR("A")="TECHNOLOGIST COMMENT: "_RATCOM_"//"
DO ^DIR
+24 IF $DATA(DUOUT)#2!($DATA(DTOUT)#2)
LOCK -^RADPT(RADFN)
DO EXIT
QUIT
+25 SET RATCOM=$PIECE(Y,U)
+26 ;
+27 ;/*** RA5_0P175 begin ***/
+28 KILL DIR,DIROUT,DIRUT,DTOUT,DUOUT
+29 SET DIR(0)="70.03,3.5^^I ""^1^9^""[(U_$P(^(0),U,2)_U)"
+30 SET DIR("A")="REASON FOR CANCELLATION"
DO ^DIR
+31 IF $DATA(DUOUT)#2!($DATA(DTOUT)#2)
LOCK -^RADPT(RADFN)
DO EXIT
QUIT
+32 ; Staying true to past functionality, this is not a required
+33 ; field. There is no default reason presented to the user.
+34 SET RAREASON=$SELECT(+Y>0:+Y,1:$ORDER(^RA(75.2,"B","EXAM CANCELLED","")))
+35 ; >>> RA5_0P175 'EXAM CANCELLED' becomes the default reason <<<
+36 ;/*** RA5_0P175 end ***/
+37 ;
+38 ;(we've not canceled the exam just yet)
+39 ;70.02
SET RAY2=$GET(^RADPT(RADFN,"DT",RADTI,0))
+40 ;70.03
SET RAY3=$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
+41 SET RAOIFN=+$PIECE(RAY3,U,11)
+42 ;
+43 ;In EXMCAN^RAORDC the logic (EN1^RASETU) is called to check
+44 ;if there are multiple studies registered for the same date/time.
+45 ;RAEXOR = the ORDER of the exam status for the exam in play
+46 ;RAOSTS = is the request status the order will be set to.
+47 SET (RAEXOR,RAOSTS)=0
DO EXMCAN^RAORDC
+48 ;
+49 ;check if the user times out or ^'s out (function returns -1)
+50 ;when asked if they want to cancel the order in RAORDC.
+51 IF RAOSTS=-1
LOCK -^RADPT(RADFN)
QUIT
+52 ;
+53 ;cancel the exam, update exam status tracking and activity logs
+54 DO CANCEL^RAEDCN1
+55 ;release the lock
+56 LOCK -^RADPT(RADFN)
+57 ;
PACS ;call all RA CANCEL* event drivers only if the order status
+1 ;and exam status have been updated! this is a new LOCK series
+2 DO CANCEL^RAHLRPC
+3 ;cleanup
DO EXIT
+4 QUIT
+5 ;
+6 ;
DUP ; Option: RA FLASH
+1 NEW RAREGX,RAYN
DO SET^RAPSET1
IF $DATA(XQUIT)
KILL XQUIT,POP
QUIT
DUP1 DO ^RACNLU
if X="^"
GOTO EXIT
+1 if '$DATA(^RADPT(RADFN,"DT",RADTI,0))
GOTO EXIT
+2 SET RAREGX(0)=$GET(^RADPT(RADFN,"DT",RADTI,0))
+3 SET RAREGX(4)=+$PIECE(RAREGX(0),"^",4)
+4 IF +$GET(RAMLC)'=RAREGX(4)
Begin DoDot:1
+5 WRITE !!?3,"Your sign-on location is: "
+6 WRITE $PIECE($GET(^SC(+$GET(^RA(79.1,+$GET(RAMLC),0)),0)),"^")_". The location"
+7 WRITE !?3,"of case ",RACN," is "
+8 WRITE $PIECE($GET(^SC(+$GET(^RA(79.1,RAREGX(4),0)),0)),"^"),".",!
+9 KILL DIR,DIROUT,DIRUT,DTOUT,DUOUT
SET DIR(0)="Y"
SET DIR("B")="Yes"
+10 SET DIR("?")="Enter 'Y'es to switch locations or 'N'o exit the option."
+11 SET DIR("A")="Do you wish to switch Imaging Locations"
DO ^DIR
+12 SET RAYN=+Y_"^"_$SELECT($DATA(DIRUT):1,1:0)
+13 ; quit if no
KILL DIR,DIROUT,DIRUT,DTOUT,DUOUT
if '+RAYN
QUIT
+14 ; else switch locations
DO KILL^RAPSET1
DO SET^RAPSET1
+15 IF $DATA(XQUIT)
SET $PIECE(RAYN,"^",2)=1
KILL XQUIT
+16 QUIT
End DoDot:1
IF $PIECE(RAYN,"^",2)
DO EXIT
QUIT
+17 ; imaging location flash card printer (if any)
SET ION=$PIECE(RAMLC,"^",3)
+18 if '$DATA(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
GOTO EXIT
SET Y=^(0)
SET Y=$SELECT($DATA(^RAMIS(71,+$PIECE(Y,"^",2),0)):$PIECE(^(0),"^",3),1:"")
+19 ; if Y, then convert the pointer value 'Y' to the .01 value of
+20 ; the procedure flash card printer (if any)
+21 IF Y]""
IF $DATA(^%ZIS(1,+Y,0))
Begin DoDot:1
+22 ; .01 value for proc flash card printer
SET Y(0)=$$GET1^DIQ(3.5,+Y,.01)
+23 if Y(0)'=$PIECE(RAMLC,"^",3)
SET ION=Y(0)
KILL Y(0)
+24 ; if flash card printer for the imaging location differs from
+25 ; the procedure flash card printer, default (print to) to the flash
+26 ; card printer for the procedure.
+27 QUIT
End DoDot:1
+28 SET RAMES="W !!,""Duplicates queued to print on "",ION,""."""
SET RAFLH=$SELECT($PIECE(RAMLC,"^",7):$PIECE(RAMLC,"^",7),1:1)
SET RAEXFM=$SELECT($PIECE(RAMLC,"^",9):$PIECE(RAMLC,"^",9),1:1)
SET RAFLHFL=RACNI
FLH ; Flash Cards
+1 READ !,"How many flash cards? 1// ",X:DTIME
if '$TEST!(X["^")
GOTO DUP1
if X=""
SET X=1
SET RANUM=X
IF '(RANUM?.N)!(RANUM>20)
WRITE !?3,$CHAR(7),"Must be a whole number less than 21!"
GOTO FLH
EXM ; Exam Labels
+1 READ !,"How many exam labels? 1// ",X:DTIME
if '$TEST!(X["^")
GOTO DUP1
if X=""
SET X=1
SET RAEXLBLS=X
IF '(RAEXLBLS?.N)!(RAEXLBLS>20)
WRITE !?3,$CHAR(7),"Must be a whole number less than 21!"
GOTO EXM
+2 SET IOP="Q"
if ION]""
SET RADFLTP=ION
+3 KILL RAFL
DO Q^RAFLH
DO EXIT
GOTO DUP1
+4 ;
SETVARS ; Setup key Rad/Nuc Med variables
+1 IF $ORDER(RACCESS(DUZ,""))=""
DO SETVARS^RAPSET1(0)
+2 ; user does not have location access
if '($DATA(RACCESS(DUZ))\10)
QUIT
+3 IF $GET(RAIMGTY)=""
DO SETVARS^RAPSET1(1)
if $GET(RAIMGTY)=""
KILL XQUIT
+4 QUIT
WARN1 WRITE !?3,"An electronically filed report has already been entered for this case.",!?3,"Please use the 'Outside Report Entry/Edit' option to change or enter",!?3,"diagnostic code for this case.",!!
+1 QUIT
