source: FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXSURG.m@ 979

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

initial load of FOIAVistA 6/30/08 version

File size: 7.8 KB
Line 
1ECXSURG ;ALB/JA,BIR/DMA,PTD-Surgery Extract for DSS ; 11/20/07 8:13am
2 ;;3.0;DSS EXTRACTS;**1,11,8,13,25,24,33,39,41,42,46,50,71,84,92,99,105**;Dec 22, 1997;Build 70
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 N ECXCRST,ECXSTCD,ECXCLIN
19 S ECXDATE=ECD,ECXERR=0,ECXQ=""
20 Q:'$$PATDEM^ECXUTL2(ECXDFN,ECXDATE,"1;2;3;5;")
21 I ECXADMDT="" S ECXADD=ECXADMDT
22 I ECXADMDT'="" S ECXADD=$$ECXDATE^ECXUTL(ECXADMDT,ECXYM)
23 S OK=$$PAT^ECXUTL3(ECXDFN,ECXDATE,"1;5",.ECXPAT)
24 I 'OK S ECXERR=1 K ECXPAT Q
25 ;OEF/OIF DATA
26 S ECXOEF=ECXPAT("ECXOEF")
27 S ECXOEFDT=ECXPAT("ECXOEFDT")
28 S EC0=^SRF(ECD0,0)
29 S DATA1=$S($D(^SRF(ECD0,.1)):^(.1),1:"")
30 S DATA2=$S($D(^SRF(ECD0,.2)):^(.2),1:"")
31 S DATAOP=$S($D(^SRO(136,ECD0,0)):^(0),1:"")
32 S ECNO=$G(^SRF(ECD0,"NON"))
33 ;get data
34 S ECSR=$P(DATA1,U,4),(ECATNPI,ECSANPI,ECSRNPI)="",ECAT=$P(DATA1,U,13)
35 S ECSRNPI=$$NPI^XUSNPI("Individual_ID",ECSR,ECXDATE)
36 S:+ECSRNPI'>0 ECSRNPI="" S ECSRNPI=$P(ECSRNPI,U)
37 ;-Time patient in OR room (Nurse Time)
38 S ECXTM=$$ECXTIME^ECXUTL($P(DATA2,U,10))
39 S ECXDIV=$S($D(^SRF(ECD0,8)):^(8),1:ECINST)
40 N ECXPDIV S ECXPDIV=$$RADDIV^ECXDEPT(ECXDIV) ;Production Division
41 S ECSA=$P($G(^SRF(ECD0,.3)),U,4),ECO=$P(EC0,U,2)
42 S ECSANPI=$$NPI^XUSNPI("Individual_ID",ECSA,ECXDATE)
43 S:+ECSANPI'>0 ECSANPI="" S ECSANPI=$P(ECSANPI,U)
44 ;get principle anesthetist and person class DBIA #103
45 S ECXPA=$P($G(^SRF(ECD0,.3)),U,1)
46 S ECPANPI=$$NPI^XUSNPI("Individual_ID",ECXPA,ECXDATE)
47 S:+ECPANPI'>0 ECPANPI="" S ECPANPI=$P(ECPANPI,U)
48 S ECXPAPC=$$PRVCLASS^ECXUTL(ECXPA,ECXDATE)
49 S ECORTY=$P($G(^SRS(+ECO,2)),U),ECO=$P($G(^SRS(+ECO,0)),U)
50 S ECSS=$P($G(^SRO(137.45,+$P(EC0,U,4),0)),U,2)
51 S ECSS=$$RJ^XLFSTR($P($G(^DIC(45.3,+ECSS,0)),U),3,0)
52 S:ECSS="000" ECSS="999"
53 ;get classification information
54 S (ECXAO,ECXHNC)="" I ECXVISIT'="" D
55 .D VISIT^ECXSCX1(ECXDFN,ECXVISIT,.ECXVIST,.ECXERR) I ECXERR K ECXERR
56 .S ECXAO=$G(ECXVIST("AO")),ECXHNC=$G(ECXVIST("HNC"))
57 ; - Head and Neck Cancer Indicator
58 S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN)
59 ;look for non-OR
60 S (ECNT,ECNL,ECXDSSD,ECXNONL,ECXSTOP)=""
61 I $P(ECNO,U)="Y" D
62 .S ECSR=$P(ECNO,U,6),ECAT=$P(ECNO,U,7)
63 .S ECSRNPI=$$NPI^XUSNPI("Individual_ID",ECSR,ECXDATE)
64 .S:+ECSRNPI'>0 ECSRNPI="" S ECSRNPI=$P(ECSRNPI,U)
65 .S ECATNPI=$$NPI^XUSNPI("Individual_ID",ECAT,ECXDATE)
66 .S:+ECATNPI'>0 ECATNPI="" S ECATNPI=$P(ECATNPI,U)
67 .S ECXTM=$$ECXTIME^ECXUTL($P(ECNO,U,4))
68 .S A1=$P(ECNO,U,5),A2=$P(ECNO,U,4),TIME="##" D:(A1&A2) TIME S ECNT=TIME
69 .S (ECXNONL,ECNL)=+$P(ECNO,U,2),ECNL=$P($G(^ECX(728.44,ECNL,0)),U,9)
70 .S:ECNL="" ECNL="UNKNOWN"
71 .;
72 .;- Get DSS Stop Code to use in encounter number
73 .S ECXSTOP=$P($G(^ECX(728.44,ECXNONL,0)),U,4)
74 ;
75 ;- Get credit stop, stop code and clinic
76 I $$SUR^ECXUTL6(.ECXCRST,.ECXSTCD,.ECXCLIN)
77 ;
78 ;- If surgery cancelled/aborted quit and go to next record
79 S ECCAN=$P($G(^SRF(ECD0,30)),U)
80 I +ECCAN S ECCAN=$$CANC^ECXUTL4(ECNL,$P(DATA2,U,10))
81 ;on hold for ECXDSSD and ECXDSSP I $P($G(^SRF(ECD0,30)),U) Q
82 ;get service of attending surgeon
83 S ECATSV=$P($G(^DIC(49,+$G(^VA(200,+ECAT,5)),730)),U)
84 ;
85 ;get surgeon, attending and anesthesia super person classes
86 S ECSRPC=$$PRVCLASS^ECXUTL(ECSR,ECXDATE)
87 S ECATPC=$$PRVCLASS^ECXUTL(ECAT,ECXDATE)
88 S ECSAPC=$$PRVCLASS^ECXUTL(ECSA,ECXDATE)
89 ;
90 ;add leading 2s for pointer to 200
91 S:ECAT ECAT="2"_ECAT S:ECSR ECSR="2"_ECSR S:ECSA ECSA="2"_ECSA
92 ;add leading 2 to principle anesthetist IEN
93 S:ECXPA ECXPA="2"_ECXPA
94 ;anesthesia technique
95 S ECANE="",PP=""
96 I $D(^SRF(ECD0,6,0)) S ECXJ=0 D
97 .F S ECXJ=$O(^SRF(ECD0,6,ECXJ)) Q:('ECXJ)!(ECANE]"") D
98 ..S PP=$P($G(^(ECXJ,0)),U,3) S:PP="Y" ECANE=$P(^(0),U,1)
99 .I ECANE="" S ECXJ=$O(^SRF(ECD0,6,0)) I ECXJ S ECANE=$P(^SRF(ECD0,6,ECXJ,0),U,1)
100 ;get primary procedure
101 ;ecode0=p^cpt code^^patient time^operation time^anesthesia time
102 S ECPT=+$P(DATAOP,U,2),ECXCMOD=""
103 K ARR,ERR D FIELD^DID(130,28,,"LABEL","ARR","ERR") I $D(ARR("LABEL")) D
104 .K ARR,ERR D FIELD^DID(130,28,,"GLOBAL SUBSCRIPT LOCATION","ARR","ERR")
105 .Q:$D(ERR("DIERR"))
106 .S SUB=$P(ARR("GLOBAL SUBSCRIPT LOCATION"),";"),MOD=0
107 .F S MOD=$O(^SRF(ECD0,SUB,MOD)) Q:MOD'>0 D
108 ..S ECXCMOD=ECXCMOD_$P(^(MOD,0),U)_";"
109 S ECXCPT=$$CPT^ECXUTL3(ECPT,ECXCMOD)
110 S ECODE0="P"_U_U ;ECPT_U
111 F J="10,12","2,3","1,4" D
112 .N ECNTIME,ECSTIME,ECATIME
113 .S A2=$P(DATA2,U,$P(J,",")),A1=$P(DATA2,U,$P(J,",",2)),TIME="##"
114 .I (A1&A2)&(+J=10) D TIME S ECNTIME=TIME
115 .I (A1&A2)&(+J=1) D TIME S ECATIME=TIME
116 .I (A1&A2)&(+J=2) D
117 ..;
118 ..;-Operation Time (Surgeon Time)
119 ..;-Get time diff (in secs) & set to .5 if < 7.5 minutes (rounds to 1)
120 ..S TIMEDIF=$$FMDIFF^XLFDT(A1,A2,2)/900
121 ..S TIMEDIF=$S(TIMEDIF>0&(TIMEDIF<.5):.5,1:TIMEDIF)
122 ..S TIME=$TR($J(TIMEDIF,4,0)," ")
123 ..S:TIME<0 TIME="###"
124 ..S:TIME ECSTIME=TIME
125 .S ECODE0=ECODE0_U_TIME K TIME
126 ; -Recovery Room Time
127 S ECRR=""
128 I $D(^SRF(ECD0,1.1)) D
129 .S A1=$P(^(1.1),U,8),A2=$P(^(1.1),U,7),TIME="##" D:(A1&A2) TIME
130 .S ECRR=TIME K TIME
131 I ECNL]"" S $P(ECODE0,U,5)=ECNT
132 ;
133 ; -OR Clean Time in 15 min increments DBIA #103
134 S ECXORCT=($$FMDIFF^XLFDT($P($G(DATA2),U,14),$P($G(DATA2),U,13),2)/60)/15
135 ; -If no OR clean time recorded set it to 2
136 I ECXORCT'>0 S ECXORCT=2
137 ;
138 ; -PT in hold area time in 15 min increments DBIA #103
139 I $P($G(DATA2),U,10),$P($G(DATA2),U,15) D
140 .S ECXPTHA=($$FMDIFF^XLFDT($P($G(DATA2),U,10),$P($G(DATA2),U,15),2)/60)/15
141 .S CON=$P($G(^SRF(ECD0,"CON")),U)
142 .I CON S ECXPTHA=ECXPTHA/2
143 .S ECXPTHA=$TR($J(ECXPTHA,3,0)," ")
144 ; -If hold time is =<0 set it to ""
145 S:$G(ECXPTHA)'>0 ECXPTHA=""
146 ;
147 ;- Observation Patient Indicator (yes/no)
148 S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECNL)
149 ;
150 ;- set national patient record flag if exist
151 D NPRF^ECXUTL5
152 ;
153 ;- If no encounter number don't file record
154 S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXSTOP,ECSS) Q:ECXENC=""
155 ;
156 ;- Get postop diagnosis codes
157 I $$SURPODX^ECXUTL6(.ECXPODX,.ECXPODX1,.ECXPODX2,.ECXPODX3,.ECXPODX4,.ECXPODX5)
158 ;
159 D FILE^ECXSURG1
160 ;get secondary procedures
161 ;ecode0=s^cpt code
162 S ECXJ=0
163 F S ECXJ=$O(^SRO(136,ECD0,3,ECXJ)) Q:'ECXJ I $D(^(ECXJ,0)),$D(^(0)),$P(^(0),"^")]"" D
164 .;S ECPT=$P(^SRF(ECD0,13,ECXJ,2),U),ECXCMOD=""
165 .S ECPT=$P(^SRO(136,ECD0,3,ECXJ,0),U),ECXMOD=""
166 .S ECPT=$P(^(0),"^"),ECXCMOD=""
167 .K ARR,ERR
168 .D FIELD^DID(130.16,4,,"LABEL","ARR","ERR") I $D(ARR("LABEL")) D
169 ..K ARR,ERR
170 ..D FIELD^DID(130.16,4,,"GLOBAL SUBSCRIPT LOCATION","ARR","ERR")
171 ..Q:$D(ERR("DIERR"))
172 ..S SUB=$P(ARR("GLOBAL SUBSCRIPT LOCATION"),";"),MOD=0
173 ..F S MOD=$O(^SRF(ECD0,13,ECXJ,SUB,MOD)) Q:MOD'>0 S ECXCMOD=ECXCMOD_$P(^(MOD,0),U)_";"
174 .S ECXCPT=$$CPT^ECXUTL3(ECPT,ECXCMOD)
175 .S ECODE0="S"_U ;_ECPT
176 .D FILE^ECXSURG1
177 ;get prostheses
178 ;ecode0=i^^^^^^prosthesis^old qty field (null)
179 S ECXJ=0
180 F S ECXJ=$O(^SRF(ECD0,1,ECXJ)) Q:'ECXJ I $D(^(ECXJ,0)) D
181 .S ECXP=+^SRF(ECD0,1,ECXJ,0),ECXQ=$P($G(^(1)),U,2) S:'ECXQ ECXQ=1
182 .S ECODE0="I"_U_U_U_U_U_U_ECXP_U_U
183 .D FILE^ECXSURG1
184 Q
185 ;
186 ;
187TIME ; given date/time get increment
188 ;A1=later, A2=earlier, TIME=difference
189 N CON,TIMEDIF
190 S CON=$P($G(^SRF(ECD0,"CON")),U)
191 ;
192 ;-Get time diff (in secs) & set to .5 if < 7.5 minutes (rounds to 1)
193 S TIMEDIF=$$FMDIFF^XLFDT(A1,A2,2)/900
194 S TIMEDIF=$S(TIMEDIF>0&(TIMEDIF<.5):.5,1:TIMEDIF)
195 I 'CON D
196 .S TIME=$J($TR($J(TIMEDIF,4,0)," "),2,1)
197 .S:TIME>"99.0" TIME="99.0"
198 I CON D
199 .S TIME=$J(($TR($J(TIMEDIF,4,0)," ")/2),2,1)
200 .S:TIME>"99.5" TIME="99.5"
201 S:TIME<0 TIME="###"
202 Q
203 ;
204SETUP ;Set required input for ECXTRAC
205 S ECHEAD="SUR"
206 D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
207 Q
208 ;
209QUE ; entry point for the background requeuing handled by ECXTAUTO
210 D SETUP,QUE^ECXTAUTO,^ECXKILL Q
Note: See TracBrowser for help on using the repository browser.