RAPINFO ;HIRMFO/GJC - Display Imaging Procedure Rad/Nuc Med info ;11/5/99 12:32
;;5.0;Radiology/Nuclear Medicine;**10,45**;Mar 16, 1998
EN1 ; Associated option: [DISPLAY IMAGING PROCEDURE RAD/NUC MED INFORMATION]
N RADIC,RAINA,RAITYPE,RAQUIT,RAUTIL
K ^TMP($J,"RA PROCEDURES") W !
S DIC="^RA(79.2,",DIC(0)="QEAMNZ",DIC("A")="Select an Imaging Type: "
S DIC("W")="D DICW^RAPINFO"
S DIC("S")="I ($D(^RAMIS(71,""AIMG"",+Y))\10)"
D ^DIC K DIC
I Y'>0 D KILL Q
S RAITYPE=Y ; 'RAITYPE' = ien of entry in 79.2 ^ .01 value in 79.2
;
PROC ; Procedure selection O-M-A
S RADIC="^RAMIS(71,",RADIC("A")="Select a Rad/Nuc Med Procedure: "
S RADIC(0)="QEANMZ",RADIC("S")="I $$DICS^RAPINFO(RAITYPE,+Y)"
S RAUTIL="RA PROCEDURES" D EN1^RASELCT(.RADIC,RAUTIL)
I '($D(^TMP($J,"RA PROCEDURES"))\10) D KILL Q ; quit, nothing selected
DEV ; Device selection
W ! S %ZIS="QM",%ZIS("A")="Select a Device: " D ^%ZIS W !
I POP K %ZIS D KILL Q
I $D(IO("Q")) D D KILL Q
. S ZTRTN="START^RAPINFO"
. S ZTSAVE("^TMP($J,""RA PROCEDURES"",")=""
. S ZTDESC="Rad/Nuc Med Display Imaging Procedure information"
. D ^%ZTLOAD
. I +$G(ZTSK("D"))>0 D
.. W !?5,"Request Queued, Task #: ",+$G(ZTSK)
.. Q
. E W !?5,"Request cancelled!"
. D HOME^%ZIS K IO("Q")
. Q
START ; Start processing data & printing to the device here.
S:$D(ZTQUEUED) ZTREQ="@"
U IO N I,J,RA0,RA1,RA2,RA71,RADD,RAHDR,RAIDFIER,RALN,RAMAX,RANOW,RAPG
N RARUNDT,RAXIT S RA0="",(RAMAX,RAPG,RAXIT)=0
S RAHDR="Radiology/Nuclear Medicine Procedure Information"
S $P(RALN,"-",(IOM+1))=""
S RADD=$P($G(^DD(71,6,0)),"^",3)
F I=1:1:$L(RADD,";") S J=$P($P(RADD,";",I),":",2) Q:J']"" D
. S:$L(J)>RAMAX RAMAX=$L(J)
. Q
S RANOW=$$NOW^XLFDT(),RANOW=$P(RANOW,".")_"."_$E($P(RANOW,".",2),1,4)
S RARUNDT=$$FMTE^XLFDT(RANOW,"1P") D HDR^RAPINFO G:RAXIT KILL
F S RA0=$O(^TMP($J,"RA PROCEDURES",RA0)) Q:RA0="" D Q:RAXIT
. S RA1=0
. F S RA1=$O(^TMP($J,"RA PROCEDURES",RA0,RA1)) Q:RA1'>0 D Q:RAXIT
.. S RA71=$G(^RAMIS(71,RA1,0)) Q:RA71']""
.. S RAIDFIER=$$BLD^RAPINFO(RA1)
.. I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() Q:RAXIT D HDR^RAPINFO
.. Q:RAXIT W !,$E(RA0,1,30),?34,RAIDFIER
..;
..;check if the descendents have CM relations
..I $P(RA71,U,6)="P" D Q:RAXIT
...S RA2=0 F S RA2=$O(^RAMIS(71,RA1,4,RA2)) Q:'RA2 D Q:RAXIT
....S RA21=+$G(^RAMIS(71,RA1,4,RA2,0)) D DESC(RA21,"P")
....Q
...K RA2,RA21 Q
..;
..;check if the non-parent has CM relations
..E D:$O(^RAMIS(71,RA1,"CM",0)) DESC(RA1,"") Q:RAXIT
..;
.. I $O(^RAMIS(71,RA1,"EDU",0)) D
... S DIWF="W",DIWL=1,DIWR=$S(IOM=132:100,1:76)
... S RA2=0 K ^UTILITY($J,"W") S X="Educational Desc: "
... F S RA2=$O(^RAMIS(71,RA1,"EDU",RA2)) Q:RA2'>0 D K X Q:RAXIT
.... I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() Q:RAXIT D HDR^RAPINFO
.... Q:RAXIT S X=$G(X)_$G(^RAMIS(71,RA1,"EDU",RA2,0)) Q:X']"" D ^DIWP
.... Q
... D:'RAXIT ^DIWW ; *** procedure message text to be printed
... Q ; *** once procedure messages are changed to WP
.. E W ! ; *** from pointers to 71.4 ***
.. Q
. Q
W ! D ^%ZISC,KILL
Q
BLD(RA1) ; Build procedure identifier string
; input: 'RA1' = ien of entry in Rad/Nuc Med Procedures file
N RA,RACPT,RAIABRV,RAPTYPE,RASTR S RASTR="("
S RA(0)=$G(^RAMIS(71,RA1,0)),RA("I")=$G(^RAMIS(71,RA1,"I"))
S RAIABRV(0)=+$P(RA(0),"^",12)
S RAIABRV(1)=$P($G(^RA(79.2,RAIABRV(0),0)),"^",3)
S RAIABRV=$S(RAIABRV(1)]"":RAIABRV(1),1:"Unknown")
I RA("I"),(RA("I")'>DT) S RAPTYPE="Inactive"
I $D(RAPTYPE)[0 D
. S RAPTYPE=$$XTERNAL^RAUTL5($P(RA(0),"^",6),$P($G(^DD(71,6,0)),"^",2))
. S RAPTYPE=$E(RAPTYPE)_$$LOW^XLFSTR($E(RAPTYPE,2,99999))
. S:RAPTYPE']"" RAPTYPE="Unknown"
. Q
S:$L(RAPTYPE)<RAMAX RAPTYPE=RAPTYPE_$E(" ",1,(RAMAX-$L(RAPTYPE)))
S RACPT(0)=+$P(RA(0),"^",9) S:'RACPT(0) RACPT="Unknown"
S:$E(RAPTYPE)="P" RACPT="See Descendents"
I '($D(RACPT)#2) D
. S RACPT=$P($$NAMCODE^RACPTMSC(RACPT(0),DT),"^")
. S:RACPT="" RACPT="Unknown"
. Q
S RASTR=RASTR_RAIABRV_" "_RAPTYPE_") CPT:"_RACPT
Q RASTR
;
DICS(RAY,Y) ; Display active procedures within an imaging type.
; Input : RAY - Imaging Type
; Y - ien of the procedure
; Output: 1 if a valid selection, 0 if invalid
Q:'$D(^RAMIS(71,"AIMG",+RAITYPE,+Y))#2 0 ; not valid, wrong i-type
N RA71ACT S RA71ACT=$G(^RAMIS(71,+Y,"I"))
Q $S(RA71ACT="":1,RA71ACT>DT:1,1:0)
;
DICW ; Display abbreviation with the I-Type
N RA792,RABBRV
S RA792=$G(^RA(79.2,+Y,0)),RABBRV=$P(RA792,"^",3)
S RABBRV(1)=$S(RABBRV]"":" "_RABBRV,1:" Unknown")
S RABBRV(1,"F")="?0" D EN^DDIOL(.RABBRV)
Q
HDR ; Header for our report
W:$Y @IOF S RAPG=RAPG+1
W !?(IOM-$L(RAHDR)\2),RAHDR
W !!,"Run Date/Time: ",RARUNDT,?($S(IOM=132:121,1:68)),"Page: ",RAPG
W !,RALN
I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAXIT=1
Q
KILL ; Kill and quit the application
K ^TMP($J,"RA PROCEDURES"),%X,%XX,%Y,%YY
K C,DDH,DIROUT,DIRUT,DIW,DIWF,DIWL,DIWR,DIWT,DN,DTOUT,DUOUT,X,Y
K Z,ZTDESC,ZTRTN,ZTSAVE,I,POP,DISYS
Q
;
DESC(RAPRC,RAFLG) ; display the descendants associated with the
; parent procedure
;input: RAPRC-IEN of the procedure in the Rad/Nuc Med Procedure file
; RAFLG-indicates procedure type; "P" if parent, else null
I RAFLG="P" D Q:RAXIT
.S RAIDFIER=$$BLD^RAPINFO(RAPRC)
.I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() Q:RAXIT D HDR^RAPINFO
.Q:RAXIT W:$X ! W ?2,$E($P($G(^RAMIS(71,RAPRC,0)),U),1,30),?34,RAIDFIER
.Q
Q:+$O(^RAMIS(71,RAPRC,"CM",0))=0
CMEDIA ; display the contrast media associated with the parent procedure
K X,^UTILITY($J,"W") S RA3=0,X="Contrast Media: "
S DIWF="W",DIWL=3,DIWR=$S(IOM=132:100,1:76)
F S RA3=$O(^RAMIS(71,RAPRC,"CM",RA3)) Q:RA3'>0 D
.S RA3(0)=$P($G(^RAMIS(71,RAPRC,"CM",RA3,0)),U)
.S X=X_$$EXTERNAL^DILFD(71.0125,.01,"",RA3(0))_", "
.Q
I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() Q:RAXIT D HDR^RAPINFO
S X=$P(X,", ",1,$L(X,", ")-1) D ^DIWP,^DIWW
K ^UTILITY($J,"W"),DIWF,DIWL,DIWR,RA3,X
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAPINFO 6005 printed Sep 23, 2025@20:14:39 Page 2
RAPINFO ;HIRMFO/GJC - Display Imaging Procedure Rad/Nuc Med info ;11/5/99 12:32
+1 ;;5.0;Radiology/Nuclear Medicine;**10,45**;Mar 16, 1998
EN1 ; Associated option: [DISPLAY IMAGING PROCEDURE RAD/NUC MED INFORMATION]
+1 NEW RADIC,RAINA,RAITYPE,RAQUIT,RAUTIL
+2 KILL ^TMP($JOB,"RA PROCEDURES")
WRITE !
+3 SET DIC="^RA(79.2,"
SET DIC(0)="QEAMNZ"
SET DIC("A")="Select an Imaging Type: "
+4 SET DIC("W")="D DICW^RAPINFO"
+5 SET DIC("S")="I ($D(^RAMIS(71,""AIMG"",+Y))\10)"
+6 DO ^DIC
KILL DIC
+7 IF Y'>0
DO KILL
QUIT
+8 ; 'RAITYPE' = ien of entry in 79.2 ^ .01 value in 79.2
SET RAITYPE=Y
+9 ;
PROC ; Procedure selection O-M-A
+1 SET RADIC="^RAMIS(71,"
SET RADIC("A")="Select a Rad/Nuc Med Procedure: "
+2 SET RADIC(0)="QEANMZ"
SET RADIC("S")="I $$DICS^RAPINFO(RAITYPE,+Y)"
+3 SET RAUTIL="RA PROCEDURES"
DO EN1^RASELCT(.RADIC,RAUTIL)
+4 ; quit, nothing selected
IF '($DATA(^TMP($JOB,"RA PROCEDURES"))\10)
DO KILL
QUIT
DEV ; Device selection
+1 WRITE !
SET %ZIS="QM"
SET %ZIS("A")="Select a Device: "
DO ^%ZIS
WRITE !
+2 IF POP
KILL %ZIS
DO KILL
QUIT
+3 IF $DATA(IO("Q"))
Begin DoDot:1
+4 SET ZTRTN="START^RAPINFO"
+5 SET ZTSAVE("^TMP($J,""RA PROCEDURES"",")=""
+6 SET ZTDESC="Rad/Nuc Med Display Imaging Procedure information"
+7 DO ^%ZTLOAD
+8 IF +$GET(ZTSK("D"))>0
Begin DoDot:2
+9 WRITE !?5,"Request Queued, Task #: ",+$GET(ZTSK)
+10 QUIT
End DoDot:2
+11 IF '$TEST
WRITE !?5,"Request cancelled!"
+12 DO HOME^%ZIS
KILL IO("Q")
+13 QUIT
End DoDot:1
DO KILL
QUIT
START ; Start processing data & printing to the device here.
+1 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 USE IO
NEW I,J,RA0,RA1,RA2,RA71,RADD,RAHDR,RAIDFIER,RALN,RAMAX,RANOW,RAPG
+3 NEW RARUNDT,RAXIT
SET RA0=""
SET (RAMAX,RAPG,RAXIT)=0
+4 SET RAHDR="Radiology/Nuclear Medicine Procedure Information"
+5 SET $PIECE(RALN,"-",(IOM+1))=""
+6 SET RADD=$PIECE($GET(^DD(71,6,0)),"^",3)
+7 FOR I=1:1:$LENGTH(RADD,";")
SET J=$PIECE($PIECE(RADD,";",I),":",2)
if J']""
QUIT
Begin DoDot:1
+8 if $LENGTH(J)>RAMAX
SET RAMAX=$LENGTH(J)
+9 QUIT
End DoDot:1
+10 SET RANOW=$$NOW^XLFDT()
SET RANOW=$PIECE(RANOW,".")_"."_$EXTRACT($PIECE(RANOW,".",2),1,4)
+11 SET RARUNDT=$$FMTE^XLFDT(RANOW,"1P")
DO HDR^RAPINFO
if RAXIT
GOTO KILL
+12 FOR
SET RA0=$ORDER(^TMP($JOB,"RA PROCEDURES",RA0))
if RA0=""
QUIT
Begin DoDot:1
+13 SET RA1=0
+14 FOR
SET RA1=$ORDER(^TMP($JOB,"RA PROCEDURES",RA0,RA1))
if RA1'>0
QUIT
Begin DoDot:2
+15 SET RA71=$GET(^RAMIS(71,RA1,0))
if RA71']""
QUIT
+16 SET RAIDFIER=$$BLD^RAPINFO(RA1)
+17 IF $Y>(IOSL-4)
SET RAXIT=$$EOS^RAUTL5()
if RAXIT
QUIT
DO HDR^RAPINFO
+18 if RAXIT
QUIT
WRITE !,$EXTRACT(RA0,1,30),?34,RAIDFIER
+19 ;
+20 ;check if the descendents have CM relations
+21 IF $PIECE(RA71,U,6)="P"
Begin DoDot:3
+22 SET RA2=0
FOR
SET RA2=$ORDER(^RAMIS(71,RA1,4,RA2))
if 'RA2
QUIT
Begin DoDot:4
+23 SET RA21=+$GET(^RAMIS(71,RA1,4,RA2,0))
DO DESC(RA21,"P")
+24 QUIT
End DoDot:4
if RAXIT
QUIT
+25 KILL RA2,RA21
QUIT
End DoDot:3
if RAXIT
QUIT
+26 ;
+27 ;check if the non-parent has CM relations
+28 IF '$TEST
if $ORDER(^RAMIS(71,RA1,"CM",0))
DO DESC(RA1,"")
if RAXIT
QUIT
+29 ;
+30 IF $ORDER(^RAMIS(71,RA1,"EDU",0))
Begin DoDot:3
+31 SET DIWF="W"
SET DIWL=1
SET DIWR=$SELECT(IOM=132:100,1:76)
+32 SET RA2=0
KILL ^UTILITY($JOB,"W")
SET X="Educational Desc: "
+33 FOR
SET RA2=$ORDER(^RAMIS(71,RA1,"EDU",RA2))
if RA2'>0
QUIT
Begin DoDot:4
+34 IF $Y>(IOSL-4)
SET RAXIT=$$EOS^RAUTL5()
if RAXIT
QUIT
DO HDR^RAPINFO
+35 if RAXIT
QUIT
SET X=$GET(X)_$GET(^RAMIS(71,RA1,"EDU",RA2,0))
if X']""
QUIT
DO ^DIWP
+36 QUIT
End DoDot:4
KILL X
if RAXIT
QUIT
+37 ; *** procedure message text to be printed
if 'RAXIT
DO ^DIWW
+38 ; *** once procedure messages are changed to WP
QUIT
End DoDot:3
+39 ; *** from pointers to 71.4 ***
IF '$TEST
WRITE !
+40 QUIT
End DoDot:2
if RAXIT
QUIT
+41 QUIT
End DoDot:1
if RAXIT
QUIT
+42 WRITE !
DO ^%ZISC
DO KILL
+43 QUIT
BLD(RA1) ; Build procedure identifier string
+1 ; input: 'RA1' = ien of entry in Rad/Nuc Med Procedures file
+2 NEW RA,RACPT,RAIABRV,RAPTYPE,RASTR
SET RASTR="("
+3 SET RA(0)=$GET(^RAMIS(71,RA1,0))
SET RA("I")=$GET(^RAMIS(71,RA1,"I"))
+4 SET RAIABRV(0)=+$PIECE(RA(0),"^",12)
+5 SET RAIABRV(1)=$PIECE($GET(^RA(79.2,RAIABRV(0),0)),"^",3)
+6 SET RAIABRV=$SELECT(RAIABRV(1)]"":RAIABRV(1),1:"Unknown")
+7 IF RA("I")
IF (RA("I")'>DT)
SET RAPTYPE="Inactive"
+8 IF $DATA(RAPTYPE)[0
Begin DoDot:1
+9 SET RAPTYPE=$$XTERNAL^RAUTL5($PIECE(RA(0),"^",6),$PIECE($GET(^DD(71,6,0)),"^",2))
+10 SET RAPTYPE=$EXTRACT(RAPTYPE)_$$LOW^XLFSTR($EXTRACT(RAPTYPE,2,99999))
+11 if RAPTYPE']""
SET RAPTYPE="Unknown"
+12 QUIT
End DoDot:1
+13 if $LENGTH(RAPTYPE)<RAMAX
SET RAPTYPE=RAPTYPE_$EXTRACT(" ",1,(RAMAX-$LENGTH(RAPTYPE)))
+14 SET RACPT(0)=+$PIECE(RA(0),"^",9)
if 'RACPT(0)
SET RACPT="Unknown"
+15 if $EXTRACT(RAPTYPE)="P"
SET RACPT="See Descendents"
+16 IF '($DATA(RACPT)#2)
Begin DoDot:1
+17 SET RACPT=$PIECE($$NAMCODE^RACPTMSC(RACPT(0),DT),"^")
+18 if RACPT=""
SET RACPT="Unknown"
+19 QUIT
End DoDot:1
+20 SET RASTR=RASTR_RAIABRV_" "_RAPTYPE_") CPT:"_RACPT
+21 QUIT RASTR
+22 ;
DICS(RAY,Y) ; Display active procedures within an imaging type.
+1 ; Input : RAY - Imaging Type
+2 ; Y - ien of the procedure
+3 ; Output: 1 if a valid selection, 0 if invalid
+4 ; not valid, wrong i-type
if '$DATA(^RAMIS(71,"AIMG",+RAITYPE,+Y))#2
QUIT 0
+5 NEW RA71ACT
SET RA71ACT=$GET(^RAMIS(71,+Y,"I"))
+6 QUIT $SELECT(RA71ACT="":1,RA71ACT>DT:1,1:0)
+7 ;
DICW ; Display abbreviation with the I-Type
+1 NEW RA792,RABBRV
+2 SET RA792=$GET(^RA(79.2,+Y,0))
SET RABBRV=$PIECE(RA792,"^",3)
+3 SET RABBRV(1)=$SELECT(RABBRV]"":" "_RABBRV,1:" Unknown")
+4 SET RABBRV(1,"F")="?0"
DO EN^DDIOL(.RABBRV)
+5 QUIT
HDR ; Header for our report
+1 if $Y
WRITE @IOF
SET RAPG=RAPG+1
+2 WRITE !?(IOM-$LENGTH(RAHDR)\2),RAHDR
+3 WRITE !!,"Run Date/Time: ",RARUNDT,?($SELECT(IOM=132:121,1:68)),"Page: ",RAPG
+4 WRITE !,RALN
+5 IF $DATA(ZTQUEUED)
DO STOPCHK^RAUTL9
if $GET(ZTSTOP)=1
SET RAXIT=1
+6 QUIT
KILL ; Kill and quit the application
+1 KILL ^TMP($JOB,"RA PROCEDURES"),%X,%XX,%Y,%YY
+2 KILL C,DDH,DIROUT,DIRUT,DIW,DIWF,DIWL,DIWR,DIWT,DN,DTOUT,DUOUT,X,Y
+3 KILL Z,ZTDESC,ZTRTN,ZTSAVE,I,POP,DISYS
+4 QUIT
+5 ;
DESC(RAPRC,RAFLG) ; display the descendants associated with the
+1 ; parent procedure
+2 ;input: RAPRC-IEN of the procedure in the Rad/Nuc Med Procedure file
+3 ; RAFLG-indicates procedure type; "P" if parent, else null
+4 IF RAFLG="P"
Begin DoDot:1
+5 SET RAIDFIER=$$BLD^RAPINFO(RAPRC)
+6 IF $Y>(IOSL-4)
SET RAXIT=$$EOS^RAUTL5()
if RAXIT
QUIT
DO HDR^RAPINFO
+7 if RAXIT
QUIT
if $X
WRITE !
WRITE ?2,$EXTRACT($PIECE($GET(^RAMIS(71,RAPRC,0)),U),1,30),?34,RAIDFIER
+8 QUIT
End DoDot:1
if RAXIT
QUIT
+9 if +$ORDER(^RAMIS(71,RAPRC,"CM",0))=0
QUIT
CMEDIA ; display the contrast media associated with the parent procedure
+1 KILL X,^UTILITY($JOB,"W")
SET RA3=0
SET X="Contrast Media: "
+2 SET DIWF="W"
SET DIWL=3
SET DIWR=$SELECT(IOM=132:100,1:76)
+3 FOR
SET RA3=$ORDER(^RAMIS(71,RAPRC,"CM",RA3))
if RA3'>0
QUIT
Begin DoDot:1
+4 SET RA3(0)=$PIECE($GET(^RAMIS(71,RAPRC,"CM",RA3,0)),U)
+5 SET X=X_$$EXTERNAL^DILFD(71.0125,.01,"",RA3(0))_", "
+6 QUIT
End DoDot:1
+7 IF $Y>(IOSL-4)
SET RAXIT=$$EOS^RAUTL5()
if RAXIT
QUIT
DO HDR^RAPINFO
+8 SET X=$PIECE(X,", ",1,$LENGTH(X,", ")-1)
DO ^DIWP
DO ^DIWW
+9 KILL ^UTILITY($JOB,"W"),DIWF,DIWL,DIWR,RA3,X
+10 QUIT
+11 ;
