- 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 Feb 18, 2025@23:18:23 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
