source: WorldVistAEHR/trunk/r/PCE_PATIENT_CARE_ENCOUNTER-AUTN-EFDP-PX-VSIT--PXRM/PXICLN9B.m@ 1006

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

initial load of WorldVistAEHR

File size: 8.6 KB
Line 
1PXICLN9B ;ISL/dee - Cleanup routine for PX*1.0*9 ;11/8/96
2 ;;1.0;PCE PATIENT CARE ENCOUNTER;**9**;Aug 12, 1996
3 ;
4CLEANUP ;
5 N PXICLN9 S PXICLN9=1 ;Flag that this job is running.
6 N PXIVSIT,PXIVDT,PXICPT,PXIFILE,PXIVFILE,PXIVIEN,PXICNT
7 N PXINODE,VSIT,PXINVSIT,PXITVSIT,PXIDEL
8 N PXITDUP,PXITCNT,PXITNODE
9 N PXISOR,PXIPKG,PXIHLOC,PXIOE
10 ;
11 ;Set up package and source for Rad and Lab
12 S PXISOR(1)=$$SOURCE^PXAPIUTL("RAD/NUC MED")
13 S PXISOR(2)=$$SOURCE^PXAPIUTL("LAB DATA")
14 S PXIPKG(1)=$$PKG2IEN^VSIT("RA")
15 S PXIPKG(2)=$$PKG2IEN^VSIT("LR")
16 S PXIPKG(0)="~"_PXIPKG(1)_"~"_PXIPKG(2)_"~"
17 ;
18 ;get clinic for lab data
19 S PXIHLOC(2)=+$G(^LAB(69.9,1,.8))
20 ;
21 I $D(^TMP("PXICLN9")) D
22 . ;save data from where tasked errored out
23 . K ^TMP("PXK",$J)
24 . M ^TMP("PXK",$J)=^TMP("PXICLN9")
25 . K ^TMP("PXICLN9")
26 . D EN1^PXKMAIN
27 . K ^TMP("PXK",$J)
28 . D EVENT^PXKMAIN
29 ;
30 ;Where to start?
31 S PXIVSIT=+$G(^PX(815,1,"PATCH"))
32 I PXIVSIT<1 D
33 . S PXIVSIT=$O(^AUPNVSIT("A"),-1)
34 . I PXIVSIT>0 S PXIVSIT=PXIVSIT+1
35 . E S PXIVSIT=0
36 . S $P(^PX(815,1,"PATCH"),"^",1)=PXIVSIT
37 ;
38 ;*R "Visit ien: ",PXIVSIT ;*
39 ;*D ;*
40 F S PXIVSIT=$O(^AUPNVSIT(PXIVSIT),-1) Q:'PXIVSIT D
41 . S PXICPT=$O(^AUPNVCPT("AD",PXIVSIT,0))
42 . S PXIPRV=$O(^AUPNVPRV("AD",PXIVSIT,0))
43 . I PXICPT S PXIPKG=$P($G(^AUPNVCPT(+PXICPT,812)),"^",2)
44 . E S PXIPKG=$P($G(^AUPNVPRV(+PXIPRV,812)),"^",2)
45 . ;
46 . ;Rad or Lab ?
47 . I (PXICPT!PXIPRV),PXIPKG(0)[("~"_PXIPKG_"~") D
48 .. K ^TMP("PXICLN9")
49 .. ;
50 .. ;Copy visit
51 .. S PXINODE=""
52 .. F S PXINODE=$O(^AUPNVSIT(PXIVSIT,PXINODE)) Q:PXINODE="" D
53 ... S ^TMP("PXICLN9","VST",1,PXINODE,"AFTER")=^AUPNVSIT(PXIVSIT,PXINODE)
54 ... S ^TMP("PXICLN9","VST",1,PXINODE,"BEFORE")=""
55 .. S ^TMP("PXICLN9","VST",1,"IEN")=""
56 .. ;Set sum stuff need by PXK
57 .. S $P(^TMP("PXICLN9","VST",1,150,"AFTER"),"^",3)="A"
58 .. S $P(^TMP("PXICLN9","VST",1,0,"AFTER"),"^",8)=""
59 .. S ^TMP("PXICLN9","PKG")=PXIPKG
60 .. ;
61 .. ;Rad?
62 .. I PXIPKG(1)=PXIPKG D
63 ... S ^TMP("PXICLN9","SOR")=PXISOR(1)
64 ... S $P(^TMP("PXICLN9","VST",1,812,"AFTER"),"^",3)=PXISOR(1)
65 ... S PXISOR=PXISOR(1)
66 ... S PXIHLOC=$P($$RADLOC($P(^TMP("PXICLN9","VST",1,0,"AFTER"),"^",5),$P(^TMP("PXICLN9","VST",1,0,"AFTER"),"^",1)),"^",2)
67 .. ;Lab?
68 .. E D
69 ... S ^TMP("PXICLN9","SOR")=PXISOR(2)
70 ... S $P(^TMP("PXICLN9","VST",1,812,"AFTER"),"^",3)=PXISOR(2)
71 ... S PXISOR=PXISOR(2)
72 ... S PXIHLOC=PXIHLOC(2)
73 .. ;
74 .. ;check if the hospital location was ok if it is see if visit needs
75 .. ;edit and quit
76 .. I PXIHLOC>0,$P(^TMP("PXICLN9","VST",1,0,"AFTER"),"^",22)=PXIHLOC D Q
77 ... K VSIT
78 ... I $P(^TMP("PXICLN9","VST",1,0,"AFTER"),"^",7)'="X" S VSIT("SVC")="X"
79 ... I $P(^TMP("PXICLN9","VST",1,150,"AFTER"),"^",3)'="A" S VSIT("PRI")="A"
80 ... I $P(^TMP("PXICLN9","VST",1,812,"AFTER"),"^",3)'=PXISOR S VSIT("SOR")=PXISOR
81 ... Q:'$D(VSIT)
82 ... S VSIT("IEN")=PXIVSIT
83 ... D UPD^VSIT
84 .. ;
85 .. S:PXIHLOC>0 $P(^TMP("PXICLN9","VST",1,0,"AFTER"),"^",22)=PXIHLOC
86 .. ;
87 .. ;Copy v-files pointing to visit
88 .. ; (do not care about the stop code visit will just delete them)
89 .. F PXIFILE="CPT","IMM","PED","POV","PRV","SK","TRT","HF","XAM" D
90 ... S PXIVFILE="^AUPNV"_PXIFILE
91 ... S PXIVIEN=0
92 ... F PXICNT=1:1 S PXIVIEN=$O(@PXIVFILE@("AD",PXIVSIT,PXIVIEN)) Q:'PXIVIEN D
93 .... ;
94 .... ;If this is Lab and is a even numbered duplicate CPT then do not save it
95 .... I PXIFILE="CPT",PXIPKG(2)=PXIPKG D Q:PXITDUP=1
96 ..... ;check set
97 ..... S PXITDUP=0
98 ..... S PXITCNT=""
99 ..... F S PXITCNT=$O(^TMP("PXICLN9","CPT",PXITCNT)) Q:'PXITCNT D Q:PXITDUP
100 ...... S PXITNODE=""
101 ...... F S PXITNODE=$O(^TMP("PXICLN9","CPT",PXITCNT,PXITNODE)) Q:PXITNODE'=+PXITNODE D Q:PXITDUP=-1
102 ....... I $P(^TMP("PXICLN9","CPT",PXITCNT,PXITNODE,"AFTER"),"^",1,15)=$P($G(^AUPNVCPT(PXIVIEN,PXITNODE)),"^",1,15) S PXITDUP=1
103 ....... E S PXITDUP=-1
104 ..... I PXITDUP=1 D
105 ...... S PXDUPCPT(PXITCNT)=$G(PXDUPCPT(PXITCNT))+1
106 ...... I '(PXDUPCPT(PXITCNT)#2) S $P(^TMP("PXICLN9","CPT",PXITCNT,0,"AFTER"),"^",16)=$P(^TMP("PXICLN9","CPT",PXITCNT,0,"AFTER"),"^",16)+$P($G(^AUPNVCPT(PXIVIEN,0)),"^",16)
107 .... ;
108 .... ;Copy a v-file entry
109 .... S PXINODE=""
110 .... F S PXINODE=$O(@PXIVFILE@(PXIVIEN,PXINODE)) Q:PXINODE="" D:PXINODE'=801
111 ..... S ^TMP("PXICLN9",PXIFILE,PXICNT,PXINODE,"AFTER")=@PXIVFILE@(PXIVIEN,PXINODE)
112 ..... S ^TMP("PXICLN9",PXIFILE,PXICNT,PXINODE,"BEFORE")=""
113 .... S ^TMP("PXICLN9",PXIFILE,PXICNT,"IEN")=""
114 .... ;
115 .... ;Now fix any fields
116 .... S:$P($G(^TMP("PXICLN9",PXIFILE,PXICNT,812,"AFTER")),"^",3)="" $P(^TMP("PXICLN9",PXIFILE,PXICNT,812,"AFTER"),"^",3)=PXISOR
117 .. ;
118 .. ;Process
119 .. ;
120 .. ;delete old data
121 .. S PXIDEL=$$DELVFILE^PXAPIDEL("ALL",PXIVSIT,"","","","","")
122 .. ;
123 .. ;save data
124 .. K ^TMP("PXK",$J)
125 .. M ^TMP("PXK",$J)=^TMP("PXICLN9")
126 .. K ^TMP("PXICLN9")
127 .. D EN1^PXKMAIN
128 .. S PXINVSIT=^TMP("PXK",$J,"VST",1,"IEN")
129 .. ;fix 801 nodes? no they are ok
130 .. D EVENT^PXKMAIN
131 .. ;
132 .. ;if the new visit is the same visit as the old visit then done
133 .. Q:PXIVSIT=PXINVSIT
134 .. ;
135 .. ;if there is a new visit then assume all worked
136 .. I PXINVSIT>0 D
137 ... ;
138 ... ;fix pointers from Rad and IB
139 ... N PXIRA,PXIIBT,PXIFDA,PXIDIERR
140 ... S (PXIRA(1),PXIIBT)=0
141 ... F S PXIRA(1)=$O(^RADPT("AVSIT",PXIVSIT,PXIRA(1))) Q:'PXIRA(1) D
142 .... S PXIRA(2)=0
143 .... F S PXIRA(2)=$O(^RADPT("AVSIT",PXIVSIT,PXIRA(1),PXIRA(2))) Q:'PXIRA(2) D
144 ..... S PXIRA(3)=0
145 ..... F S PXIRA(3)=$O(^RADPT("AVSIT",PXIVSIT,PXIRA(1),PXIRA(2),PXIRA(3))) Q:'PXIRA(3) D
146 ...... I PXIRA(1)>0,PXIRA(2)>0,PXIRA(3)>0 D
147 ....... S PXIRA=PXIRA(3)_","_PXIRA(2)_","_PXIRA(1)_","
148 ....... S PXIFDA(70.03,PXIRA,27)=PXINVSIT
149 ... F S PXIIBT=$O(^IBT(356,"AVSIT",PXIVSIT,PXIIBT)) Q:'PXIIBT D
150 .... I PXIIBT>0 D
151 ..... S PXIIBT=PXIIBT_","
152 ..... S PXIFDA(356,PXIIBT,.03)=PXINVSIT
153 ... I $D(PXIFDA) D FILE^DIE("","PXIFDA","PXIDIERR")
154 .. ;
155 .. ;if the visit was not deleted try again
156 .. I PXIDEL<1 D
157 ... ;make sure that there are no extra Outpatient Encounter entries
158 ... S PXIOE=0
159 ... F S PXIOE=$O(^SCE("AVSIT",PXIVSIT,PXIOE)) Q:'PXIOE D EN^SDCODEL(PXIOE,0)
160 ... S PXIDEL=$$KILL^VSITKIL(PXIVSIT)
161 ... I PXIDEL>0 D
162 .... ;change it to a stop visit
163 .... K VSIT
164 .... S VSIT("PRI")="S"
165 .... S VSIT("IEN")=PXIVSIT
166 .... D UPD^VSIT
167 .... ;there was some problem deleting this one save it
168 .... S ^XTMP("PXICLN9",$J,PXIVST)=PXIDEL
169 . ;
170 . ;Check the encounter type
171 . I $P($G(^AUPNVSIT(PXIVSIT,150)),"^",3)="O" D
172 .. Q:$D(^VSIT(150.1,"B",+$P($G(^DIC(40.7,+$P($G(^AUPNVSIT(PXIVSIT,0)),"^",8),0)),"^",2)))
173 .. ;If it is "O" and it should not be, change it to "P"
174 .. K VSIT
175 .. I $P($G(^AUPNVSIT(PXIVSIT,812)),"^",3)="" D
176 ... I PXICPT,$P($G(^AUPNVCPT(PXICPT,812)),"^",3)]"" S VSIT("SOR")=$P($G(^AUPNVCPT(PXICPT,812)),"^",3)
177 ... E I PXIPRV,$P($G(^AUPNVPRV(PXIPRV,812)),"^",3)]"" S VSIT("SOR")=$P($G(^AUPNVPRV(PXIPRV,812)),"^",3)
178 .. S VSIT("PRI")="P"
179 .. S VSIT("SVC")="A"
180 .. I +$$IP^VSITCK1(+$G(^AUPNVSIT(PXIVSIT,0)),$P($G(^AUPNVSIT(PXIVSIT,0)),"^",5)) S VSIT("SVC")="I"
181 .. S VSIT("IEN")=PXIVSIT
182 .. D UPD^VSIT
183 . ;
184 . E I $P($G(^AUPNVSIT(PXIVSIT,150)),"^",3)="P" D
185 .. Q:'$D(^VSIT(150.1,"B",+$P($G(^DIC(40.7,+$P($G(^AUPNVSIT(PXIVSIT,0)),"^",8),0)),"^",2)))
186 .. ;If it is "P" and it should not be, change it to "O"
187 .. K VSIT
188 .. I $P($G(^AUPNVSIT(PXIVSIT,812)),"^",3)="" D
189 ... I PXICPT,$P($G(^AUPNVCPT(PXICPT,812)),"^",3)]"" S VSIT("SOR")=$P($G(^AUPNVCPT(PXICPT,812)),"^",3)
190 ... E I PXIPRV,$P($G(^AUPNVPRV(PXIPRV,812)),"^",3)]"" S VSIT("SOR")=$P($G(^AUPNVPRV(PXIPRV,812)),"^",3)
191 .. S VSIT("PRI")="O"
192 .. S VSIT("SVC")="X"
193 .. I +$$IP^VSITCK1(+$G(^AUPNVSIT(PXIVSIT,0)),$P($G(^AUPNVSIT(PXIVSIT,0)),"^",5)) S VSIT("SVC")="D"
194 .. S VSIT("IEN")=PXIVSIT
195 .. D UPD^VSIT
196 . S $P(^PX(815,1,"PATCH"),"^",1)=PXIVSIT
197 K ^TMP("PXICLN9"),^TMP("PXK",$J)
198 Q
199 ;
200RADNUC ;CAH/HIRMFO;for PCE data clean-up ;10/7/96 09:42
201 ;
202RADLOC(DFN,PXRADT) ;Returns Hosp Loc of Rad/Nuc Med exam
203 ;Input:
204 ; DFN = Patient file #2 internal entry number
205 ; PXRADT = Rad exam dt/time in internal FileMan format
206 ; Sample input: (6552,2961015.0915)
207 ;Output:
208 ; If successful -
209 ; Imaging Loc name ^ pointer to file 44
210 ; Sample output: X-RAY AREA B^35
211 ;
212 ; If unsuccessful (exam or Imaging loc missing, or file 44
213 ; entry deleted, or patient does not exist in Rad/NM Patient
214 ; file #70) - 0
215 ;
216 N X,PXRA0,PXRADTI,PXRALOC,PXRALOC1,PXRALOC2
217 I 'DFN Q 0
218 I 'PXRADT Q 0
219 I '$D(^RADPT(DFN)) Q 0 ;patient doesn't exist in file #70
220 S PXRADTI=9999999.9999-PXRADT ;Convert exam dt/t to subfile ien
221 S PXRA0=$G(^RADPT(DFN,"DT",PXRADTI,0)) I '$L(PXRA0) Q 0 ;if no such rad/nuc med visit, fail
222 S PXRALOC=$P(PXRA0,"^",4) I 'PXRALOC Q 0 ;if no imaging loc, fail
223 S PXRALOC1=$P(^RA(79.1,+PXRALOC,0),"^",1) I 'PXRALOC1 Q 0 ;if dangling pointer - file 44 entry deleted? fail
224 I '$D(^SC(PXRALOC1)) Q 0 ;File 44 entry deleted? fail
225 S PXRALOC2=$P($G(^SC(PXRALOC1,0)),"^",1)
226 Q PXRALOC2_"^"_PXRALOC1
227 ;
Note: See TracBrowser for help on using the repository browser.