LRLNCPMP ;DALOI/FHS - PRINT LAB TESTS MAPPED/NOT MAPPED TO LOINC CODES ;1-OCT-1998
;;5.2;LAB SERVICE;**215,232,278,303**;Sep 27,1994
EN ;
W @IOF K LRMAP,LREND
W !,$$CJ^XLFSTR("This option prints a list of the LABORATORY TESTS from the LABORATORY TEST FILE.",IOM)
W !,$$CJ^XLFSTR("You will be prompted to print lab tests that are",IOM)
W !,$$CJ^XLFSTR("mapped/not mapped to a LOINC code.",IOM)
W !,$$CJ^XLFSTR("Inactive(Type:Neither) lab tests are not reported.",IOM)
WHICH ;
W !!!,"Print lab tests that are mapped/not mapped to a LOINC code."
K DIR,LRMAP
S DIR("?")="Select 1 for mapped, 0 for not mapped or 2 for Individual"
S DIR(0)="SO^0:Not Mapped;1:Mapped test;2:Individual Mapped Test"
D ^DIR K DIR
I Y=""!($D(DIRUT)) D EXIT Q
S LRMAP=Y
D:+Y=2 SING G:$G(LREND) EXIT
K %ZIS S %ZIS="Q" D ^%ZIS G:POP EXIT
I $D(IO("Q")) D QUE Q
;
U IO
D START,^%ZISC
Q
;
;
SING ; Select individual lab test for report
I LRMAP=2 D
. K LRMAP
. S LREND=0,LRMAP=2
. W !,$$CJ^XLFSTR("You can only select test that have been mapped.",IOM)
. W !,$$CJ^XLFSTR("You can a quick list of mapped tests by entering '?'.",IOM)
. W !,$$CJ^XLFSTR("Then enter 'Yes' you want a complete list.",IOM),!
. K DIR,X,Y
. S DIR(0)="PO^60:EZNMQ"
. S DIR("S")="I $S($D(^LAM(""AL"",+Y)):1,$D(^LAM(""AM"",+Y)):1,1:0)"
. S DIR("?")="You must select a Mapped LABORATORY TEST"
. F D ^DIR Q:Y<1!($D(DIRUT)) S LRMAP(+Y)=Y
. I '$O(LRMAP(0)) W !!?5,"Nothing Selected" S LREND=1
Q
QUE ;
S ZTRTN="START^LRLNCPMP"
S ZTDESC="LAB TESTS MAP REPORT",ZTSAVE("LRMAP*")=""
D ^%ZTLOAD
I $D(ZTSK)'[0 W !,"REQUEST QUEUED ",ION
D HOME^%ZIS
K IO("Q")
Q
;
;
START ; Begins report
N LINE,LOINCDTA,LOINCDTB,LOINCTAS,LRAA,LRAA1,LRPNTA,LRPNTB,LRSUB
S LINE=0
D INI
I LRMAP'=2 D EN1
I LRMAP=2 D
. S LRIEN=0
. F S LRIEN=$O(LRMAP(LRIEN)) Q:LRIEN<1 S LRNODE=$G(^LAB(60,LRIEN,0)) D YMAP
D YMAPPRT,EXIT
Q
;
;
EN1 ; Print mapped or not mapped lab tests if there is a data name
S LRTEST=""
S LRTST="^LAB(60,""B"",0)"
F S LRTST=$Q(@LRTST) Q:$QS(LRTST,2)'="B" D Q:$G(LREND)
. Q:$G(@LRTST)
. S LRIEN=$QS(LRTST,4)
. Q:'$D(^LAB(60,LRIEN,0))#2 S LRNODE=^(0)
. I $S($P(LRNODE,U,3)="":1,$P(LRNODE,U,3)="N":1,'$P($P(LRNODE,U,5),";",2):1,1:0) Q
. N LRNLT
. S LRNLT=+$P($G(^LAB(60,LRIEN,64)),U,2)
. I 'LRMAP,$S(('$D(^LAM("AL",LRIEN))&('$D(^LAM("AM",LRIEN)))):1,1:0) D NMAP
. I LRMAP,$S($D(^LAM("AL",LRIEN)):1,$D(^LAM("AM",LRIEN)):1,1:0) D YMAP
Q
;
;
YMAPPRT I $D(^TMP($J,"LRDATA")) D
. S LRPRT=0
. F S LRPRT=$O(^TMP($J,"LRDATA",LRPRT)) Q:LRPRT="" D Q:$G(LREND)
.. I $Y+4>IOSL D HDR Q:$G(LREND)
.. W !,^TMP($J,"LRDATA",LRPRT)
Q
;
;
NMAP ;
I $Y+4>IOSL D HDR Q:$G(LREND)
S LRTESTN=$P(LRNODE,U)
W !,?1,LRTESTN
S LRNLT=$P($G(^LAB(60,LRIEN,64)),U,2)
I LRNLT D
. N LROUT
. D GETS^DIQ(64,LRNLT_",",".01;1","E","LROUT")
. W !?5,$G(LROUT(64,LRNLT_",",1,"E")),?18,$G(LROUT(64,LRNLT_",",.01,"E"))
W !
Q
;
;
YMAP ;
S LINE=$G(LINE)+1
S ^TMP($J,"LRDATA",LINE)="LAB TEST : "_$P(LRNODE,U),LINE=LINE+1
S LRSUB="LOCAL REPORT"
N LRA,LRNLTX
S LRNLT=0
F S LRNLT=$O(^LAM("AM",LRIEN,LRNLT)) Q:LRNLT="" I '$D(LRNLTX(LRNLT)) D
. S LRA=LRNLT,LRNLTX(LRNLT)=1
. D LOINCLA^LRSRVR1
S LRNLT=0
F S LRNLT=$O(^LAM("AL",LRIEN,LRNLT)) Q:LRNLT="" I '$D(LRNLTX(LRNLT)) D
. S LRA=LRNLT,LRNLTX(LRNLT)=1
. D LOINCLA^LRSRVR1
S LINE=$G(LINE)+1,^TMP($J,"LRDATA",LINE)="-------------------"
S LINE=LINE+1,^TMP($J,"LRDATA",LINE)="",LINE=LINE+1
Q
;
;
INI ; Initialize variables
K ^TMP($J,"LRDATA")
S (LREND,LRPAGE)=0,$P(LRLINE,"=",(IOM-1))=""
S LRPDT=$$HTE^XLFDT($H,"MZ")
;
HDR ; Print heading
I LRPAGE,$E(IOST,1,2)="C-" W !,"Press RETURN to continue or '^' to exit: " R N:DTIME S LREND='$T!(N="^") Q:LREND
S LRPAGE=LRPAGE+1
W @IOF,!?16,"LAB TESTS"_$S(LRMAP=2:" Individual Mapped",LRMAP=1:" Mapped",LRMAP'=1:" NOT Mapped",1:0)_" TO LOINC CODES"
W !?5,LRPDT,?(IOM-15)," Page ",$J(LRPAGE,3)
I 'LRMAP W !,?5,"LAB TEST"
I 'LRMAP W !,?10,"RESULT NLT"
W !,LRLINE,!
Q
;
;
EXIT I $E(IOST,1,2)="P-" W @IOF
S:$D(ZTQUEUED) ZTREQ="@"
Q:$G(LRDBUG)
K DIR,DIRUT,LREND,LRPAGE,I,J,LRA,LRLOC,LRIEN,LRPREV,ZTIO,ZTDESC,ZTRTN
K LRMAP,LRSPEC,LRTEST,LRTESTN,LRLOINC,LRPDT,LRLINE,LRX,DUOUT,ZTSAVE
K LRNLT,LRNLTN,LRNODE,LRPRT,LRSPECN,LRTST,N,Y,POP,ZTSK,ZTQUEUED,ZTREQ
K ^TMP($J,"LRDATA")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRLNCPMP 4408 printed Sep 23, 2025@19:52:18 Page 2
LRLNCPMP ;DALOI/FHS - PRINT LAB TESTS MAPPED/NOT MAPPED TO LOINC CODES ;1-OCT-1998
+1 ;;5.2;LAB SERVICE;**215,232,278,303**;Sep 27,1994
EN ;
+1 WRITE @IOF
KILL LRMAP,LREND
+2 WRITE !,$$CJ^XLFSTR("This option prints a list of the LABORATORY TESTS from the LABORATORY TEST FILE.",IOM)
+3 WRITE !,$$CJ^XLFSTR("You will be prompted to print lab tests that are",IOM)
+4 WRITE !,$$CJ^XLFSTR("mapped/not mapped to a LOINC code.",IOM)
+5 WRITE !,$$CJ^XLFSTR("Inactive(Type:Neither) lab tests are not reported.",IOM)
WHICH ;
+1 WRITE !!!,"Print lab tests that are mapped/not mapped to a LOINC code."
+2 KILL DIR,LRMAP
+3 SET DIR("?")="Select 1 for mapped, 0 for not mapped or 2 for Individual"
+4 SET DIR(0)="SO^0:Not Mapped;1:Mapped test;2:Individual Mapped Test"
+5 DO ^DIR
KILL DIR
+6 IF Y=""!($DATA(DIRUT))
DO EXIT
QUIT
+7 SET LRMAP=Y
+8 if +Y=2
DO SING
if $GET(LREND)
GOTO EXIT
+9 KILL %ZIS
SET %ZIS="Q"
DO ^%ZIS
if POP
GOTO EXIT
+10 IF $DATA(IO("Q"))
DO QUE
QUIT
+11 ;
+12 USE IO
+13 DO START
DO ^%ZISC
+14 QUIT
+15 ;
+16 ;
SING ; Select individual lab test for report
+1 IF LRMAP=2
Begin DoDot:1
+2 KILL LRMAP
+3 SET LREND=0
SET LRMAP=2
+4 WRITE !,$$CJ^XLFSTR("You can only select test that have been mapped.",IOM)
+5 WRITE !,$$CJ^XLFSTR("You can a quick list of mapped tests by entering '?'.",IOM)
+6 WRITE !,$$CJ^XLFSTR("Then enter 'Yes' you want a complete list.",IOM),!
+7 KILL DIR,X,Y
+8 SET DIR(0)="PO^60:EZNMQ"
+9 SET DIR("S")="I $S($D(^LAM(""AL"",+Y)):1,$D(^LAM(""AM"",+Y)):1,1:0)"
+10 SET DIR("?")="You must select a Mapped LABORATORY TEST"
+11 FOR
DO ^DIR
if Y<1!($DATA(DIRUT))
QUIT
SET LRMAP(+Y)=Y
+12 IF '$ORDER(LRMAP(0))
WRITE !!?5,"Nothing Selected"
SET LREND=1
End DoDot:1
+13 QUIT
QUE ;
+1 SET ZTRTN="START^LRLNCPMP"
+2 SET ZTDESC="LAB TESTS MAP REPORT"
SET ZTSAVE("LRMAP*")=""
+3 DO ^%ZTLOAD
+4 IF $DATA(ZTSK)'[0
WRITE !,"REQUEST QUEUED ",ION
+5 DO HOME^%ZIS
+6 KILL IO("Q")
+7 QUIT
+8 ;
+9 ;
START ; Begins report
+1 NEW LINE,LOINCDTA,LOINCDTB,LOINCTAS,LRAA,LRAA1,LRPNTA,LRPNTB,LRSUB
+2 SET LINE=0
+3 DO INI
+4 IF LRMAP'=2
DO EN1
+5 IF LRMAP=2
Begin DoDot:1
+6 SET LRIEN=0
+7 FOR
SET LRIEN=$ORDER(LRMAP(LRIEN))
if LRIEN<1
QUIT
SET LRNODE=$GET(^LAB(60,LRIEN,0))
DO YMAP
End DoDot:1
+8 DO YMAPPRT
DO EXIT
+9 QUIT
+10 ;
+11 ;
EN1 ; Print mapped or not mapped lab tests if there is a data name
+1 SET LRTEST=""
+2 SET LRTST="^LAB(60,""B"",0)"
+3 FOR
SET LRTST=$QUERY(@LRTST)
if $QSUBSCRIPT(LRTST,2)'="B"
QUIT
Begin DoDot:1
+4 if $GET(@LRTST)
QUIT
+5 SET LRIEN=$QSUBSCRIPT(LRTST,4)
+6 if '$DATA(^LAB(60,LRIEN,0))#2
QUIT
SET LRNODE=^(0)
+7 IF $SELECT($PIECE(LRNODE,U,3)="":1,$PIECE(LRNODE,U,3)="N":1,'$PIECE($PIECE(LRNODE,U,5),";",2):1,1:0)
QUIT
+8 NEW LRNLT
+9 SET LRNLT=+$PIECE($GET(^LAB(60,LRIEN,64)),U,2)
+10 IF 'LRMAP
IF $SELECT(('$DATA(^LAM("AL",LRIEN))&('$DATA(^LAM("AM",LRIEN)))):1,1:0)
DO NMAP
+11 IF LRMAP
IF $SELECT($DATA(^LAM("AL",LRIEN)):1,$DATA(^LAM("AM",LRIEN)):1,1:0)
DO YMAP
End DoDot:1
if $GET(LREND)
QUIT
+12 QUIT
+13 ;
+14 ;
YMAPPRT IF $DATA(^TMP($JOB,"LRDATA"))
Begin DoDot:1
+1 SET LRPRT=0
+2 FOR
SET LRPRT=$ORDER(^TMP($JOB,"LRDATA",LRPRT))
if LRPRT=""
QUIT
Begin DoDot:2
+3 IF $Y+4>IOSL
DO HDR
if $GET(LREND)
QUIT
+4 WRITE !,^TMP($JOB,"LRDATA",LRPRT)
End DoDot:2
if $GET(LREND)
QUIT
End DoDot:1
+5 QUIT
+6 ;
+7 ;
NMAP ;
+1 IF $Y+4>IOSL
DO HDR
if $GET(LREND)
QUIT
+2 SET LRTESTN=$PIECE(LRNODE,U)
+3 WRITE !,?1,LRTESTN
+4 SET LRNLT=$PIECE($GET(^LAB(60,LRIEN,64)),U,2)
+5 IF LRNLT
Begin DoDot:1
+6 NEW LROUT
+7 DO GETS^DIQ(64,LRNLT_",",".01;1","E","LROUT")
+8 WRITE !?5,$GET(LROUT(64,LRNLT_",",1,"E")),?18,$GET(LROUT(64,LRNLT_",",.01,"E"))
End DoDot:1
+9 WRITE !
+10 QUIT
+11 ;
+12 ;
YMAP ;
+1 SET LINE=$GET(LINE)+1
+2 SET ^TMP($JOB,"LRDATA",LINE)="LAB TEST : "_$PIECE(LRNODE,U)
SET LINE=LINE+1
+3 SET LRSUB="LOCAL REPORT"
+4 NEW LRA,LRNLTX
+5 SET LRNLT=0
+6 FOR
SET LRNLT=$ORDER(^LAM("AM",LRIEN,LRNLT))
if LRNLT=""
QUIT
IF '$DATA(LRNLTX(LRNLT))
Begin DoDot:1
+7 SET LRA=LRNLT
SET LRNLTX(LRNLT)=1
+8 DO LOINCLA^LRSRVR1
End DoDot:1
+9 SET LRNLT=0
+10 FOR
SET LRNLT=$ORDER(^LAM("AL",LRIEN,LRNLT))
if LRNLT=""
QUIT
IF '$DATA(LRNLTX(LRNLT))
Begin DoDot:1
+11 SET LRA=LRNLT
SET LRNLTX(LRNLT)=1
+12 DO LOINCLA^LRSRVR1
End DoDot:1
+13 SET LINE=$GET(LINE)+1
SET ^TMP($JOB,"LRDATA",LINE)="-------------------"
+14 SET LINE=LINE+1
SET ^TMP($JOB,"LRDATA",LINE)=""
SET LINE=LINE+1
+15 QUIT
+16 ;
+17 ;
INI ; Initialize variables
+1 KILL ^TMP($JOB,"LRDATA")
+2 SET (LREND,LRPAGE)=0
SET $PIECE(LRLINE,"=",(IOM-1))=""
+3 SET LRPDT=$$HTE^XLFDT($HOROLOG,"MZ")
+4 ;
HDR ; Print heading
+1 IF LRPAGE
IF $EXTRACT(IOST,1,2)="C-"
WRITE !,"Press RETURN to continue or '^' to exit: "
READ N:DTIME
SET LREND='$TEST!(N="^")
if LREND
QUIT
+2 SET LRPAGE=LRPAGE+1
+3 WRITE @IOF,!?16,"LAB TESTS"_$SELECT(LRMAP=2:" Individual Mapped",LRMAP=1:" Mapped",LRMAP'=1:" NOT Mapped",1:0)_" TO LOINC CODES"
+4 WRITE !?5,LRPDT,?(IOM-15)," Page ",$JUSTIFY(LRPAGE,3)
+5 IF 'LRMAP
WRITE !,?5,"LAB TEST"
+6 IF 'LRMAP
WRITE !,?10,"RESULT NLT"
+7 WRITE !,LRLINE,!
+8 QUIT
+9 ;
+10 ;
EXIT IF $EXTRACT(IOST,1,2)="P-"
WRITE @IOF
+1 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 if $GET(LRDBUG)
QUIT
+3 KILL DIR,DIRUT,LREND,LRPAGE,I,J,LRA,LRLOC,LRIEN,LRPREV,ZTIO,ZTDESC,ZTRTN
+4 KILL LRMAP,LRSPEC,LRTEST,LRTESTN,LRLOINC,LRPDT,LRLINE,LRX,DUOUT,ZTSAVE
+5 KILL LRNLT,LRNLTN,LRNODE,LRPRT,LRSPECN,LRTST,N,Y,POP,ZTSK,ZTQUEUED,ZTREQ
+6 KILL ^TMP($JOB,"LRDATA")
+7 QUIT
