source: FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXNURS.m@ 1608

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

initial load of FOIAVistA 6/30/08 version
File size: 6.7 KB
Line 
1ECXNURS ;ALB/JAP,BIR/DMA,PTD-Nursing Extract for DSS ;4/19/2007
2 ;;3.0;DSS EXTRACTS;**8,14,22,24,33,39,46,71,107**;Dec 22, 1997;Build 9
3BEG ;entry point from option
4 D SETUP I ECFILE="" Q
5 D ^ECXTRAC,^ECXKILL
6 Q
7 ;
8START ;entry when queued
9 ;store in ^tmp by patient and date/time
10 N CNT,INP,FIRSTDAY,LASTDAY
11 S QFLG=0,CNT=0
12 K ^TMP("ECX",$J)
13 S FIRSTDAY=$P(ECSD1,".")+1,LASTDAY=$P(ECED,".")
14 S ECED=ECED+.3,ECD=ECSD1
15 F S ECD=$O(^NURSA(214.6,"B",ECD)),ECDA=0 Q:'ECD Q:ECD>ECED D Q:QFLG
16 .F S ECDA=$O(^NURSA(214.6,"B",ECD,ECDA)) Q:'ECDA D Q:QFLG
17 ..K LOC S DIC=214.6,DIQ(0)="I",DA=ECDA,DIQ="LOC",DR=".01;.02;1;3;4;6;7;8"
18 ..D EN^DIQ1 K DIQ,DIC,DA,DR
19 ..F J=.01,.02,1,3,4,6,7,8 S EC(J)=LOC(214.6,ECDA,J,"I")
20 ..Q:EC(8)'=""
21 ..S INP=$$INP^ECXUTL2(EC(.02),EC(.01))
22 ..;
23 ..;- Don't create ^TMP record if outpatient and no treat spec
24 ..Q:$P(INP,U)="O"&($P(INP,U,3)="")
25 ..; retain latest classification per day per patient
26 ..S ^TMP("ECX",$J,EC(.02),$P(EC(.01),"."))=EC(1)_U_EC(3)_U_EC(4)_U_EC(6)_U_EC(7)_U_$P(INP,U,1,6)_U_EC(.01)_U_$P(INP,U,10)
27 ..K LOC(214.6,ECDA),EC,INP
28 ..S CNT=CNT+1
29 ..I $D(ZTQUEUED),(CNT>499),'(CNT#500),$$S^%ZTLOAD S QFLG=1
30 I QFLG K ^TMP("ECX",$J) Q
31 D RESOLVE
32 D FILE
33 K ^TMP("ECX",$J)
34 ;
35RESOLVE ;process ^tmp by patient
36 N DFN,TM,ECD,ECDPREV,ECDNEW,OLDWARD,NEWWARD,NEWDT
37 S DFN=0
38 F S DFN=$O(^TMP("ECX",$J,DFN)) S ECD=0 Q:'DFN D
39 .;remove any classifications for day of discharge
40 .F S ECD=$O(^TMP("ECX",$J,DFN,ECD)) Q:'ECD D
41 ..I ECD=$P($P(^TMP("ECX",$J,DFN,ECD),U,11),".") K ^TMP("ECX",$J,DFN,ECD)
42 .;proceed only if ^tmp remains
43 .Q:'$D(^TMP("ECX",$J,DFN))
44 .;proceed with fill-in only if processing more than 3 days' data
45 .Q:LASTDAY<(FIRSTDAY+2)
46 .;fill-in records for any missing days per inpatient episode
47 .K TM S ECD=0
48 .F S ECD=$O(^TMP("ECX",$J,DFN,ECD)) Q:'ECD D
49 ..S TM(ECD)=$P(^TMP("ECX",$J,DFN,ECD),U,9)
50 .S (ECD,ECDPREV)=0
51 .F S ECD=$O(TM(ECD)) Q:'ECD D
52 ..I ECDPREV=0 S ECDPREV=ECD Q
53 ..I (ECD-ECDPREV)>1,+TM(ECD)=+TM(ECDPREV) D
54 ...F ECDNEW=ECDPREV+1:1:ECD-1 S ^TMP("ECX",$J,DFN,ECDNEW)=^TMP("ECX",$J,DFN,ECDPREV) D
55 ....S NEWWARD="",OLDWARD=$P(^TMP("ECX",$J,DFN,ECDPREV),U,10)
56 ....D NEWWARD(ECDNEW,OLDWARD,.NEWWARD)
57 ....Q:'NEWWARD
58 ....S $P(^TMP("ECX",$J,DFN,ECDNEW),U,4)=$P(NEWWARD,U,1)
59 ....S $P(^TMP("ECX",$J,DFN,ECDNEW),U,5)=$P(NEWWARD,U,2)
60 ..S ECDPREV=ECD
61 .;fill-in to end of extract date range
62 .K TM S ECD=0
63 .F S ECD=$O(^TMP("ECX",$J,DFN,ECD)) Q:'ECD D
64 ..S TM(ECD)=$P(^TMP("ECX",$J,DFN,ECD),U,11)
65 .S ECD=$O(TM(""),-1),DCDT=+TM(ECD)
66 .;if last day in date range is after last classification date
67 .I LASTDAY>ECD D
68 ..;if there is no d/c date
69 ..I DCDT=0 F ECDNEW=ECD+1:1:LASTDAY D Q
70 ...I '$D(^TMP("ECX",$J,DFN,ECDNEW)) S ^TMP("ECX",$J,DFN,ECDNEW)=^TMP("ECX",$J,DFN,ECD)
71 ...S NEWWARD="",OLDWARD=$P(^TMP("ECX",$J,DFN,ECD),U,10)
72 ...D NEWWARD(ECDNEW,OLDWARD,.NEWWARD)
73 ...Q:'NEWWARD
74 ...S $P(^TMP("ECX",$J,DFN,ECDNEW),U,4)=$P(NEWWARD,U,1)
75 ...S $P(^TMP("ECX",$J,DFN,ECDNEW),U,5)=$P(NEWWARD,U,2)
76 ..;if d/c date is after last classification date
77 ..I $P(DCDT,".")>ECD S NEWDT=$S($P(DCDT,".")>LASTDAY:LASTDAY,1:($P(DCDT,".")-1)) F ECDNEW=ECD+1:1:NEWDT D Q
78 ...I '$D(^TMP("ECX",$J,DFN,ECDNEW)) S ^TMP("ECX",$J,DFN,ECDNEW)=^TMP("ECX",$J,DFN,ECD)
79 ...S NEWWARD="",OLDWARD=$P(^TMP("ECX",$J,DFN,ECD),U,10)
80 ...D NEWWARD(ECDNEW,OLDWARD,.NEWWARD)
81 ...Q:'NEWWARD
82 ...S $P(^TMP("ECX",$J,DFN,ECDNEW),U,4)=$P(NEWWARD,U,1)
83 ...S $P(^TMP("ECX",$J,DFN,ECDNEW),U,5)=$P(NEWWARD,U,2)
84 Q
85 ;
86NEWWARD(ECDNEW,OLDWARD,NEWWARD) ;get new nursing location
87 ; input ECDNEW = date of care
88 ; OLDWARD = pointer to file #42, previous mas ward
89 ; NEWWARD = null
90 ; output NEWWARD = new nursing location^new nursing bedsection
91 ; OR "^", if new ward same as previous ward or
92 ;could not be resolved
93 ;if the new ward is mapped to multiple nursing locations, get the
94 ;first active location
95 N NEWW,NEWLOC,NEWSEC,OUT,DA,DR,DIC,DIQ,LOC,INP
96 S INP=$$INP^ECXUTL2(DFN,ECDNEW)
97 S NEWWARD=$P(INP,U,5)
98 I NEWWARD=OLDWARD S NEWWARD=""
99 Q:'NEWWARD
100 S (NEWW,NEWW2,NEWLOC,NEWSEC)="",OUT=0
101 F S NEWW=$O(^NURSF(211.4,"C",NEWWARD,NEWW)) Q:OUT Q:+NEWW<1 D
102 .S DIC=211.4,DIQ(0)="I",DIQ="LOC",DA=NEWW,DR="1;1.5"
103 .D EN^DIQ1 K DIQ,DIC,DA,DR
104 .Q:LOC(211.4,NEWW,1,"I")="I"
105 .Q:LOC(211.4,NEWW,1.5,"I")="I"
106 .S JJ=$O(^NURSF(211.4,"C",NEWWARD,NEWW,""))
107 .S DIC=211.4,DIQ(0)="I",DIQ="LOC",DA=NEWW,DA(211.41)=JJ,DR="2",DR(211.41)=".01;1"
108 .D EN^DIQ1 K DIQ,DIC,DA,DR
109 .Q:NEWWARD'=LOC(211.41,JJ,.01,"I")
110 .S NEWLOC=NEWW,NEWSEC=LOC(211.41,JJ,1,"I"),OUT=1
111 I (NEWLOC="")!(NEWSEC="") S NEWWARD="" Q
112 S NEWWARD=NEWLOC_U_NEWSEC
113 Q
114 ;
115FILE ;file extract records
116 ;node0
117 ;inst^dfn^ssn^name^in/out (ECXA)^date^acuity level(category)^entered by^
118 ;classifier^nurs location^nursing bed section^mov #^treat spec^adm date^
119 ;adm time
120 ;node1
121 ;mpi^dss dept ECXDSSD^dom (ECXDOM)^observ pat ind (ECXOBS)^dss
122 ;product ECXDSSP
123 N DA,DIK
124 S EC7=$O(^ECX(ECFILE,999999999),-1)
125 S DFN=0,QFLG=0
126 F S DFN=$O(^TMP("ECX",$J,DFN)) Q:'DFN D Q:QFLG
127 .K ECXPAT S OK=$$PAT^ECXUTL3(DFN,DT,"1;",.ECXPAT)
128 .Q:'OK
129 .S ECXDFN=DFN,ECXPNM=ECXPAT("NAME"),ECXSSN=ECXPAT("SSN")
130 .S ECXMPI=ECXPAT("MPI"),ECD=0
131 .;file patient's classification data
132 .F S ECD=$O(^TMP("ECX",$J,DFN,ECD)) Q:'ECD D
133 ..S ECC=$P(^TMP("ECX",$J,DFN,ECD),U,1,5),ECMN=$P(^(ECD),U,7),ECXA=$P(^(ECD),U,6)
134 ..S ECTS=$P(^(ECD),U,8),ECA=$P(^(ECD),U,9),ECXDOM=$P(^(ECD),U,13)
135 ..S ECXACU=$P(ECC,U,1),ECXEB=$P(ECC,U,2),ECXCLS=$P(ECC,U,3)
136 ..S ECXNLOC=$P(ECC,U,4),ECXNBED=$P(ECC,U,5)
137 ..;
138 ..;Get DSS Department and Product
139 ..S (ECXDSSD,ECXDSSP)=""
140 ..;I ECXLOGIC>2004 S X=$$NUR^ECXDEPT(ECD)
141 ..;
142 ..;- Observation patient indicator (YES/NO)
143 ..S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECTS)
144 ..;
145 ..;- Don't file record if outpatient and NOT an observation patient
146 ..Q:ECXA="O"&(ECXOBS="NO")
147 ..;
148 ..;- If no encounter number don't file record
149 ..S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECA,ECD,ECTS,ECXOBS,ECHEAD,,) Q:ECXENC=""
150 ..S EC7=EC7+1
151 ..S ECODE=EC7_U_EC23_U_ECINST_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U
152 ..S ECODE=ECODE_$$ECXDATE^ECXUTL(ECD,ECXYM)_U
153 ..S ECODE=ECODE_ECXACU_U_ECXEB_U_ECXCLS_U_ECXNLOC_U_ECXNBED_U
154 ..;convert specialties to PTF Codes for transmission
155 .. N ECXDATA
156 .. S ECXDATA=$$TSDATA^DGACT(42.4,+ECTS,.ECXDATA)
157 .. S ECTS=$G(ECXDATA(7))
158 ..;done
159 ..S ECODE=ECODE_ECMN_U_ECTS_U_$$ECXDATE^ECXUTL(ECA,ECXYM)_U
160 ..S ECODE=ECODE_$$ECXTIME^ECXUTL(ECA)_U
161 ..S ECODE1=ECXMPI_U_ECXDSSD_U_ECXDOM_U_ECXOBS_U_ECXENC_U
162 ..S ECODE1=ECODE1_ECINST_U
163 ..I ECXLOGIC>2004 S ECODE1=ECODE1_ECXDSSP
164 ..S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,ECRN=ECRN+1
165 ..S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
166 ..I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1
167 Q
168 ;
169SETUP ;Set required input for ECXTRAC
170 S ECHEAD="NUR"
171 D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
172 Q
173 ;
174QUE ; entry point for the background requeuing handled by ECXTAUTO
175 D SETUP,QUE^ECXTAUTO,^ECXKILL Q
Note: See TracBrowser for help on using the repository browser.