source: FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAUTL.m@ 750

Last change on this file since 750 was 628, checked in by George Lilly, 16 years ago

initial load of FOIAVistA 6/30/08 version
File size: 6.0 KB
Line 
1RAUTL ;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
6DATE 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
8END 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
10DATE1 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
12END1 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.
18ZIS 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
27ZIS1 K RAMES,RASELDEV,ZTDESC,ZTRTN,ZTSAVE Q
28 ;
29CLOSE I $D(ZTQUEUED) S ZTREQ="@" Q
30 D ^%ZISC Q
31 ;
32D 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
39USER 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
40USER1 Q:'$D(RAKEY) Q:$D(^XUSEC(RAKEY,RADUZ)) W !!?3,*7,"Must be a user with the appropriate privileges to continue!"
41USERQ S RAPOP=1 Q
42 ;
43DEV ;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 ;
49VERIFY ;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 ;
52A ;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 ;
57DUZ ;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 ;
65SSN(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
74WARNPRC ; 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
99WARN0 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
Note: See TracBrowser for help on using the repository browser.