source: WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAUTL2.m@ 846

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

initial load of WorldVistAEHR

File size: 7.7 KB
Line 
1RAUTL2 ;HISC/CAH,FPT,GJC AISC/MJK,RMO-Utility Routine ;11/10/97 11:18
2 ;;5.0;Radiology/Nuclear Medicine;**10,26,45**;Mar 16, 1998
3 ;
4 ;Called from many points within Rad/Nuc Med package ;ch
5 ;INPUT VARIABLES: Y=IEN of Rad Report file #74
6 ; XRT0,XRT1 If set, will do some response time checks
7 ;OUTPUT VARIABLES:
8 ; RADFN=Patient DFN, RADTE=Exam date/time (FM format),
9 ; RACN=long case number, RADTI=reverse exam date/time,
10 ; RACNI=short case number, RADATE=Exam date/time (external format)
11 ; Y=If active case, zeroeth node of case record in file #70
12RASET D:$D(XRTL) T0^%ZOSV S Y=$S($D(^RARPT(+Y,0)):^(0),1:"") Q:'Y S RADFN=+$P(Y,"^",2),RADTE=+$P(Y,"^",3),RACN=+$P(Y,"^",4),RADTI=9999999.9999-RADTE,RACNI=$O(^RADPT("ADC",$P(Y,"^"),RADFN,RADTI,0)) S Y=RADTE D D^RAUTL S RADATE=Y
13 S Y="" I RACNI,$D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) S Y=^(0)
14 I $D(XRT0) S XRTN=$T(+0) D T1^%ZOSV
15 Q
16 ;
17 ;Called from 2 x-refs on file #74, Rpt Status fld 5 ;ch
18 ;Does sets and kills for 'ARES', and 'ASTF' xrefs
19 ; ** CAUTION ** 1st RARAD=12 or 15, 2nd RARAD=ien for file 200
20XREF Q:'$D(^RARPT(DA,0)) S RADFNZ=^(0),RADTIZ=9999999.9999-$P(RADFNZ,"^",3),RACNIZ=$O(^RADPT(+$P(RADFNZ,"^",2),"DT",RADTIZ,"P","B",+$P(RADFNZ,"^",4),0)),RADFNZ=+$P(RADFNZ,"^",2),RADA=DA G Q:'RACNIZ
21 S RARADOLD=RARAD ;save 1st value of rarad
22 G Q:'$D(^RADPT(RADFNZ,"DT",RADTIZ,"P",RACNIZ,0)) S RARAD=+$P(^(0),"^",RARAD) G Q:'RARAD
23 ; ** CAUTION ** next line is reached 2 ways : from line above,
24 ; and also from file 70.03, fld 15's "ASTF" xref
25 ; thus RARAD's 2nd meaning must be preserved for XREF1
26XREF1 S:$D(RASET) ^RARPT(RAXREF,RARAD,RADA)="" K:$D(RAKILL) ^RARPT(RAXREF,RARAD,RADA) D XPRI^RAUTL20
27Q K RADA,RADFNZ,RADTIZ,RACNIZ,RARADOLD Q
28 ;
29 ;Checks for CONTRAST MEDIA given the necessary subscripts
30 ;to access a record in File #70.
31 ;RADFN, RADTI, RACNI must be set.
32 ;Output is Y=a string delimited by commas containing all
33 ;applicable items in externally formatted text (ex: If exam was
34 ;done with contrast media Y="CONTRAST MEDIA USED"
35 ;06/16/99 remove obsolete RAF2
36 ; add CPT Modifiers string
37 ; output Y = procedure modifiers string
38 ; Y(1)= CPT modifiers string, external
39 ; Y(2)= CPT modifiers string, internal
40MODS ;get procedure modifiers
41 S (Y,Y(1),Y(2))="" Q:'$D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) S X=^(0)
42 F I=0:0 S I=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"M",I)) Q:I'>0 I $D(^RAMIS(71.2,+^(I,0),0)) S X1=$P(^(0),"^") D MODS1
43 S:$P(X,"^",10)["Y" X1="CONTRAST MEDIA USED"
44 ;
45MODS0 ;falls through from MODS; get CPT modifiers
46 S:Y="" Y="None"
47 S X=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),I=0
48 F S I=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",I)) Q:I'>0 S X1=$$BASICMOD^RACPTMSC(+$G(^(I,0)),DT) I +X1>0 S Y(1)=Y(1)_$S(Y(1)="":"",1:", ")_$P(X1,"^",2),Y(2)=Y(2)_$S(Y(2)="":"",1:", ")_$P(X1,"^")
49 S:Y(1)="" Y(1)="None"
50 K I,X,X1 Q
51 ;
52MODS1 ;builds procedure modifier string (called from MODS above)
53 S Y=Y_$S(Y="":"",1:", ")_X1 Q
54 ;
55 ;called to do some order checks - takes appropriate action if:
56 ; procedure requested needs Rad/NM physician approval (File 71, fld 11)
57 ; there are other outstanding orders for this procedure for this pt
58 ; user is inactivated (file 200, "I" node)
59ORDPRC I $D(^RAMIS(71,+X,0)),$P(^(0),"^",11)["y" D CHKUSR I 'RAMSG W !!,"Please contact appropriate Imaging Service to request this procedure! " K X,RAMSG Q
60 S RAS3=+$P(^RAO(75.1,DA,0),"^")
61ORDPRC1 Q:'$D(^RAO(75.1,"AP",RAS3,X)) S RAS4=X,RASCNT=0 K RAX
62 F RAS5=0:0 S RAS5=$O(^RAO(75.1,"AP",RAS3,RAS4,RAS5)) Q:'RAS5 F RAS6=0:0 S RAS6=$O(^RAO(75.1,"AP",RAS3,RAS4,RAS5,RAS6)) Q:'RAS6 I $D(^RAO(75.1,RAS6,0)) S RAT=+$P(^(0),"^",5) I RAT>2 S RASCNT=RASCNT+1 D:$S('$D(RAQUIT):1,1:RASCNT>1) ORDMES
63 I $D(RAX),'$D(RAQUIT) D ORDMES1
64 K:$D(RAX) RAQUIT K RAMSG,RAS3,RAS4,RAS5,RAS6,RASCNT,RAT,RAX Q
65 ;
66CHKUSR ; Check if valid user
67 N RAINADT,RAC
68 S RAINADT=+$P($G(^VA(200,+$G(DUZ),"PS")),"^",4)
69 S RAC=$O(^VA(200,+$G(DUZ),"RAC",0))
70 S RAMSG=$S('($D(DUZ)#2):0,'$D(^VA(200,DUZ,0)):0,'RAC:0,'RAINADT:1,'$D(DT):0,DT'>RAINADT:1,1:0)
71 Q
72ORDMES W:'$D(RAX) !!,*7,"The following requests are already on file for this procedure:",!
73 W !?3,"A request dated " S Y=9999999.9999-RAS5 D DT^DIO2 W " is already ",$S(RAT=3:"on ",1:""),$P($P(^DD(75.1,5,0),RAT_":",2),";")," for this procedure." S RAX=1 Q
74ORDMES1 W !!?3,"Is it ok to continue? No// " R RAX:DTIME S:'$T!(RAX="")!(RAX["^") RAX="N"
75 I "Nn"[$E(RAX) K X S RAPRI=0
76 I $D(X),"Yy"'[$E(RAX) W !!?3,"Enter 'YES' to request this procedure for this patient, or 'NO' not to.",! G ORDMES1
77 Q
78 ;
79 ;Called (from RAPSET) to determine if at least one division and at
80 ;least one location are set up. Can't use pkg unless these are set up.
81CHKSP S RADV=$S($O(^RA(79,0))>0:1,1:0),RALC=$S($D(^RA(79.1,+$O(^RA(79,"AL",0)),0)):1,1:0)
82 Q
83 ;
84KILLVAR ;This call will clean up possible variables left after execution
85 ;of the Label print fields in file 78.7
86 K RAY0,RAY1,RAY2,RAY3,RAGE,RACSE,RANOW,RADOB,RAEXDT,RATRAN,RARPDT,RADIAG,RAMOD,RAINST,RAEXLST,RAVST,RALCSE,RANM,RAPAGE,RAPR,RAL,RARST,RAREA,RADOC,RARAD,RASSN
87 K RASTAFF,RASIGS,RATECH,RACTY,RASIGVES,RAVER,RASIGVS,RASIGVSB,RASIGR,RASERV,RASEX,RAS,RAII,RAFMT,RASV
88 Q
89 ;
90CONTRAST(RAZ71) ;Display the contrast media/medium associated with a Rad/Nuc
91 ;Med Procedure. Called from: PRC1^RAUTL8 & ALLERGY^RAORD1
92 ;input: RAZ71=ien of the non-parent procedure in file 71
93 ;
94 K RAZCM S RAZ71(0)=$G(^RAMIS(71,RAZ71,0))
95 S RAZCMU=$P(RAZ71(0),"^",20) ;is contrast media used?
96 I RAZCMU'="Y" K RAZCMU Q
97 D GETS^DIQ(71,RAZ71_",","125*","E","RAZCM")
98 ; The RAZCM(71.0125,x,.01,"E") array will be one or more of following
99 ; values: I:Iodinated contrast, ionic;N:Iodinated contrast, non-ionic
100 ; L:Gadolinium, C:Cholecystogram;G:Gastrografin;B:Barium
101 ;
102 S:$O(RAZCM(71.0125,$C(126)),-1)=$O(RAZCM(71.0125,"")) RAZTAG="medium"
103 S:'$D(RAZTAG)#2 RAZTAG="media"
104 S RAPMSG(1)="************** Patient reaction to contrast "_RAZTAG_" *************"
105 S RAPMSG(2)=$E($P(RAZ71(0),"^"),1,47)_" uses contrast "_RAZTAG_": "
106 S RAPMSG(2,"F")="!",RAZI="",RAZSUB=$O(RAPMSG($C(32)),-1)
107 F S RAZI=$O(RAZCM(71.0125,RAZI)) Q:RAZI="" D
108 .S:$L($G(RAPMSG(RAZSUB)))+$L(RAZCM(71.0125,RAZI,.01,"E"))>69 RAZSUB=RAZSUB+1
109 .S RAPMSG(RAZSUB)=$G(RAPMSG(RAZSUB))_RAZCM(71.0125,RAZI,.01,"E")_", "
110 .Q
111 ; The reverse dollar order (R$O) is used to strip off the ", " string
112 ; from the last printable subscript containing CM data. I also use the
113 ; R$O to set my last printable array element to '*'s to box off the
114 ; warning.
115 S RAPMSG($O(RAPMSG($C(32)),-1))=$E(RAPMSG($O(RAPMSG($C(32)),-1)),1,$L(RAPMSG($O(RAPMSG($C(32)),-1)))-2) ;strips off the ", "
116 S $P(RAPMSG($O(RAPMSG($C(32)),-1)+1),"*",69)="",RAPMSG(99)=" "
117 D EN^DDIOL(.RAPMSG)
118 K RAPMSG,RAZCM,RAZCMU,RAZI,RAZTAG,RAZSUB
119 Q
120 ;
121DELCM(DA) ;Ask the user if he/she is sure that deletion of contrast media
122 ;is intended. If the user enter '^' exit editng the template
123 ; input: DA=the ien of the record in file 71
124 ;output: RAYN=response to 'Are you sure?'; either 'Y', 'N', or '^'
125 ;Called from the RA PROCEDURE EDIT input template (RA*5*45)
126 N RAYN W !?3,"*** Deleting all contrast media data associated with this procedure. ***"
127 F D Q:$L($G(RAYN))
128 .R !!?3,"All contrast relationships with this procedure will be deleted.",!?3,"Are you sure you want to delete? N// ",RAYN:DTIME
129 .S:'$T!(RAYN["^") RAYN="^" Q:RAYN="^"
130 .S:RAYN="" RAYN="N" Q:RAYN="N"
131 .S RAYN=$$UP^XLFSTR($E(RAYN)) Q:RAYN="Y"!(RAYN="N")
132 .I RAYN["?" W !?3,"Enter 'Y'es to delete associated contrasts, or 'N'o to preserve associated",!?3,"contrasts." K RAYN Q
133 .K RAYN W !?3,"Please enter 'Y' for yes, or 'N' for no."
134 .Q
135 ;The user does not want to delete associated cm data or has '^' out of
136 ;the option. We must reset the CONTRAST MEDIA USED (#20) field back to
137 ;yes from no.
138 I RAYN'="Y" D
139 .K RAFDA S RAFDA(71,DA_",",20)="Y" D FILE^DIE("","RAFDA")
140 .K RAFDA Q
141 Q RAYN
142 ;
Note: See TracBrowser for help on using the repository browser.