ECXLBB.m

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 ---ECXLBB   10576     printed  Mar 13, 2025@20:57:35                                                                                                                                                                                                     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