LRLNCPMP.m

LRLNCPMP ;VA/DALOI/FHS - PRINT LAB TESTS MAPPED/NOT MAPPED TO LOINC CODES ;JUL 06, 2010 3:14 PM

 ;;5.2;LAB SERVICE;**215,232,278,303,1027**;NOV 01, 1997

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

LRLNCPMP  ;VA/DALOI/FHS - PRINT LAB TESTS MAPPED/NOT MAPPED TO LOINC CODES ;JUL 06, 2010 3:14 PM

 +1       ;;5.2;LAB SERVICE;**215,232,278,303,1027**;NOV 01, 1997

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