| 1 | RAUTL ;HISC/CAH,FPT,GJC AISC/MJK,RMO-Utility Routine ;12/4/97 14:21
|
|---|
| 2 | ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
|
|---|
| 3 | ;
|
|---|
| 4 | ;Date range selection. Time is allowed if RASKTIME is defined
|
|---|
| 5 | ;Past date assumed. BEGDATE and ENDDATE are output variables
|
|---|
| 6 | DATE S RAPOP=0 K BEGDATE,ENDDATE W !!,"**** Date Range Selection ****"
|
|---|
| 7 | 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
|
|---|
| 8 | 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
|
|---|
| 9 | Q
|
|---|
| 10 | DATE1 S RAPOP=0 K BEGDATE,ENDDATE W !!,"**** Date Range Selection ****"
|
|---|
| 11 | 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
|
|---|
| 12 | 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
|
|---|
| 13 | Q
|
|---|
| 14 | ;
|
|---|
| 15 | ;Generic device/queuing selector
|
|---|
| 16 | ;RAPOP will be >0 if the job was queued, or if device selection failed
|
|---|
| 17 | ; $D(RADUPSCN)&$D(RADFLTP) stems from the 'Duplicate Flash Card' option.
|
|---|
| 18 | ZIS I '$D(ZTDESC) S ZTDESC="Rad/Nuc Med "_$S($D(ZTRTN):ZTRTN,1:"UNKNOWN OPTION")
|
|---|
| 19 | S RAMES=$S($D(RAMES):RAMES,1:"W !?5,*7,""Request Queued.""")
|
|---|
| 20 | W ! I $D(RASELDEV) W RASELDEV,! K RASELDEV
|
|---|
| 21 | 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
|
|---|
| 22 | G ZIS1:'$D(IO("Q"))
|
|---|
| 23 | 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)
|
|---|
| 24 | D ^%ZTLOAD
|
|---|
| 25 | I +$G(ZTSK("D"))>0 X:$D(ZTSK) RAMES W:$D(ZTSK) " Task #: "_$G(ZTSK)
|
|---|
| 26 | K RAMES,ZTDESC,ZTSK,ZTIO,ZTSAVE,ZTRTN,RASV,ZTDTH D HOME^%ZIS S RAPOP=1 Q
|
|---|
| 27 | ZIS1 K RAMES,RASELDEV,ZTDESC,ZTRTN,ZTSAVE Q
|
|---|
| 28 | ;
|
|---|
| 29 | CLOSE I $D(ZTQUEUED) S ZTREQ="@" Q
|
|---|
| 30 | D ^%ZISC Q
|
|---|
| 31 | ;
|
|---|
| 32 | 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
|
|---|
| 33 | ;
|
|---|
| 34 | ;called to do some user checks
|
|---|
| 35 | ;if div param set to ask user instead of auto filing DUZ, prompt for
|
|---|
| 36 | ; access/verify code
|
|---|
| 37 | ;if RAKEY is defined, check if user owns this key and set RAPOP=1
|
|---|
| 38 | ; if user doesn't own key
|
|---|
| 39 | 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
|
|---|
| 40 | USER1 Q:'$D(RAKEY) Q:$D(^XUSEC(RAKEY,RADUZ)) W !!?3,*7,"Must be a user with the appropriate privileges to continue!"
|
|---|
| 41 | USERQ S RAPOP=1 Q
|
|---|
| 42 | ;
|
|---|
| 43 | DEV ;EXECUTEABLE HELP FOR DEVICE FIELDS IN FILE 79.1 (IMAGING LOCATIONS)
|
|---|
| 44 | 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!",!
|
|---|
| 45 | W !?3,"Device Name:",?25,"Device Location:",!?3,"------------",?25,"----------------"
|
|---|
| 46 | 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
|
|---|
| 47 | Q
|
|---|
| 48 | ;
|
|---|
| 49 | VERIFY ;Ask Access Code
|
|---|
| 50 | 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
|
|---|
| 51 | ;
|
|---|
| 52 | A ;Create signature block name using RASIG("PER") as input IEN of file 200
|
|---|
| 53 | ;Write signature to node 20 of file 200
|
|---|
| 54 | ;(Signature is name in Firstname Lastname format)
|
|---|
| 55 | 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
|
|---|
| 56 | ;
|
|---|
| 57 | DUZ ;Lookup and set RASIG("PER")=New Person File IFN, set signature block
|
|---|
| 58 | ;text in File 200 if necessary, set RASIG("NAME")=signature block text
|
|---|
| 59 | S %=1 I $D(DUZ)#2,+DUZ>0,$D(^VA(200,DUZ,0)) S RASIG("PER")=DUZ
|
|---|
| 60 | 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
|
|---|
| 61 | I '$D(^VA(200,RASIG("PER"),20)) D A K %INT Q
|
|---|
| 62 | 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
|
|---|
| 63 | S RASIG("NAME")=$P(^VA(200,RASIG("PER"),20),"^",2) K %INT Q
|
|---|
| 64 | ;
|
|---|
| 65 | SSN(PID,BID,DOD) ;returns full Pt.ID (VA("PID")), BID=1 returns VA("BID")
|
|---|
| 66 | ;DOD is defined to internal entry # of eligibility of desired Pt.ID
|
|---|
| 67 | N DFN
|
|---|
| 68 | I '$D(RADFN) Q "Unknown"
|
|---|
| 69 | S:'$D(BID) BID="" S:$D(DOD) VAPTYP=DOD
|
|---|
| 70 | S DFN=RADFN D PID^VADPT6 I VAERR K VAERR Q "Unknown"
|
|---|
| 71 | S RASSN=$S(BID:VA("BID"),1:VA("PID"))
|
|---|
| 72 | K VA("BID"),VA("PID"),VAERR,VAPTYP
|
|---|
| 73 | Q RASSN
|
|---|
| 74 | WARNPRC ; send warning if user changes procedure within exam edit
|
|---|
| 75 | ; and the exam has either or both radiopharms and meds
|
|---|
| 76 | ; RAY (sub-rec 70.03) comes from rtns RAEDCN or RAEDPT (exam edit)
|
|---|
| 77 | ; RAPRIT (ien file 71) comes from rtn RASTED (status tracking)
|
|---|
| 78 | Q:'$D(RADFN)!('$D(RADTI))!('$D(RACNI))
|
|---|
| 79 | Q:$G(RAY)']""&('$D(RAPRIT))
|
|---|
| 80 | N RAMEDS,RADIO,RATAB,RATEXT
|
|---|
| 81 | S RAMEDS=0,RADIO=0
|
|---|
| 82 | I $G(RAY)]"",$P(RAY,U,2)=RAPRI Q ;no change in procedure
|
|---|
| 83 | I $G(RAPRIT)]"",RAPRIT=RAPRI Q ;no change in procedure
|
|---|
| 84 | S RADIO=$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),U,28) ;ptr fle #70.2
|
|---|
| 85 | S RADIO=+$O(^RADPTN(+RADIO,"NUC",0))
|
|---|
| 86 | S RAMEDS=+$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"RX",0))
|
|---|
| 87 | S RAWHICH=0 ;first assume neither radiopharm nor meds
|
|---|
| 88 | I 'RAMEDS,RADIO S RAWHICH=1 ;radiopharm only
|
|---|
| 89 | I RAMEDS,'RADIO S RAWHICH=2 ;meds only
|
|---|
| 90 | I RAMEDS,RADIO S RAWHICH=3 ;both radiopharm and meds
|
|---|
| 91 | G:'RAWHICH WARN0
|
|---|
| 92 | W !!?2,"**",?21,"Since you have changed the procedure,",?76,"**"
|
|---|
| 93 | S RATAB=$S(RAWHICH=1:26,RAWHICH=2:34,1:21)
|
|---|
| 94 | W !?2,"**",?RATAB,"the",$S(RAWHICH#2:" Radiopharmaceuticals",1:""),$S(RAWHICH=3:" and",1:""),$S(RAWHICH>1:" Meds",1:"")," for",?76,"**"
|
|---|
| 95 | 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
|
|---|
| 96 | W !?2,"**",?RATAB,RATEXT,?76,"**"
|
|---|
| 97 | W !?2,"**",?30,"will now be deleted.",?76,"**",!,*7
|
|---|
| 98 | Q
|
|---|
| 99 | WARN0 W !!?2,"**",?17,"You have changed the procedure, but there are",?76,"**"
|
|---|
| 100 | W !?2,"**",?14,"no data for Radiopharmaceuticals and Meds to delete.",?76,"**",*7,!
|
|---|
| 101 | Q
|
|---|
