source: FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAUTL11.m@ 794

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

initial load of FOIAVistA 6/30/08 version
File size: 7.2 KB
Line 
1RAUTL11 ;HISC/CAH,FPT,GJC,SS-Utility File Maintenance ;4/21/97 11:59
2 ;;5.0;Radiology/Nuclear Medicine;**18,35,34**;Mar 16, 1998
3 ;
4 ;Last modification : by SS, SEP 30,2000 for P18
5HEAD ; Header
6 I $E(IOST,1,2)="C-"!(RAPG>0) W:$Y>0 @IOF
7 S RAPG=RAPG+1
8 W !?62,"Page: ",RAPG,!?62,"Date: ",RADATE
9 W !!?(IOM-$L(RAHDR)\2),RAHDR,!,RALINE,!
10 Q
11ORDELSH ;Called by the 'List Exams with Inactive/Invalid Statuses' option.
12 ;Exams with statuses whose 'Order' field is blank are printed
13 N RADATE,RAHDR,RALINE,RAOUT,RAPG,Y
14 S RAHDR="Exams with Inactive/Invalid Statuses"
15 S (RAPG,RAOUT)=0,$P(RALINE,"=",(IOM+1))="",Y=DT
16 X ^DD("DD") S RADATE=Y
17 K %ZIS S %ZIS="MQ" W ! D ^%ZIS I POP D Q2 Q
18 I $D(IO("Q")) D W ! Q
19 . S ZTDESC="Rad/Nuc Med List Exams with Inactive/Invalid Statuses",ZTSAVE("RA*")=""
20 . S ZTRTN="2^RAUTL11" D ^%ZTLOAD
21 . W !?5,$S($D(ZTSK):"Request Queued!",1:"Request Cancelled!")
22 . Q
23 D 2
24 Q
252 ;
26 N A,B,C,D,E,F,FT,G,H,HD,I,J,K,L,LN,RACASE,RAEXDT,RAPAT,RAPROC,RARPT
27 N RASSN,X,Y,Y1,Y2 D HEAD
28 S (A,F)=0,FT="No evidence of inactive/invalid exams was detected."
29 S HD(1)="Exam Status: ",HD(2)="Imaging Type: "
30 S $P(LN(1),"*",($L(HD(1))-1))="",$P(LN(2),"*",($L(HD(2))-1))=""
31 F S A=$O(^RA(72,A)) Q:A'>0 D Q:RAOUT
32 . S B=$G(^RA(72,A,0)) Q:B']""
33 . S C=$P(B,U),D=$P(B,U,3),E=$P($G(^RA(79.2,+$P(B,U,7),0)),U)
34 . I D']"",($D(^RADPT("AS",A))) D
35 .. I $Y'<(IOSL-4) S RAOUT=$$EOS^RAUTL5() Q:RAOUT D HEAD
36 .. W !,HD(1),C
37 .. W ?45,HD(2),$E($S(E]"":E,1:"Unknown"),1,20),!,LN(1),?45,LN(2),!
38 .. S F=1,G=0
39 .. F S G=$O(^RADPT("AS",A,G)) Q:G'>0 S H=0 D Q:RAOUT
40 ... S J=$G(^RADPT(G,0))
41 ... F S H=$O(^RADPT("AS",A,G,H)) Q:H'>0 S I=0 D Q:RAOUT
42 .... S K=$G(^RADPT(G,"DT",H,0))
43 .... F S I=$O(^RADPT("AS",A,G,H,I)) Q:I'>0 D Q:RAOUT
44 ..... S L=$G(^RADPT(G,"DT",H,"P",I,0))
45 ..... S RAPAT=$P($G(^DPT(+$P(J,U),0)),U)
46 ..... S RASSN=$P($G(^DPT(+$P(J,U),0)),U,9),RARPT=+$P(L,U,17)
47 ..... I RARPT D
48 ...... S Y1=$P($G(^RARPT(RARPT,0)),U,5)
49 ...... S Y2=$P($G(^DD(74,5,0)),U,2)
50 ...... S RARPT("STAT")=$$XTERNAL^RAUTL5(Y1,Y2)
51 ...... Q
52 ..... S Y=$P(K,U) X ^DD("DD") S RAEXDT=Y
53 ..... S RACASE=$P(L,U),RAPROC=$P($G(^RAMIS(71,+$P(L,U,2),0)),U)
54 ..... I $Y'<(IOSL-4) D Q:RAOUT
55 ...... S RAOUT=$$EOS^RAUTL5() Q:RAOUT D HEAD
56 ...... W !,HD(1),C,?45,HD(2),$E($S(E]"":E,1:"Unknown"),1,20)
57 ...... W !,LN(1),?45,LN(2),!
58 ...... Q
59 ..... W !,"Patient: ",$S(RAPAT]"":RAPAT,1:"Unknown")
60 ..... W ?45,"SSN: ",$E(RASSN,1,3)_"-"_$E(RASSN,4,5)_"-"_$E(RASSN,6,9)
61 ..... W !,"Exam Date: ",$S(RAEXDT]"":RAEXDT,1:"Unknown")
62 ..... W ?45,"Case #: ",$S(RACASE]"":RACASE,1:" --- ")
63 ..... I RARPT D
64 ...... W !,"Reported: Yes",?45,"Report Status: "
65 ...... W $S(RARPT("STAT")]"":$E(RARPT("STAT"),1,19),1:"Unknown")
66 ...... Q
67 ..... W !,"Procedure: ",$S(RAPROC]"":RAPROC,1:"Unknown"),!
68 ..... Q
69 .... Q
70 ... Q
71 .. Q
72 . Q
73 I 'F W !?(IOM-$L(FT)\2),FT
74 S:$D(ZTQUEUED) ZTREQ="@" D ^%ZISC
75Q2 K DUOUT,I,POP
76 Q
77 ;
78 ;called from RAO7PC1,saves TECH COMMENT in ^TMP($J,"RAE2",
79SVTCOM(RA11DFN,RA11DTI,RA11CNI) ;P18 used for API call
80 N RA11
81 S RA11(0)=$G(^RADPT(RA11DFN,"DT",RA11DTI,"P",RA11CNI,0))
82 Q:RA11(0)']""
83 S RA11(1)=$G(^RAMIS(71,+$P(RA11(0),"^",2),0))
84 S RA11(2)=$S($P(RA11(1),"^")]"":$P(RA11(1),"^"),1:"Unknown")
85 S RA11(3)=$$GETTCOM(RA11DFN,RA11DTI,RA11CNI)
86 S:RA11(3)'="" ^TMP($J,"RAE2",RA11DFN,RA11CNI,RA11(2),"TCOM",1)=RA11(3)
87 Q
88 ;
89GETTCOM(RA11DFN,RA11DTI,RA11CNI) ;P18 returns most recent tech comment
90 N RA11X,RA11XI
91 S RA11X="",RA11XI=99999
92 F S RA11XI=$O(^RADPT(RA11DFN,"DT",RA11DTI,"P",RA11CNI,"L",RA11XI),-1) Q:+RA11XI=0 I RA11XI>0 S RA11X=$G(^RADPT(RA11DFN,"DT",RA11DTI,"P",RA11CNI,"L",RA11XI,"TCOM"),"") Q:RA11X'=""
93 Q RA11X
94 ;
95 ;Outputs most recent tech comments.Arguments:
96 ;RADFN,RADTI,RACNI,header(can be ""),left margin,right margin,
97 ;number of lines in the bottom before checking bottom of screen,
98 ;is NL before and after header,number of lines to output,
99 ;put header even if no text
100PUTTCOM(RA18DFN,RA18DTI,RA18CNI,RA18HDR,RA18LFTM,RA18RGHM,RA18BOT,RANLHD,RAHDNL,RALINES,RAWRHDR) ;P18 outputs techcomm
101 N RA18X,RA18XI
102 S RA18X="",RA18X=$$GETTCOM(RA18DFN,RA18DTI,RA18CNI) I RA18X="" D Q 0
103 . I RAWRHDR=1 W:RANLHD ! W RA18HDR W:RAHDNL !
104 . Q
105 W:RANLHD ! W RA18HDR W:RAHDNL !
106 Q:$$TXTOUT(RA18X,RA18LFTM,RA18RGHM,RA18BOT,RA18HDR,RALINES,RANLHD,RAHDNL,0)=-1 -1
107 Q 1
108 ;
109CONTIN(RABTM) ;P18 screen check
110 Q:$D(RARTVERF) 0 ;on-line verify or resident preverify--ENTIRE report
111 I ($Y+RABTM)'>IOSL Q 0
112 Q:$$EOS^RAUTL5()>0 -1
113 W:$E(IOST,1,2)="C-" @IOF
114 Q 1
115 ;
116 ;Prints text.Arguments:
117 ;Text,Left margin,Right margin
118 ;Number of lines in the bottom before screen check.if <0 don't check
119 ;Header text displayed ONLY for next page;Max lines to output, Should place NL before header,
120 ;Should place NL after header
121 ;Should place header for continuation after screen check
122TXTOUT(RA11TXT,RA11LM,RA11RM,RABT,RAHD,RALIN,RANLHD,RAHDNL,RA18ISHD) ;P18 outputs text
123 Q:(RA11LM'<RA11RM) 0
124 N DIWF,DIWL,DIWR,RAX,X,RALN,RA18EX,RA18A,RA18B,RA18C,RACHKBOT S (RA18EX,RAX)=0,RA18A="",RA18C=0
125 S RACHKBOT=$S(RABT<0:0,1:1)
126 S DIWF="|",DIWL=RA11LM,DIWR=RA11RM K ^UTILITY($J,"W")
127 S X=RA11TXT
128 D ^DIWP
129 S RAX=0 F RALN=1:1 S RAX=$O(^UTILITY($J,"W",DIWL,RAX)) Q:RAX'>0!(RA18EX'=0)!(RA18C=-1) D
130 . S RA18B=+$O(^UTILITY($J,"W",DIWL,RAX)) ;is it last?
131 . S X=$G(^UTILITY($J,"W",DIWL,RAX,0))
132 . I RALN'<RALIN S RA18EX=1 D Q
133 .. S $P(RA18A," ",RA11RM-RA11LM-$L(X))="",X=X_RA18A
134 .. S:+RA18B'=0 X=$E(X,1,RA11RM-RA11LM)_"(more...)" W ?DIWL,X
135 .. Q
136 . W ?DIWL,X
137 . W:+RA18B>0 !
138 . I RACHKBOT=1 S RA18C=$$CONTIN(RABT) Q:RA18C=-1
139 . I RA18ISHD I RA18C=1 I RA18B W:RANLHD ! W RAHD W:RAHDNL !
140 . Q
141 Q $S(RA18C=-1:-1,1:0)
142 ;
143PUTTCOM2(RA18DFN,RA18DTI,RA18CN,RA18HDR,RA18LFTM,RA18RGHM,RA18BOT,RA18HDNL) ;P18 outputs techcomm using caseNo see PUTTCOM
144 N RA18A S RA18A=$$FNDIN70M^RAO7XX(RA18DFN,RA18DTI,RA18CN,"T")
145 Q:RA18A=0 0
146 Q:$$PUTTCOM(RA18DFN,RA18DTI,$P(RA18A,"^",2),RA18HDR,RA18LFTM,RA18RGHM,RA18BOT,1,RA18HDNL,2,0)=-1 -1
147 Q 0
148 ;
149VERONLY() ;outputs header with case info for Verify only menu option
150 N RA18EX,RA18I S RA18EX=0 ;P18 for quit if uparrow inside PUTTCOM
151 I '($D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))#2) D Q
152 . W !!?2,"Case #: ",RACN," for ",RANME S RAXIT=1
153 . W !?2,"Procedure: '",$E(RAPRC,1,45),"' has been deleted"
154 . W !?2,"by another user!",$C(7)
155 . Q
156 W !
157 S RA18EX=$$PUTTCOM2^RAUTL11(RADFN,RADTI,RACN,"Tech. Comment for case No. "_RACN_":",1,70,-1,1)
158 Q:RA18EX=-1
159 N RAPRTSET,RAMEMARR,RA1P18
160 D EN2^RAUTL20(.RAMEMARR)
161 I RAPRTSET D
162 . S RA1P18=""
163 . F S RA1P18=$O(RAMEMARR(RA1P18)) Q:RA1P18=""!(RA18EX=-1) I RA1P18'=RACNI D
164 .. S RA18EX=$$PUTTCOM2^RAUTL11(RADFN,RADTI,+RAMEMARR(RA1P18),"Tech. Comment for case No. "_+RAMEMARR(RA1P18)_":",1,70,-1,1) Q:RA18EX=-1 ;
165 .. Q
166 . Q
167 Q RA18EX
168 ;------------
169 ;Outputs tech comment using
170 ;RADFN,RADTI,RACNI,activity log ien,header(can be ""),left margin,
171 ;right margin,number of lines in the bottom
172 ;before checking bottom of screen,is NL after header,
173 ;number of lines to output,header even if no comments
174PUTTCOM3(RA18DFN,RA18DTI,RA18CNI,RA18LOG,RA18HDR,RA18LFTM,RA18RGHM,RA18BOT,RANLHD,RAHDNL,RALINES,RAWRHDR) ;P18 outputs techcomm
175 N RA18X,RA18XI,I
176 S RA18X="",RA18X=$G(^RADPT(RA18DFN,"DT",RA18DTI,"P",RA18CNI,"L",RA18LOG,"TCOM"),"") I RA18X="" D Q 0
177 . I RAWRHDR=1 W:RANLHD ! W RA18HDR W:RAHDNL !
178 . Q
179 W:RANLHD ! W RA18HDR W:RAHDNL !
180 Q:$$TXTOUT(RA18X,RA18LFTM,RA18RGHM,RA18BOT,RA18HDR,RALINES,RANLHD,RAHDNL,0)=-1 -1
181 Q 1
Note: See TracBrowser for help on using the repository browser.