BLSLNCPM ;DALOI/FHS/TPF - PRINT LAB TESTS MAPPED/NOT MAPPED TO LOINC CODES - THIS IS MODIFIED TO PRINT OUT LOINC TESTS AS DEVELOPED BY CIMARRON FOR LAB PATCH 15
;;5.2T9;LR;**1015,1017,1018**;Nov 17, 2004
;;5.2;LAB SERVICE;**215,232,278**;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
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
S DIR("?")="Select 1 for mapped or 0 for not mapped"
S DIR(0)="SO^0:Not Mapped;1: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 LOINCDTA,LOINCDTB,LOINCTAS,LRAA,LRAA1,LRPNTA,LRPNTB
N LINE
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
.;----- BEGIN IHS MODIFCATIONS LR*5.2*1018
.D BLRLOINC ;SEARCH FOR IHS LOINC ENTRIES
.Q
.;----- END IHS MODIFICATIONS
. 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
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^LRSRVR
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^LRSRVR
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=$$FMTE^XLFDT($$NOW^XLFDT,"Z5M")
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
;PRINT HEADING
W !?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"
I LRMAP=1 W !!?5,"LAB TEST",?37,"SPECIMEN",?67,"LOINC CODE"
I LRMAP=0 W !!?5,"LAB TEST",?37,"SPECIMEN"
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
;IHS LOINC REPORT
BLRLOINC ;
S LRTEST=$P(LRNODE,U)
S LRX=0
F S LRX=$O(^LAB(60,LRIEN,1,LRX)) Q:'LRX D Q:$G(LREND)
.S BLRLOINC=+$G(^LAB(60,LRIEN,1,LRX,95.3))
.I $G(LRMAP)=0,BLRLOINC'=0 Q
.I $G(LRMAP)=1,BLRLOINC=0 Q
.S LRSPEC=$P($G(^LAB(61,LRX,0)),U)
.;S LRTEST=$P($G(^LAB(60,LRIEN,0)),U)
.I $Y+4>IOSL D HDR Q:$G(LREND)
.W !?1,LRTEST,?37,$E(LRSPEC,1,30) I $G(LRMAP)=1 W ?67,BLRLOINC,!,$G(^LAB(95.3,BLRLOINC,80)),!
Q
BLSLNCPM ;DALOI/FHS/TPF - PRINT LAB TESTS MAPPED/NOT MAPPED TO LOINC CODES - THIS IS MODIFIED TO PRINT OUT LOINC TESTS AS DEVELOPED BY CIMARRON FOR LAB PATCH 15
+1 ;;5.2T9;LR;**1015,1017,1018**;Nov 17, 2004
+2 ;;5.2;LAB SERVICE;**215,232,278**;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 ;S DIR("?")="Select 1 for mapped, 0 for not mapped or 2 for Individual"
+4 ;S DIR(0)="SO^0:Not Mapped;1:Mapped test;2:Individual Mapped Test" D ^DIR K DIR
+5 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+6 SET DIR("?")="Select 1 for mapped or 0 for not mapped"
+7 SET DIR(0)="SO^0:Not Mapped;1:Mapped test"
DO ^DIR
KILL DIR
+8 IF Y=""!($DATA(DIRUT))
DO EXIT
QUIT
+9 SET LRMAP=Y
+10 IF +Y=2
DO SING
IF $GET(LREND)
GOTO EXIT
+11 KILL %ZIS
SET %ZIS="Q"
DO ^%ZIS
IF POP
GOTO EXIT
+12 IF $DATA(IO("Q"))
DO QUE
QUIT
+13 USE IO
DO START
DO ^%ZISC
QUIT
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
KILL IO("Q")
QUIT
START ;BEGINS REPORT
+1 NEW LOINCDTA,LOINCDTB,LOINCTAS,LRAA,LRAA1,LRPNTA,LRPNTB
+2 NEW LINE
+3 SET LINE=0
+4 DO INI
+5 IF LRMAP'=2
DO EN1
+6 IF LRMAP=2
Begin DoDot:1
+7 SET LRIEN=0
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
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 ;----- BEGIN IHS MODIFCATIONS LR*5.2*1018
+9 ;SEARCH FOR IHS LOINC ENTRIES
DO BLRLOINC
+10 QUIT
+11 ;----- END IHS MODIFICATIONS
+12 NEW LRNLT
+13 SET LRNLT=+$PIECE($GET(^LAB(60,LRIEN,64)),U,2)
+14 IF 'LRMAP
IF $SELECT(('$DATA(^LAM("AL",LRIEN))&('$DATA(^LAM("AM",LRIEN)))):1,1:0)
DO NMAP
+15 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
+16 QUIT
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
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
YMAP ;
+1 SET LINE=$GET(LINE)+1
+2 SET ^TMP($JOB,"LRDATA",LINE)="LAB TEST : "_$PIECE(LRNODE,U)
SET LINE=LINE+1
+3 NEW LRA,LRNLTX
+4 SET LRNLT=0
+5 FOR
SET LRNLT=$ORDER(^LAM("AM",LRIEN,LRNLT))
IF LRNLT=""
QUIT
IF '$DATA(LRNLTX(LRNLT))
Begin DoDot:1
+6 SET LRA=LRNLT
SET LRNLTX(LRNLT)=1
+7 DO LOINCLA^LRSRVR
End DoDot:1
+8 SET LRNLT=0
+9 FOR
SET LRNLT=$ORDER(^LAM("AL",LRIEN,LRNLT))
IF LRNLT=""
QUIT
IF '$DATA(LRNLTX(LRNLT))
Begin DoDot:1
+10 SET LRA=LRNLT
SET LRNLTX(LRNLT)=1
+11 DO LOINCLA^LRSRVR
End DoDot:1
+12 SET LINE=$GET(LINE)+1
SET ^TMP($JOB,"LRDATA",LINE)="-------------------"
+13 SET LINE=LINE+1
SET ^TMP($JOB,"LRDATA",LINE)=""
SET LINE=LINE+1
+14 QUIT
INI ;INITIALIZE VARIABLES
+1 KILL ^TMP($JOB,"LRDATA")
+2 SET (LREND,LRPAGE)=0
SET $PIECE(LRLINE,"=",(IOM-1))=""
+3 SET LRPDT=$$FMTE^XLFDT($$NOW^XLFDT,"Z5M")
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
WRITE @IOF
+3 ;PRINT HEADING
+4 WRITE !?16,"LAB TESTS"_$SELECT(LRMAP=2:" Individual Mapped",LRMAP=1:" Mapped",LRMAP'=1:" NOT Mapped",1:0)_" TO LOINC CODES"
+5 WRITE !?5,LRPDT,?(IOM-15)," Page ",$JUSTIFY(LRPAGE,3)
+6 ;I 'LRMAP W !?5,"LAB TEST"
+7 ;I 'LRMAP W !,?10,"RESULT NLT"
+8 IF LRMAP=1
WRITE !!?5,"LAB TEST",?37,"SPECIMEN",?67,"LOINC CODE"
+9 IF LRMAP=0
WRITE !!?5,"LAB TEST",?37,"SPECIMEN"
+10 WRITE !,LRLINE,!
+11 QUIT
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
+8 ;IHS LOINC REPORT
BLRLOINC ;
+1 SET LRTEST=$PIECE(LRNODE,U)
+2 SET LRX=0
+3 FOR
SET LRX=$ORDER(^LAB(60,LRIEN,1,LRX))
IF 'LRX
QUIT
Begin DoDot:1
+4 SET BLRLOINC=+$GET(^LAB(60,LRIEN,1,LRX,95.3))
+5 IF $GET(LRMAP)=0
IF BLRLOINC'=0
QUIT
+6 IF $GET(LRMAP)=1
IF BLRLOINC=0
QUIT
+7 SET LRSPEC=$PIECE($GET(^LAB(61,LRX,0)),U)
+8 ;S LRTEST=$P($G(^LAB(60,LRIEN,0)),U)
+9 IF $Y+4>IOSL
DO HDR
IF $GET(LREND)
QUIT
+10 WRITE !?1,LRTEST,?37,$EXTRACT(LRSPEC,1,30)
IF $GET(LRMAP)=1
WRITE ?67,BLRLOINC,!,$GET(^LAB(95.3,BLRLOINC,80)),!
End DoDot:1
IF $GET(LREND)
QUIT
+11 QUIT
