ECXLABR ;ALB/JAP,BIR/CML-LAR Extract for DSS (New Format - With LMIP Codes) ;2/6/19 12:50
;;3.0;DSS EXTRACTS;**8,24,33,37,39,46,71,80,107,105,112,127,144,154,161,170,174**;Dec 22, 1997;Build 33
BEG ;entry point from option
D SETUP I ECFILE="" Q
D ^ECXTRAC,^ECXKILL
Q
;
START ; entry when queued
N X,OK,ECTRS,ECTRANS,ECTRIEN,ECDOC,ECDOCPC,ECXESC,ECXECL,ECXCLST,ECCLASS,ECRETM,ECREDT,ECSCDT,ECSCTM,ECXTIME,ECXASIH ;144,154,170
K ^LAR(64.036) S LRSDT=ECSD,LREDT=ECED
D ^LRCAPDAR
;quit if no completion date for API compile
I '$P($G(^LAR(64.036,1,2,1,0)),U,4) Q
;process temporary lab file #64.036
S QFLG=0,ECLRN=1
F S ECLRN=$O(^LAR(64.036,ECLRN)) Q:('ECLRN)!(QFLG) D
.I $D(^LAR(64.036,ECLRN,0)) D
..S EC1=^LAR(64.036,ECLRN,0),ECF=$P(EC1,U,2)
..Q:ECF=""
..S (ECXESC,ECXECL,ECXCLST)="" ;144
..S ECXDFN=$P(EC1,U,3),ECPTPR=$P($G(EC1),U,11),ECCLASS=""
..S ECXTIME=$S($P(EC1,U,10)="":"000300",1:$P(EC1,U,10))
..S ECXDATE=$P(EC1,U,9)_"."_$P(EC1,U,10)
..I ECPTPR S ECCLASS=$$PRVCLASS^ECXUTL(ECPTPR,ECXDATE)
..I ECPTPR S ECPTNPI=$$NPI^XUSNPI("Individual_ID",ECPTPR,+ECXDATE) D
...S:+ECPTNPI'>0 ECPTNPI="" S ECPTNPI=$P(ECPTNPI,U)
..S ECORDT=$$ECXDATE^ECXUTL($P(EC1,U,4),ECXYM)
..S ECORTM=$$ECXTIME^ECXUTL($P(EC1,U,4)_"."_$P(EC1,U,5))
..S ECREDT=$$ECXDATE^ECXUTL($P(EC1,U,6),ECXYM)
..S ECRETM=$$ECXTIME^ECXUTL($P(EC1,U,6)_"."_$P(EC1,U,7))
..S ECSCDT=$$ECXDATE^ECXUTL($P(EC1,U,9),ECXYM)
..S ECSCTM=$$ECXTIME^ECXUTL($P(EC1,U,9)_"."_$P(EC1,U,10))
..S (ECXADMDT,ECXDOM,ECXDSSD,ECXPNM,ECXSSN,ECXA,ECXMN,ECXTS)=""
..I ECF=2 D Q:'OK
...K ECXPAT S OK=$$PAT^ECXUTL3(ECXDFN,ECXDATE,"1;5",.ECXPAT) ;154 Added service related information (5) to the list
...Q:'OK
...S ECXPNM=ECXPAT("NAME"),ECXSSN=ECXPAT("SSN"),ECXMPI=ECXPAT("MPI")
...S X=$$INP^ECXUTL2(ECXDFN,ECXDATE),ECXA=$P(X,U),ECXADMDT=$P(X,U,4),ECXASIH=$P(X,U,14) ;170
...S ECXMN=$P(X,U,2),ECXTS=$P(X,U,3),ECXDOM=$P(X,U,10)
...S ECXCLST=ECXPAT("CL STAT") ;144
..;allow for referral patients in future??
..;I ECF=67 S ECSN="000123456",ECNA="RFRL"
..;loop on results multiple
..;
..;Get production division ECXDIEN added p-80
..N ECXPDIV,ECXDIEN S ECXDIEN=$O(^DIC(4,"D",ECINST,"")),ECXPDIV=$$RADDIV^ECXDEPT(ECXDIEN) ;p-46
..K ECXDIEN
..;- Observation patient indicator (y/n)
..S ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS)
..;
..;- If no encounter number don't file record
..S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,$P(EC1,U,9),ECXTS,ECXOBS,ECHEAD,,) Q:ECXENC=""
..S ECRES=0
..F S ECRES=$O(^LAR(64.036,ECLRN,1,ECRES)) Q:('ECRES)!(QFLG) D
...I $D(^LAR(64.036,ECLRN,1,ECRES,0)) D Q:QFLG
....S EC2=^LAR(64.036,ECLRN,1,ECRES,0),ECN=$P(EC2,U),ECRS=$P(EC2,U,2)
....S ECHL=$E($P(EC2,U,3)),ECWC=+$P(EC2,U,4)
....I ECWC S ECWC=$P(^LAM(ECWC,0),U,2)
....S ECLNC=$P(EC2,U,5)
.... ; ******* - PATCH 127, ADD PATCAT CODE
....S ECXPATCAT=$$PATCAT^ECXUTL(ECXDFN)
....;
....; - Free text results translation
....S ECTRANS="",ECTRS=ECRS
....I +ECTRS S ECTRS=$TR(ECTRS,",","") D
.....I (ECTRS?.N)!(ECTRS?.N1".".N) S ECRS=ECTRS
....F Q:$E(ECTRS,1)'=" " S ECTRS=$E(ECTRS,2,$L(ECTRS))
....F Q:$E(ECTRS,$L(ECTRS))'=" " S ECTRS=$E(ECTRS,1,($L(ECTRS)-1))
....I ECTRS]"" I ECTRS'?.N I ECTRS'?.N1".".N D ;translate
.....S ECTRS=$TR(ECRS,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
.....S ECTRIEN="",ECTRIEN=$O(^ECX(727.7,"B",ECTRS,ECTRIEN))
.....S ECTRANS=$S(ECTRIEN:$P(^ECX(727.7,ECTRIEN,0),U,2),1:5)
....;
....I $G(ECXASIH) S ECXA="A" ;170
....I ECWC]"" D FILE
K ^LAR(64.036) S ^LAR(64.036,0)="LAB DSS LAR EXTRACT^64.036^"
Q
;
FILE ;file record
;node0
;facility (ECINST)^dfn (ECXDFN)^ssn (ECXSSN)^name(ECXPNM)^in/out (ECXA)^
;day(ECSCDT)^
;lab test code (ECN)^placehold results (ECRS) - pre-2018^hi/lo indicator (ECHL)^
;date ordered (ECORDT)^time ordered (ECORTM)^date ready (ECREDT)^
;time ready (ECRETM)^
;movement file # (ECXMN)^treating specialty (ECXTS)^
;workload code(ECWC)^
;node1
;mpi (ECXMPI)^placeholder (ECXDSSD)^dom (ECXDOM)^time (ECSCTM)^
;observ pat ind (ECXOBS)^encounter num (ECXENC)^prod div ECXPDIV^
;placehold lab results translation ECTRANS^ordering provider (ECPTPR)^
;ordering provider person class (ECCLASS)^ordering provider npi ECPTNPI^LOINC code ECLNC
;Patient Category PATCAT^PLACEHOLD Encounter SC ECXESC^Camp Lejeune Status ECXCLST^PLACEHOLD Encounter Camp Lejeune ECXECL^Long Results (ECRS) post-2018
N DA,DIK
S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
S ECODE=EC7_U_EC23_U_ECINST_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U
S ECODE=ECODE_ECSCDT_U_$$RJ^XLFSTR(ECN,4,0)_U_$S(ECXLOGIC>2018:"",1:$E(ECRS,1,20))_U_ECHL_U_ECORDT_U ;170 Change result field to be null after 2018, otherwise 1st 20 chars
S ECODE=ECODE_$$LJ^XLFSTR(ECORTM,6,0)_U
;convert specialty to PTF Code for transmission
N ECXDATA,ECXTSC
S ECXDATA=$$TSDATA^DGACT(42.4,+ECXTS,.ECXDATA)
S ECXTSC=$G(ECXDATA(7))
;done
S ECODE=ECODE_ECREDT_U_$$LJ^XLFSTR(ECRETM,6,0)_U_ECXMN_U_ECXTSC_U_ECWC_U
S ECODE1=ECXMPI_U_ECXDSSD_U_ECXDOM_U_ECSCTM_U_ECXOBS_U_ECXENC_U_ECXPDIV_U_$S(ECXLOGIC>2019:"",1:ECTRANS) ;174 Remove translated results after FY2019
I ECXLOGIC>2004 S ECODE1=ECODE1_U_2_ECPTPR_U_ECCLASS
I ECXLOGIC>2007 S ECODE1=ECODE1_U_ECPTNPI
I ECXLOGIC>2008 S ECODE1=ECODE1_U_ECLNC
I ECXLOGIC>2010 S ECODE1=ECODE1_U_ECXPATCAT
I ECXLOGIC>2013 S ECODE1=ECODE1_U_ECXESC_U_ECXCLST_U_ECXECL ;144
I ECXLOGIC>2018 S ECODE1=ECODE1_U_ECRS ;170 Longer result moved here
S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,ECRN=ECRN+1
S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1
Q
;
SETUP ;Set required input for ECXTRAC
S ECHEAD="LAR"
D ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
Q
;
QUE ; entry point for the background requeuing handled by ECXTAUTO
D SETUP,QUE^ECXTAUTO,^ECXKILL Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXLABR 5893 printed Oct 16, 2024@17:53:37 Page 2
ECXLABR ;ALB/JAP,BIR/CML-LAR Extract for DSS (New Format - With LMIP Codes) ;2/6/19 12:50
+1 ;;3.0;DSS EXTRACTS;**8,24,33,37,39,46,71,80,107,105,112,127,144,154,161,170,174**;Dec 22, 1997;Build 33
BEG ;entry point from option
+1 DO SETUP
IF ECFILE=""
QUIT
+2 DO ^ECXTRAC
DO ^ECXKILL
+3 QUIT
+4 ;
START ; entry when queued
+1 ;144,154,170
NEW X,OK,ECTRS,ECTRANS,ECTRIEN,ECDOC,ECDOCPC,ECXESC,ECXECL,ECXCLST,ECCLASS,ECRETM,ECREDT,ECSCDT,ECSCTM,ECXTIME,ECXASIH
+2 KILL ^LAR(64.036)
SET LRSDT=ECSD
SET LREDT=ECED
+3 DO ^LRCAPDAR
+4 ;quit if no completion date for API compile
+5 IF '$PIECE($GET(^LAR(64.036,1,2,1,0)),U,4)
QUIT
+6 ;process temporary lab file #64.036
+7 SET QFLG=0
SET ECLRN=1
+8 FOR
SET ECLRN=$ORDER(^LAR(64.036,ECLRN))
if ('ECLRN)!(QFLG)
QUIT
Begin DoDot:1
+9 IF $DATA(^LAR(64.036,ECLRN,0))
Begin DoDot:2
+10 SET EC1=^LAR(64.036,ECLRN,0)
SET ECF=$PIECE(EC1,U,2)
+11 if ECF=""
QUIT
+12 ;144
SET (ECXESC,ECXECL,ECXCLST)=""
+13 SET ECXDFN=$PIECE(EC1,U,3)
SET ECPTPR=$PIECE($GET(EC1),U,11)
SET ECCLASS=""
+14 SET ECXTIME=$SELECT($PIECE(EC1,U,10)="":"000300",1:$PIECE(EC1,U,10))
+15 SET ECXDATE=$PIECE(EC1,U,9)_"."_$PIECE(EC1,U,10)
+16 IF ECPTPR
SET ECCLASS=$$PRVCLASS^ECXUTL(ECPTPR,ECXDATE)
+17 IF ECPTPR
SET ECPTNPI=$$NPI^XUSNPI("Individual_ID",ECPTPR,+ECXDATE)
Begin DoDot:3
+18 if +ECPTNPI'>0
SET ECPTNPI=""
SET ECPTNPI=$PIECE(ECPTNPI,U)
End DoDot:3
+19 SET ECORDT=$$ECXDATE^ECXUTL($PIECE(EC1,U,4),ECXYM)
+20 SET ECORTM=$$ECXTIME^ECXUTL($PIECE(EC1,U,4)_"."_$PIECE(EC1,U,5))
+21 SET ECREDT=$$ECXDATE^ECXUTL($PIECE(EC1,U,6),ECXYM)
+22 SET ECRETM=$$ECXTIME^ECXUTL($PIECE(EC1,U,6)_"."_$PIECE(EC1,U,7))
+23 SET ECSCDT=$$ECXDATE^ECXUTL($PIECE(EC1,U,9),ECXYM)
+24 SET ECSCTM=$$ECXTIME^ECXUTL($PIECE(EC1,U,9)_"."_$PIECE(EC1,U,10))
+25 SET (ECXADMDT,ECXDOM,ECXDSSD,ECXPNM,ECXSSN,ECXA,ECXMN,ECXTS)=""
+26 IF ECF=2
Begin DoDot:3
+27 ;154 Added service related information (5) to the list
KILL ECXPAT
SET OK=$$PAT^ECXUTL3(ECXDFN,ECXDATE,"1;5",.ECXPAT)
+28 if 'OK
QUIT
+29 SET ECXPNM=ECXPAT("NAME")
SET ECXSSN=ECXPAT("SSN")
SET ECXMPI=ECXPAT("MPI")
+30 ;170
SET X=$$INP^ECXUTL2(ECXDFN,ECXDATE)
SET ECXA=$PIECE(X,U)
SET ECXADMDT=$PIECE(X,U,4)
SET ECXASIH=$PIECE(X,U,14)
+31 SET ECXMN=$PIECE(X,U,2)
SET ECXTS=$PIECE(X,U,3)
SET ECXDOM=$PIECE(X,U,10)
+32 ;144
SET ECXCLST=ECXPAT("CL STAT")
End DoDot:3
if 'OK
QUIT
+33 ;allow for referral patients in future??
+34 ;I ECF=67 S ECSN="000123456",ECNA="RFRL"
+35 ;loop on results multiple
+36 ;
+37 ;Get production division ECXDIEN added p-80
+38 ;p-46
NEW ECXPDIV,ECXDIEN
SET ECXDIEN=$ORDER(^DIC(4,"D",ECINST,""))
SET ECXPDIV=$$RADDIV^ECXDEPT(ECXDIEN)
+39 KILL ECXDIEN
+40 ;- Observation patient indicator (y/n)
+41 SET ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS)
+42 ;
+43 ;- If no encounter number don't file record
+44 SET ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,$PIECE(EC1,U,9),ECXTS,ECXOBS,ECHEAD,,)
if ECXENC=""
QUIT
+45 SET ECRES=0
+46 FOR
SET ECRES=$ORDER(^LAR(64.036,ECLRN,1,ECRES))
if ('ECRES)!(QFLG)
QUIT
Begin DoDot:3
+47 IF $DATA(^LAR(64.036,ECLRN,1,ECRES,0))
Begin DoDot:4
+48 SET EC2=^LAR(64.036,ECLRN,1,ECRES,0)
SET ECN=$PIECE(EC2,U)
SET ECRS=$PIECE(EC2,U,2)
+49 SET ECHL=$EXTRACT($PIECE(EC2,U,3))
SET ECWC=+$PIECE(EC2,U,4)
+50 IF ECWC
SET ECWC=$PIECE(^LAM(ECWC,0),U,2)
+51 SET ECLNC=$PIECE(EC2,U,5)
+52 ; ******* - PATCH 127, ADD PATCAT CODE
+53 SET ECXPATCAT=$$PATCAT^ECXUTL(ECXDFN)
+54 ;
+55 ; - Free text results translation
+56 SET ECTRANS=""
SET ECTRS=ECRS
+57 IF +ECTRS
SET ECTRS=$TRANSLATE(ECTRS,",","")
Begin DoDot:5
+58 IF (ECTRS?.N)!(ECTRS?.N1".".N)
SET ECRS=ECTRS
End DoDot:5
+59 FOR
if $EXTRACT(ECTRS,1)'=" "
QUIT
SET ECTRS=$EXTRACT(ECTRS,2,$LENGTH(ECTRS))
+60 FOR
if $EXTRACT(ECTRS,$LENGTH(ECTRS))'=" "
QUIT
SET ECTRS=$EXTRACT(ECTRS,1,($LENGTH(ECTRS)-1))
+61 ;translate
IF ECTRS]""
IF ECTRS'?.N
IF ECTRS'?.N1".".N
Begin DoDot:5
+62 SET ECTRS=$TRANSLATE(ECRS,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+63 SET ECTRIEN=""
SET ECTRIEN=$ORDER(^ECX(727.7,"B",ECTRS,ECTRIEN))
+64 SET ECTRANS=$SELECT(ECTRIEN:$PIECE(^ECX(727.7,ECTRIEN,0),U,2),1:5)
End DoDot:5
+65 ;
+66 ;170
IF $GET(ECXASIH)
SET ECXA="A"
+67 IF ECWC]""
DO FILE
End DoDot:4
if QFLG
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+68 KILL ^LAR(64.036)
SET ^LAR(64.036,0)="LAB DSS LAR EXTRACT^64.036^"
+69 QUIT
+70 ;
FILE ;file record
+1 ;node0
+2 ;facility (ECINST)^dfn (ECXDFN)^ssn (ECXSSN)^name(ECXPNM)^in/out (ECXA)^
+3 ;day(ECSCDT)^
+4 ;lab test code (ECN)^placehold results (ECRS) - pre-2018^hi/lo indicator (ECHL)^
+5 ;date ordered (ECORDT)^time ordered (ECORTM)^date ready (ECREDT)^
+6 ;time ready (ECRETM)^
+7 ;movement file # (ECXMN)^treating specialty (ECXTS)^
+8 ;workload code(ECWC)^
+9 ;node1
+10 ;mpi (ECXMPI)^placeholder (ECXDSSD)^dom (ECXDOM)^time (ECSCTM)^
+11 ;observ pat ind (ECXOBS)^encounter num (ECXENC)^prod div ECXPDIV^
+12 ;placehold lab results translation ECTRANS^ordering provider (ECPTPR)^
+13 ;ordering provider person class (ECCLASS)^ordering provider npi ECPTNPI^LOINC code ECLNC
+14 ;Patient Category PATCAT^PLACEHOLD Encounter SC ECXESC^Camp Lejeune Status ECXCLST^PLACEHOLD Encounter Camp Lejeune ECXECL^Long Results (ECRS) post-2018
+15 NEW DA,DIK
+16 SET EC7=$ORDER(^ECX(ECFILE,999999999),-1)
SET EC7=EC7+1
+17 SET ECODE=EC7_U_EC23_U_ECINST_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U
+18 ;170 Change result field to be null after 2018, otherwise 1st 20 chars
SET ECODE=ECODE_ECSCDT_U_$$RJ^XLFSTR(ECN,4,0)_U_$SELECT(ECXLOGIC>2018:"",1:$EXTRACT(ECRS,1,20))_U_ECHL_U_ECORDT_U
+19 SET ECODE=ECODE_$$LJ^XLFSTR(ECORTM,6,0)_U
+20 ;convert specialty to PTF Code for transmission
+21 NEW ECXDATA,ECXTSC
+22 SET ECXDATA=$$TSDATA^DGACT(42.4,+ECXTS,.ECXDATA)
+23 SET ECXTSC=$GET(ECXDATA(7))
+24 ;done
+25 SET ECODE=ECODE_ECREDT_U_$$LJ^XLFSTR(ECRETM,6,0)_U_ECXMN_U_ECXTSC_U_ECWC_U
+26 ;174 Remove translated results after FY2019
SET ECODE1=ECXMPI_U_ECXDSSD_U_ECXDOM_U_ECSCTM_U_ECXOBS_U_ECXENC_U_ECXPDIV_U_$SELECT(ECXLOGIC>2019:"",1:ECTRANS)
+27 IF ECXLOGIC>2004
SET ECODE1=ECODE1_U_2_ECPTPR_U_ECCLASS
+28 IF ECXLOGIC>2007
SET ECODE1=ECODE1_U_ECPTNPI
+29 IF ECXLOGIC>2008
SET ECODE1=ECODE1_U_ECLNC
+30 IF ECXLOGIC>2010
SET ECODE1=ECODE1_U_ECXPATCAT
+31 ;144
IF ECXLOGIC>2013
SET ECODE1=ECODE1_U_ECXESC_U_ECXCLST_U_ECXECL
+32 ;170 Longer result moved here
IF ECXLOGIC>2018
SET ECODE1=ECODE1_U_ECRS
+33 SET ^ECX(ECFILE,EC7,0)=ECODE
SET ^ECX(ECFILE,EC7,1)=ECODE1
SET ECRN=ECRN+1
+34 SET DA=EC7
SET DIK="^ECX("_ECFILE_","
DO IX1^DIK
KILL DIK,DA
+35 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
SET QFLG=1
+36 QUIT
+37 ;
SETUP ;Set required input for ECXTRAC
+1 SET ECHEAD="LAR"
+2 DO ECXDEF^ECXUTL2(ECHEAD,.ECPACK,.ECGRP,.ECFILE,.ECRTN,.ECPIECE,.ECVER)
+3 QUIT
+4 ;
QUE ; entry point for the background requeuing handled by ECXTAUTO
+1 DO SETUP
DO QUE^ECXTAUTO
DO ^ECXKILL
QUIT
