RAEDCN ;HISC/CAH,FPT,GJC,SS AISC/MJK,RMO-Edit Exams by Case Number ;1/11/02 11:15
;;5.0;Radiology/Nuclear Medicine;**5,13,10,18,28,31,34,45,85,97**;Mar 16, 1998;Build 6
;
; 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 Q:X="^"
I RADR="[RA DIAGNOSTIC BY CASE]" D I RAERR R !?5,"Press RETURN to exit:",RAXIT:DTIME G Q
.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)
;
Q 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
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 D SET^RAPSET1 I $D(XQUIT) K XQUIT Q
S RAXIT=$$CKREASON^RAEDCN1("C") I RAXIT K RAXIT Q ;P18
D ^RACNLU G Q:X="^" I $D(^RA(72,"AA",RAIMGTY,0,+RAST)) W !?3,$C(7),"This exam has already been cancelled!" G Q
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 Q
; 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) Q 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,1,2)_"-"_RACN
. 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 Q
ASKCAN R !!,"Do you wish to cancel this exam now? NO// ",X:DTIME S:'$T!(X="")!(X["^") X="N" G Q:"Nn"[$E(X) I "Yy"'[$E(X) W:X'["?" $C(7) W !!?3,"Enter 'YES' to cancel this exam, or 'NO' not to." G ASKCAN
N REM ;used for remarks within edit template
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 Q
S DA=RADFN,DR="[RA CANCEL]",DIE="^RADPT(" D ^DIE K DE,DQ,DIE,DR
K RADTE,RACN,RAPOP,RADUZ ;moved from edit template
PACS I '$D(Y),$D(RAFIN) W !?10,"...cancellation complete." D DELPNT^RAUTL20(RADFN,RADTI,RACNI),^RAORDC,CANCEL^RAHLRPC
L -^RADPT(RADFN)
G Q
;
DUP ; Option: RA FLASH
N RAREGX,RAYN D SET^RAPSET1 I $D(XQUIT) K XQUIT,POP Q
DUP1 D ^RACNLU G Q:X="^"
G Q:'$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 Q 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 Q:'$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,Q 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
RAEDCN ;HISC/CAH,FPT,GJC,SS AISC/MJK,RMO-Edit Exams by Case Number ;1/11/02 11:15
+1 ;;5.0;Radiology/Nuclear Medicine;**5,13,10,18,28,31,34,45,85,97**;Mar 16, 1998;Build 6
+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 Q
+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 Q
+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 ;
Q 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
+1 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")
+2 KILL %H,%I,D,D3,DDER,DI,DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,GMRAL
+3 KILL J,SDCLST,R1,RA,RACANC,RACN0,RACPT,RACPTNDE,RADA,RAEND,RAFELIG,RAFST
+4 KILL RAIX,RAN,RAOBR4,RAPRCNDE,RAPROC,RAPROCIT,RAPRV,RAXIT,VA,VADM,VAERR,Z
+5 KILL DFN,DIPGM,DISYS,DQ,DR,HLN,HLRESLT,HLSAN,RAAFTER,RABEFORE,X0
+6 KILL DLAYGO,DDH,RADFLTP
+7 QUIT
+8 ;
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 DO SET^RAPSET1
IF $DATA(XQUIT)
KILL XQUIT
QUIT
+1 ;P18
SET RAXIT=$$CKREASON^RAEDCN1("C")
IF RAXIT
KILL RAXIT
QUIT
+2 DO ^RACNLU
IF X="^"
GOTO Q
IF $DATA(^RA(72,"AA",RAIMGTY,0,+RAST))
WRITE !?3,$CHAR(7),"This exam has already been cancelled!"
GOTO Q
+3 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 Q
+4 ; 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 SET X=RANME_"'s Case No. "_$EXTRACT(RADTE,4,7)_$EXTRACT(RADTE,1,2)_"-"_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 Q
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 IF RARPT
WRITE !?3,$CHAR(7),"A report has been filed for this case. Therefore cancellation is not allowed!"
GOTO Q
ASKCAN READ !!,"Do you wish to cancel this exam now? NO// ",X:DTIME
IF '$TEST!(X="")!(X["^")
SET X="N"
IF "Nn"[$EXTRACT(X)
GOTO Q
IF "Yy"'[$EXTRACT(X)
IF X'["?"
WRITE $CHAR(7)
WRITE !!?3,"Enter 'YES' to cancel this exam, or 'NO' not to."
GOTO ASKCAN
+1 ;used for remarks within edit template
NEW REM
+2 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 Q
+3 SET DA=RADFN
SET DR="[RA CANCEL]"
SET DIE="^RADPT("
DO ^DIE
KILL DE,DQ,DIE,DR
+4 ;moved from edit template
KILL RADTE,RACN,RAPOP,RADUZ
PACS IF '$DATA(Y)
IF $DATA(RAFIN)
WRITE !?10,"...cancellation complete."
DO DELPNT^RAUTL20(RADFN,RADTI,RACNI)
DO ^RAORDC
DO CANCEL^RAHLRPC
+1 LOCK -^RADPT(RADFN)
+2 GOTO Q
+3 ;
DUP ; Option: RA FLASH
+1 NEW RAREGX,RAYN
DO SET^RAPSET1
IF $DATA(XQUIT)
KILL XQUIT,POP
QUIT
DUP1 DO ^RACNLU
IF X="^"
GOTO Q
+1 IF '$DATA(^RADPT(RADFN,"DT",RADTI,0))
GOTO Q
+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 Q
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 Q
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 Q
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
