ECXLABO ;BIR/MAM,DMA,CML-Lab Extract for DSS (Old Version - W/O LMIP Codes); [ 11/22/96 5:28 PM ]
;;3.0;DSS EXTRACTS;**11**;Dec 22, 1997
V ;;2.0T11;DSS EXTRACTS;**24**;DEC 18,1996
;This routine was originally called ECXLAB1, as called from the DSS menu. Now ECXLAB1 is the driver routine to call ECXLABO (old format) or ECXLABN (new format)
D SETUP,^ECXTRAC
END D ^ECXKILL
Q
START ; entry when queued
S QFLG=0
S ECED=ECED+.3
K ECXDD D FIELD^DID(69.01,7,,"SPECIFIER","ECXDD") S ECPROF=$E(+$P(ECXDD("SPECIFIER"),"P",2)) K ECXDD ; provider points to
S ECD=ECSD1 F S ECD=$O(^LRO(69,ECD)),ECLRN=0 Q:'ECD Q:ECD>ECED F S ECLRN=$O(^LRO(69,ECD,1,ECLRN)) Q:'ECLRN I $D(^(ECLRN,0)) S EC1=^(0),ECDOC=ECPROF_$P(EC1,"^",6),ECLOC=$P(EC1,"^",9),EC=$G(^LR(+EC1,0)) I EC]"" D Q:QFLG
.S ECDT=$P(EC1,"^",5),ECTM=$$ECXTIME^ECXUTL(ECDT)
.S (ECNA,ECSN,ECMN,ECTREAT,ECPTTM,ECPTPR)="",ECA=1
.S ECF=$P(EC,"^",2),ECIFN=$P(EC,"^",3)
.I ECF=2,$D(^DPT(ECIFN,0)) D
..S EC0=^(0),ECNA=$E($P($P(EC0,"^"),",")_" ",1,4),ECSN=$P(EC0,"^",9) K VAIP S VAIP("D")=ECD,DFN=ECIFN D IN5^VADPT S ECMN=VAIP(1) I ECMN S ECA=3,ECTREAT=$P($G(^DIC(45.7,+VAIP(8),0)),"^",2)
..S ECPTTM=+$$OUTPTTM^ECXUTL3(DFN,ECDT)
..S:ECPTTM=0 ECPTTM=""
..S ECPTPR=+$$OUTPTPR^ECXUTL3(DFN,ECDT)
..S:ECPTPR=0 ECPTPR=""
.K VAIP,VAERR
.I ECF=67 S ECSN="000123456",ECNA="RFRL"
.I ECF=67.1 S ECSN=888888888,ECNA="RSCH"
.I ECNA]"" S J=0 F S J=$O(^LRO(69,ECD,1,ECLRN,2,J)) Q:'J S EC=$G(^(J,0)) I EC]"" S ECT=$P(EC,"^"),ECURG=$P(EC,"^",2),EC=+$P(EC,"^",4),ECACA=EC_"^"_$P($G(^LRO(68,EC,0)),"^",11) I EC D
..S ECODE=ECINST_"^"_ECIFN_"^"_ECSN_"^"_ECNA_"^"_ECA_"^"_$$ECXDATE^ECXUTL(ECD,ECXYM)_"^"_ECACA_"^"_ECT_"^"_ECURG_"^"_ECTREAT_"^"_ECLOC_"^"_ECDOC_"^"_ECMN_"^"_ECF_"^"_ECTM_"^^"_ECPTTM_"^"_ECPTPR_"^"
..;inst^patient (or thing) number^SSN (or equivalent)^name^in/out^day^accession area^abbreviation^test^urgency^treating spec^location^provider and file^
..;movement number^file^time^workload code^primary care team^primary care provider
..;(ECACA=acc area^abbreviation)
..S EC7=-$O(^ECX(ECFILE,"AINV","")) F S EC7=EC7+1 Q:'$D(^ECX(ECFILE,EC7))
..S ^ECX(ECFILE,EC7,0)=EC7_"^"_EC23_"^"_ECODE,ECRN=ECRN+1 S DA=EC7,DIK="^ECX("_ECFILE_"," D IX^DIK K DIK,DA
.I $D(ZTQUEUED),(ECRN>499),'(ECRN#500),$$S^%ZTLOAD S QFLG=1
Q
;
SETUP S ECPACK="Laboratory",ECPIECE=1,ECRTN="START^ECXLABO",ECGRP="LAB",ECHEAD="LAB",ECFILE=727.813,ECVER=3
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[HECXLABO 2541 printed Apr 09, 2024@20:56:45 Page 2
ECXLABO ;BIR/MAM,DMA,CML-Lab Extract for DSS (Old Version - W/O LMIP Codes); [ 11/22/96 5:28 PM ]
+1 ;;3.0;DSS EXTRACTS;**11**;Dec 22, 1997
V ;;2.0T11;DSS EXTRACTS;**24**;DEC 18,1996
+1 ;This routine was originally called ECXLAB1, as called from the DSS menu. Now ECXLAB1 is the driver routine to call ECXLABO (old format) or ECXLABN (new format)
+2 DO SETUP
DO ^ECXTRAC
END DO ^ECXKILL
+1 QUIT
START ; entry when queued
+1 SET QFLG=0
+2 SET ECED=ECED+.3
+3 ; provider points to
KILL ECXDD
DO FIELD^DID(69.01,7,,"SPECIFIER","ECXDD")
SET ECPROF=$EXTRACT(+$PIECE(ECXDD("SPECIFIER"),"P",2))
KILL ECXDD
+4 SET ECD=ECSD1
FOR
SET ECD=$ORDER(^LRO(69,ECD))
SET ECLRN=0
if 'ECD
QUIT
if ECD>ECED
QUIT
FOR
SET ECLRN=$ORDER(^LRO(69,ECD,1,ECLRN))
if 'ECLRN
QUIT
IF $DATA(^(ECLRN,0))
SET EC1=^(0)
SET ECDOC=ECPROF_$PIECE(EC1,"^",6)
SET ECLOC=$PIECE(EC1,"^",9)
SET EC=$GET(^LR(+EC1,0))
IF EC]""
Begin DoDot:1
+5 SET ECDT=$PIECE(EC1,"^",5)
SET ECTM=$$ECXTIME^ECXUTL(ECDT)
+6 SET (ECNA,ECSN,ECMN,ECTREAT,ECPTTM,ECPTPR)=""
SET ECA=1
+7 SET ECF=$PIECE(EC,"^",2)
SET ECIFN=$PIECE(EC,"^",3)
+8 IF ECF=2
IF $DATA(^DPT(ECIFN,0))
Begin DoDot:2
+9 SET EC0=^(0)
SET ECNA=$EXTRACT($PIECE($PIECE(EC0,"^"),",")_" ",1,4)
SET ECSN=$PIECE(EC0,"^",9)
KILL VAIP
SET VAIP("D")=ECD
SET DFN=ECIFN
DO IN5^VADPT
SET ECMN=VAIP(1)
IF ECMN
SET ECA=3
SET ECTREAT=$PIECE($GET(^DIC(45.7,+VAIP(8),0)),"^",2)
+10 SET ECPTTM=+$$OUTPTTM^ECXUTL3(DFN,ECDT)
+11 if ECPTTM=0
SET ECPTTM=""
+12 SET ECPTPR=+$$OUTPTPR^ECXUTL3(DFN,ECDT)
+13 if ECPTPR=0
SET ECPTPR=""
End DoDot:2
+14 KILL VAIP,VAERR
+15 IF ECF=67
SET ECSN="000123456"
SET ECNA="RFRL"
+16 IF ECF=67.1
SET ECSN=888888888
SET ECNA="RSCH"
+17 IF ECNA]""
SET J=0
FOR
SET J=$ORDER(^LRO(69,ECD,1,ECLRN,2,J))
if 'J
QUIT
SET EC=$GET(^(J,0))
IF EC]""
SET ECT=$PIECE(EC,"^")
SET ECURG=$PIECE(EC,"^",2)
SET EC=+$PIECE(EC,"^",4)
SET ECACA=EC_"^"_$PIECE($GET(^LRO(68,EC,0)),"^",11)
IF EC
Begin DoDot:2
+18 SET ECODE=ECINST_"^"_ECIFN_"^"_ECSN_"^"_ECNA_"^"_ECA_"^"_$$ECXDATE^ECXUTL(ECD,ECXYM)_"^"_ECACA_"^"_ECT_"^"_ECURG_"^"_ECTREAT_"^"_ECLOC_"^"_ECDOC_"^"_ECMN_"^"_ECF_"^"_ECTM_"^^"_ECPTTM_"^"_ECPTPR_"^"
+19 ;inst^patient (or thing) number^SSN (or equivalent)^name^in/out^day^accession area^abbreviation^test^urgency^treating spec^location^provider and file^
+20 ;movement number^file^time^workload code^primary care team^primary care provider
+21 ;(ECACA=acc area^abbreviation)
+22 SET EC7=-$ORDER(^ECX(ECFILE,"AINV",""))
FOR
SET EC7=EC7+1
if '$DATA(^ECX(ECFILE,EC7))
QUIT
+23 SET ^ECX(ECFILE,EC7,0)=EC7_"^"_EC23_"^"_ECODE
SET ECRN=ECRN+1
SET DA=EC7
SET DIK="^ECX("_ECFILE_","
DO IX^DIK
KILL DIK,DA
End DoDot:2
+24 IF $DATA(ZTQUEUED)
IF (ECRN>499)
IF '(ECRN#500)
IF $$S^%ZTLOAD
SET QFLG=1
End DoDot:1
if QFLG
QUIT
+25 QUIT
+26 ;
SETUP SET ECPACK="Laboratory"
SET ECPIECE=1
SET ECRTN="START^ECXLABO"
SET ECGRP="LAB"
SET ECHEAD="LAB"
SET ECFILE=727.813
SET ECVER=3
+1 QUIT
+2 ;
+3 ;
QUE ; entry point for the background requeuing handled by ECXTAUTO
+1 DO SETUP
DO QUE^ECXTAUTO
DO ^ECXKILL
QUIT
