RAUTL ;HISC/CAH,FPT,GJC AISC/MJK,RMO-Utility Routine ;12/4/97 14:21
;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
;
;Date range selection. Time is allowed if RASKTIME is defined
;Past date assumed. BEGDATE and ENDDATE are output variables
DATE S RAPOP=0 K BEGDATE,ENDDATE W !!,"**** Date Range Selection ****"
W ! S %DT="APEX"_$S($D(RASKTIME):"T",1:""),%DT("A")=" Beginning DATE : ",%DT(0)=$S($D(RADDT):"0000101",1:"-NOW") D ^%DT S:Y<0 RAPOP=1 Q:Y<0 S (%DT(0),BEGDATE)=Y
END W ! S %DT="APEX"_$S($D(RASKTIME):"T",1:""),%DT("A")=" Ending DATE : " D ^%DT K %DT S:Y<0 RAPOP=1 Q:Y<0 S ENDDATE=Y
Q
DATE1 S RAPOP=0 K BEGDATE,ENDDATE W !!,"**** Date Range Selection ****"
W ! S %DT="AEX"_$S($D(RASKTIME):"T",1:""),%DT("A")=" Beginning DATE : ",%DT(0)=$S($D(RADDT):"0000101",1:"-NOW") D ^%DT S:Y<0 RAPOP=1 Q:Y<0 S (%DT(0),BEGDATE)=Y
END1 W ! S %DT="AEX"_$S($D(RASKTIME):"T",1:""),%DT("A")=" Ending DATE : " D ^%DT K %DT S:Y<0 RAPOP=1 Q:Y<0 S ENDDATE=Y
Q
;
;Generic device/queuing selector
;RAPOP will be >0 if the job was queued, or if device selection failed
; $D(RADUPSCN)&$D(RADFLTP) stems from the 'Duplicate Flash Card' option.
ZIS I '$D(ZTDESC) S ZTDESC="Rad/Nuc Med "_$S($D(ZTRTN):ZTRTN,1:"UNKNOWN OPTION")
S RAMES=$S($D(RAMES):RAMES,1:"W !?5,*7,""Request Queued.""")
W ! I $D(RASELDEV) W RASELDEV,! K RASELDEV
S %ZIS="QMP" K:$G(IOP)="Q" %ZIS S:$D(RADUPSCN)&$D(RADFLTP) %ZIS("B")=RADFLTP D ^%ZIS S RAPOP=POP Q:RAPOP I $D(RAZIS),$E(IOST)'="P" D ^%ZISC S IOP="Q" W *7,!?5,"You must select a printer for this output.",! G ZIS
G ZIS1:'$D(IO("Q"))
K IO("Q") S ZTIO=$S($D(ION):ION,1:"") I ZTIO]"" S ZTIO=ZTIO_$S($D(IO("DOC")):";"_IOST_";"_IO("DOC"),1:";"_IOST_";"_IOM_";"_IOSL)
D ^%ZTLOAD
I +$G(ZTSK("D"))>0 X:$D(ZTSK) RAMES W:$D(ZTSK) " Task #: "_$G(ZTSK)
K RAMES,ZTDESC,ZTSK,ZTIO,ZTSAVE,ZTRTN,RASV,ZTDTH D HOME^%ZIS S RAPOP=1 Q
ZIS1 K RAMES,RASELDEV,ZTDESC,ZTRTN,ZTSAVE Q
;
CLOSE I $D(ZTQUEUED) S ZTREQ="@" Q
D ^%ZISC Q
;
D S Y=$P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",$E(Y,4,5))_" "_$S(Y#100:$J(Y#100\1,2)_",",1:"")_(Y\10000+1700)_$S(Y#1:" "_$E(Y_0,9,10)_":"_$E(Y_"000",11,12),1:"") Q
;
;called to do some user checks
;if div param set to ask user instead of auto filing DUZ, prompt for
; access/verify code
;if RAKEY is defined, check if user owns this key and set RAPOP=1
; if user doesn't own key
USER S RADUZ=DUZ S:'$D(RAMDV) RAMDV="" I '$P(RAMDV,"^",6) S %="A",%DUZ=DUZ W ! D ^XUVERIFY G USERQ:%=-1 I %'=1 W *7," ??" G USER
USER1 Q:'$D(RAKEY) Q:$D(^XUSEC(RAKEY,RADUZ)) W !!?3,*7,"Must be a user with the appropriate privileges to continue!"
USERQ S RAPOP=1 Q
;
DEV ;EXECUTEABLE HELP FOR DEVICE FIELDS IN FILE 79.1 (IMAGING LOCATIONS)
D HOME^%ZIS W @IOF,!,"The following is a list of possible devices. You must choose",!,"one of these by entering in the device's full name.",!!,"NOTE: This field is not a pointer field to file 3.5!",!
W !?3,"Device Name:",?25,"Device Location:",!?3,"------------",?25,"----------------"
F I=0:0 S I=$O(^%ZIS(1,I)) Q:I'>0 I $D(^(I,0)) W !?3,$P(^(0),"^"),?25,$S($D(^(1)):^(1),1:"") I ($Y+4)>IOSL R !,"(Type ""^"" to stop)",X:DTIME Q:'$T!(X="^") W @IOF
Q
;
VERIFY ;Ask Access Code
K RADUZ S %="A",%DUZ=DUZ W ! D ^XUVERIFY S RADUZ=DUZ Q:%=-1!(%=1) W:%=2 *7,!,"Sorry, that's not your access code. Try again." W:%=0 !,"Enter your access code or an uparrow to exit." G VERIFY
;
A ;Create signature block name using RASIG("PER") as input IEN of file 200
;Write signature to node 20 of file 200
;(Signature is name in Firstname Lastname format)
S %X=$P(^VA(200,RASIG("PER"),0),"^"),%X=$P(%X,",",2)_" "_$P(%X,",")_$P(%X,",",3),$P(^VA(200,RASIG("PER"),20),"^",2)=%X K %X Q
;
DUZ ;Lookup and set RASIG("PER")=New Person File IFN, set signature block
;text in File 200 if necessary, set RASIG("NAME")=signature block text
S %=1 I $D(DUZ)#2,+DUZ>0,$D(^VA(200,DUZ,0)) S RASIG("PER")=DUZ
I '$D(RASIG("PER")) S %=0 W:'$D(%INT) !,*7,"YOU ARE NOT IN THE 'NEW PERSON' FILE. CONTACT YOUR IRM SERVICE",! K %INT Q
I '$D(^VA(200,RASIG("PER"),20)) D A K %INT Q
I $P(^VA(200,RASIG("PER"),20),"^",2)="" S %X=$P(^VA(200,RASIG("PER"),0),"^"),%X=$P(%X,",",2)_" "_$P(%X,",")_$P(%X,",",3),$P(^(20),"^",2)=%X K %X
S RASIG("NAME")=$P(^VA(200,RASIG("PER"),20),"^",2) K %INT Q
;
SSN(PID,BID,DOD) ;returns full Pt.ID (VA("PID")), BID=1 returns VA("BID")
;DOD is defined to internal entry # of eligibility of desired Pt.ID
N DFN
I '$D(RADFN) Q "Unknown"
S:'$D(BID) BID="" S:$D(DOD) VAPTYP=DOD
S DFN=RADFN D PID^VADPT6 I VAERR K VAERR Q "Unknown"
S RASSN=$S(BID:VA("BID"),1:VA("PID"))
K VA("BID"),VA("PID"),VAERR,VAPTYP
Q RASSN
WARNPRC ; send warning if user changes procedure within exam edit
; and the exam has either or both radiopharms and meds
; RAY (sub-rec 70.03) comes from rtns RAEDCN or RAEDPT (exam edit)
; RAPRIT (ien file 71) comes from rtn RASTED (status tracking)
Q:'$D(RADFN)!('$D(RADTI))!('$D(RACNI))
Q:$G(RAY)']""&('$D(RAPRIT))
N RAMEDS,RADIO,RATAB,RATEXT
S RAMEDS=0,RADIO=0
I $G(RAY)]"",$P(RAY,U,2)=RAPRI Q ;no change in procedure
I $G(RAPRIT)]"",RAPRIT=RAPRI Q ;no change in procedure
S RADIO=$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),U,28) ;ptr fle #70.2
S RADIO=+$O(^RADPTN(+RADIO,"NUC",0))
S RAMEDS=+$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"RX",0))
S RAWHICH=0 ;first assume neither radiopharm nor meds
I 'RAMEDS,RADIO S RAWHICH=1 ;radiopharm only
I RAMEDS,'RADIO S RAWHICH=2 ;meds only
I RAMEDS,RADIO S RAWHICH=3 ;both radiopharm and meds
G:'RAWHICH WARN0
W !!?2,"**",?21,"Since you have changed the procedure,",?76,"**"
S RATAB=$S(RAWHICH=1:26,RAWHICH=2:34,1:21)
W !?2,"**",?RATAB,"the",$S(RAWHICH#2:" Radiopharmaceuticals",1:""),$S(RAWHICH=3:" and",1:""),$S(RAWHICH>1:" Meds",1:"")," for",?76,"**"
S RATEXT=$S($G(RAY)]"":$P($G(^RAMIS(71,+$P(RAY,U,2),0)),U),1:$P($G(^RAMIS(71,+$G(RAPRIT),0)),U)),RATAB=80-$L(RATEXT)/2
W !?2,"**",?RATAB,RATEXT,?76,"**"
W !?2,"**",?30,"will now be deleted.",?76,"**",!,*7
Q
WARN0 W !!?2,"**",?17,"You have changed the procedure, but there are",?76,"**"
W !?2,"**",?14,"no data for Radiopharmaceuticals and Meds to delete.",?76,"**",*7,!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAUTL 6224 printed Oct 16, 2024@18:40:40 Page 2
RAUTL ;HISC/CAH,FPT,GJC AISC/MJK,RMO-Utility Routine ;12/4/97 14:21
+1 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
+2 ;
+3 ;Date range selection. Time is allowed if RASKTIME is defined
+4 ;Past date assumed. BEGDATE and ENDDATE are output variables
DATE SET RAPOP=0
KILL BEGDATE,ENDDATE
WRITE !!,"**** Date Range Selection ****"
+1 WRITE !
SET %DT="APEX"_$SELECT($DATA(RASKTIME):"T",1:"")
SET %DT("A")=" Beginning DATE : "
SET %DT(0)=$SELECT($DATA(RADDT):"0000101",1:"-NOW")
DO ^%DT
if Y<0
SET RAPOP=1
if Y<0
QUIT
SET (%DT(0),BEGDATE)=Y
END WRITE !
SET %DT="APEX"_$SELECT($DATA(RASKTIME):"T",1:"")
SET %DT("A")=" Ending DATE : "
DO ^%DT
KILL %DT
if Y<0
SET RAPOP=1
if Y<0
QUIT
SET ENDDATE=Y
+1 QUIT
DATE1 SET RAPOP=0
KILL BEGDATE,ENDDATE
WRITE !!,"**** Date Range Selection ****"
+1 WRITE !
SET %DT="AEX"_$SELECT($DATA(RASKTIME):"T",1:"")
SET %DT("A")=" Beginning DATE : "
SET %DT(0)=$SELECT($DATA(RADDT):"0000101",1:"-NOW")
DO ^%DT
if Y<0
SET RAPOP=1
if Y<0
QUIT
SET (%DT(0),BEGDATE)=Y
END1 WRITE !
SET %DT="AEX"_$SELECT($DATA(RASKTIME):"T",1:"")
SET %DT("A")=" Ending DATE : "
DO ^%DT
KILL %DT
if Y<0
SET RAPOP=1
if Y<0
QUIT
SET ENDDATE=Y
+1 QUIT
+2 ;
+3 ;Generic device/queuing selector
+4 ;RAPOP will be >0 if the job was queued, or if device selection failed
+5 ; $D(RADUPSCN)&$D(RADFLTP) stems from the 'Duplicate Flash Card' option.
ZIS IF '$DATA(ZTDESC)
SET ZTDESC="Rad/Nuc Med "_$SELECT($DATA(ZTRTN):ZTRTN,1:"UNKNOWN OPTION")
+1 SET RAMES=$SELECT($DATA(RAMES):RAMES,1:"W !?5,*7,""Request Queued.""")
+2 WRITE !
IF $DATA(RASELDEV)
WRITE RASELDEV,!
KILL RASELDEV
+3 SET %ZIS="QMP"
if $GET(IOP)="Q"
KILL %ZIS
if $DATA(RADUPSCN)&$DATA(RADFLTP)
SET %ZIS("B")=RADFLTP
DO ^%ZIS
SET RAPOP=POP
if RAPOP
QUIT
IF $DATA(RAZIS)
IF $EXTRACT(IOST)'="P"
DO ^%ZISC
SET IOP="Q"
WRITE *7,!?5,"You must select a printer for this output.",!
GOTO ZIS
+4 if '$DATA(IO("Q"))
GOTO ZIS1
+5 KILL IO("Q")
SET ZTIO=$SELECT($DATA(ION):ION,1:"")
IF ZTIO]""
SET ZTIO=ZTIO_$SELECT($DATA(IO("DOC")):";"_IOST_";"_IO("DOC"),1:";"_IOST_";"_IOM_";"_IOSL)
+6 DO ^%ZTLOAD
+7 IF +$GET(ZTSK("D"))>0
if $DATA(ZTSK)
XECUTE RAMES
if $DATA(ZTSK)
WRITE " Task #: "_$GET(ZTSK)
+8 KILL RAMES,ZTDESC,ZTSK,ZTIO,ZTSAVE,ZTRTN,RASV,ZTDTH
DO HOME^%ZIS
SET RAPOP=1
QUIT
ZIS1 KILL RAMES,RASELDEV,ZTDESC,ZTRTN,ZTSAVE
QUIT
+1 ;
CLOSE IF $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
+1 DO ^%ZISC
QUIT
+2 ;
D SET Y=$PIECE("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",$EXTRACT(Y,4,5))_" "_$SELECT(Y#100:$JUSTIFY(Y#100\1,2)_",",1:"")_(Y\10000+1700)_$SELECT(Y#1:" "_$EXTRACT(Y_0,9,10)_":"_$EXTRACT(Y_"000",11,12),1:"")
QUIT
+1 ;
+2 ;called to do some user checks
+3 ;if div param set to ask user instead of auto filing DUZ, prompt for
+4 ; access/verify code
+5 ;if RAKEY is defined, check if user owns this key and set RAPOP=1
+6 ; if user doesn't own key
USER SET RADUZ=DUZ
if '$DATA(RAMDV)
SET RAMDV=""
IF '$PIECE(RAMDV,"^",6)
SET %="A"
SET %DUZ=DUZ
WRITE !
DO ^XUVERIFY
if %=-1
GOTO USERQ
IF %'=1
WRITE *7," ??"
GOTO USER
USER1 if '$DATA(RAKEY)
QUIT
if $DATA(^XUSEC(RAKEY,RADUZ))
QUIT
WRITE !!?3,*7,"Must be a user with the appropriate privileges to continue!"
USERQ SET RAPOP=1
QUIT
+1 ;
DEV ;EXECUTEABLE HELP FOR DEVICE FIELDS IN FILE 79.1 (IMAGING LOCATIONS)
+1 DO HOME^%ZIS
WRITE @IOF,!,"The following is a list of possible devices. You must choose",!,"one of these by entering in the device's full name.",!!,"NOTE: This field is not a pointer field to file 3.5!",!
+2 WRITE !?3,"Device Name:",?25,"Device Location:",!?3,"------------",?25,"----------------"
+3 FOR I=0:0
SET I=$ORDER(^%ZIS(1,I))
if I'>0
QUIT
IF $DATA(^(I,0))
WRITE !?3,$PIECE(^(0),"^"),?25,$SELECT($DATA(^(1)):^(1),1:"")
IF ($Y+4)>IOSL
READ !,"(Type ""^"" to stop)",X:DTIME
if '$TEST!(X="^")
QUIT
WRITE @IOF
+4 QUIT
+5 ;
VERIFY ;Ask Access Code
+1 KILL RADUZ
SET %="A"
SET %DUZ=DUZ
WRITE !
DO ^XUVERIFY
SET RADUZ=DUZ
if %=-1!(%=1)
QUIT
if %=2
WRITE *7,!,"Sorry, that's not your access code. Try again."
if %=0
WRITE !,"Enter your access code or an uparrow to exit."
GOTO VERIFY
+2 ;
A ;Create signature block name using RASIG("PER") as input IEN of file 200
+1 ;Write signature to node 20 of file 200
+2 ;(Signature is name in Firstname Lastname format)
+3 SET %X=$PIECE(^VA(200,RASIG("PER"),0),"^")
SET %X=$PIECE(%X,",",2)_" "_$PIECE(%X,",")_$PIECE(%X,",",3)
SET $PIECE(^VA(200,RASIG("PER"),20),"^",2)=%X
KILL %X
QUIT
+4 ;
DUZ ;Lookup and set RASIG("PER")=New Person File IFN, set signature block
+1 ;text in File 200 if necessary, set RASIG("NAME")=signature block text
+2 SET %=1
IF $DATA(DUZ)#2
IF +DUZ>0
IF $DATA(^VA(200,DUZ,0))
SET RASIG("PER")=DUZ
+3 IF '$DATA(RASIG("PER"))
SET %=0
if '$DATA(%INT)
WRITE !,*7,"YOU ARE NOT IN THE 'NEW PERSON' FILE. CONTACT YOUR IRM SERVICE",!
KILL %INT
QUIT
+4 IF '$DATA(^VA(200,RASIG("PER"),20))
DO A
KILL %INT
QUIT
+5 IF $PIECE(^VA(200,RASIG("PER"),20),"^",2)=""
SET %X=$PIECE(^VA(200,RASIG("PER"),0),"^")
SET %X=$PIECE(%X,",",2)_" "_$PIECE(%X,",")_$PIECE(%X,",",3)
SET $PIECE(^(20),"^",2)=%X
KILL %X
+6 SET RASIG("NAME")=$PIECE(^VA(200,RASIG("PER"),20),"^",2)
KILL %INT
QUIT
+7 ;
SSN(PID,BID,DOD) ;returns full Pt.ID (VA("PID")), BID=1 returns VA("BID")
+1 ;DOD is defined to internal entry # of eligibility of desired Pt.ID
+2 NEW DFN
+3 IF '$DATA(RADFN)
QUIT "Unknown"
+4 if '$DATA(BID)
SET BID=""
if $DATA(DOD)
SET VAPTYP=DOD
+5 SET DFN=RADFN
DO PID^VADPT6
IF VAERR
KILL VAERR
QUIT "Unknown"
+6 SET RASSN=$SELECT(BID:VA("BID"),1:VA("PID"))
+7 KILL VA("BID"),VA("PID"),VAERR,VAPTYP
+8 QUIT RASSN
WARNPRC ; send warning if user changes procedure within exam edit
+1 ; and the exam has either or both radiopharms and meds
+2 ; RAY (sub-rec 70.03) comes from rtns RAEDCN or RAEDPT (exam edit)
+3 ; RAPRIT (ien file 71) comes from rtn RASTED (status tracking)
+4 if '$DATA(RADFN)!('$DATA(RADTI))!('$DATA(RACNI))
QUIT
+5 if $GET(RAY)']""&('$DATA(RAPRIT))
QUIT
+6 NEW RAMEDS,RADIO,RATAB,RATEXT
+7 SET RAMEDS=0
SET RADIO=0
+8 ;no change in procedure
IF $GET(RAY)]""
IF $PIECE(RAY,U,2)=RAPRI
QUIT
+9 ;no change in procedure
IF $GET(RAPRIT)]""
IF RAPRIT=RAPRI
QUIT
+10 ;ptr fle #70.2
SET RADIO=$PIECE($GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),U,28)
+11 SET RADIO=+$ORDER(^RADPTN(+RADIO,"NUC",0))
+12 SET RAMEDS=+$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"RX",0))
+13 ;first assume neither radiopharm nor meds
SET RAWHICH=0
+14 ;radiopharm only
IF 'RAMEDS
IF RADIO
SET RAWHICH=1
+15 ;meds only
IF RAMEDS
IF 'RADIO
SET RAWHICH=2
+16 ;both radiopharm and meds
IF RAMEDS
IF RADIO
SET RAWHICH=3
+17 if 'RAWHICH
GOTO WARN0
+18 WRITE !!?2,"**",?21,"Since you have changed the procedure,",?76,"**"
+19 SET RATAB=$SELECT(RAWHICH=1:26,RAWHICH=2:34,1:21)
+20 WRITE !?2,"**",?RATAB,"the",$SELECT(RAWHICH#2:" Radiopharmaceuticals",1:""),$SELECT(RAWHICH=3:" and",1:""),$SELECT(RAWHICH>1:" Meds",1:"")," for",?76,"**"
+21 SET RATEXT=$SELECT($GET(RAY)]"":$PIECE($GET(^RAMIS(71,+$PIECE(RAY,U,2),0)),U),1:$PIECE($GET(^RAMIS(71,+$GET(RAPRIT),0)),U))
SET RATAB=80-$LENGTH(RATEXT)/2
+22 WRITE !?2,"**",?RATAB,RATEXT,?76,"**"
+23 WRITE !?2,"**",?30,"will now be deleted.",?76,"**",!,*7
+24 QUIT
WARN0 WRITE !!?2,"**",?17,"You have changed the procedure, but there are",?76,"**"
+1 WRITE !?2,"**",?14,"no data for Radiopharmaceuticals and Meds to delete.",?76,"**",*7,!
+2 QUIT
