ECXLBB ;DALOI/KML - DSS BLOOD BANK EXTRACT ;4/16/13 16:03
;;3.0;DSS EXTRACTS;**78,84,90,92,104,105,102,120,127,144**;Dec 22, 1997;Build 9
;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
; access to the LAB DATA file (#63) is supported by
; controlled subscription to IA 525 (global root ^LR)
; access to the BLOOD PRODUCT (#66) is supported by IA 4510
BEG ;entry point from option
D SETUP I ECFILE="" Q
D ^ECXTRAC,^ECXKILL
Q
START ; Entry point from tasked job
; begin package specific extract
N ECTRSP,ECADMT,ECTODT,ECENCTR,ECPAT,ECLRDFN,ECXPHY,ECXPHYPC,ECPHYNPI
N ECD,ECXDFN,ECARRY,EC66,ECERR,ECTRFDT,ECTRFTM,ECX,ECINOUT,ECXINST,ECXPATCAT,ECXESC ;144
;variables ECFILE,EC23,ECXYM,ECINST,ECSD,ECSD1,ECED passed in
; by taskmanager
; ECED defined in ^ECXTRAC - it represents the end date of the extract
; sort process. TRANSFUSION DATE should be within start and end dates
; ECED and ECSD were assigned with input provided by the user interface
; and ECSD1 = ECSD-.1
; Read through the TRANSFUSION RECORD sub-file (63.017) of
; the LAB DATA file (#63)
;the global nodes containing transfusion record entries are constructed
; by calculating the TRANSFUSION DATE/TIME (.01)
; into its reverse date/time representation and then DINUM'd when
;filing the record entry
; ECD equals the reverse date/time of ECED+.3 and will need to be
; reset for each DFN.
I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1 Q ;quit if tasked and user sends stop request (QFLG assigned in ECXTRAC)
AUDRPT ; entry point for pre-extract audit report
S ECTODT=9999999-ECSD1,ECLRDFN=0
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
.; ECARRY(1)=TRANSFUSION DATE AND TIME,
.; ECARRY(3)=COMPONENT, ECARRY(4)=COMPONENT ABBREVIATION
.; ECARRY(5)=UNITS POOLED, ECARRY(6)=TRANSFUSION REACTION,
.; ECARRY(7)=VOLUME TRANSFUSED, ECARRY(8)=TRANSFUSION REACTION TYPE
.; ECARRY(9)=REQUESTING PROVIDER, ECARRY(10)=REQUEST. PROV. PERSON CLASS
.; ECARRY(11)=UNIT MODIFIED,ECARRY(12)=UNIT MODIFICATION
.; ECARRY(13)=PRODUCTION DIVISION CODE
. S ECARRY(1)=$P(EC0,"^"),EC66=$G(^LAB(66,$P(EC0,"^",2),0))
. S ECARRY(3)=$E($P(EC66,"^"),1,15),ECARRY(4)=$P(EC66,"^",2)
. S ECARRY(5)=$S(+$P(EC0,"^",7)=0:1,1:+$P(EC0,"^",7))
. S ECARRY(6)=$S($P(EC0,"^",8)=1:"Y",1:"N"),ECARRY(7)=$P(EC0,"^",10)
. S ECARRY(8)=$E($P($G(^LAB(65.4,+$P(EC0,"^",11),0)),"^"),1,10)
. S (ECARRY(9),ECARRY(10),ECARRY(13))="" D GETRPRV
. S ECARRY(11)=$$MODIFIED(),(ECXPHY,ECXPHYPC,ECPHYNPI)=""
. S ECARRY(12)=$S(ECARRY(11)="Y":$$UNITMODS(),1:"")
. D GETDATA
. K ECARRY
D AUDRPT^ECXLBB1
Q
UNITMODS() ; Get modification criteria from fields #.06 and #3 from file #66
N MODARY,MO,EC66A,MODSTR,STR3
S MODARY("DIVIDED")="D",MODARY("POOLED")="P",MODARY("WASHED")="W"
S MODARY("FROZEN")="F",MODARY("LEUKOCYTE POOR")="L"
S MODARY("REJUVENATED")="R",MODARY("DEGLYCEROLIZED")="G"
S MODARY("IRRADIATED")="I",MODARY("SEPARATED")="S"
;if modification criteria is null determine value from description
S MODSTR=$S($P(EC66,U,6)'="":$P(EC66,U,6),1:$$CHKMOD^ECXLBB1($P(EC66,"^")))
;get modification criteria for entries at field #3 in file #66
S MOD=0 F S MOD=$O(^LAB(66,$P(EC0,"^",2),3,MOD)) Q:'MOD D
.S EC66A=$G(^LAB(66,MOD,0)) I EC66A="" Q
.S STR3=$S($P(EC66A,U,6)'="":$P(EC66A,U,6),1:$$CHKMOD^ECXLBB1($P(EC66A,"^")))
.I STR3'="",MODSTR'[STR3 S MODSTR=MODSTR_STR3
Q MODSTR
MODIFIED() ; Was unit modified
; Init variables
N XMATCH,UNIT,MOD,COMPID,MODNODE,MODTO
S (XMATCH,UNIT)=0,MOD=""
; Check input
Q:'$G(ECLRDFN)!'$P(EC0,U,2) "N"
;Find xmatch for blood component request
S XMATCH=$O(^LR(ECLRDFN,1.8,$P(EC0,U,2),1,XMATCH)) Q:'XMATCH "N"
;Get blood inventory file (#65) pointer
S UNIT=$P($G(^LR(ECLRDFN,1.8,$P(EC0,"^",2),1,XMATCH,0)),U)
;Look at disposition field (#4.1) in blood inventory file (#65)
S MOD=$P($G(^LRD(65,+XMATCH,4)),U),COMPID=$P(EC66,U,3)
; Get 'the modified to' entry pointer to blood inventory file (#66)
I MOD="MO" S MODTO=0 F S MODTO=$O(^LRD(65,+XMATCH,9,MODTO)) Q:'MODTO D
.S MODNODE=$G(^LRD(65,+XMATCH,9,MODTO,0)) Q:$P(^(0),U,3)'>1
.Q:$P(MODNODE,U,2)'=COMPID
.; Set the modify to unit ien for file (#66)
Q $S(MOD="MO":"Y",1:"N")
GETRPRV ; get requesting provider, requesting provider person class and
; production division code
; input: ECD =INVERTED DATE SUBSCRIPT
; ECARRY(1)=TRANSFUSION DATE AND TIME
; note: Accessioned data in file #68 is stored up to 90 days.
N ECXBNOD,ACC,ACCDT,ACCNODE,PERCLS,DIV,NUM
I ECARRY(1)="" Q ;there is no transfusion date
;get BLOOD BANK record, field #1, in file #63 located on "BB" node
;since there is a slight time lapse, $O will find the BB record
S ECXBNOD=$O(^LR(ECLRDFN,"BB",ECD)) I ECXBNOD="" Q
S ECXBNOD=^LR(ECLRDFN,"BB",ECXBNOD,0) I ECXBNOD="" Q
;Compose accession number,originating from field #.06 subfile #63.01
; ex. ACC=BB 0528 27
S ACC=$P(ECXBNOD,U,6),ACC=$TR($P(ACC," ",2,99)," ")
S ACCDT=$E(ECARRY(1),1,3)_$E(ACC,1,4),NUM=$E(ACC,5,99)
;Get field #2 from file #68, field #1 from subfile #68.01 which is
;subfile #68.02. Look at 29=blood bank ien, from 0th node, get fields
;#6.5 PROVIDER and #26 DIV
I (ACCDT)=""!(NUM="") Q
; identify bb accession area the patient was in to get the right DIV
S AREA=$$AREA
S ACCNODE=$G(^LRO(68,+AREA,1,ACCDT,1,NUM,0))
S ECARRY(9)=$P(ACCNODE,U,8) I ECARRY(9)'="" D
. S PERCLS=$$GET^XUA4A72(ECARRY(9),ACCDT)
. I +PERCLS>0 S ECARRY(10)=$P(PERCLS,U,7)
. S ECREQNPI=$$NPI^XUSNPI("Individual_ID",ECARRY(9),ACCDT)
. S:+ECREQNPI'>0 ECREQNPI="" S ECREQNPI=$P(ECREQNPI,U)
. S ECARRY(9)=2_ECARRY(9)
S DIV=$P($G(^LRO(68,+AREA,1,ACCDT,1,NUM,.4)),U)
I DIV'="" S ECARRY(13)=$$RADDIV^ECXDEPT(DIV)
Q
AREA() ; resolve accession area's ien to use and validate
; Accession number
; Patient LRDFN
; note: if there is only one accession area use '29'
N A,CNT,BBLIST,DFN,ACC,AREA,DATE,TDATE,ACCNODE
S (CNT,FLAG,A)=0,DFN=""
; set the date from the "bb" node in file (#63)
S DATE=$P(ECXBNOD,U)
; setup array for bb accession areas if more than one
F S A=$O(^LRO(68,A)) Q:'A I $P($G(^LRO(68,A,0)),"^",2)="BB" D
. S BBLIST(A)=""
. S CNT=CNT+1
I CNT'>1 Q 29
S AREA=0 F S AREA=$O(BBLIST(AREA)) Q:'AREA D Q:FLAG
. ; get additional accession information for validation
. S ACCNODE=$G(^LRO(68,AREA,1,$P(DATE,"."),1,NUM,0))
. S ACC=$G(^LRO(68,AREA,1,$P(DATE,"."),1,NUM,.2))
. S DFN=$P($G(ACCNODE),U)
. S TDATE=$P($G(^LRO(68,AREA,1,$P(DATE,"."),1,NUM,3)),U)
. I (DFN=ECLRDFN)&(ACC=$P(ECXBNOD,U,6))&(DATE=TDATE) S FLAG=1
Q AREA
GETDATA ; gather rest of extract data that will be recorded in an
; entry in file 727.829
N ECXSTR
S ECTRFDT=$$ECXDOB^ECXUTL(ECARRY(1)),ECTRFTM=$$ECXTIME^ECXUTL(ECARRY(1))
S ECX=$$INP^ECXUTL2(ECXDFN,ECARRY(1)),ECINOUT=$P(ECX,U),ECTRSP=$P(ECX,U,3),ECADMT=$P(ECX,U,4) ; [FLD #5]
;
;- Observation patient indicator (YES/NO)
S ECXOBS=$$OBSPAT^ECXUTL4(ECINOUT,ECTRSP)
;- If no encounter number don't file record
S ECENCTR=$$ENCNUM^ECXUTL4(ECINOUT,ECPAT("SSN"),ECADMT,ECARRY(1),ECTRSP,ECXOBS,ECHEAD,,) ; [FLD #6]
Q:ECENCTR=""
;get emergency response indicator (FEMA)
S ECXERI=ECPAT("ERI")
;
; ******* - PATCH 127, ADD PATCAT CODE ********
S ECXPATCAT=$$PATCAT^ECXUTL(ECXDFN)
S ECXESC="" ;144
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)_"^^"
I $G(ECXLOGIC)>2005 S ECXSTR=ECXSTR_U_ECXPHY_U_ECXPHYPC
I $G(ECXLOGIC)>2006 D
.S ECXSTR=ECXSTR_U_ECXERI_U_ECARRY(11)_U_ECARRY(12)_U_ECARRY(9)_U_ECARRY(10)_U_ECARRY(13)_U
I '$D(ECXRPT) D FILE(ECXSTR) Q
S ^TMP("ECXLBB",$J,ECXDFN,ECD)=ECXSTR ;temporary global array
I $D(ECXCRPT) D
. N ECCOUNT S ECCOUNT=0
. F S ECCOUNT=ECCOUNT+1 Q:'$D(^TMP("ECXLBBC",$J,$S($G(ECXCFLG)=1:ECARRY(4),1:"ZZNOZZ"),ECXDFN,ECTRFDT_"."_ECTRFTM_"."_ECCOUNT,"S"))
. S ^TMP("ECXLBBC",$J,$S($G(ECXCFLG)=1:ECARRY(4),1:"ZZNOZZ"),ECXDFN,ECTRFDT_"."_ECTRFTM_"."_ECCOUNT,"S")=ECXSTR
; used in ECXPLBB/ECXLBBC (pre-extract audit report)
Q
GETDFN(ECXLRDFN) ;
; INPUT - LRDFN
; OUTPUT - DFN
; Obtains DFN (Patient ID) from LRDFN (Lab Patient ID).
; If no valid DFN exists, 0 is returned.
S ECXLRDFN=+$G(ECXLRDFN)
I $P($G(^LR(ECXLRDFN,0)),"^",2)'=2 Q 0
Q +$P(^LR(ECXLRDFN,0),"^",3)
;
PAT(ECXDFN) ;get/set patient data
; INPUT - ECXDFN = patient ien (DFN)
; OUTPUT - ECPAT array:
; ECPAT("SSN")
; ECPAT("NAME")
; returns 0 or 1 in ECXERR - 0=successful
; 1=error condition
N X,OK,ECXERR
;get data
S ECXERR=0
K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,"","1;3",.ECPAT)
I 'OK S ECXERR=1
Q ECXERR
;
FILE(ECODE) ;
; Input - ECODE = extract record
;
; record the extract record at a global node in file 727.829
; sequence #^year/month of extract^extract #^facility^patient dfn^SSN^
; name^i/o pt indicator^encounter #^date of transfusion^time of
; transfusion^component^component abbrev^# of units^volume in mm^
; reaction^reaction type^feeder location^DSS product dept^DSS IP #
; ordering physician^ordering physician pc^emergency response indicator
; (FEMA)^unit modified^unit modification^requesting provider^request.
; provider person class^ordering provider npi ECPHYNPI
;ECODE1- requesting provider npi ECREQNPI^PATCAT^Encounter SC ECXESC
;note: DSS product dept and DSS IP # are dependent on the release of
; ECX*3*61
N DA,DIK,EC7
S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
S ECODE=EC7_"^"_ECODE
I ECXLOGIC>2007 D
.S ECODE=ECODE_ECPHYNPI_U
.S ECODE1=$G(ECREQNPI)_U
.I ECXLOGIC>2010 S ECODE1=ECODE1_ECXPATCAT
I ECXLOGIC>2013 S ECODE1=ECODE1_U_ECXESC ;144
S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=$G(ECODE1),ECRN=ECRN+1
S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
Q
;
;
SETUP ;Set required input for ECXTRAC.
S ECHEAD="LBB"
D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
Q
;
LOCAL ; to extract nightly for local use not to be transmitted to TSI
; should be queued with a 1D frequency
D SETUP,^ECXTLOCL,^ECXKILL Q
;
QUE ; entry point for the background requeuing handled by ECXTAUTO
D SETUP,QUE^ECXTAUTO,^ECXKILL
Q
;
;ECXLBB
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXLBB 10576 printed Sep 02, 2024@18:38:12 Page 2
ECXLBB ;DALOI/KML - DSS BLOOD BANK EXTRACT ;4/16/13 16:03
+1 ;;3.0;DSS EXTRACTS;**78,84,90,92,104,105,102,120,127,144**;Dec 22, 1997;Build 9
+2 ;Per VHA Directive 97-033 this routine should not be modified. Medical Device # BK970021
+3 ; access to the LAB DATA file (#63) is supported by
+4 ; controlled subscription to IA 525 (global root ^LR)
+5 ; access to the BLOOD PRODUCT (#66) is supported by IA 4510
BEG ;entry point from option
+1 DO SETUP
IF ECFILE=""
QUIT
+2 DO ^ECXTRAC
DO ^ECXKILL
+3 QUIT
START ; Entry point from tasked job
+1 ; begin package specific extract
+2 NEW ECTRSP,ECADMT,ECTODT,ECENCTR,ECPAT,ECLRDFN,ECXPHY,ECXPHYPC,ECPHYNPI
+3 ;144
NEW ECD,ECXDFN,ECARRY,EC66,ECERR,ECTRFDT,ECTRFTM,ECX,ECINOUT,ECXINST,ECXPATCAT,ECXESC
+4 ;variables ECFILE,EC23,ECXYM,ECINST,ECSD,ECSD1,ECED passed in
+5 ; by taskmanager
+6 ; ECED defined in ^ECXTRAC - it represents the end date of the extract
+7 ; sort process. TRANSFUSION DATE should be within start and end dates
+8 ; ECED and ECSD were assigned with input provided by the user interface
+9 ; and ECSD1 = ECSD-.1
+10 ; Read through the TRANSFUSION RECORD sub-file (63.017) of
+11 ; the LAB DATA file (#63)
+12 ;the global nodes containing transfusion record entries are constructed
+13 ; by calculating the TRANSFUSION DATE/TIME (.01)
+14 ; into its reverse date/time representation and then DINUM'd when
+15 ;filing the record entry
+16 ; ECD equals the reverse date/time of ECED+.3 and will need to be
+17 ; reset for each DFN.
+18 ;quit if tasked and user sends stop request (QFLG assigned in ECXTRAC)
IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
SET QFLG=1
QUIT
AUDRPT ; entry point for pre-extract audit report
+1 SET ECTODT=9999999-ECSD1
SET ECLRDFN=0
+2 FOR
SET ECLRDFN=$ORDER(^LR(ECLRDFN))
if 'ECLRDFN
QUIT
SET ECXDFN=$$GETDFN(ECLRDFN)
SET ECERR=$$PAT(ECXDFN)
SET ECD=9999999-(ECED+.3)
FOR
SET ECD=$ORDER(^LR(ECLRDFN,1.6,ECD))
if ECERR
QUIT
if 'ECD!(ECD>ECTODT)
QUIT
SET EC0=^LR(ECLRDFN,1.6,ECD,0)
Begin DoDot:1
+3 ; ECARRY(1)=TRANSFUSION DATE AND TIME,
+4 ; ECARRY(3)=COMPONENT, ECARRY(4)=COMPONENT ABBREVIATION
+5 ; ECARRY(5)=UNITS POOLED, ECARRY(6)=TRANSFUSION REACTION,
+6 ; ECARRY(7)=VOLUME TRANSFUSED, ECARRY(8)=TRANSFUSION REACTION TYPE
+7 ; ECARRY(9)=REQUESTING PROVIDER, ECARRY(10)=REQUEST. PROV. PERSON CLASS
+8 ; ECARRY(11)=UNIT MODIFIED,ECARRY(12)=UNIT MODIFICATION
+9 ; ECARRY(13)=PRODUCTION DIVISION CODE
+10 SET ECARRY(1)=$PIECE(EC0,"^")
SET EC66=$GET(^LAB(66,$PIECE(EC0,"^",2),0))
+11 SET ECARRY(3)=$EXTRACT($PIECE(EC66,"^"),1,15)
SET ECARRY(4)=$PIECE(EC66,"^",2)
+12 SET ECARRY(5)=$SELECT(+$PIECE(EC0,"^",7)=0:1,1:+$PIECE(EC0,"^",7))
+13 SET ECARRY(6)=$SELECT($PIECE(EC0,"^",8)=1:"Y",1:"N")
SET ECARRY(7)=$PIECE(EC0,"^",10)
+14 SET ECARRY(8)=$EXTRACT($PIECE($GET(^LAB(65.4,+$PIECE(EC0,"^",11),0)),"^"),1,10)
+15 SET (ECARRY(9),ECARRY(10),ECARRY(13))=""
DO GETRPRV
+16 SET ECARRY(11)=$$MODIFIED()
SET (ECXPHY,ECXPHYPC,ECPHYNPI)=""
+17 SET ECARRY(12)=$SELECT(ECARRY(11)="Y":$$UNITMODS(),1:"")
+18 DO GETDATA
+19 KILL ECARRY
End DoDot:1
+20 DO AUDRPT^ECXLBB1
+21 QUIT
UNITMODS() ; Get modification criteria from fields #.06 and #3 from file #66
+1 NEW MODARY,MO,EC66A,MODSTR,STR3
+2 SET MODARY("DIVIDED")="D"
SET MODARY("POOLED")="P"
SET MODARY("WASHED")="W"
+3 SET MODARY("FROZEN")="F"
SET MODARY("LEUKOCYTE POOR")="L"
+4 SET MODARY("REJUVENATED")="R"
SET MODARY("DEGLYCEROLIZED")="G"
+5 SET MODARY("IRRADIATED")="I"
SET MODARY("SEPARATED")="S"
+6 ;if modification criteria is null determine value from description
+7 SET MODSTR=$SELECT($PIECE(EC66,U,6)'="":$PIECE(EC66,U,6),1:$$CHKMOD^ECXLBB1($PIECE(EC66,"^")))
+8 ;get modification criteria for entries at field #3 in file #66
+9 SET MOD=0
FOR
SET MOD=$ORDER(^LAB(66,$PIECE(EC0,"^",2),3,MOD))
if 'MOD
QUIT
Begin DoDot:1
+10 SET EC66A=$GET(^LAB(66,MOD,0))
IF EC66A=""
QUIT
+11 SET STR3=$SELECT($PIECE(EC66A,U,6)'="":$PIECE(EC66A,U,6),1:$$CHKMOD^ECXLBB1($PIECE(EC66A,"^")))
+12 IF STR3'=""
IF MODSTR'[STR3
SET MODSTR=MODSTR_STR3
End DoDot:1
+13 QUIT MODSTR
MODIFIED() ; Was unit modified
+1 ; Init variables
+2 NEW XMATCH,UNIT,MOD,COMPID,MODNODE,MODTO
+3 SET (XMATCH,UNIT)=0
SET MOD=""
+4 ; Check input
+5 if '$GET(ECLRDFN)!'$PIECE(EC0,U,2)
QUIT "N"
+6 ;Find xmatch for blood component request
+7 SET XMATCH=$ORDER(^LR(ECLRDFN,1.8,$PIECE(EC0,U,2),1,XMATCH))
if 'XMATCH
QUIT "N"
+8 ;Get blood inventory file (#65) pointer
+9 SET UNIT=$PIECE($GET(^LR(ECLRDFN,1.8,$PIECE(EC0,"^",2),1,XMATCH,0)),U)
+10 ;Look at disposition field (#4.1) in blood inventory file (#65)
+11 SET MOD=$PIECE($GET(^LRD(65,+XMATCH,4)),U)
SET COMPID=$PIECE(EC66,U,3)
+12 ; Get 'the modified to' entry pointer to blood inventory file (#66)
+13 IF MOD="MO"
SET MODTO=0
FOR
SET MODTO=$ORDER(^LRD(65,+XMATCH,9,MODTO))
if 'MODTO
QUIT
Begin DoDot:1
+14 SET MODNODE=$GET(^LRD(65,+XMATCH,9,MODTO,0))
if $PIECE(^(0),U,3)'>1
QUIT
+15 if $PIECE(MODNODE,U,2)'=COMPID
QUIT
+16 ; Set the modify to unit ien for file (#66)
End DoDot:1
+17 QUIT $SELECT(MOD="MO":"Y",1:"N")
GETRPRV ; get requesting provider, requesting provider person class and
+1 ; production division code
+2 ; input: ECD =INVERTED DATE SUBSCRIPT
+3 ; ECARRY(1)=TRANSFUSION DATE AND TIME
+4 ; note: Accessioned data in file #68 is stored up to 90 days.
+5 NEW ECXBNOD,ACC,ACCDT,ACCNODE,PERCLS,DIV,NUM
+6 ;there is no transfusion date
IF ECARRY(1)=""
QUIT
+7 ;get BLOOD BANK record, field #1, in file #63 located on "BB" node
+8 ;since there is a slight time lapse, $O will find the BB record
+9 SET ECXBNOD=$ORDER(^LR(ECLRDFN,"BB",ECD))
IF ECXBNOD=""
QUIT
+10 SET ECXBNOD=^LR(ECLRDFN,"BB",ECXBNOD,0)
IF ECXBNOD=""
QUIT
+11 ;Compose accession number,originating from field #.06 subfile #63.01
+12 ; ex. ACC=BB 0528 27
+13 SET ACC=$PIECE(ECXBNOD,U,6)
SET ACC=$TRANSLATE($PIECE(ACC," ",2,99)," ")
+14 SET ACCDT=$EXTRACT(ECARRY(1),1,3)_$EXTRACT(ACC,1,4)
SET NUM=$EXTRACT(ACC,5,99)
+15 ;Get field #2 from file #68, field #1 from subfile #68.01 which is
+16 ;subfile #68.02. Look at 29=blood bank ien, from 0th node, get fields
+17 ;#6.5 PROVIDER and #26 DIV
+18 IF (ACCDT)=""!(NUM="")
QUIT
+19 ; identify bb accession area the patient was in to get the right DIV
+20 SET AREA=$$AREA
+21 SET ACCNODE=$GET(^LRO(68,+AREA,1,ACCDT,1,NUM,0))
+22 SET ECARRY(9)=$PIECE(ACCNODE,U,8)
IF ECARRY(9)'=""
Begin DoDot:1
+23 SET PERCLS=$$GET^XUA4A72(ECARRY(9),ACCDT)
+24 IF +PERCLS>0
SET ECARRY(10)=$PIECE(PERCLS,U,7)
+25 SET ECREQNPI=$$NPI^XUSNPI("Individual_ID",ECARRY(9),ACCDT)
+26 if +ECREQNPI'>0
SET ECREQNPI=""
SET ECREQNPI=$PIECE(ECREQNPI,U)
+27 SET ECARRY(9)=2_ECARRY(9)
End DoDot:1
+28 SET DIV=$PIECE($GET(^LRO(68,+AREA,1,ACCDT,1,NUM,.4)),U)
+29 IF DIV'=""
SET ECARRY(13)=$$RADDIV^ECXDEPT(DIV)
+30 QUIT
AREA() ; resolve accession area's ien to use and validate
+1 ; Accession number
+2 ; Patient LRDFN
+3 ; note: if there is only one accession area use '29'
+4 NEW A,CNT,BBLIST,DFN,ACC,AREA,DATE,TDATE,ACCNODE
+5 SET (CNT,FLAG,A)=0
SET DFN=""
+6 ; set the date from the "bb" node in file (#63)
+7 SET DATE=$PIECE(ECXBNOD,U)
+8 ; setup array for bb accession areas if more than one
+9 FOR
SET A=$ORDER(^LRO(68,A))
if 'A
QUIT
IF $PIECE($GET(^LRO(68,A,0)),"^",2)="BB"
Begin DoDot:1
+10 SET BBLIST(A)=""
+11 SET CNT=CNT+1
End DoDot:1
+12 IF CNT'>1
QUIT 29
+13 SET AREA=0
FOR
SET AREA=$ORDER(BBLIST(AREA))
if 'AREA
QUIT
Begin DoDot:1
+14 ; get additional accession information for validation
+15 SET ACCNODE=$GET(^LRO(68,AREA,1,$PIECE(DATE,"."),1,NUM,0))
+16 SET ACC=$GET(^LRO(68,AREA,1,$PIECE(DATE,"."),1,NUM,.2))
+17 SET DFN=$PIECE($GET(ACCNODE),U)
+18 SET TDATE=$PIECE($GET(^LRO(68,AREA,1,$PIECE(DATE,"."),1,NUM,3)),U)
+19 IF (DFN=ECLRDFN)&(ACC=$PIECE(ECXBNOD,U,6))&(DATE=TDATE)
SET FLAG=1
End DoDot:1
if FLAG
QUIT
+20 QUIT AREA
GETDATA ; gather rest of extract data that will be recorded in an
+1 ; entry in file 727.829
+2 NEW ECXSTR
+3 SET ECTRFDT=$$ECXDOB^ECXUTL(ECARRY(1))
SET ECTRFTM=$$ECXTIME^ECXUTL(ECARRY(1))
+4 ; [FLD #5]
SET ECX=$$INP^ECXUTL2(ECXDFN,ECARRY(1))
SET ECINOUT=$PIECE(ECX,U)
SET ECTRSP=$PIECE(ECX,U,3)
SET ECADMT=$PIECE(ECX,U,4)
+5 ;
+6 ;- Observation patient indicator (YES/NO)
+7 SET ECXOBS=$$OBSPAT^ECXUTL4(ECINOUT,ECTRSP)
+8 ;- If no encounter number don't file record
+9 ; [FLD #6]
SET ECENCTR=$$ENCNUM^ECXUTL4(ECINOUT,ECPAT("SSN"),ECADMT,ECARRY(1),ECTRSP,ECXOBS,ECHEAD,,)
+10 if ECENCTR=""
QUIT
+11 ;get emergency response indicator (FEMA)
+12 SET ECXERI=ECPAT("ERI")
+13 ;
+14 ; ******* - PATCH 127, ADD PATCAT CODE ********
+15 SET ECXPATCAT=$$PATCAT^ECXUTL(ECXDFN)
+16 ;144
SET ECXESC=""
+17 SET ECXSTR=$GET(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)_"^^"
+18 IF $GET(ECXLOGIC)>2005
SET ECXSTR=ECXSTR_U_ECXPHY_U_ECXPHYPC
+19 IF $GET(ECXLOGIC)>2006
Begin DoDot:1
+20 SET ECXSTR=ECXSTR_U_ECXERI_U_ECARRY(11)_U_ECARRY(12)_U_ECARRY(9)_U_ECARRY(10)_U_ECARRY(13)_U
End DoDot:1
+21 IF '$DATA(ECXRPT)
DO FILE(ECXSTR)
QUIT
+22 ;temporary global array
SET ^TMP("ECXLBB",$JOB,ECXDFN,ECD)=ECXSTR
+23 IF $DATA(ECXCRPT)
Begin DoDot:1
+24 NEW ECCOUNT
SET ECCOUNT=0
+25 FOR
SET ECCOUNT=ECCOUNT+1
if '$DATA(^TMP("ECXLBBC",$JOB,$SELECT($GET(ECXCFLG)=1
QUIT
+26 SET ^TMP("ECXLBBC",$JOB,$SELECT($GET(ECXCFLG)=1:ECARRY(4),1:"ZZNOZZ"),ECXDFN,ECTRFDT_"."_ECTRFTM_"."_ECCOUNT,"S")=ECXSTR
End DoDot:1
+27 ; used in ECXPLBB/ECXLBBC (pre-extract audit report)
+28 QUIT
GETDFN(ECXLRDFN) ;
+1 ; INPUT - LRDFN
+2 ; OUTPUT - DFN
+3 ; Obtains DFN (Patient ID) from LRDFN (Lab Patient ID).
+4 ; If no valid DFN exists, 0 is returned.
+5 SET ECXLRDFN=+$GET(ECXLRDFN)
+6 IF $PIECE($GET(^LR(ECXLRDFN,0)),"^",2)'=2
QUIT 0
+7 QUIT +$PIECE(^LR(ECXLRDFN,0),"^",3)
+8 ;
PAT(ECXDFN) ;get/set patient data
+1 ; INPUT - ECXDFN = patient ien (DFN)
+2 ; OUTPUT - ECPAT array:
+3 ; ECPAT("SSN")
+4 ; ECPAT("NAME")
+5 ; returns 0 or 1 in ECXERR - 0=successful
+6 ; 1=error condition
+7 NEW X,OK,ECXERR
+8 ;get data
+9 SET ECXERR=0
+10 KILL ECXPAT
SET OK=$$PAT^ECXUTL3(ECXDFN,"","1;3",.ECPAT)
+11 IF 'OK
SET ECXERR=1
+12 QUIT ECXERR
+13 ;
FILE(ECODE) ;
+1 ; Input - ECODE = extract record
+2 ;
+3 ; record the extract record at a global node in file 727.829
+4 ; sequence #^year/month of extract^extract #^facility^patient dfn^SSN^
+5 ; name^i/o pt indicator^encounter #^date of transfusion^time of
+6 ; transfusion^component^component abbrev^# of units^volume in mm^
+7 ; reaction^reaction type^feeder location^DSS product dept^DSS IP #
+8 ; ordering physician^ordering physician pc^emergency response indicator
+9 ; (FEMA)^unit modified^unit modification^requesting provider^request.
+10 ; provider person class^ordering provider npi ECPHYNPI
+11 ;ECODE1- requesting provider npi ECREQNPI^PATCAT^Encounter SC ECXESC
+12 ;note: DSS product dept and DSS IP # are dependent on the release of
+13 ; ECX*3*61
+14 NEW DA,DIK,EC7
+15 SET EC7=$ORDER(^ECX(ECFILE,999999999),-1)
SET EC7=EC7+1
+16 SET ECODE=EC7_"^"_ECODE
+17 IF ECXLOGIC>2007
Begin DoDot:1
+18 SET ECODE=ECODE_ECPHYNPI_U
+19 SET ECODE1=$GET(ECREQNPI)_U
+20 IF ECXLOGIC>2010
SET ECODE1=ECODE1_ECXPATCAT
End DoDot:1
+21 ;144
IF ECXLOGIC>2013
SET ECODE1=ECODE1_U_ECXESC
+22 SET ^ECX(ECFILE,EC7,0)=ECODE
SET ^ECX(ECFILE,EC7,1)=$GET(ECODE1)
SET ECRN=ECRN+1
+23 SET DA=EC7
SET DIK="^ECX("_ECFILE_","
DO IX1^DIK
KILL DIK,DA
+24 QUIT
+25 ;
+26 ;
SETUP ;Set required input for ECXTRAC.
+1 SET ECHEAD="LBB"
+2 DO ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
+3 QUIT
+4 ;
LOCAL ; to extract nightly for local use not to be transmitted to TSI
+1 ; should be queued with a 1D frequency
+2 DO SETUP
DO ^ECXTLOCL
DO ^ECXKILL
QUIT
+3 ;
QUE ; entry point for the background requeuing handled by ECXTAUTO
+1 DO SETUP
DO QUE^ECXTAUTO
DO ^ECXKILL
+2 QUIT
+3 ;
+4 ;ECXLBB
