source: FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RADD1.m@ 1757

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

initial load of FOIAVistA 6/30/08 version

File size: 6.1 KB
Line 
1RADD1 ;HISC/FPT-Radiology Utility Routine ;6/2/98 16:17
2 ;;5.0;Radiology/Nuclear Medicine;**1,5,10**;Mar 16, 1998
3SECXREF ; sets/kills 'ARES' & 'ASTF' x-refs for secondary resident/staff rads
4 ; called from ^DD(74,5
5 ;
6 Q:'$D(^RARPT(DA,0)) S RADFNZ=^(0)
7 S RADTIZ=9999999.9999-$P(RADFNZ,"^",3),RACNIZ=$O(^RADPT(+$P(RADFNZ,"^",2),"DT",RADTIZ,"P","B",+$P(RADFNZ,"^",4),0)),RADFNZ=+$P(RADFNZ,"^",2)
8 I 'RACNIZ D KILL Q
9 I '$D(^RADPT(RADFNZ,"DT",RADTIZ,"P",RACNIZ,0)) D KILL Q
10 I '$D(^RADPT(RADFNZ,"DT",RADTIZ,"P",RACNIZ,RASECOND,0)) D KILL Q
11 S RASECIEN=0
12 F S RASECIEN=$O(^RADPT(RADFNZ,"DT",RADTIZ,"P",RACNIZ,RASECOND,RASECIEN)) Q:RASECIEN<1 S RARAD=+$P($G(^(RASECIEN,0)),"^",1) I RARAD>0 D
13 .S:$D(RASET) ^RARPT(RAXREF,RARAD,DA)="" K:$D(RAKILL) ^RARPT(RAXREF,RARAD,DA)
14 D XSEC^RAUTL20
15KILL K RACNIZ,RADFNZ,RADTIZ,RASECOND,RASECIEN
16 Q
17SCDTC ; status change date/time check
18 ; called from ^DD(70.05,.01
19 ; if X is a date/time prior to the exam date/time, then set Y=0.
20 ; if X is a over a minute in the future, then set Y=0.
21 ; if X is missing the time portion, then set Y=0.
22 I '($D(X)#2) Q
23 I '$F(X,".") D EN^DDIOL("** Time is Required **","","!!?20") S Y=0 Q
24 N RASTATUS,RAORDNUM,RAPLUS1
25 ; eg. da(3)=1128, da(2)=7028970.8743,da(1)=1,da=1
26 S RASTATUS=$P($G(^RADPT(+$G(DA(3)),"DT",+$G(DA(2)),"P",+$G(DA(1)),0)),U,3)
27 S RAORDNUM=$P($G(^RA(72,+RASTATUS,0)),U,3)
28 I X<(9999999.9999-$G(DA(2))),RAORDNUM>1 S Y=0 Q
29 S RADTHOLD=X
30 D NOW^%DTC
31 ; 2/25/98 allow entry to be at most 1 minute after current time
32 S RAPLUS1=%,RAPLUS1=$$FMADD^XLFDT(RAPLUS1,0,0,1,0)
33 I RADTHOLD>RAPLUS1 S Y=0
34 S X=RADTHOLD
35 K RADTHOLD
36 Q
37PDC() ; do not enter secondary into primary diagnostic code field
38 ; called from ^DD(70.03,13,0)
39 ; do not select inactive diagnostic code 12/23/96
40 I $P(^RA(78.3,+Y,0),U,5)="Y" Q 0
41 I $D(^RADPT(DA(2),"DT",DA(1),"P",DA,"DX","B",+Y)) Q 0
42 Q 1
43SDC() ; do not enter primary into secondary diagnostic code field
44 ; called from ^DD(70.14,.01,0)
45 ; do not select inactive diagnostic code 12/23/96
46 I $P(^RA(78.3,+Y,0),U,5)="Y" Q 0
47 I '$D(X)!('$D(DA(3))) G SDC2
48 I '$D(^RADPT(DA(3),"DT",DA(2),"P",DA(1),0)) G SDC2
49 I $P(^RADPT(DA(3),"DT",DA(2),"P",DA(1),0),"^",13)=+Y Q 0
50 Q 1
51SDC2 ;
52 I '$D(X)!('$D(DA(2))) G SDC3
53 I '$D(^RADPT(DA(2),"DT",DA(1),"P",DA,0)) Q 0
54 I $P(^RADPT(DA(2),"DT",DA(1),"P",DA,0),"^",13)=+Y Q 0
55 Q 1
56SDC3 ;
57 I '$D(RADFN) Q 0
58 S DA(2)=RADFN
59 I '$D(^RADPT(DA(2),"DT",DA(1),"P",DA,0)) Q 0
60 I $P(^RADPT(DA(2),"DT",DA(1),"P",DA,0),"^",13)=+Y Q 0
61 Q 1
62NODEL ; no deletion of primary dx code, primary resident or staff if there
63 ; is a secondary
64 S RASECCHK=0,RASECCHK=$O(^RADPT(DA(2),"DT",DA(1),"P",DA,RAMULT,RASECCHK))
65 I RASECCHK W " Required"
66 K RAMULT,RASECCHK
67 Q
68PRCCPT() ; Displays the procedure type and CPT code if applicable.
69 ; This code is called from ^DD(71,0,"ID","WRITE") and rtn RAPROD
70 N RA,RATXT S RA(0)=$G(^(0)),RA("I")=+$G(^("I")),RATXT=""
71 S RA=$S('RA("I"):0,DT'>RA("I"):0,1:1)
72 S RA(6)=$P(RA(0),U,6),RA(9)=$P(RA(0),U,9)
73 S RA(12)=$P(RA(0),U,12) I 'RA(12) S RA(10)="UNKN "
74 I '$D(RA(10)) S RA(10)=$P(^RA(79.2,+RA(12),0),U,3)_" "
75 I $L(RA(10))<5 F S RA(10)=RA(10)_" " Q:$L(RA(10))>4
76 S RATXT="("_RA(10)_$S(RA:"Inactive",RA(6)="B":"Broad ",RA(6)="D":"Detailed",RA(6)="P":"Parent ",RA(6)="S":"Series ",1:"Unknown ")_")"
77 S:RA(9)]"" RATXT=RATXT_" CPT:"_$P($$NAMCODE^RACPTMSC(RA(9),DT),"^")
78 Q RATXT
79INDTCHK(RADA) ; Cannot inactivate a procedure if it is a common procedure
80 ; with a valid sequence number. Code resides in ^DD(71,100,0)!
81 ; 'RADA' is the ien of the procedure in file 71. if this procedure is
82 ; a common procedure i.e, $D(^RAMIS(71.3,"B",RADA)) inform the user that
83 ; the sequence number must be deleted. This relies on the "AA" xref in
84 ; the Common Proc. file for the Sequence # fld (#3) 0 node, 4th pce.
85 N RA,RAIEN S RAIEN=+$O(^RAMIS(71.3,"B",RADA,0))
86 S RA(0)=$G(^RAMIS(71.3,RAIEN,0)) Q:RA(0)']""
87 S RA(4)=+$P(RA(0),"^",4) ; obtain the sequence number
88 I $D(^RAMIS(71.3,"AA",$$EN3^RAUTL17(RADA),RA(4),RAIEN)) D ; sequence #?
89 . N RATXT S RATXT(1)=" "
90 . S RATXT(2)=" Cannot inactivate - this procedure is currently in the"
91 . S RATXT(3)=" Rad/Nuc Med Common Procedure file with a sequence"
92 . S RATXT(4)=" number. Please remove the sequence number thru the"
93 . S RATXT(5)=" 'Common Procedure Enter/Edit' option before assigning"
94 . S RATXT(6)=" an inactivation date to this procedure."
95 . S RATXT(7)=" "
96 . D EN^DDIOL(.RATXT) K X ; display message, can't input ANY date!
97 . Q
98 Q
99CPTCHK(RADA) ; Check if the CPT code is inactive nationally.
100 ; 'RADA' assume the value of +Y passed from the input xform, ^DD(71,9,0)
101 ; quit if CPT code is active
102 ;
103 Q:$$ACTCODE^RACPTMSC(RADA,DT)
104 N RATXT S RATXT(1)=" "
105 S RATXT(2)=" Warning - Nationally inactive CPT code."
106 S RATXT(3)=" " D EN^DDIOL(.RATXT)
107 K X
108 Q
109DCHK(RADG,RADT,Y) ; Check if drug if DRUG is active AND a Radiopharmaceu-
110 ; tical.
111 ; 'RASTAT=1' if active AND RADG condition met
112 ; 'RASTAT=0' if inactive OR RADG condition not met
113 ; VERSION 5.0 called from ^DD(70.21,.01,12.1)
114 ; 'Y' is the IEN for the Drug file
115 ; 'RADT' is the cutoff date for drugs in the drug file
116 ; 'RADG':$S(RADG="R":Radiopharm,"P":non-Radioharm,1:non-Radiopharm)
117 Q $$DCHK^RADD4()
118 ;
119VALADM(RAD0,Y,RADT,RAUTH) ;edit validation
120 ;Used to validate/screen radiopharm dosage administrator,
121 ; radiopharm prescribing phys, person who measured radiopharm dose,
122 ;----------------------------------------------------------------------
123 ; RAD0 : IEN of entry in question for NUC MED EXAM DATA (70.2) file
124 ; Y : Pointer to the New Person file
125 ; RADT : Xam Date; if not passed, calculate exam date from file 70.2
126 ; RAUTH : 1 - only staff/resid, must be auth'zd to write med orders
127 ; : 0 - staff/resid & tech's
128 ;----------------------------------------------------------------------
129 ; Output: '1' authorized to write med orders, else '0'
130 ;----------------------------------------------------------------------
131 Q $$VALADM^RADD4()
132 ;
133VOL(RAX) ; Validate the format of the value input for volume.
134 ; RAX must be a number followed by a space then text -or-
135 ; a number followed by text
136 ; Input Variable : 'RAX'- user's input
137 ; Output Variable: null if 'RAX' erroneous, formatted version of 'RAX'
138 Q $$VOL^RADD4()
Note: See TracBrowser for help on using the repository browser.