source: FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAPINFO.m@ 1770

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

initial load of FOIAVistA 6/30/08 version

File size: 5.7 KB
Line 
1RAPINFO ;HIRMFO/GJC - Display Imaging Procedure Rad/Nuc Med info ;11/5/99 12:32
2 ;;5.0;Radiology/Nuclear Medicine;**10,45**;Mar 16, 1998
3EN1 ; Associated option: [DISPLAY IMAGING PROCEDURE RAD/NUC MED INFORMATION]
4 N RADIC,RAINA,RAITYPE,RAQUIT,RAUTIL
5 K ^TMP($J,"RA PROCEDURES") W !
6 S DIC="^RA(79.2,",DIC(0)="QEAMNZ",DIC("A")="Select an Imaging Type: "
7 S DIC("W")="D DICW^RAPINFO"
8 S DIC("S")="I ($D(^RAMIS(71,""AIMG"",+Y))\10)"
9 D ^DIC K DIC
10 I Y'>0 D KILL Q
11 S RAITYPE=Y ; 'RAITYPE' = ien of entry in 79.2 ^ .01 value in 79.2
12 ;
13PROC ; Procedure selection O-M-A
14 S RADIC="^RAMIS(71,",RADIC("A")="Select a Rad/Nuc Med Procedure: "
15 S RADIC(0)="QEANMZ",RADIC("S")="I $$DICS^RAPINFO(RAITYPE,+Y)"
16 S RAUTIL="RA PROCEDURES" D EN1^RASELCT(.RADIC,RAUTIL)
17 I '($D(^TMP($J,"RA PROCEDURES"))\10) D KILL Q ; quit, nothing selected
18DEV ; Device selection
19 W ! S %ZIS="QM",%ZIS("A")="Select a Device: " D ^%ZIS W !
20 I POP K %ZIS D KILL Q
21 I $D(IO("Q")) D D KILL Q
22 . S ZTRTN="START^RAPINFO"
23 . S ZTSAVE("^TMP($J,""RA PROCEDURES"",")=""
24 . S ZTDESC="Rad/Nuc Med Display Imaging Procedure information"
25 . D ^%ZTLOAD
26 . I +$G(ZTSK("D"))>0 D
27 .. W !?5,"Request Queued, Task #: ",+$G(ZTSK)
28 .. Q
29 . E W !?5,"Request cancelled!"
30 . D HOME^%ZIS K IO("Q")
31 . Q
32START ; Start processing data & printing to the device here.
33 S:$D(ZTQUEUED) ZTREQ="@"
34 U IO N I,J,RA0,RA1,RA2,RA71,RADD,RAHDR,RAIDFIER,RALN,RAMAX,RANOW,RAPG
35 N RARUNDT,RAXIT S RA0="",(RAMAX,RAPG,RAXIT)=0
36 S RAHDR="Radiology/Nuclear Medicine Procedure Information"
37 S $P(RALN,"-",(IOM+1))=""
38 S RADD=$P($G(^DD(71,6,0)),"^",3)
39 F I=1:1:$L(RADD,";") S J=$P($P(RADD,";",I),":",2) Q:J']"" D
40 . S:$L(J)>RAMAX RAMAX=$L(J)
41 . Q
42 S RANOW=$$NOW^XLFDT(),RANOW=$P(RANOW,".")_"."_$E($P(RANOW,".",2),1,4)
43 S RARUNDT=$$FMTE^XLFDT(RANOW,"1P") D HDR^RAPINFO G:RAXIT KILL
44 F S RA0=$O(^TMP($J,"RA PROCEDURES",RA0)) Q:RA0="" D Q:RAXIT
45 . S RA1=0
46 . F S RA1=$O(^TMP($J,"RA PROCEDURES",RA0,RA1)) Q:RA1'>0 D Q:RAXIT
47 .. S RA71=$G(^RAMIS(71,RA1,0)) Q:RA71']""
48 .. S RAIDFIER=$$BLD^RAPINFO(RA1)
49 .. I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() Q:RAXIT D HDR^RAPINFO
50 .. Q:RAXIT W !,$E(RA0,1,30),?34,RAIDFIER
51 ..;
52 ..;check if the descendents have CM relations
53 ..I $P(RA71,U,6)="P" D Q:RAXIT
54 ...S RA2=0 F S RA2=$O(^RAMIS(71,RA1,4,RA2)) Q:'RA2 D Q:RAXIT
55 ....S RA21=+$G(^RAMIS(71,RA1,4,RA2,0)) D DESC(RA21,"P")
56 ....Q
57 ...K RA2,RA21 Q
58 ..;
59 ..;check if the non-parent has CM relations
60 ..E D:$O(^RAMIS(71,RA1,"CM",0)) DESC(RA1,"") Q:RAXIT
61 ..;
62 .. I $O(^RAMIS(71,RA1,"EDU",0)) D
63 ... S DIWF="W",DIWL=1,DIWR=$S(IOM=132:100,1:76)
64 ... S RA2=0 K ^UTILITY($J,"W") S X="Educational Desc: "
65 ... F S RA2=$O(^RAMIS(71,RA1,"EDU",RA2)) Q:RA2'>0 D K X Q:RAXIT
66 .... I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() Q:RAXIT D HDR^RAPINFO
67 .... Q:RAXIT S X=$G(X)_$G(^RAMIS(71,RA1,"EDU",RA2,0)) Q:X']"" D ^DIWP
68 .... Q
69 ... D:'RAXIT ^DIWW ; *** procedure message text to be printed
70 ... Q ; *** once procedure messages are changed to WP
71 .. E W ! ; *** from pointers to 71.4 ***
72 .. Q
73 . Q
74 W ! D ^%ZISC,KILL
75 Q
76BLD(RA1) ; Build procedure identifier string
77 ; input: 'RA1' = ien of entry in Rad/Nuc Med Procedures file
78 N RA,RACPT,RAIABRV,RAPTYPE,RASTR S RASTR="("
79 S RA(0)=$G(^RAMIS(71,RA1,0)),RA("I")=$G(^RAMIS(71,RA1,"I"))
80 S RAIABRV(0)=+$P(RA(0),"^",12)
81 S RAIABRV(1)=$P($G(^RA(79.2,RAIABRV(0),0)),"^",3)
82 S RAIABRV=$S(RAIABRV(1)]"":RAIABRV(1),1:"Unknown")
83 I RA("I"),(RA("I")'>DT) S RAPTYPE="Inactive"
84 I $D(RAPTYPE)[0 D
85 . S RAPTYPE=$$XTERNAL^RAUTL5($P(RA(0),"^",6),$P($G(^DD(71,6,0)),"^",2))
86 . S RAPTYPE=$E(RAPTYPE)_$$LOW^XLFSTR($E(RAPTYPE,2,99999))
87 . S:RAPTYPE']"" RAPTYPE="Unknown"
88 . Q
89 S:$L(RAPTYPE)<RAMAX RAPTYPE=RAPTYPE_$E(" ",1,(RAMAX-$L(RAPTYPE)))
90 S RACPT(0)=+$P(RA(0),"^",9) S:'RACPT(0) RACPT="Unknown"
91 S:$E(RAPTYPE)="P" RACPT="See Descendents"
92 I '($D(RACPT)#2) D
93 . S RACPT=$P($$NAMCODE^RACPTMSC(RACPT(0),DT),"^")
94 . S:RACPT="" RACPT="Unknown"
95 . Q
96 S RASTR=RASTR_RAIABRV_" "_RAPTYPE_") CPT:"_RACPT
97 Q RASTR
98 ;
99DICS(RAY,Y) ; Display active procedures within an imaging type.
100 ; Input : RAY - Imaging Type
101 ; Y - ien of the procedure
102 ; Output: 1 if a valid selection, 0 if invalid
103 Q:'$D(^RAMIS(71,"AIMG",+RAITYPE,+Y))#2 0 ; not valid, wrong i-type
104 N RA71ACT S RA71ACT=$G(^RAMIS(71,+Y,"I"))
105 Q $S(RA71ACT="":1,RA71ACT>DT:1,1:0)
106 ;
107DICW ; Display abbreviation with the I-Type
108 N RA792,RABBRV
109 S RA792=$G(^RA(79.2,+Y,0)),RABBRV=$P(RA792,"^",3)
110 S RABBRV(1)=$S(RABBRV]"":" "_RABBRV,1:" Unknown")
111 S RABBRV(1,"F")="?0" D EN^DDIOL(.RABBRV)
112 Q
113HDR ; Header for our report
114 W:$Y @IOF S RAPG=RAPG+1
115 W !?(IOM-$L(RAHDR)\2),RAHDR
116 W !!,"Run Date/Time: ",RARUNDT,?($S(IOM=132:121,1:68)),"Page: ",RAPG
117 W !,RALN
118 I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAXIT=1
119 Q
120KILL ; Kill and quit the application
121 K ^TMP($J,"RA PROCEDURES"),%X,%XX,%Y,%YY
122 K C,DDH,DIROUT,DIRUT,DIW,DIWF,DIWL,DIWR,DIWT,DN,DTOUT,DUOUT,X,Y
123 K Z,ZTDESC,ZTRTN,ZTSAVE,I,POP,DISYS
124 Q
125 ;
126DESC(RAPRC,RAFLG) ; display the descendants associated with the
127 ; parent procedure
128 ;input: RAPRC-IEN of the procedure in the Rad/Nuc Med Procedure file
129 ; RAFLG-indicates procedure type; "P" if parent, else null
130 I RAFLG="P" D Q:RAXIT
131 .S RAIDFIER=$$BLD^RAPINFO(RAPRC)
132 .I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() Q:RAXIT D HDR^RAPINFO
133 .Q:RAXIT W:$X ! W ?2,$E($P($G(^RAMIS(71,RAPRC,0)),U),1,30),?34,RAIDFIER
134 .Q
135 Q:+$O(^RAMIS(71,RAPRC,"CM",0))=0
136CMEDIA ; display the contrast media associated with the parent procedure
137 K X,^UTILITY($J,"W") S RA3=0,X="Contrast Media: "
138 S DIWF="W",DIWL=3,DIWR=$S(IOM=132:100,1:76)
139 F S RA3=$O(^RAMIS(71,RAPRC,"CM",RA3)) Q:RA3'>0 D
140 .S RA3(0)=$P($G(^RAMIS(71,RAPRC,"CM",RA3,0)),U)
141 .S X=X_$$EXTERNAL^DILFD(71.0125,.01,"",RA3(0))_", "
142 .Q
143 I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() Q:RAXIT D HDR^RAPINFO
144 S X=$P(X,", ",1,$L(X,", ")-1) D ^DIWP,^DIWW
145 K ^UTILITY($J,"W"),DIWF,DIWL,DIWR,RA3,X
146 Q
147 ;
Note: See TracBrowser for help on using the repository browser.