RAUTL2 ;HISC/CAH,FPT,GJC AISC/MJK,RMO-Utility Routine ;11/10/97 11:18
;;5.0;Radiology/Nuclear Medicine;**10,26,45,47**;Mar 16, 1998;Build 21
;
;Called from many points within Rad/Nuc Med package ;ch
;INPUT VARIABLES: Y=IEN of Rad Report file #74
; XRT0,XRT1 If set, will do some response time checks
;OUTPUT VARIABLES:
; RADFN=Patient DFN, RADTE=Exam date/time (FM format),
; RACN=long case number, RADTI=reverse exam date/time,
; RACNI=short case number, RADATE=Exam date/time (external format)
; Y=If active case, zeroeth node of case record in file #70
RASET ;P47 Check SSAN and use ADC or ADC1 accordingly:
;If .01 of RARPT>12 (SSAN) use "ADC1" x-ref to look up exam
;If .01 of RARPT'>12 (old CASE NO.) use "ADC" x-ref to look up exam
D:$D(XRTL) T0^%ZOSV
S Y=$S($D(^RARPT(+Y,0)):^(0),1:"") Q:'Y S RADFN=+$P(Y,"^",2)
S RADTE=+$P(Y,"^",3),RACN=+$P(Y,"^",4),RADTI=9999999.9999-RADTE
I $L($P(Y,"^"),"-")>2 S RACNI=$O(^RADPT("ADC1",$P(Y,"^"),RADFN,RADTI,0))
I $L($P(Y,"^"),"-")<3 S RACNI=$O(^RADPT("ADC",$P(Y,"^"),RADFN,RADTI,0))
S Y=RADTE D D^RAUTL S RADATE=Y
;D:$D(XRTL) T0^%ZOSV S Y=$S($D(^RARPT(+Y,0)):^(0),1:"") Q:'Y S RADFN=+$P(Y,"^",2),RADTE=+$P(Y,"^",3),RACN=+$P(Y,"^",4),RADTI=9999999.9999-RADTE,RACNI=$O(^RADPT("ADC",$P(Y,"^"),RADFN,RADTI,0)) S Y=RADTE D D^RAUTL S RADATE=Y
S Y="" I RACNI,$D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) S Y=^(0)
I $D(XRT0) S XRTN=$T(+0) D T1^%ZOSV
Q
;
;Called from 2 x-refs on file #74, Rpt Status fld 5 ;ch
;Does sets and kills for 'ARES', and 'ASTF' xrefs
; ** CAUTION ** 1st RARAD=12 or 15, 2nd RARAD=ien for file 200
XREF Q:'$D(^RARPT(DA,0)) S RADFNZ=^(0),RADTIZ=9999999.9999-$P(RADFNZ,"^",3),RACNIZ=$O(^RADPT(+$P(RADFNZ,"^",2),"DT",RADTIZ,"P","B",+$P(RADFNZ,"^",4),0)),RADFNZ=+$P(RADFNZ,"^",2),RADA=DA G Q:'RACNIZ
S RARADOLD=RARAD ;save 1st value of rarad
G Q:'$D(^RADPT(RADFNZ,"DT",RADTIZ,"P",RACNIZ,0)) S RARAD=+$P(^(0),"^",RARAD) G Q:'RARAD
; ** CAUTION ** next line is reached 2 ways : from line above,
; and also from file 70.03, fld 15's "ASTF" xref
; thus RARAD's 2nd meaning must be preserved for XREF1
XREF1 S:$D(RASET) ^RARPT(RAXREF,RARAD,RADA)="" K:$D(RAKILL) ^RARPT(RAXREF,RARAD,RADA) D XPRI^RAUTL20
Q K RADA,RADFNZ,RADTIZ,RACNIZ,RARADOLD Q
;
;Checks for CONTRAST MEDIA given the necessary subscripts
;to access a record in File #70.
;RADFN, RADTI, RACNI must be set.
;Output is Y=a string delimited by commas containing all
;applicable items in externally formatted text (ex: If exam was
;done with contrast media Y="CONTRAST MEDIA USED"
;06/16/99 remove obsolete RAF2
; add CPT Modifiers string
; output Y = procedure modifiers string
; Y(1)= CPT modifiers string, external
; Y(2)= CPT modifiers string, internal
MODS ;get procedure modifiers
S (Y,Y(1),Y(2))="" Q:'$D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) S X=^(0)
F I=0:0 S I=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"M",I)) Q:I'>0 I $D(^RAMIS(71.2,+^(I,0),0)) S X1=$P(^(0),"^") D MODS1
S:$P(X,"^",10)["Y" X1="CONTRAST MEDIA USED"
;
MODS0 ;falls through from MODS; get CPT modifiers
S:Y="" Y="None"
S X=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),I=0
F S I=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",I)) Q:I'>0 S X1=$$BASICMOD^RACPTMSC(+$G(^(I,0)),DT) I +X1>0 S Y(1)=Y(1)_$S(Y(1)="":"",1:", ")_$P(X1,"^",2),Y(2)=Y(2)_$S(Y(2)="":"",1:", ")_$P(X1,"^")
S:Y(1)="" Y(1)="None"
K I,X,X1 Q
;
MODS1 ;builds procedure modifier string (called from MODS above)
S Y=Y_$S(Y="":"",1:", ")_X1 Q
;
;called to do some order checks - takes appropriate action if:
; procedure requested needs Rad/NM physician approval (File 71, fld 11)
; there are other outstanding orders for this procedure for this pt
; user is inactivated (file 200, "I" node)
ORDPRC I $D(^RAMIS(71,+X,0)),$P(^(0),"^",11)["y" D CHKUSR I 'RAMSG W !!,"Please contact appropriate Imaging Service to request this procedure! " K X,RAMSG Q
S RAS3=+$P(^RAO(75.1,DA,0),"^")
ORDPRC1 Q:'$D(^RAO(75.1,"AP",RAS3,X)) S RAS4=X,RASCNT=0 K RAX
F RAS5=0:0 S RAS5=$O(^RAO(75.1,"AP",RAS3,RAS4,RAS5)) Q:'RAS5 F RAS6=0:0 S RAS6=$O(^RAO(75.1,"AP",RAS3,RAS4,RAS5,RAS6)) Q:'RAS6 I $D(^RAO(75.1,RAS6,0)) S RAT=+$P(^(0),"^",5) I RAT>2 S RASCNT=RASCNT+1 D:$S('$D(RAQUIT):1,1:RASCNT>1) ORDMES
I $D(RAX),'$D(RAQUIT) D ORDMES1
K:$D(RAX) RAQUIT K RAMSG,RAS3,RAS4,RAS5,RAS6,RASCNT,RAT,RAX Q
;
CHKUSR ; Check if valid user
N RAINADT,RAC
S RAINADT=+$P($G(^VA(200,+$G(DUZ),"PS")),"^",4)
S RAC=$O(^VA(200,+$G(DUZ),"RAC",0))
S RAMSG=$S('($D(DUZ)#2):0,'$D(^VA(200,DUZ,0)):0,'RAC:0,'RAINADT:1,'$D(DT):0,DT'>RAINADT:1,1:0)
Q
ORDMES W:'$D(RAX) !!,*7,"The following requests are already on file for this procedure:",!
W !?3,"A request dated " S Y=9999999.9999-RAS5 D DT^DIO2 W " is already ",$S(RAT=3:"on ",1:""),$P($P(^DD(75.1,5,0),RAT_":",2),";")," for this procedure." S RAX=1 Q
ORDMES1 W !!?3,"Is it ok to continue? No// " R RAX:DTIME S:'$T!(RAX="")!(RAX["^") RAX="N"
I "Nn"[$E(RAX) K X S RAPRI=0
I $D(X),"Yy"'[$E(RAX) W !!?3,"Enter 'YES' to request this procedure for this patient, or 'NO' not to.",! G ORDMES1
Q
;
;Called (from RAPSET) to determine if at least one division and at
;least one location are set up. Can't use pkg unless these are set up.
CHKSP S RADV=$S($O(^RA(79,0))>0:1,1:0),RALC=$S($D(^RA(79.1,+$O(^RA(79,"AL",0)),0)):1,1:0)
Q
;
KILLVAR ;This call will clean up possible variables left after execution
;of the Label print fields in file 78.7
K RAY0,RAY1,RAY2,RAY3,RAGE,RACSE,RANOW,RADOB,RAEXDT,RATRAN,RARPDT,RADIAG,RAMOD,RAINST,RAEXLST,RAVST,RALCSE,RANM,RAPAGE,RAPR,RAL,RARST,RAREA,RADOC,RARAD,RASSN
K RASTAFF,RASIGS,RATECH,RACTY,RASIGVES,RAVER,RASIGVS,RASIGVSB,RASIGR,RASERV,RASEX,RAS,RAII,RAFMT,RASV
Q
;
CONTRAST(RAZ71) ;Display the contrast media/medium associated with a Rad/Nuc
;Med Procedure. Called from: PRC1^RAUTL8 & ALLERGY^RAORD1
;input: RAZ71=ien of the non-parent procedure in file 71
;
K RAZCM S RAZ71(0)=$G(^RAMIS(71,RAZ71,0))
S RAZCMU=$P(RAZ71(0),"^",20) ;is contrast media used?
I RAZCMU'="Y" K RAZCMU Q
D GETS^DIQ(71,RAZ71_",","125*","E","RAZCM")
; The RAZCM(71.0125,x,.01,"E") array will be one or more of following
; values: I:Iodinated contrast, ionic;N:Iodinated contrast, non-ionic
; L:Gadolinium, C:Cholecystogram;G:Gastrografin;B:Barium
;
S:$O(RAZCM(71.0125,$C(126)),-1)=$O(RAZCM(71.0125,"")) RAZTAG="medium"
S:'$D(RAZTAG)#2 RAZTAG="media"
S RAPMSG(1)="************** Patient reaction to contrast "_RAZTAG_" *************"
S RAPMSG(2)=$E($P(RAZ71(0),"^"),1,47)_" uses contrast "_RAZTAG_": "
S RAPMSG(2,"F")="!",RAZI="",RAZSUB=$O(RAPMSG($C(32)),-1)
F S RAZI=$O(RAZCM(71.0125,RAZI)) Q:RAZI="" D
.S:$L($G(RAPMSG(RAZSUB)))+$L(RAZCM(71.0125,RAZI,.01,"E"))>69 RAZSUB=RAZSUB+1
.S RAPMSG(RAZSUB)=$G(RAPMSG(RAZSUB))_RAZCM(71.0125,RAZI,.01,"E")_", "
.Q
; The reverse dollar order (R$O) is used to strip off the ", " string
; from the last printable subscript containing CM data. I also use the
; R$O to set my last printable array element to '*'s to box off the
; warning.
S RAPMSG($O(RAPMSG($C(32)),-1))=$E(RAPMSG($O(RAPMSG($C(32)),-1)),1,$L(RAPMSG($O(RAPMSG($C(32)),-1)))-2) ;strips off the ", "
S $P(RAPMSG($O(RAPMSG($C(32)),-1)+1),"*",69)="",RAPMSG(99)=" "
D EN^DDIOL(.RAPMSG)
K RAPMSG,RAZCM,RAZCMU,RAZI,RAZTAG,RAZSUB
Q
;
DELCM(DA) ;Ask the user if he/she is sure that deletion of contrast media
;is intended. If the user enter '^' exit editng the template
; input: DA=the ien of the record in file 71
;output: RAYN=response to 'Are you sure?'; either 'Y', 'N', or '^'
;Called from the RA PROCEDURE EDIT input template (RA*5*45)
N RAYN W !?3,"*** Deleting all contrast media data associated with this procedure. ***"
F D Q:$L($G(RAYN))
.R !!?3,"All contrast relationships with this procedure will be deleted.",!?3,"Are you sure you want to delete? N// ",RAYN:DTIME
.S:'$T!(RAYN["^") RAYN="^" Q:RAYN="^"
.S:RAYN="" RAYN="N" Q:RAYN="N"
.S RAYN=$$UP^XLFSTR($E(RAYN)) Q:RAYN="Y"!(RAYN="N")
.I RAYN["?" W !?3,"Enter 'Y'es to delete associated contrasts, or 'N'o to preserve associated",!?3,"contrasts." K RAYN Q
.K RAYN W !?3,"Please enter 'Y' for yes, or 'N' for no."
.Q
;The user does not want to delete associated cm data or has '^' out of
;the option. We must reset the CONTRAST MEDIA USED (#20) field back to
;yes from no.
I RAYN'="Y" D
.K RAFDA S RAFDA(71,DA_",",20)="Y" D FILE^DIE("","RAFDA")
.K RAFDA Q
Q RAYN
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAUTL2 8518 printed Oct 16, 2024@18:40:57 Page 2
RAUTL2 ;HISC/CAH,FPT,GJC AISC/MJK,RMO-Utility Routine ;11/10/97 11:18
+1 ;;5.0;Radiology/Nuclear Medicine;**10,26,45,47**;Mar 16, 1998;Build 21
+2 ;
+3 ;Called from many points within Rad/Nuc Med package ;ch
+4 ;INPUT VARIABLES: Y=IEN of Rad Report file #74
+5 ; XRT0,XRT1 If set, will do some response time checks
+6 ;OUTPUT VARIABLES:
+7 ; RADFN=Patient DFN, RADTE=Exam date/time (FM format),
+8 ; RACN=long case number, RADTI=reverse exam date/time,
+9 ; RACNI=short case number, RADATE=Exam date/time (external format)
+10 ; Y=If active case, zeroeth node of case record in file #70
RASET ;P47 Check SSAN and use ADC or ADC1 accordingly:
+1 ;If .01 of RARPT>12 (SSAN) use "ADC1" x-ref to look up exam
+2 ;If .01 of RARPT'>12 (old CASE NO.) use "ADC" x-ref to look up exam
+3 if $DATA(XRTL)
DO T0^%ZOSV
+4 SET Y=$SELECT($DATA(^RARPT(+Y,0)):^(0),1:"")
if 'Y
QUIT
SET RADFN=+$PIECE(Y,"^",2)
+5 SET RADTE=+$PIECE(Y,"^",3)
SET RACN=+$PIECE(Y,"^",4)
SET RADTI=9999999.9999-RADTE
+6 IF $LENGTH($PIECE(Y,"^"),"-")>2
SET RACNI=$ORDER(^RADPT("ADC1",$PIECE(Y,"^"),RADFN,RADTI,0))
+7 IF $LENGTH($PIECE(Y,"^"),"-")<3
SET RACNI=$ORDER(^RADPT("ADC",$PIECE(Y,"^"),RADFN,RADTI,0))
+8 SET Y=RADTE
DO D^RAUTL
SET RADATE=Y
+9 ;D:$D(XRTL) T0^%ZOSV S Y=$S($D(^RARPT(+Y,0)):^(0),1:"") Q:'Y S RADFN=+$P(Y,"^",2),RADTE=+$P(Y,"^",3),RACN=+$P(Y,"^",4),RADTI=9999999.9999-RADTE,RACNI=$O(^RADPT("ADC",$P(Y,"^"),RADFN,RADTI,0)) S Y=RADTE D D^RAUTL S RADATE=Y
+10 SET Y=""
IF RACNI
IF $DATA(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
SET Y=^(0)
+11 IF $DATA(XRT0)
SET XRTN=$TEXT(+0)
DO T1^%ZOSV
+12 QUIT
+13 ;
+14 ;Called from 2 x-refs on file #74, Rpt Status fld 5 ;ch
+15 ;Does sets and kills for 'ARES', and 'ASTF' xrefs
+16 ; ** CAUTION ** 1st RARAD=12 or 15, 2nd RARAD=ien for file 200
XREF if '$DATA(^RARPT(DA,0))
QUIT
SET RADFNZ=^(0)
SET RADTIZ=9999999.9999-$PIECE(RADFNZ,"^",3)
SET RACNIZ=$ORDER(^RADPT(+$PIECE(RADFNZ,"^",2),"DT",RADTIZ,"P","B",+$PIECE(RADFNZ,"^",4),0))
SET RADFNZ=+$PIECE(RADFNZ,"^",2)
SET RADA=DA
if 'RACNIZ
GOTO Q
+1 ;save 1st value of rarad
SET RARADOLD=RARAD
+2 if '$DATA(^RADPT(RADFNZ,"DT",RADTIZ,"P",RACNIZ,0))
GOTO Q
SET RARAD=+$PIECE(^(0),"^",RARAD)
if 'RARAD
GOTO Q
+3 ; ** CAUTION ** next line is reached 2 ways : from line above,
+4 ; and also from file 70.03, fld 15's "ASTF" xref
+5 ; thus RARAD's 2nd meaning must be preserved for XREF1
XREF1 if $DATA(RASET)
SET ^RARPT(RAXREF,RARAD,RADA)=""
if $DATA(RAKILL)
KILL ^RARPT(RAXREF,RARAD,RADA)
DO XPRI^RAUTL20
Q KILL RADA,RADFNZ,RADTIZ,RACNIZ,RARADOLD
QUIT
+1 ;
+2 ;Checks for CONTRAST MEDIA given the necessary subscripts
+3 ;to access a record in File #70.
+4 ;RADFN, RADTI, RACNI must be set.
+5 ;Output is Y=a string delimited by commas containing all
+6 ;applicable items in externally formatted text (ex: If exam was
+7 ;done with contrast media Y="CONTRAST MEDIA USED"
+8 ;06/16/99 remove obsolete RAF2
+9 ; add CPT Modifiers string
+10 ; output Y = procedure modifiers string
+11 ; Y(1)= CPT modifiers string, external
+12 ; Y(2)= CPT modifiers string, internal
MODS ;get procedure modifiers
+1 SET (Y,Y(1),Y(2))=""
if '$DATA(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
QUIT
SET X=^(0)
+2 FOR I=0:0
SET I=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"M",I))
if I'>0
QUIT
IF $DATA(^RAMIS(71.2,+^(I,0),0))
SET X1=$PIECE(^(0),"^")
DO MODS1
+3 if $PIECE(X,"^",10)["Y"
SET X1="CONTRAST MEDIA USED"
+4 ;
MODS0 ;falls through from MODS; get CPT modifiers
+1 if Y=""
SET Y="None"
+2 SET X=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)
SET I=0
+3 FOR
SET I=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",I))
if I'>0
QUIT
SET X1=$$BASICMOD^RACPTMSC(+$GET(^(I,0)),DT)
IF +X1>0
SET Y(1)=Y(1)_$SELECT(Y(1)="":"",1:", ")_$PIECE(X1,"^",2)
SET Y(2)=Y(2)_$SELECT(Y(2)="":"",1:", ")_$PIECE(X1,"^")
+4 if Y(1)=""
SET Y(1)="None"
+5 KILL I,X,X1
QUIT
+6 ;
MODS1 ;builds procedure modifier string (called from MODS above)
+1 SET Y=Y_$SELECT(Y="":"",1:", ")_X1
QUIT
+2 ;
+3 ;called to do some order checks - takes appropriate action if:
+4 ; procedure requested needs Rad/NM physician approval (File 71, fld 11)
+5 ; there are other outstanding orders for this procedure for this pt
+6 ; user is inactivated (file 200, "I" node)
ORDPRC IF $DATA(^RAMIS(71,+X,0))
IF $PIECE(^(0),"^",11)["y"
DO CHKUSR
IF 'RAMSG
WRITE !!,"Please contact appropriate Imaging Service to request this procedure! "
KILL X,RAMSG
QUIT
+1 SET RAS3=+$PIECE(^RAO(75.1,DA,0),"^")
ORDPRC1 if '$DATA(^RAO(75.1,"AP",RAS3,X))
QUIT
SET RAS4=X
SET RASCNT=0
KILL RAX
+1 FOR RAS5=0:0
SET RAS5=$ORDER(^RAO(75.1,"AP",RAS3,RAS4,RAS5))
if 'RAS5
QUIT
FOR RAS6=0:0
SET RAS6=$ORDER(^RAO(75.1,"AP",RAS3,RAS4,RAS5,RAS6))
if 'RAS6
QUIT
IF $DATA(^RAO(75.1,RAS6,0))
SET RAT=+$PIECE(^(0),"^",5)
IF RAT>2
SET RASCNT=RASCNT+1
if $SELECT('$DATA(RAQUIT)
DO ORDMES
+2 IF $DATA(RAX)
IF '$DATA(RAQUIT)
DO ORDMES1
+3 if $DATA(RAX)
KILL RAQUIT
KILL RAMSG,RAS3,RAS4,RAS5,RAS6,RASCNT,RAT,RAX
QUIT
+4 ;
CHKUSR ; Check if valid user
+1 NEW RAINADT,RAC
+2 SET RAINADT=+$PIECE($GET(^VA(200,+$GET(DUZ),"PS")),"^",4)
+3 SET RAC=$ORDER(^VA(200,+$GET(DUZ),"RAC",0))
+4 SET RAMSG=$SELECT('($DATA(DUZ)#2):0,'$DATA(^VA(200,DUZ,0)):0,'RAC:0,'RAINADT:1,'$DATA(DT):0,DT'>RAINADT:1,1:0)
+5 QUIT
ORDMES if '$DATA(RAX)
WRITE !!,*7,"The following requests are already on file for this procedure:",!
+1 WRITE !?3,"A request dated "
SET Y=9999999.9999-RAS5
DO DT^DIO2
WRITE " is already ",$SELECT(RAT=3:"on ",1:""),$PIECE($PIECE(^DD(75.1,5,0),RAT_":",2),";")," for this procedure."
SET RAX=1
QUIT
ORDMES1 WRITE !!?3,"Is it ok to continue? No// "
READ RAX:DTIME
if '$TEST!(RAX="")!(RAX["^")
SET RAX="N"
+1 IF "Nn"[$EXTRACT(RAX)
KILL X
SET RAPRI=0
+2 IF $DATA(X)
IF "Yy"'[$EXTRACT(RAX)
WRITE !!?3,"Enter 'YES' to request this procedure for this patient, or 'NO' not to.",!
GOTO ORDMES1
+3 QUIT
+4 ;
+5 ;Called (from RAPSET) to determine if at least one division and at
+6 ;least one location are set up. Can't use pkg unless these are set up.
CHKSP SET RADV=$SELECT($ORDER(^RA(79,0))>0:1,1:0)
SET RALC=$SELECT($DATA(^RA(79.1,+$ORDER(^RA(79,"AL",0)),0)):1,1:0)
+1 QUIT
+2 ;
KILLVAR ;This call will clean up possible variables left after execution
+1 ;of the Label print fields in file 78.7
+2 KILL RAY0,RAY1,RAY2,RAY3,RAGE,RACSE,RANOW,RADOB,RAEXDT,RATRAN,RARPDT,RADIAG,RAMOD,RAINST,RAEXLST,RAVST,RALCSE,RANM,RAPAGE,RAPR,RAL,RARST,RAREA,RADOC,RARAD,RASSN
+3 KILL RASTAFF,RASIGS,RATECH,RACTY,RASIGVES,RAVER,RASIGVS,RASIGVSB,RASIGR,RASERV,RASEX,RAS,RAII,RAFMT,RASV
+4 QUIT
+5 ;
CONTRAST(RAZ71) ;Display the contrast media/medium associated with a Rad/Nuc
+1 ;Med Procedure. Called from: PRC1^RAUTL8 & ALLERGY^RAORD1
+2 ;input: RAZ71=ien of the non-parent procedure in file 71
+3 ;
+4 KILL RAZCM
SET RAZ71(0)=$GET(^RAMIS(71,RAZ71,0))
+5 ;is contrast media used?
SET RAZCMU=$PIECE(RAZ71(0),"^",20)
+6 IF RAZCMU'="Y"
KILL RAZCMU
QUIT
+7 DO GETS^DIQ(71,RAZ71_",","125*","E","RAZCM")
+8 ; The RAZCM(71.0125,x,.01,"E") array will be one or more of following
+9 ; values: I:Iodinated contrast, ionic;N:Iodinated contrast, non-ionic
+10 ; L:Gadolinium, C:Cholecystogram;G:Gastrografin;B:Barium
+11 ;
+12 if $ORDER(RAZCM(71.0125,$CHAR(126)),-1)=$ORDER(RAZCM(71.0125,""))
SET RAZTAG="medium"
+13 if '$DATA(RAZTAG)#2
SET RAZTAG="media"
+14 SET RAPMSG(1)="************** Patient reaction to contrast "_RAZTAG_" *************"
+15 SET RAPMSG(2)=$EXTRACT($PIECE(RAZ71(0),"^"),1,47)_" uses contrast "_RAZTAG_": "
+16 SET RAPMSG(2,"F")="!"
SET RAZI=""
SET RAZSUB=$ORDER(RAPMSG($CHAR(32)),-1)
+17 FOR
SET RAZI=$ORDER(RAZCM(71.0125,RAZI))
if RAZI=""
QUIT
Begin DoDot:1
+18 if $LENGTH($GET(RAPMSG(RAZSUB)))+$LENGTH(RAZCM(71.0125,RAZI,.01,"E"))>69
SET RAZSUB=RAZSUB+1
+19 SET RAPMSG(RAZSUB)=$GET(RAPMSG(RAZSUB))_RAZCM(71.0125,RAZI,.01,"E")_", "
+20 QUIT
End DoDot:1
+21 ; The reverse dollar order (R$O) is used to strip off the ", " string
+22 ; from the last printable subscript containing CM data. I also use the
+23 ; R$O to set my last printable array element to '*'s to box off the
+24 ; warning.
+25 ;strips off the ", "
SET RAPMSG($ORDER(RAPMSG($CHAR(32)),-1))=$EXTRACT(RAPMSG($ORDER(RAPMSG($CHAR(32)),-1)),1,$LENGTH(RAPMSG($ORDER(RAPMSG($CHAR(32)),-1)))-2)
+26 SET $PIECE(RAPMSG($ORDER(RAPMSG($CHAR(32)),-1)+1),"*",69)=""
SET RAPMSG(99)=" "
+27 DO EN^DDIOL(.RAPMSG)
+28 KILL RAPMSG,RAZCM,RAZCMU,RAZI,RAZTAG,RAZSUB
+29 QUIT
+30 ;
DELCM(DA) ;Ask the user if he/she is sure that deletion of contrast media
+1 ;is intended. If the user enter '^' exit editng the template
+2 ; input: DA=the ien of the record in file 71
+3 ;output: RAYN=response to 'Are you sure?'; either 'Y', 'N', or '^'
+4 ;Called from the RA PROCEDURE EDIT input template (RA*5*45)
+5 NEW RAYN
WRITE !?3,"*** Deleting all contrast media data associated with this procedure. ***"
+6 FOR
Begin DoDot:1
+7 READ !!?3,"All contrast relationships with this procedure will be deleted.",!?3,"Are you sure you want to delete? N// ",RAYN:DTIME
+8 if '$TEST!(RAYN["^")
SET RAYN="^"
if RAYN="^"
QUIT
+9 if RAYN=""
SET RAYN="N"
if RAYN="N"
QUIT
+10 SET RAYN=$$UP^XLFSTR($EXTRACT(RAYN))
if RAYN="Y"!(RAYN="N")
QUIT
+11 IF RAYN["?"
WRITE !?3,"Enter 'Y'es to delete associated contrasts, or 'N'o to preserve associated",!?3,"contrasts."
KILL RAYN
QUIT
+12 KILL RAYN
WRITE !?3,"Please enter 'Y' for yes, or 'N' for no."
+13 QUIT
End DoDot:1
if $LENGTH($GET(RAYN))
QUIT
+14 ;The user does not want to delete associated cm data or has '^' out of
+15 ;the option. We must reset the CONTRAST MEDIA USED (#20) field back to
+16 ;yes from no.
+17 IF RAYN'="Y"
Begin DoDot:1
+18 KILL RAFDA
SET RAFDA(71,DA_",",20)="Y"
DO FILE^DIE("","RAFDA")
+19 KILL RAFDA
QUIT
End DoDot:1
+20 QUIT RAYN
+21 ;
