ECXALAR2 ;ALB/TMD-LAR Extract Report of Untranslatable Results ; 8/9/06 9:45am
;;3.0;DSS EXTRACTS;**46,51,112**;Dec 22, 1997;Build 26
;
EN ; entry point
N COUNT
K ^TMP($J)
S COUNT=0
S ECSD=ECSD1,ECED=ECED+.3
D PROCESS
Q
;
PROCESS ;
N QFLG,ECDTST,ECLTST,ECWCDA,ECWC,ECLOC,ECLRN,ECRES,EC2,ECN,ECRS,ECTRS,ECTRANS,ECTRIEN,ECSCDT,ECSCTM,ECXDFN
K ^LAR(64.036) S LRSDT=$P(ECSD,"."),LREDT=$P(ECED,".")
D ^LRCAPDAR
;quit if no completion date for API compile
;I '$P($G(^LAR(64.036,1,2,1,0)),U,4) S ECXERR=1 Q
;build local array of workload codes from DSS LOINC codes
N ECLOINC,ECA K ECLOC,ECA S ECLOINC=0
S ECA("ALL")="" D LOINC^ECXUTL6(.ECA) ;builds ^tmp
F S ECLOINC=$O(^TMP($J,"ECXUTL6",ECLOINC)) Q:(ECLOINC="") D
. S ECWCDA=0 F S ECWCDA=$O(^TMP($J,"ECXUTL6",ECLOINC,ECWCDA)) Q:('ECWCDA) D
.. I ECWCDA S ECWC=$P(^LAM(ECWCDA,0),U,2),ECLOC(ECWCDA)=ECWC
K ECLOINC,ECA
;process temporary lab file #64.036
S QFLG=0,ECLRN=1
F S ECLRN=$O(^LAR(64.036,ECLRN)) Q:('ECLRN)!(QFLG)!(ECXERR) D
.I $D(^LAR(64.036,ECLRN,0)) D
..S EC1=^LAR(64.036,ECLRN,0)
..Q:$P(EC1,U,2)=""
..S ECXDFN=$P(EC1,U,3)
..S ECSCDT=$P(EC1,U,9),ECSCTM=$P(EC1,U,10)
..;loop on results multiple
..S ECRES=0
..F S ECRES=$O(^LAR(64.036,ECLRN,1,ECRES)) Q:('ECRES)!(QFLG)!(ECXERR) D
...I $D(^LAR(64.036,ECLRN,1,ECRES,0)) D Q:QFLG
....S EC2=^LAR(64.036,ECLRN,1,ECRES,0)
....S ECN=$P(EC2,U),ECRS=$P(EC2,U,2),ECWC=+$P(EC2,U,4)
....S ECWC=$S($D(ECLOC(ECWC)):ECLOC(ECWC),1:"")
....; - 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")
.....I ("<>"[$E(ECTRS))!($E(ECTRS,1,2)="GT")!($E(ECTRS,1,2)="LT") Q
.....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 ECTRANS="5~" I ECWC]"" D FILE
K ^LAR(64.036) S ^LAR(64.036,0)="LAB DSS LAR EXTRACT^64.036^"
Q
;
FILE ; put records in temp file to print later
S COUNT=COUNT+1
S ^TMP($J,"ECXALAR2",COUNT)=ECXDFN_U_ECSCDT_U_ECSCTM_U_ECN_U_ECRS
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXALAR2 2385 printed Apr 09, 2024@20:59:16 Page 2
ECXALAR2 ;ALB/TMD-LAR Extract Report of Untranslatable Results ; 8/9/06 9:45am
+1 ;;3.0;DSS EXTRACTS;**46,51,112**;Dec 22, 1997;Build 26
+2 ;
EN ; entry point
+1 NEW COUNT
+2 KILL ^TMP($JOB)
+3 SET COUNT=0
+4 SET ECSD=ECSD1
SET ECED=ECED+.3
+5 DO PROCESS
+6 QUIT
+7 ;
PROCESS ;
+1 NEW QFLG,ECDTST,ECLTST,ECWCDA,ECWC,ECLOC,ECLRN,ECRES,EC2,ECN,ECRS,ECTRS,ECTRANS,ECTRIEN,ECSCDT,ECSCTM,ECXDFN
+2 KILL ^LAR(64.036)
SET LRSDT=$PIECE(ECSD,".")
SET LREDT=$PIECE(ECED,".")
+3 DO ^LRCAPDAR
+4 ;quit if no completion date for API compile
+5 ;I '$P($G(^LAR(64.036,1,2,1,0)),U,4) S ECXERR=1 Q
+6 ;build local array of workload codes from DSS LOINC codes
+7 NEW ECLOINC,ECA
KILL ECLOC,ECA
SET ECLOINC=0
+8 ;builds ^tmp
SET ECA("ALL")=""
DO LOINC^ECXUTL6(.ECA)
+9 FOR
SET ECLOINC=$ORDER(^TMP($JOB,"ECXUTL6",ECLOINC))
if (ECLOINC="")
QUIT
Begin DoDot:1
+10 SET ECWCDA=0
FOR
SET ECWCDA=$ORDER(^TMP($JOB,"ECXUTL6",ECLOINC,ECWCDA))
if ('ECWCDA)
QUIT
Begin DoDot:2
+11 IF ECWCDA
SET ECWC=$PIECE(^LAM(ECWCDA,0),U,2)
SET ECLOC(ECWCDA)=ECWC
End DoDot:2
End DoDot:1
+12 KILL ECLOINC,ECA
+13 ;process temporary lab file #64.036
+14 SET QFLG=0
SET ECLRN=1
+15 FOR
SET ECLRN=$ORDER(^LAR(64.036,ECLRN))
if ('ECLRN)!(QFLG)!(ECXERR)
QUIT
Begin DoDot:1
+16 IF $DATA(^LAR(64.036,ECLRN,0))
Begin DoDot:2
+17 SET EC1=^LAR(64.036,ECLRN,0)
+18 if $PIECE(EC1,U,2)=""
QUIT
+19 SET ECXDFN=$PIECE(EC1,U,3)
+20 SET ECSCDT=$PIECE(EC1,U,9)
SET ECSCTM=$PIECE(EC1,U,10)
+21 ;loop on results multiple
+22 SET ECRES=0
+23 FOR
SET ECRES=$ORDER(^LAR(64.036,ECLRN,1,ECRES))
if ('ECRES)!(QFLG)!(ECXERR)
QUIT
Begin DoDot:3
+24 IF $DATA(^LAR(64.036,ECLRN,1,ECRES,0))
Begin DoDot:4
+25 SET EC2=^LAR(64.036,ECLRN,1,ECRES,0)
+26 SET ECN=$PIECE(EC2,U)
SET ECRS=$PIECE(EC2,U,2)
SET ECWC=+$PIECE(EC2,U,4)
+27 SET ECWC=$SELECT($DATA(ECLOC(ECWC)):ECLOC(ECWC),1:"")
+28 ; - Free text results translation
+29 SET ECTRANS=""
SET ECTRS=ECRS
+30 IF +ECTRS
SET ECTRS=$TRANSLATE(ECTRS,",","")
Begin DoDot:5
+31 IF (ECTRS?.N)!(ECTRS?.N1".".N)
SET ECRS=ECTRS
End DoDot:5
+32 FOR
if $EXTRACT(ECTRS,1)'=" "
QUIT
SET ECTRS=$EXTRACT(ECTRS,2,$LENGTH(ECTRS))
+33 FOR
if $EXTRACT(ECTRS,$LENGTH(ECTRS))'=" "
QUIT
SET ECTRS=$EXTRACT(ECTRS,1,($LENGTH(ECTRS)-1))
+34 ;translate
IF ECTRS]""
IF ECTRS'?.N
IF ECTRS'?.N1".".N
Begin DoDot:5
+35 SET ECTRS=$TRANSLATE(ECRS,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+36 IF ("<>"[$EXTRACT(ECTRS))!($EXTRACT(ECTRS,1,2)="GT")!($EXTRACT(ECTRS,1,2)="LT")
QUIT
+37 SET ECTRIEN=""
SET ECTRIEN=$ORDER(^ECX(727.7,"B",ECTRS,ECTRIEN))
+38 SET ECTRANS=$SELECT(ECTRIEN:$PIECE(^ECX(727.7,ECTRIEN,0),U,2),1:"5~")
End DoDot:5
End DoDot:4
if QFLG
QUIT
+39 IF ECTRANS="5~"
IF ECWC]""
DO FILE
End DoDot:3
End DoDot:2
End DoDot:1
+40 KILL ^LAR(64.036)
SET ^LAR(64.036,0)="LAB DSS LAR EXTRACT^64.036^"
+41 QUIT
+42 ;
FILE ; put records in temp file to print later
+1 SET COUNT=COUNT+1
+2 SET ^TMP($JOB,"ECXALAR2",COUNT)=ECXDFN_U_ECSCDT_U_ECSCTM_U_ECN_U_ECRS
+3 QUIT
