Routine: RAUTL2

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

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

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

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

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

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

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

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      ;

RAUTL2.m