- 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 Jan 18, 2025@03:41:05 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