source: WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXLBB.m@ 701

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

revised back to 6/30/08 version

File size: 8.6 KB
Line 
1ECXLBB ;DALOI/KML - DSS BLOOD BANK EXTRACT ; 2/22/07 11:42am
2 ;;3.0;DSS EXTRACTS;**78,84,90,92,104**;Dec 22, 1997;Build 8
3 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
4 ; access to the LAB DATA file (#63) is supported by
5 ; controlled subscription to IA 525 (global root ^LR)
6 ; access to the BLOOD PRODUCT (#66) is supported by IA 4510
7BEG ;entry point from option
8 D SETUP I ECFILE="" Q
9 D ^ECXTRAC,^ECXKILL
10 Q
11 ;
12START ; Entry point from tasked job
13 ; begin package specific extract
14 N ECTRSP,ECADMT,ECTODT,ECENCTR,ECPAT,ECLRDFN,ECXPHY,ECXPHYPC
15 N ECD,ECXDFN,ECARRY,EC66,ECERR,ECTRFDT,ECTRFTM,ECX,ECINOUT,ECXINST
16 ;variables ECFILE,EC23,ECXYM,ECINST,ECSD,ECSD1,ECED passed in
17 ; by taskmanager
18 ; ECED defined in ^ECXTRAC - it represents the end date of the extract
19 ; sort process. TRANSFUSION DATE should be within start and end dates
20 ; ECED and ECSD were assigned with input provided by the user interface
21 ; and ECSD1 = ECSD-.1
22 ; Read through the TRANSFUSION RECORD sub-file (63.017) of
23 ; the LAB DATA file (#63)
24 ;the global nodes containing transfusion record entries are constructed
25 ; by calculating the TRANSFUSION DATE/TIME (.01)
26 ; into its reverse date/time representation and then DINUM'd when
27 ;filing the record entry
28 ; ECD equals the reverse date/time of ECED+.3 and will need to be
29 ; reset for each DFN.
30 I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 Q ;quit if tasked and user sends stop request (QFLG assigned in ECXTRAC)
31AUDRPT ; entry point for pre-extract audit report
32 S ECTODT=9999999-ECSD1,ECLRDFN=0
33 F S ECLRDFN=$O(^LR(ECLRDFN)) Q:'ECLRDFN S ECXDFN=$$GETDFN(ECLRDFN),ECERR=$$PAT(ECXDFN) S ECD=9999999-(ECED+.3) F S ECD=$O(^LR(ECLRDFN,1.6,ECD)) Q:ECERR Q:'ECD!(ECD>ECTODT) S EC0=^LR(ECLRDFN,1.6,ECD,0) D
34 .; ECARRY(1)=TRANSFUSION DATE AND TIME,
35 .; ECARRY(3)=COMPONENT, ECARRY(4)=COMPONENT ABBREVIATION
36 .; ECARRY(5)=UNITS POOLED, ECARRY(6)=TRANSFUSION REACTION,
37 .; ECARRY(7)=VOLUME TRANSFUSED, ECARRY(8)=TRANSFUSION REACTION TYPE
38 .; ECARRY(9)=REQUESTING PROVIDER, ECARRY(10)=REQUEST. PROV. PERSON CLASS
39 .; ECARRY(11)=UNIT MODIFIED, ECARRY(12)=UNIT MODIFICATION
40 .; ECARRY(13)=PRODUCTION DIVISION CODE
41 . S ECARRY(1)=$P(EC0,"^"),EC66=$G(^LAB(66,$P(EC0,"^",2),0))
42 . S ECARRY(3)=$E($P(EC66,"^"),1,15),ECARRY(4)=$P(EC66,"^",2)
43 . S ECARRY(5)=$S(+$P(EC0,"^",7)=0:1,1:+$P(EC0,"^",7))
44 . S ECARRY(6)=$S($P(EC0,"^",8)=1:"Y",1:"N"),ECARRY(7)=$P(EC0,"^",10)
45 . S ECARRY(8)=$E($P($G(^LAB(65.4,+$P(EC0,"^",11),0)),"^"),1,10)
46 . S (ECARRY(9),ECARRY(10),ECARRY(13))="" D GETRPRV
47 . S ECARRY(12)=$$UNITMOD(),ECARRY(11)=$S(ECARRY(12)'="":"Y",1:"N")
48 . S (ECXPHY,ECXPHYPC)=""
49 . D GETDATA
50 . K ECARRY
51 Q
52 ;
53UNITMOD() ; Get modification criteria from fields #.06 and #3 from file #66
54 N MODARY,MO,EC66A,MODSTR,STR3
55 S MODARY("DIVIDED")="D",MODARY("POOLED")="P",MODARY("WASHED")="W"
56 S MODARY("FROZEN")="F",MODARY("LEUKOCYTE POOR")="L"
57 S MODARY("REJUVENATED")="R",MODARY("DEGLYCEROLIZED")="G"
58 S MODARY("IRRADIATED")="I",MODARY("SEPARATED")="S"
59 ;if modification criteria is null determine value from description
60 S MODSTR=$S($P(EC66,U,6)'="":$P(EC66,U,6),1:$$CHKMOD($P(EC66,"^")))
61 ;get modification criteria for entries at field #3 in file #66
62 S MOD=0 F S MOD=$O(^LAB(66,$P(EC0,"^",2),3,MOD)) Q:'MOD D
63 .S EC66A=$G(^LAB(66,MOD,0)) I EC66A="" Q
64 .S STR3=$S($P(EC66A,U,6)'="":$P(EC66A,U,6),1:$$CHKMOD($P(EC66A,"^")))
65 .I STR3'="",MODSTR'[STR3 S MODSTR=MODSTR_STR3
66 Q MODSTR
67 ;
68CHKMOD(MD) ;check if modifier is contained in string
69 N RES,MODX
70 I MD="" Q ""
71 S (RES,MODX)="" F S MODX=$O(MODARY(MODX)) Q:MODX="" D I RES'="" Q
72 .I MD[MODX S RES=MODARY(MODX)
73 Q RES
74GETRPRV ; get requesting provider, requesting provider person class and
75 ; production division code
76 ; input: ECD =INVERTED DATE SUBSCRIPT
77 ; ECARRY(1)=TRANSFUSION DATE AND TIME
78 ; note: Accessioned data in file #68 is stored up to 90 days.
79 N ECXBNOD,ACC,ACCDT,ACCNODE,PERCLS
80 I ECARRY(1)="" Q ;there is no transfusion date
81 ;get BLOOD BANK record, field #1, in file #63 located on "BB" node
82 ;since there is a slight time lapse, $O will find the BB record
83 S ECXBNOD=$O(^LR(ECLRDFN,"BB",ECD)) I ECXBNOD="" Q
84 S ECXBNOD=^LR(ECLRDFN,"BB",ECXBNOD,0) I ECXBNOD="" Q
85 ;Compose accession number,originating from field #.06 subfile #63.01
86 ; ex. ACC=BB 0528 27
87 S ACC=$P(ECXBNOD,U,6),ACC=$TR($P(ACC," ",2,99)," ")
88 S ACCDT=$E(ECARRY(1),1,3)_$E(ACC,1,4),NUM=$E(ACC,5,99)
89 ;Get field #2 from file #68, field #1 from subfile #68.01 which is
90 ;subfile #68.02. Look at 29=blood bank ien, from 0th node, get fields
91 ;#6.5 PROVIDER and #26 DIV
92 I (ACCDT)=""!(NUM="") Q
93 ; identify bb accession area the patient was in to get the right DIV
94 S AREA=$$AREA
95 S ACCNODE=$G(^LRO(68,+AREA,1,ACCDT,1,NUM,0))
96 S ECARRY(9)=$P(ACCNODE,U,8) I ECARRY(9)'="" D
97 . S PERCLS=$$GET^XUA4A72(ECARRY(9),ACCDT)
98 . I +PERCLS>0 S ECARRY(10)=$P(PERCLS,U,7)
99 . S ECARRY(9)=2_ECARRY(9)
100 S DIV=$P($G(^LRO(68,+AREA,1,ACCDT,1,NUM,.4)),U)
101 I DIV'="" S ECARRY(13)=$$RADDIV^ECXDEPT(DIV)
102 Q
103 ;
104AREA() ; resolve accession area's ien to use and validate
105 ; Accession number
106 ; Patient LRDFN
107 ; note: if there is only one accession area use '29'
108 N A,CNT,BBLIST,DFN,ACC,AREA,DATE,TDATE,ACCNODE
109 S (CNT,FLAG,A)=0,DFN=""
110 ; set the date from the "bb" node in file (#63)
111 S DATE=$P(ECXBNOD,U)
112 ; setup array for bb accession areas if more than one
113 F S A=$O(^LRO(68,A)) Q:'A I $P($G(^LRO(68,A,0)),"^",2)="BB" D
114 . S BBLIST(A)=""
115 . S CNT=CNT+1
116 I CNT'>1 Q 29
117 S AREA=0 F S AREA=$O(BBLIST(AREA)) Q:'AREA D Q:FLAG
118 . ; get additional accession information for validation
119 . S ACCNODE=$G(^LRO(68,AREA,1,$P(DATE,"."),1,NUM,0))
120 . S ACC=$G(^LRO(68,AREA,1,$P(DATE,"."),1,NUM,.2))
121 . S DFN=$P($G(ACCNODE),U)
122 . S TDATE=$P($G(^LRO(68,AREA,1,$P(DATE,"."),1,NUM,3)),U)
123 . I (DFN=ECLRDFN)&(ACC=$P(ECXBNOD,U,6))&(DATE=TDATE) S FLAG=1
124 Q AREA
125 ;
126GETDATA ; gather rest of extract data that will be recorded in an
127 ; entry in file 727.829
128 S ECTRFDT=$$ECXDOB^ECXUTL(ECARRY(1)),ECTRFTM=$$ECXTIME^ECXUTL(ECARRY(1))
129 S ECX=$$INP^ECXUTL2(ECXDFN,ECARRY(1)),ECINOUT=$P(ECX,U),ECTRSP=$P(ECX,U,3),ECADMT=$P(ECX,U,4) ; [FLD #5]
130 ;
131 ;- Observation patient indicator (YES/NO)
132 S ECXOBS=$$OBSPAT^ECXUTL4(ECINOUT,ECTRSP)
133 ;- If no encounter number don't file record
134 S ECENCTR=$$ENCNUM^ECXUTL4(ECINOUT,ECPAT("SSN"),ECADMT,ECARRY(1),ECTRSP,ECXOBS,ECHEAD,,) ; [FLD #6]
135 Q:ECENCTR=""
136 ;get emergency response indicator (FEMA)
137 S ECXERI=ECPAT("ERI")
138 ;
139 S ECXSTR=$G(EC23)_"^"_ECINST_"^"_ECXDFN_"^"_ECPAT("SSN")_"^"_ECPAT("NAME")_"^"_ECINOUT_"^"_ECENCTR_"^"_ECTRFDT_"^"_ECTRFTM_"^"_ECARRY(3)_"^"_ECARRY(4)_"^"_ECARRY(5)_"^"_ECARRY(7)_"^"_ECARRY(6)_"^"_ECARRY(8)_"^BB"_ECARRY(13)_"^^"
140 I $G(ECXLOGIC)>2005 S ECXSTR=ECXSTR_U_ECXPHY_U_ECXPHYPC
141 I $G(ECXLOGIC)>2006 D
142 .S ECXSTR=ECXSTR_U_ECXERI_U_ECARRY(11)_U_ECARRY(12)_U_ECARRY(9)_U_ECARRY(10)_U_ECARRY(13)
143 I '$D(ECXRPT) D FILE(ECXSTR) Q
144 S ^TMP("ECXLBB",$J,ECXDFN,ECD)=ECXSTR ;temporary global array
145 ; used in ECXPLBB (pre-extract audit report)
146 Q
147 ;
148GETDFN(ECXLRDFN) ;
149 ; INPUT - LRDFN
150 ; OUTPUT - DFN
151 ; Obtains DFN (Patient ID) from LRDFN (Lab Patient ID).
152 ; If no valid DFN exists, 0 is returned.
153 S ECXLRDFN=+$G(ECXLRDFN)
154 I $P($G(^LR(ECXLRDFN,0)),"^",2)'=2 Q 0
155 Q +$P(^LR(ECXLRDFN,0),"^",3)
156 ;
157PAT(ECXDFN) ;get/set patient data
158 ; INPUT - ECXDFN = patient ien (DFN)
159 ; OUTPUT - ECPAT array:
160 ; ECPAT("SSN")
161 ; ECPAT("NAME")
162 ; returns 0 or 1 in ECXERR - 0=successful
163 ; 1=error condition
164 N X,OK,ECXERR
165 ;get data
166 S ECXERR=0
167 K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,"","1;3",.ECPAT)
168 I 'OK S ECXERR=1
169 Q ECXERR
170 ;
171FILE(ECODE) ;
172 ; Input - ECODE = extract record
173 ;
174 ; record the extract record at a global node in file 727.829
175 ; sequence #^year/month of extract^extract #^facility^patient dfn^SSN^
176 ; name^i/o pt indicator^encounter #^date of transfusion^time of
177 ; transfusion^component^component abbrev^# of units^volume in mm^
178 ; reaction^reaction type^feeder location^DSS product dept^DSS IP #
179 ; ordering physician^ordering physician pc^emergency response indicator
180 ; (FEMA)^unit modified^unit modification^requesting provider^request.
181 ; provider person class
182 ;note: DSS product dept and DSS IP # are dependent on the release of
183 ; ECX*3*61
184 N DA,DIK,EC7
185 S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
186 S ECODE=EC7_"^"_ECODE
187 S ^ECX(ECFILE,EC7,0)=ECODE,ECRN=ECRN+1
188 S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
189 Q
190 ;
191 ;
192SETUP ;Set required input for ECXTRAC.
193 S ECHEAD="LBB"
194 D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
195 Q
196 ;
197LOCAL ; to extract nightly for local use not to be transmitted to TSI
198 ; should be queued with a 1D frequency
199 D SETUP,^ECXTLOCL,^ECXKILL Q
200 ;
201QUE ; entry point for the background requeuing handled by ECXTAUTO
202 D SETUP,QUE^ECXTAUTO,^ECXKILL
203 Q
204 ;
205 ;ECXLBB
Note: See TracBrowser for help on using the repository browser.