source: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXSURG.m@ 636

Last change on this file since 636 was 636, checked in by George Lilly, 14 years ago

WorldVistAEHR overlayed on FOIAVistA

File size: 9.5 KB
Line 
1ECXSURG ;ALB/JA,BIR/DMA,PTD-Surgery Extract for DSS ; 11/2/06 9:00am
2 ;;3.0;DSS EXTRACTS;**1,11,8,13,25,24,33,39,41,42,46,50,71,84,92,99**;Dec 22, 1997;Build 2
3BEG ;entry point from option
4 D SETUP I ECFILE="" Q
5 D ^ECXTRAC,^ECXKILL
6 Q
7 ;
8START ;
9 S QFLG=0,ECED=ECED+.3,ECD=ECSD1
10 F S ECD=$O(^SRF("AC",ECD)),ECD0=0 Q:('ECD)!(ECD>ECED)!(QFLG) D
11 .F S ECD0=$O(^SRF("AC",ECD,ECD0)) Q:'ECD0 D
12 ..I $D(^SRF(ECD0,0)) S EC=^SRF(ECD0,0),ECXDFN=+$P(EC,U),ECXVISIT=$P(EC,U,15) D STUFF Q:QFLG
13 Q
14 ;
15STUFF ;gather data
16 N J,X,Y,PP,DATA1,DATA2,DATAOP,ARR,ERR,SUB,MOD,ECXNONL,ECXSTOP,TIMEDIF
17 N ECPRO,ECXORCT,ECXPTHA,ECXNPRFI,ECXPA,ECXPAPC,ECSRPC,ECATPC,ECSAPC
18 S ECXDATE=ECD,ECXERR=0,ECXQ=""
19 Q:'$$PATDEM^ECXUTL2(ECXDFN,ECXDATE,"1;2;3;5;")
20 I ECXADMDT="" S ECXADD=ECXADMDT
21 I ECXADMDT'="" S ECXADD=$$ECXDATE^ECXUTL(ECXADMDT,ECXYM)
22 S EC0=^SRF(ECD0,0)
23 S DATA1=$S($D(^SRF(ECD0,.1)):^(.1),1:"")
24 S DATA2=$S($D(^SRF(ECD0,.2)):^(.2),1:"")
25 ;S DATAOP=$S($D(^SRF(ECD0,"OP")):^("OP"),1:"")
26 S DATAOP=$S($D(^SRO(136,ECD0,0)):^(0),1:"")
27 S ECNO=$G(^SRF(ECD0,"NON"))
28 ;get data
29 S ECSR=$P(DATA1,U,4),(ECATNPI,ECSANPI,ECSRNPI)="",ECAT=$P(DATA1,U,13)
30 ;-Time patient in OR room (Nurse Time)
31 S ECXTM=$$ECXTIME^ECXUTL($P(DATA2,U,10))
32 S ECXDIV=$S($D(^SRF(ECD0,8)):^(8),1:ECINST)
33 N ECXPDIV S ECXPDIV=$$RADDIV^ECXDEPT(ECXDIV) ;Production Division
34 S ECSA=$P($G(^SRF(ECD0,.3)),U,4),ECO=$P(EC0,U,2)
35 ;get principle anesthetist and person class DBIA #103
36 S ECXPA=$P($G(^SRF(ECD0,.3)),U,1)
37 S ECXPAPC=$$PRVCLASS^ECXUTL(ECXPA,ECXDATE)
38 S ECORTY=$P($G(^SRS(+ECO,2)),U),ECO=$P($G(^SRS(+ECO,0)),U)
39 S ECSS=$P($G(^SRO(137.45,+$P(EC0,U,4),0)),U,2)
40 S ECSS=$$RJ^XLFSTR($P($G(^DIC(45.3,+ECSS,0)),U),3,0)
41 S:ECSS="000" ECSS="999"
42 ;get classification information
43 S (ECXAO,ECXHNC)="" I ECXVISIT'="" D
44 .D VISIT^ECXSCX1(ECXDFN,ECXVISIT,.ECXVIST,.ECXERR) I ECXERR K ECXERR
45 .S ECXAO=$G(ECXVIST("AO")),ECXHNC=$G(ECXVIST("HNC"))
46 ; - Head and Neck Cancer Indicator
47 S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN)
48 ;look for non-OR
49 S (ECNT,ECNL,ECXDSSD,ECXNONL,ECXSTOP)=""
50 I $P(ECNO,U)="Y" D
51 .S ECSR=$P(ECNO,U,6),ECAT=$P(ECNO,U,7)
52 .S ECXTM=$$ECXTIME^ECXUTL($P(ECNO,U,4))
53 .S A1=$P(ECNO,U,5),A2=$P(ECNO,U,4),TIME="##" D:(A1&A2) TIME S ECNT=TIME
54 .S (ECXNONL,ECNL)=+$P(ECNO,U,2),ECNL=$P($G(^ECX(728.44,ECNL,0)),U,9)
55 .S:ECNL="" ECNL="UNKNOWN"
56 .;
57 .;- Get DSS Stop Code to use in encounter number
58 .S ECXSTOP=$P($G(^ECX(728.44,ECXNONL,0)),U,4)
59 ;
60 ;- If surgery cancelled/aborted quit and go to next record
61 S ECCAN=$P($G(^SRF(ECD0,30)),U)
62 I +ECCAN S ECCAN=$$CANC^ECXUTL4(ECNL,$P(DATA2,U,10))
63 ;on hold for ECXDSSD and ECXDSSP I $P($G(^SRF(ECD0,30)),U) Q
64 ;get service of attending surgeon
65 S ECATSV=$P($G(^DIC(49,+$G(^VA(200,+ECAT,5)),730)),U)
66 ;
67 ;get surgeon, attending and anesthesia super person classes
68 S ECSRPC=$$PRVCLASS^ECXUTL(ECSR,ECXDATE)
69 S ECATPC=$$PRVCLASS^ECXUTL(ECAT,ECXDATE)
70 S ECSAPC=$$PRVCLASS^ECXUTL(ECSA,ECXDATE)
71 ;
72 ;add leading 2s for pointer to 200
73 S:ECAT ECAT="2"_ECAT S:ECSR ECSR="2"_ECSR S:ECSA ECSA="2"_ECSA
74 ;add leading 2 to principle anesthetist IEN
75 S:ECXPA ECXPA="2"_ECXPA
76 ;anesthesia technique
77 S ECANE="",PP=""
78 I $D(^SRF(ECD0,6,0)) S ECXJ=0 D
79 .F S ECXJ=$O(^SRF(ECD0,6,ECXJ)) Q:('ECXJ)!(ECANE]"") D
80 ..S PP=$P($G(^(ECXJ,0)),U,3) S:PP="Y" ECANE=$P(^(0),U,1)
81 .I ECANE="" S ECXJ=$O(^SRF(ECD0,6,0)) I ECXJ S ECANE=$P(^SRF(ECD0,6,ECXJ,0),U,1)
82 ;get primary procedure
83 ;ecode0=p^cpt code^^patient time^operation time^anesthesia time
84 S ECPT=+$P(DATAOP,U,2),ECXCMOD=""
85 K ARR,ERR D FIELD^DID(130,28,,"LABEL","ARR","ERR") I $D(ARR("LABEL")) D
86 .K ARR,ERR D FIELD^DID(130,28,,"GLOBAL SUBSCRIPT LOCATION","ARR","ERR")
87 .Q:$D(ERR("DIERR"))
88 .S SUB=$P(ARR("GLOBAL SUBSCRIPT LOCATION"),";"),MOD=0
89 .F S MOD=$O(^SRF(ECD0,SUB,MOD)) Q:MOD'>0 D
90 ..S ECXCMOD=ECXCMOD_$P(^(MOD,0),U)_";"
91 S ECXCPT=$$CPT^ECXUTL3(ECPT,ECXCMOD)
92 S ECODE0="P"_U_U ;ECPT_U
93 F J="10,12","2,3","1,4" D
94 .N ECNTIME,ECSTIME,ECATIME
95 .S A2=$P(DATA2,U,$P(J,",")),A1=$P(DATA2,U,$P(J,",",2)),TIME="##"
96 .I (A1&A2)&(+J=10) D TIME S ECNTIME=TIME
97 .I (A1&A2)&(+J=1) D TIME S ECATIME=TIME
98 .I (A1&A2)&(+J=2) D
99 ..;
100 ..;-Operation Time (Surgeon Time)
101 ..;-Get time diff (in secs) & set to .5 if < 7.5 minutes (rounds to 1)
102 ..S TIMEDIF=$$FMDIFF^XLFDT(A1,A2,2)/900
103 ..S TIMEDIF=$S(TIMEDIF>0&(TIMEDIF<.5):.5,1:TIMEDIF)
104 ..S TIME=$TR($J(TIMEDIF,4,0)," ")
105 ..S:TIME<0 TIME="###"
106 ..S:TIME ECSTIME=TIME
107 .S ECODE0=ECODE0_U_TIME K TIME
108 ; -Recovery Room Time
109 S ECRR=""
110 I $D(^SRF(ECD0,1.1)) D
111 .S A1=$P(^(1.1),U,8),A2=$P(^(1.1),U,7),TIME="##" D:(A1&A2) TIME
112 .S ECRR=TIME K TIME
113 I ECNL]"" S $P(ECODE0,U,5)=ECNT
114 ;
115 ; -OR Clean Time in 15 min increments DBIA #103
116 S ECXORCT=($$FMDIFF^XLFDT($P($G(DATA2),U,14),$P($G(DATA2),U,13),2)/60)/15
117 ; -If no OR clean time recorded set it to 2
118 I ECXORCT'>0 S ECXORCT=2
119 ;
120 ; -PT in hold area time in 15 min increments DBIA #103
121 I $P($G(DATA2),U,10),$P($G(DATA2),U,15) D
122 .S ECXPTHA=($$FMDIFF^XLFDT($P($G(DATA2),U,10),$P($G(DATA2),U,15),2)/60)/15
123 .S CON=$P($G(^SRF(ECD0,"CON")),U)
124 .I CON S ECXPTHA=ECXPTHA/2
125 .S ECXPTHA=$TR($J(ECXPTHA,3,0)," ")
126 ; -If hold time is =<0 set it to ""
127 S:$G(ECXPTHA)'>0 ECXPTHA=""
128 ;
129 ;- Observation Patient Indicator (yes/no)
130 S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECNL)
131 ;
132 ;- set national patient record flag if exist
133 D NPRF^ECXUTL5
134 ;
135 ;- If no encounter number don't file record
136 S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXSTOP,ECSS) Q:ECXENC=""
137 ;
138 D FILE
139 ;get secondary procedures
140 ;ecode0=s^cpt code
141 S ECXJ=0
142 ;F S ECXJ=$O(^SRF(ECD0,13,ECXJ)) Q:'ECXJ I $D(^(ECXJ,0)),$D(^(2)),$P(^(2),U)]"" D
143 F S ECXJ=$O(^SRO(136,ECD0,3,ECXJ)) Q:'ECXJ I $D(^(ECXJ,0)),$D(^(0)),$P(^(0),"^")]"" D
144 .;S ECPT=$P(^SRF(ECD0,13,ECXJ,2),U),ECXCMOD=""
145 . S ECPT=$P(^SRO(136,ECD0,3,ECXJ,0),"^"),ECXCMOD=""
146 .K ARR,ERR
147 .D FIELD^DID(130.16,4,,"LABEL","ARR","ERR") I $D(ARR("LABEL")) D
148 ..K ARR,ERR
149 ..D FIELD^DID(130.16,4,,"GLOBAL SUBSCRIPT LOCATION","ARR","ERR")
150 ..Q:$D(ERR("DIERR"))
151 ..S SUB=$P(ARR("GLOBAL SUBSCRIPT LOCATION"),";"),MOD=0
152 ..F S MOD=$O(^SRF(ECD0,13,ECXJ,SUB,MOD)) Q:MOD'>0 S ECXCMOD=ECXCMOD_$P(^(MOD,0),U)_";"
153 .S ECXCPT=$$CPT^ECXUTL3(ECPT,ECXCMOD)
154 .S ECODE0="S"_U ;_ECPT
155 .D FILE
156 ;get prostheses
157 ;ecode0=i^^^^^^prosthesis^old qty field (null)
158 S ECXJ=0
159 F S ECXJ=$O(^SRF(ECD0,1,ECXJ)) Q:'ECXJ I $D(^(ECXJ,0)) D
160 .S ECXP=+^SRF(ECD0,1,ECXJ,0),ECXQ=$P($G(^(1)),U,2) S:'ECXQ ECXQ=1
161 .S ECODE0="I"_U_U_U_U_U_U_ECXP_U_U
162 .D FILE
163 Q
164 ;
165FILE ;file record
166 ;node0
167 ;division^dfn^ssn^name^in/out (ECXA)^day^case #^
168 ;surg specialty^or room #^
169 ;surgeon^attending^anesthesia supervisor^anesthesia technique^
170 ;primary/secondary/prostheses^cpt^^pt time^op time^anes time^
171 ;prostheses^qty^^
172 ;movement number^treating specialty^cancel/abort (ECCAN)^time^or type^
173 ;attending's service^non-or dss id^recovery room time^^
174 ;primary care team^primary care provider^admission date
175 ;node1
176 ;mpi^dss dept ECXDSSD^surgeon npi^attending npi^anes supervisor npi^
177 ;pc provider npi^pc prov person class^
178 ;assoc pc provider^assoc pc prov person class^assoc pc prov npi^
179 ;cpt&modifiers ECXCPT^dom ECXDOM^enrollment category ECXCAT^
180 ;enrollment status ECXSTAT^enrollment priority ECXPRIOR^
181 ;period of service ECXPOS^purple heart indicator ECXPHI^
182 ;observ pat ind ECXOBS^encounter num ECXENC^ao loc ECXAOL^
183 ;production division ECXPDIV^head & neck canc ind ECXHNCI^
184 ;ethnicity ECXETH^race1 ECXRC1^new quantity ECXQ^
185 ;^user enrollee ECXUESTA^patient type ECXPTYPE^combat vet elig
186 ;ECXCVE^combat vet elig end date ECXCVEDT^enc cv eligible ECXCVENC
187 ;or clean time ECXORCT^time pt in hold area ECXPTHA^national patient
188 ;record flag ECXNPRFI^princ anesthetist ECXPA^surgeon per class ECSRPC
189 ;node2
190 ;atten surgeon per class ECATPC^anesthesia super person class ECSAPC^
191 ;princ anesthetist PC ECXPAPC^emergency response indicator(FEMA) ECXERI^
192 ;agent orange indic ECXAO^head/neck cancer ECXHNC
193 ;
194 N DA,DIK,STR
195 S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
196 S ECODE=EC7_U_EC23_U_ECXDIV_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U
197 S ECODE=ECODE_$$ECXDATE^ECXUTL(ECXDATE,ECXYM)_U_ECD0_U_ECSS_U_ECO_U
198 S ECODE=ECODE_ECSR_U_ECAT_U_ECSA_U_ECANE_U_ECODE0_U
199 S STR=ECXMN_U_ECXTS_U_$S(ECCAN'="":ECCAN,1:"")_U_ECXTM_U_ECORTY_U
200 S STR=STR_ECATSV_U_ECNL_U_ECRR_U_U_ECPTTM_U_ECPTPR_U_ECXADD_U
201 S $P(ECODE,U,26,38)=STR
202 S ECODE1=ECXMPI_U_ECXDSSD_U_ECSRNPI_U_ECATNPI_U_ECSANPI_U_ECPTNPI_U
203 S ECODE1=ECODE1_ECCLAS_U_ECASPR_U_ECCLAS2_U_ECASNPI_U_ECXCPT_U_ECXDOM_U
204 S ECODE1=ECODE1_ECXCAT_U_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXPOS_U_ECXPHI_U
205 S ECODE1=ECODE1_ECXOBS_U_ECXENC_U_ECXAOL_U_ECXPDIV_U_ECXHNCI_U
206 S ECODE1=ECODE1_ECXETH_U_ECXRC1_U_ECXQ_U
207 I ECXLOGIC>2004 S ECODE1=ECODE1_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXORCT_U_ECXPTHA_U_ECXNPRFI
208 I ECXLOGIC>2005 S ECODE1=ECODE1_U_ECXPA_U_ECSRPC_U,ECODE2=ECATPC_U_ECSAPC_U_ECXPAPC
209 I ECXLOGIC>2006 S ECODE2=ECODE2_U_ECXERI_U_ECXAO_U_ECXHNC
210 S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,^ECX(ECFILE,EC7,2)=ECODE2,ECRN=ECRN+1
211 S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
212 I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1
213 ;
214TIME ; given date/time get increment
215 ;A1=later, A2=earlier, TIME=difference
216 N CON,TIMEDIF
217 S CON=$P($G(^SRF(ECD0,"CON")),U)
218 ;
219 ;-Get time diff (in secs) & set to .5 if < 7.5 minutes (rounds to 1)
220 S TIMEDIF=$$FMDIFF^XLFDT(A1,A2,2)/900
221 S TIMEDIF=$S(TIMEDIF>0&(TIMEDIF<.5):.5,1:TIMEDIF)
222 I 'CON D
223 .S TIME=$J($TR($J(TIMEDIF,4,0)," "),2,1)
224 .S:TIME>"99.0" TIME="99.0"
225 I CON D
226 .S TIME=$J(($TR($J(TIMEDIF,4,0)," ")/2),2,1)
227 .S:TIME>"99.5" TIME="99.5"
228 S:TIME<0 TIME="###"
229 Q
230 ;
231SETUP ;Set required input for ECXTRAC
232 S ECHEAD="SUR"
233 D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
234 Q
235 ;
236QUE ; entry point for the background requeuing handled by ECXTAUTO
237 D SETUP,QUE^ECXTAUTO,^ECXKILL Q
Note: See TracBrowser for help on using the repository browser.