source: FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAO7PC2.m@ 810

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

initial load of FOIAVistA 6/30/08 version
File size: 7.0 KB
Line 
1RAO7PC2 ;HISC/GJC-Part two for Return Narrative (EN3^RAO7PC1);1/17/95 ;9/13/01 10:39
2 ;;5.0;Radiology/Nuclear Medicine;**1,11,14,16,22,27,45,75**;Mar 16, 1998;Build 4
3CASE(Y) ; Retrieve exam data for specified inverse exam date range.
4 ; 'Y'-> Exam node IEN
5 N RABNOR,RACNT,RAEXAM,RAI,RAIMPRES,RAINCLUD,RAOPRC,RAORD,RAPDIAG
6 N RAPIST,RAPIRE,RAPROC,RARDE,RADTI,RACNI,RADUPHX,RAREASDY
7 N RARPT,RARPTST,RARPTXT,RASBN,RASDIAG,RAVER,RAERRFLG,Z,Z1,Z2
8 S RACNT=1
9 S RAEXAM(0)=$G(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,0)) Q:RAEXAM(0)']""
10 S:$P(RAEXAM(0),"^",25)=2 RAPSET=1
11 S:RAPSET=1 ^TMP($J,"RAE2",RADFN,"PRINT_SET")="" ; xam set with same rpt
12 S RAPROC(0)=$G(^RAMIS(71,+$P(RAEXAM(0),"^",2),0))
13 S RAPROC=$S($P(RAPROC(0),"^")]"":$P(RAPROC(0),"^"),1:"Unknown")
14 S RAORD(0)=$G(^RAO(75.1,+$P(RAEXAM(0),"^",11),0))
15 S RAORD(7)=$P(RAORD(0),"^",7) ; CPRS order ien
16 S RAREASDY=$P($G(^RAO(75.1,+$P(RAEXAM(0),"^",11),.1)),"^") ;REASON FOR STUDY
17 S RAOPRC(0)=$G(^RAMIS(71,+$P(RAORD(0),"^",2),0))
18 S RAOPRC=$S($P(RAOPRC(0),"^")]"":$P(RAOPRC(0),"^"),1:"Unknown")
19 S RAPDIAG(0)=$G(^RA(78.3,+$P(RAEXAM(0),"^",13),0))
20 S RAPDIAG=$P(RAPDIAG(0),"^"),RARPT=+$P(RAEXAM(0),"^",17)
21 S RARPT(0)=$G(^RARPT(RARPT,0)),RARPTST=$P(RARPT(0),"^",5)
22 S RARPTST=$S(RARPTST="V":"Verified",RARPTST="R":"Released/Not verified",RARPTST="D":"Draft",RARPTST="PD":"Problem Draft",1:"No Report")
23 ; set the following flag variable: RAINCLUD
24 ; RAINCLUD=$S(RPT STATUS=verif'd or released/unverif'd:1,1:0)
25 S RAINCLUD=$S("RV"[$E(RARPTST):1,1:0)
26 I $E(RARPTST)="V",(RAPSET'<0) D
27 . S RAVER=$P(RARPT(0),"^",9),RASBN=$P($G(^VA(200,+RAVER,20)),"^",2)
28 . S ^TMP($J,"RAE2",RADFN,Y,RAPROC,"V")=RAVER_"^"_RASBN
29 . Q
30 S RABNOR=$$UP^XLFSTR($P(RAPDIAG(0),"^",4)) S:RABNOR'="Y" RABNOR=""
31 I RAPDIAG]"",(RAINCLUD),(RAPSET'<0) D ; if diag & verif'd or released/unverif'd & first pass if part of xam set (many xams - one rpt)
32 . S ^TMP($J,"RAE2",RADFN,Y,RAPROC,"D",RACNT)=RAPDIAG
33 . Q
34 S ^TMP($J,"RAE2",RADFN,Y,RAPROC,"RFS")=RAREASDY ;REASON FOR STUDY
35 ; 1st, get clnhist from file70. 2nd, get addl clnhist form file74
36 ; 1st:
37 I +$O(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"H",0)) D
38 . N RAI S (RAI,Z)=0
39 . F S Z=$O(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"H",Z)) Q:Z'>0 D
40 .. S RAI=RAI+1
41 .. S ^TMP($J,"RAE2",RADFN,Y,RAPROC,"H",RAI)=$G(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"H",Z,0))
42 .. Q
43 . Q
44 ;2nd:
45 S RADTI=RAINVXDT,RACNI=Y D CHKDUPHX^RART1 ;chk if file74 clnhist is dupl
46 I 'RADUPHX,$O(^RARPT(RARPT,"H",0)) S Z="H" D RPTXT(RARPT,Z)
47 ;
48 I +$O(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"M",0)) D ; save modifiers
49 . N RAI S (RAI,Z)=0
50 . F S Z=$O(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"M",Z)) Q:Z'>0 D
51 .. S RAI=RAI+1
52 .. S ^TMP($J,"RAE2",RADFN,Y,RAPROC,"M",RAI)=$P($G(^RAMIS(71.2,+$G(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"M",Z,0)),0)),"^")
53 .. Q
54 . Q
55 I +$O(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"DX",0)),(RAPSET'<0) D
56 . S Z=0 F S Z=$O(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"DX",Z)) Q:Z'>0 D
57 .. S RASDIAG=+$G(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"DX",Z,0))
58 .. S RASDIAG(0)=$G(^RA(78.3,RASDIAG,0)),RASDIAG(1)=$P(RASDIAG(0),"^")
59 .. I RASDIAG(1)]"",(RAINCLUD) D
60 ... S RACNT=RACNT+1,^TMP($J,"RAE2",RADFN,Y,RAPROC,"D",RACNT)=RASDIAG(1)
61 ... I RABNOR'="Y" D
62 .... S RABNOR=$$UP^XLFSTR($P(RASDIAG(0),"^",4)) S:RABNOR'="Y" RABNOR=""
63 .... Q
64 ... Q
65 .. Q
66 . Q
67 I RAINCLUD,(RAPSET'<0) D
68 . I +$O(^RARPT(RARPT,"I",0)) S Z="I" D RPTXT(RARPT,Z)
69 . I +$O(^RARPT(RARPT,"R",0)) S Z="R" D RPTXT(RARPT,Z)
70 . Q
71 I $P(RAEXAM(0),"^",25) S ^TMP($J,"RAE2",RADFN,"ORD")=RAOPRC
72 I '$P(RAEXAM(0),"^",25) S ^TMP($J,"RAE2",RADFN,"ORD",Y)=RAOPRC
73 ;
74 ; Check to see if amended report
75 I RAPSET'<0,+$O(^RARPT(RARPT,"ERR",0)) S RAERRFLG="A"
76 ;
77 S:RAPSET'<0 ^TMP($J,"RAE2",RADFN,Y,RAPROC)=RARPTST_"^"_$G(RABNOR)_"^"_$G(RAORD(7))_"^"_$G(RAERRFLG)
78 S:RAPSET<0 ^TMP($J,"RAE2",RADFN,Y,RAPROC)=""
79 S:RAPSET=1 RAPSET=-1
80 ;
81 I RARPTST'="No Report" D
82 .; Add Prim Int Staff, Prim Int Resident & Reported Date
83 .S RAPIST=$P(RAEXAM(0),"^",15)
84 .S RAPIRE=$P(RAEXAM(0),"^",12)
85 .S RARDE=$P(RARPT(0),"^",8)
86 .S ^TMP($J,"RAE2",RADFN,Y,RAPROC,"P")=RAPIST_"^"_RAPIRE_"^"_RARDE
87 ;If contrast media was involved in the exam pass that information.
88 I +$O(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"CM",0)) S (RACNT,RAI)=0 D
89 .F S RAI=$O(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"CM",RAI)) Q:'RAI D
90 ..S RACNT=RACNT+1
91 ..S RAI(0)=$G(^RADPT(RADFN,"DT",RAINVXDT,"P",Y,"CM",RAI,0))
92 ..S ^TMP($J,"RAE2",RADFN,Y,RAPROC,"CM",RACNT)=$P(RAI(0),U)_"^"_$$EXTERNAL^DILFD(70.3225,.01,"",$P(RAI(0),U))
93 ..Q
94 Q
95 ;
96RPTXT(RARPT,Z) ; Retrieve report text & store in ^TMP
97 ; 'RARPT' -> Report IEN
98 ; 'Z' -> "I":Impression Text <> "R":Report Text
99 S (Z1,Z2)=0
100 ;file 74's "H" nodes are now additional clinical history
101 I Z="H" S Z2=$O(^TMP($J,"RAE2",RADFN,Y,RAPROC,Z,""),-1) I $O(^RARPT(RARPT,Z,Z1)) S Z2=Z2+1,^TMP($J,"RAE2",RADFN,Y,RAPROC,Z,Z2)="Additional Clinical History:"
102 F S Z1=$O(^RARPT(RARPT,Z,Z1)) Q:Z1'>0 D
103 . S Z1(0)=$G(^RARPT(RARPT,Z,Z1,0)),Z2=Z2+1
104 . S ^TMP($J,"RAE2",RADFN,Y,RAPROC,Z,Z2)=Z1(0)
105 . Q
106 Q
107 ;
108CLIN(DFN,PROCLIST) ;Radiology and Clinical Reminders API
109 ;
110 ; Created by Cameron Taylor March 1999
111 ;
112 ; This API recieves a patient and a list of procedures. For each
113 ; Procedure, the details of the last 'complete' procedure and/or the
114 ; last 'cancelled' & 'in progress' procedure details and returns them
115 ; in ^TMP($J,"RADPROC"
116 N XX,PROC,DATE,STATUS,PROVIDER,EXAM,X,Y,EXAMIEN,RADPTIEN,ORDER,SUCCESS
117 ;
118 S DFN=$G(DFN) ; Patient Name
119 S PROCLIST=$G(PROCLIST) ; List of Procedures (separated by '^')
120 K ^TMP($J,"RADPROC")
121 ;
122 S RADPTIEN=$O(^RADPT("B",DFN,""))
123 I (RADPTIEN="")!(RADPTIEN=0) D Q
124 .S ^TMP($J,"RADPROC")="Invalid/Unknown Radiology Patient"
125 ;
126 F XX=1:1 S PROC=$P(PROCLIST,U,XX) Q:PROC="" D
127 .S SUCCESS=0 ; Quit searching if SUCCESS=3 (comp, canc & in prog)
128 .S DATE=0 F S DATE=$O(^RADPT(RADPTIEN,"DT",DATE)) Q:DATE'?7N1".".N!(SUCCESS=3) D
129 ..S EXAMIEN=0 F S EXAMIEN=$O(^RADPT(RADPTIEN,"DT",DATE,"P",EXAMIEN)) Q:'EXAMIEN!(SUCCESS=3) D
130 ...S EXAM=$G(^RADPT(RADPTIEN,"DT",DATE,"P",EXAMIEN,0))
131 ...Q:$P(EXAM,U,2)'=PROC
132 ...;
133 ...; Continue, get STATUS and ORDER
134 ...; (0 is cancelled, 1-8 in progress & 9 is COMPLETE)
135 ...; (ignore if null)
136 ...;
137 ...S STATUS=$P(EXAM,U,3)
138 ...I STATUS'="" D
139 ....S ORDER=$P(^RA(72,STATUS,0),U,3)
140 ....S STATUS=$P(^RA(72,STATUS,0),U) ; description
141 ...;
142 ...; Only one of each type (ORDER)
143 ...;
144 ...Q:ORDER=""
145 ...I ORDER=0 Q:$D(^TMP($J,"RADPROC",RADPTIEN,PROC,"CANCELLED")) S ORDER="CANCELLED"
146 ...I ORDER=9 Q:$D(^TMP($J,"RADPROC",RADPTIEN,PROC,"COMPLETE")) S ORDER="COMPLETE"
147 ...I ORDER<9,ORDER>0 Q:$D(^TMP($J,"RADPROC",RADPTIEN,PROC,"IN PROGRESS")) S ORDER="IN PROGRESS"
148 ...;
149 ...; Now for the PROVIDER. Check PRIMARY INTERPRETING STAFF
150 ...; if none, then default to PRIMARY INTERPRETING RESIDENT.
151 ...;
152 ...S PROVIDER=$P(EXAM,U,15)
153 ...S:PROVIDER="" PROVIDER=$P(EXAM,U,12)
154 ...S:PROVIDER'="" PROVIDER=$P($G(^VA(200,PROVIDER,0)),U,1) ; description
155 ...;
156 ...; Create return info. on ^TMP (1st manipulate DATE)
157 ...;
158 ...S Y=9999999.9999-DATE
159 ...S ^TMP($J,"RADPROC",RADPTIEN,PROC,ORDER)=Y_U_STATUS_U_PROVIDER
160 ...S SUCCESS=SUCCESS+1
161 .;
162 .; Finished searching Patient file. Any Procedures with no activity?
163 .;
164 .I '$D(^TMP($J,"RADPROC",RADPTIEN,PROC)) S ^TMP($J,"RADPROC",RADPTIEN,PROC,"NONE")=""
165 Q
166 ;
Note: See TracBrowser for help on using the repository browser.