ECXLARPT ;ALB/DHH-LAR Results LOINC CODE Report ;10/22/13 17:36
;;3.0;DSS EXTRACTS;**112,120,144,148**;Dec 22, 1997;Build 3
;
EN ; entry point
N X,Y,DATE,ECRUN,ECXDESC,ECXSAVE,ECXTL,ECTHLD,CNT,ECXPORT ;144
N ECSD,ECSD1,ECSTART,ECED,ECEND,ECXERR,QFLG,ECXFLAG
; get today's date
D NOW^%DTC S DATE=X,Y=$E(%,1,12) D DD^%DT S ECRUN=$P(Y,"@") K %DT
S ECXDESC="LAB Results LOINC CODE Report"
S ECXSAVE("EC*")=""
S ECXPORT=$$EXPORT^ECXUTL1 Q:ECXPORT=-1 I ECXPORT D Q ;144
.K ^TMP($J,"ECXPORT") ;144
.S ^TMP($J,"ECXPORT",0)="LAR TEST# (#727.29)^LAR TEST NAME (#727.29)^LAR UNITS (#727.29)^LAR LOINC (#727.29)^FLAG^LOCAL TEST NAME (#64)^LOC SPEC TYPE (#64)^LOC WKLD IEN (#64)^LOC WKLD CODE (#64)" ;144
.S CNT=1 ;144
.D PROCESS ;144
.D EXPDISP^ECXUTL1 ;144
.D ^ECXKILL ;144
W !!,"This report requires 132-column format."
D EN^XUTMDEVQ("PROCESS^ECXLARPT",ECXDESC,.ECXSAVE)
I POP W !!,"No device selected...exiting.",! Q
I IO'=IO(0) D ^%ZISC
D HOME^%ZIS
D AUDIT^ECXKILL
Q
;
;
PROCESS ; entry point for queued report
S ZTREQ="@" N ECXDIV
D DEFAULT^ECXDVSN(.ECXDIV,1,.ECXERR)
Q:ECXERR=1
N TNUM,DSSNM,TSTNM,SPECNM,RU,ECXLNC,LLNC,I,J,K,L,M,N,WKLD,WKLDCD,SPEC,TA,LTEST,A
S A("ALL")=""
D LOINC^ECXUTL6(.A)
K ^TMP($J,"ECXLARPT")
S ECXLNC="" F I=0:0 S ECXLNC=$O(^TMP($J,"ECXUTL6",ECXLNC)) Q:ECXLNC']"" D
. S RU=$P(^TMP($J,"ECXUTL6",ECXLNC),U,4) S:$G(RU)="" RU="UNKNOWN"
. S TNUM=$P(^TMP($J,"ECXUTL6",ECXLNC),U,2)
. S DSSNM=$P(^TMP($J,"ECXUTL6",ECXLNC),U,3)
. I '$O(^TMP($J,"ECXUTL6",ECXLNC,0)) D
.. S ^TMP($J,"ECXLARPT",TNUM,DSSNM,"ZZZZ","ZZZZ",RU,ECXLNC)=""
. S WKLD="" F J=0:0 S WKLD=$O(^TMP($J,"ECXUTL6",ECXLNC,WKLD)) Q:WKLD']"" D
.. S SPEC="" F K=0:0 S SPEC=$O(^TMP($J,"ECXUTL6",ECXLNC,WKLD,SPEC)) Q:SPEC']"" D
... S LTEST="" F M=0:0 S LTEST=$O(^TMP($J,"ECXUTL6",ECXLNC,WKLD,SPEC,LTEST)) Q:LTEST']"" D
.... S SPECNM=$P(^TMP($J,"ECXUTL6",ECXLNC,WKLD,SPEC,LTEST),U,2)
.... I SPECNM="DEFAULT LOINC" Q ;ECXUTL6 default loinc not functionally correct
.... ;I SPECNM="DEFAULT LOINC" S SPECNM="ZZDEFAULT LOINC"
.... S TSTNM=$P(^TMP($J,"ECXUTL6",ECXLNC,WKLD,SPEC,LTEST),U,3) S:$G(TSTNM)="" TSTNM="UNKNOWN"
.... S WKLDCD=$S($D(^LAM(WKLD,0)):$P(^(0),"^",2),1:"")
.... S LLNC=$P(^TMP($J,"ECXUTL6",ECXLNC,WKLD,SPEC,LTEST),U,4)
.... S ^TMP($J,"ECXLARPT",TNUM,DSSNM,TSTNM,SPECNM,RU,ECXLNC)=WKLD_"^"_WKLDCD_"^"_LLNC
D PRINT
Q
;
PRINT ; process temp file and print report
N PG,QFLG,GTOT,LN,COUNT,VOL,SUB,REC,WKLD1
U IO
I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ Q
S (PG,QFLG,GTOT,COUNT)=0,$P(LN,"-",132)=""
I '$G(ECXPORT) D HEADER Q:QFLG ;144
S COUNT=COUNT+1
S TNUM=0 F I=0:0 S TNUM=$O(^TMP($J,"ECXLARPT",TNUM)) Q:'TNUM D Q:QFLG
. S DSSNM="" F J=0:0 S DSSNM=$O(^TMP($J,"ECXLARPT",TNUM,DSSNM)) Q:DSSNM']"" D Q:QFLG
.. S TSTNM="" F K=0:0 S TSTNM=$O(^TMP($J,"ECXLARPT",TNUM,DSSNM,TSTNM)) Q:TSTNM']"" D Q:QFLG
... S SPECNM="" F L=0:0 S SPECNM=$O(^TMP($J,"ECXLARPT",TNUM,DSSNM,TSTNM,SPECNM)) Q:SPECNM']"" D Q:QFLG
.... S RU="" F M=0:0 S RU=$O(^TMP($J,"ECXLARPT",TNUM,DSSNM,TSTNM,SPECNM,RU)) Q:RU']"" D Q:QFLG
..... S ECXLNC="" F N=0:0 S ECXLNC=$O(^TMP($J,"ECXLARPT",TNUM,DSSNM,TSTNM,SPECNM,RU,ECXLNC)) Q:ECXLNC']"" D Q:QFLG
...... S WKLD1=$P(^TMP($J,"ECXLARPT",TNUM,DSSNM,TSTNM,SPECNM,RU,ECXLNC),"^")
...... S WKLDCD=$P(^TMP($J,"ECXLARPT",TNUM,DSSNM,TSTNM,SPECNM,RU,ECXLNC),"^",2)
...... S LLNC=$P(^TMP($J,"ECXLARPT",TNUM,DSSNM,TSTNM,SPECNM,RU,ECXLNC),"^",3)
...... I $G(ECXPORT) D Q ;144
....... S ^TMP($J,"ECXPORT",CNT)=TNUM_U_DSSNM_U_RU_U_ECXLNC_U_$S(WKLD1="":"*",1:"")_U_$S(TSTNM'="ZZZZ":TSTNM,1:"")_U_$S(SPECNM'="ZZZZ":$S(SPECNM="ZZDEFAULT LOINC":"DEFAULT LOINC",1:SPECNM),1:"")_U_WKLD1_U_WKLDCD ;144
....... S CNT=CNT+1 ;144
...... W !,$$RJ^XLFSTR(TNUM,4,"0"),?11,$E(DSSNM,1,24),?37,$E(RU,1,13),?53,$$RJ^XLFSTR(ECXLNC,10," ") ;,?56,$$RJ^XLFSTR(LLNC,10," ")
...... I WKLD1="" W ?67,"*"
...... ;I SPECNM'="ZZDEFAULT LOINC",$P(LLNC,"(")'=ECXLNC W ?67,"*"
...... W ?71,$S(TSTNM'="ZZZZ":$E(TSTNM,1,24),1:" ")
...... W ?97,$S(SPECNM'="ZZZZ":$S(SPECNM="ZZDEFAULT LOINC":"DEFAULT LOINC",1:$E(SPECNM,1,13)),1:" "),?112,$$RJ^XLFSTR(WKLD1,8," "),?122,$$RJ^XLFSTR(WKLDCD,10," ")
...... S COUNT=COUNT+1
...... I $Y+3>IOSL D HEADER Q:QFLG
I $G(ECXPORT) Q ;144 stop processing if exporting
W !!,"FLG ('*'=site not using LOINC code that DSS collects)"
Q:QFLG
CLOSE ;
I $E(IOST)="C",'QFLG D
.S SS=22-$Y F JJ=1:1:SS W !
.S DIR(0)="E" W ! D ^DIR K DIR
K ^TMP($J,"ECXLARPT")
Q
;
N SS,JJ
I $E(IOST)="C" D
.S SS=22-$Y F JJ=1:1:SS W !
.I PG>0 S DIR(0)="E" W ! D ^DIR K DIR S:'Y QFLG=1
Q:QFLG
W:$Y!($E(IOST)="C") @IOF S PG=PG+1
W !,"LAB RESULTS DSS LOINC CODE REPORT",?124,"Page: "_PG
W !,"Report Run Date/Time: "_ECRUN
W !,"DSS Site: "_$P(ECXDIV(1),U,2)_" ("_$P(ECXDIV(1),U,3)_")"
;W !,?97,"LOC",?117,"LOC",?122,"LOC"
;W !!,?68,"F",!,"LAR",?49,"LAR",?61,"LOCAL",?68,"L",?97,"LOC SPEC",?113,"LOC WKLD",?122,"LOC WKLD"
;W !,"TEST#",?7,"LAR TEST NAME",?33,"LAR UNITS",?49,"LOINC",?61,"LOINC",?68,"G",?71,"LOCAL TEST NAME",?99,"TYPE",?115,"IEN",?125,"CD"
W !!,?67,"F",?97,"LOC SPEC",?113,"LOC WKLD",?122,"LOC WKLD"
W !,"LAR TEST#",?11,"LAR TEST NAME",?37,"LAR UNITS",?53,"LAR LOINC",?67,"L",?71,"LOCAL TEST NAME",?99,"TYPE",?115,"IEN",?124,"CODE"
W !,"(#727.29)",?13,"(#727.29)",?37,"(#727.29)",?53,"(#727.29)",?67,"G",?76,"(#64)",?99,"(#64)",?115,"(#64)",?124,"(#64)"
W !,LN,!
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXLARPT 5505 printed Dec 13, 2024@01:52:54 Page 2
ECXLARPT ;ALB/DHH-LAR Results LOINC CODE Report ;10/22/13 17:36
+1 ;;3.0;DSS EXTRACTS;**112,120,144,148**;Dec 22, 1997;Build 3
+2 ;
EN ; entry point
+1 ;144
NEW X,Y,DATE,ECRUN,ECXDESC,ECXSAVE,ECXTL,ECTHLD,CNT,ECXPORT
+2 NEW ECSD,ECSD1,ECSTART,ECED,ECEND,ECXERR,QFLG,ECXFLAG
+3 ; get today's date
+4 DO NOW^%DTC
SET DATE=X
SET Y=$EXTRACT(%,1,12)
DO DD^%DT
SET ECRUN=$PIECE(Y,"@")
KILL %DT
+5 SET ECXDESC="LAB Results LOINC CODE Report"
+6 SET ECXSAVE("EC*")=""
+7 ;144
SET ECXPORT=$$EXPORT^ECXUTL1
if ECXPORT=-1
QUIT
IF ECXPORT
Begin DoDot:1
+8 ;144
KILL ^TMP($JOB,"ECXPORT")
+9 ;144
SET ^TMP($JOB,"ECXPORT",0)="LAR TEST# (#727.29)^LAR TEST NAME (#727.29)^LAR UNITS (#727.29)^LAR LOINC (#727.29)^FLAG^LOCAL TEST NAME (#64)^LOC SPEC TYPE (#64)^LOC WKLD IEN (#64)^LOC WKLD CODE (#64)"
+10 ;144
SET CNT=1
+11 ;144
DO PROCESS
+12 ;144
DO EXPDISP^ECXUTL1
+13 ;144
DO ^ECXKILL
End DoDot:1
QUIT
+14 WRITE !!,"This report requires 132-column format."
+15 DO EN^XUTMDEVQ("PROCESS^ECXLARPT",ECXDESC,.ECXSAVE)
+16 IF POP
WRITE !!,"No device selected...exiting.",!
QUIT
+17 IF IO'=IO(0)
DO ^%ZISC
+18 DO HOME^%ZIS
+19 DO AUDIT^ECXKILL
+20 QUIT
+21 ;
+22 ;
PROCESS ; entry point for queued report
+1 SET ZTREQ="@"
NEW ECXDIV
+2 DO DEFAULT^ECXDVSN(.ECXDIV,1,.ECXERR)
+3 if ECXERR=1
QUIT
+4 NEW TNUM,DSSNM,TSTNM,SPECNM,RU,ECXLNC,LLNC,I,J,K,L,M,N,WKLD,WKLDCD,SPEC,TA,LTEST,A
+5 SET A("ALL")=""
+6 DO LOINC^ECXUTL6(.A)
+7 KILL ^TMP($JOB,"ECXLARPT")
+8 SET ECXLNC=""
FOR I=0:0
SET ECXLNC=$ORDER(^TMP($JOB,"ECXUTL6",ECXLNC))
if ECXLNC']""
QUIT
Begin DoDot:1
+9 SET RU=$PIECE(^TMP($JOB,"ECXUTL6",ECXLNC),U,4)
if $GET(RU)=""
SET RU="UNKNOWN"
+10 SET TNUM=$PIECE(^TMP($JOB,"ECXUTL6",ECXLNC),U,2)
+11 SET DSSNM=$PIECE(^TMP($JOB,"ECXUTL6",ECXLNC),U,3)
+12 IF '$ORDER(^TMP($JOB,"ECXUTL6",ECXLNC,0))
Begin DoDot:2
+13 SET ^TMP($JOB,"ECXLARPT",TNUM,DSSNM,"ZZZZ","ZZZZ",RU,ECXLNC)=""
End DoDot:2
+14 SET WKLD=""
FOR J=0:0
SET WKLD=$ORDER(^TMP($JOB,"ECXUTL6",ECXLNC,WKLD))
if WKLD']""
QUIT
Begin DoDot:2
+15 SET SPEC=""
FOR K=0:0
SET SPEC=$ORDER(^TMP($JOB,"ECXUTL6",ECXLNC,WKLD,SPEC))
if SPEC']""
QUIT
Begin DoDot:3
+16 SET LTEST=""
FOR M=0:0
SET LTEST=$ORDER(^TMP($JOB,"ECXUTL6",ECXLNC,WKLD,SPEC,LTEST))
if LTEST']""
QUIT
Begin DoDot:4
+17 SET SPECNM=$PIECE(^TMP($JOB,"ECXUTL6",ECXLNC,WKLD,SPEC,LTEST),U,2)
+18 ;ECXUTL6 default loinc not functionally correct
IF SPECNM="DEFAULT LOINC"
QUIT
+19 ;I SPECNM="DEFAULT LOINC" S SPECNM="ZZDEFAULT LOINC"
+20 SET TSTNM=$PIECE(^TMP($JOB,"ECXUTL6",ECXLNC,WKLD,SPEC,LTEST),U,3)
if $GET(TSTNM)=""
SET TSTNM="UNKNOWN"
+21 SET WKLDCD=$SELECT($DATA(^LAM(WKLD,0)):$PIECE(^(0),"^",2),1:"")
+22 SET LLNC=$PIECE(^TMP($JOB,"ECXUTL6",ECXLNC,WKLD,SPEC,LTEST),U,4)
+23 SET ^TMP($JOB,"ECXLARPT",TNUM,DSSNM,TSTNM,SPECNM,RU,ECXLNC)=WKLD_"^"_WKLDCD_"^"_LLNC
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+24 DO PRINT
+25 QUIT
+26 ;
PRINT ; process temp file and print report
+1 NEW PG,QFLG,GTOT,LN,COUNT,VOL,SUB,REC,WKLD1
+2 USE IO
+3 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
SET ZTSTOP=1
KILL ZTREQ
QUIT
+4 SET (PG,QFLG,GTOT,COUNT)=0
SET $PIECE(LN,"-",132)=""
+5 ;144
IF '$GET(ECXPORT)
DO HEADER
if QFLG
QUIT
+6 SET COUNT=COUNT+1
+7 SET TNUM=0
FOR I=0:0
SET TNUM=$ORDER(^TMP($JOB,"ECXLARPT",TNUM))
if 'TNUM
QUIT
Begin DoDot:1
+8 SET DSSNM=""
FOR J=0:0
SET DSSNM=$ORDER(^TMP($JOB,"ECXLARPT",TNUM,DSSNM))
if DSSNM']""
QUIT
Begin DoDot:2
+9 SET TSTNM=""
FOR K=0:0
SET TSTNM=$ORDER(^TMP($JOB,"ECXLARPT",TNUM,DSSNM,TSTNM))
if TSTNM']""
QUIT
Begin DoDot:3
+10 SET SPECNM=""
FOR L=0:0
SET SPECNM=$ORDER(^TMP($JOB,"ECXLARPT",TNUM,DSSNM,TSTNM,SPECNM))
if SPECNM']""
QUIT
Begin DoDot:4
+11 SET RU=""
FOR M=0:0
SET RU=$ORDER(^TMP($JOB,"ECXLARPT",TNUM,DSSNM,TSTNM,SPECNM,RU))
if RU']""
QUIT
Begin DoDot:5
+12 SET ECXLNC=""
FOR N=0:0
SET ECXLNC=$ORDER(^TMP($JOB,"ECXLARPT",TNUM,DSSNM,TSTNM,SPECNM,RU,ECXLNC))
if ECXLNC']""
QUIT
Begin DoDot:6
+13 SET WKLD1=$PIECE(^TMP($JOB,"ECXLARPT",TNUM,DSSNM,TSTNM,SPECNM,RU,ECXLNC),"^")
+14 SET WKLDCD=$PIECE(^TMP($JOB,"ECXLARPT",TNUM,DSSNM,TSTNM,SPECNM,RU,ECXLNC),"^",2)
+15 SET LLNC=$PIECE(^TMP($JOB,"ECXLARPT",TNUM,DSSNM,TSTNM,SPECNM,RU,ECXLNC),"^",3)
+16 ;144
IF $GET(ECXPORT)
Begin DoDot:7
+17 ;144
SET ^TMP($JOB,"ECXPORT",CNT)=TNUM_U_DSSNM_U_RU_U_ECXLNC_U_$SELECT(WKLD1="":"*",1:"")_U_$SELECT(TSTNM'="ZZZZ":TSTNM,1:"")_U_$SELECT(SPECNM'="ZZZZ":$SELECT(SPECNM="ZZDEFAULT LOINC":"DEFAULT
LOINC",1:SPECNM),1:"")_U_WKLD1_U_WKLDCD
+18 ;144
SET CNT=CNT+1
End DoDot:7
QUIT
+19 ;,?56,$$RJ^XLFSTR(LLNC,10," ")
WRITE !,$$RJ^XLFSTR(TNUM,4,"0"),?11,$EXTRACT(DSSNM,1,24),?37,$EXTRACT(RU,1,13),?53,$$RJ^XLFSTR(ECXLNC,10," ")
+20 IF WKLD1=""
WRITE ?67,"*"
+21 ;I SPECNM'="ZZDEFAULT LOINC",$P(LLNC,"(")'=ECXLNC W ?67,"*"
+22 WRITE ?71,$SELECT(TSTNM'="ZZZZ":$EXTRACT(TSTNM,1,24),1:" ")
+23 WRITE ?97,$SELECT(SPECNM'="ZZZZ":$SELECT(SPECNM="ZZDEFAULT LOINC":"DEFAULT LOINC",1:$EXTRACT(SPECNM,1,13)),1:" "),?112,$$RJ^XLFSTR(WKLD1,8," "),?122,$$RJ^XLFSTR(WKLDCD,10," ")
+24 SET COUNT=COUNT+1
+25 IF $Y+3>IOSL
DO HEADER
if QFLG
QUIT
End DoDot:6
if QFLG
QUIT
End DoDot:5
if QFLG
QUIT
End DoDot:4
if QFLG
QUIT
End DoDot:3
if QFLG
QUIT
End DoDot:2
if QFLG
QUIT
End DoDot:1
if QFLG
QUIT
+26 ;144 stop processing if exporting
IF $GET(ECXPORT)
QUIT
+27 WRITE !!,"FLG ('*'=site not using LOINC code that DSS collects)"
+28 if QFLG
QUIT
CLOSE ;
+1 IF $EXTRACT(IOST)="C"
IF 'QFLG
Begin DoDot:1
+2 SET SS=22-$Y
FOR JJ=1:1:SS
WRITE !
+3 SET DIR(0)="E"
WRITE !
DO ^DIR
KILL DIR
End DoDot:1
+4 KILL ^TMP($JOB,"ECXLARPT")
+5 QUIT
+6 ;
+1 NEW SS,JJ
+2 IF $EXTRACT(IOST)="C"
Begin DoDot:1
+3 SET SS=22-$Y
FOR JJ=1:1:SS
WRITE !
+4 IF PG>0
SET DIR(0)="E"
WRITE !
DO ^DIR
KILL DIR
if 'Y
SET QFLG=1
End DoDot:1
+5 if QFLG
QUIT
+6 if $Y!($EXTRACT(IOST)="C")
WRITE @IOF
SET PG=PG+1
+7 WRITE !,"LAB RESULTS DSS LOINC CODE REPORT",?124,"Page: "_PG
+8 WRITE !,"Report Run Date/Time: "_ECRUN
+9 WRITE !,"DSS Site: "_$PIECE(ECXDIV(1),U,2)_" ("_$PIECE(ECXDIV(1),U,3)_")"
+10 ;W !,?97,"LOC",?117,"LOC",?122,"LOC"
+11 ;W !!,?68,"F",!,"LAR",?49,"LAR",?61,"LOCAL",?68,"L",?97,"LOC SPEC",?113,"LOC WKLD",?122,"LOC WKLD"
+12 ;W !,"TEST#",?7,"LAR TEST NAME",?33,"LAR UNITS",?49,"LOINC",?61,"LOINC",?68,"G",?71,"LOCAL TEST NAME",?99,"TYPE",?115,"IEN",?125,"CD"
+13 WRITE !!,?67,"F",?97,"LOC SPEC",?113,"LOC WKLD",?122,"LOC WKLD"
+14 WRITE !,"LAR TEST#",?11,"LAR TEST NAME",?37,"LAR UNITS",?53,"LAR LOINC",?67,"L",?71,"LOCAL TEST NAME",?99,"TYPE",?115,"IEN",?124,"CODE"
+15 WRITE !,"(#727.29)",?13,"(#727.29)",?37,"(#727.29)",?53,"(#727.29)",?67,"G",?76,"(#64)",?99,"(#64)",?115,"(#64)",?124,"(#64)"
+16 WRITE !,LN,!
+17 QUIT
+18 ;
