Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RAUTL

RAUTL.m

Go to the documentation of this file.
  1. RAUTL ;HISC/CAH,FPT,GJC AISC/MJK,RMO-Utility Routine ;12/4/97 14:21
  1. ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
  1. ;
  1. ;Date range selection. Time is allowed if RASKTIME is defined
  1. ;Past date assumed. BEGDATE and ENDDATE are output variables
  1. DATE S RAPOP=0 K BEGDATE,ENDDATE W !!,"**** Date Range Selection ****"
  1. 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
  1. 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
  1. Q
  1. DATE1 S RAPOP=0 K BEGDATE,ENDDATE W !!,"**** Date Range Selection ****"
  1. 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
  1. 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
  1. Q
  1. ;
  1. ;Generic device/queuing selector
  1. ;RAPOP will be >0 if the job was queued, or if device selection failed
  1. ; $D(RADUPSCN)&$D(RADFLTP) stems from the 'Duplicate Flash Card' option.
  1. ZIS I '$D(ZTDESC) S ZTDESC="Rad/Nuc Med "_$S($D(ZTRTN):ZTRTN,1:"UNKNOWN OPTION")
  1. S RAMES=$S($D(RAMES):RAMES,1:"W !?5,*7,""Request Queued.""")
  1. W ! I $D(RASELDEV) W RASELDEV,! K RASELDEV
  1. 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
  1. G ZIS1:'$D(IO("Q"))
  1. 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)
  1. D ^%ZTLOAD
  1. I +$G(ZTSK("D"))>0 X:$D(ZTSK) RAMES W:$D(ZTSK) " Task #: "_$G(ZTSK)
  1. K RAMES,ZTDESC,ZTSK,ZTIO,ZTSAVE,ZTRTN,RASV,ZTDTH D HOME^%ZIS S RAPOP=1 Q
  1. ZIS1 K RAMES,RASELDEV,ZTDESC,ZTRTN,ZTSAVE Q
  1. ;
  1. CLOSE I $D(ZTQUEUED) S ZTREQ="@" Q
  1. D ^%ZISC Q
  1. ;
  1. 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
  1. ;
  1. ;called to do some user checks
  1. ;if div param set to ask user instead of auto filing DUZ, prompt for
  1. ; access/verify code
  1. ;if RAKEY is defined, check if user owns this key and set RAPOP=1
  1. ; if user doesn't own key
  1. 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
  1. USER1 Q:'$D(RAKEY) Q:$D(^XUSEC(RAKEY,RADUZ)) W !!?3,*7,"Must be a user with the appropriate privileges to continue!"
  1. USERQ S RAPOP=1 Q
  1. ;
  1. DEV ;EXECUTEABLE HELP FOR DEVICE FIELDS IN FILE 79.1 (IMAGING LOCATIONS)
  1. 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!",!
  1. W !?3,"Device Name:",?25,"Device Location:",!?3,"------------",?25,"----------------"
  1. 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
  1. Q
  1. ;
  1. VERIFY ;Ask Access Code
  1. 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
  1. ;
  1. A ;Create signature block name using RASIG("PER") as input IEN of file 200
  1. ;Write signature to node 20 of file 200
  1. ;(Signature is name in Firstname Lastname format)
  1. 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
  1. ;
  1. 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
  1. S %=1 I $D(DUZ)#2,+DUZ>0,$D(^VA(200,DUZ,0)) S RASIG("PER")=DUZ
  1. 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
  1. I '$D(^VA(200,RASIG("PER"),20)) D A K %INT Q
  1. 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
  1. S RASIG("NAME")=$P(^VA(200,RASIG("PER"),20),"^",2) K %INT Q
  1. ;
  1. 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
  1. N DFN
  1. I '$D(RADFN) Q "Unknown"
  1. S:'$D(BID) BID="" S:$D(DOD) VAPTYP=DOD
  1. S DFN=RADFN D PID^VADPT6 I VAERR K VAERR Q "Unknown"
  1. S RASSN=$S(BID:VA("BID"),1:VA("PID"))
  1. K VA("BID"),VA("PID"),VAERR,VAPTYP
  1. Q RASSN
  1. WARNPRC ; send warning if user changes procedure within exam edit
  1. ; and the exam has either or both radiopharms and meds
  1. ; RAY (sub-rec 70.03) comes from rtns RAEDCN or RAEDPT (exam edit)
  1. ; RAPRIT (ien file 71) comes from rtn RASTED (status tracking)
  1. Q:'$D(RADFN)!('$D(RADTI))!('$D(RACNI))
  1. Q:$G(RAY)']""&('$D(RAPRIT))
  1. N RAMEDS,RADIO,RATAB,RATEXT
  1. S RAMEDS=0,RADIO=0
  1. I $G(RAY)]"",$P(RAY,U,2)=RAPRI Q ;no change in procedure
  1. I $G(RAPRIT)]"",RAPRIT=RAPRI Q ;no change in procedure
  1. S RADIO=$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),U,28) ;ptr fle #70.2
  1. S RADIO=+$O(^RADPTN(+RADIO,"NUC",0))
  1. S RAMEDS=+$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"RX",0))
  1. S RAWHICH=0 ;first assume neither radiopharm nor meds
  1. I 'RAMEDS,RADIO S RAWHICH=1 ;radiopharm only
  1. I RAMEDS,'RADIO S RAWHICH=2 ;meds only
  1. I RAMEDS,RADIO S RAWHICH=3 ;both radiopharm and meds
  1. G:'RAWHICH WARN0
  1. W !!?2,"**",?21,"Since you have changed the procedure,",?76,"**"
  1. S RATAB=$S(RAWHICH=1:26,RAWHICH=2:34,1:21)
  1. W !?2,"**",?RATAB,"the",$S(RAWHICH#2:" Radiopharmaceuticals",1:""),$S(RAWHICH=3:" and",1:""),$S(RAWHICH>1:" Meds",1:"")," for",?76,"**"
  1. 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
  1. W !?2,"**",?RATAB,RATEXT,?76,"**"
  1. W !?2,"**",?30,"will now be deleted.",?76,"**",!,*7
  1. Q
  1. WARN0 W !!?2,"**",?17,"You have changed the procedure, but there are",?76,"**"
  1. W !?2,"**",?14,"no data for Radiopharmaceuticals and Meds to delete.",?76,"**",*7,!
  1. Q