LRLNCNLT ;DALOI/FHS-PRINT LAB TEST W/O RESULT NLT CODE ;1-OCT-1998
;;5.2;LAB SERVICE;**215,278,418**;NOV 01, 1997;Build 31
EN ;
W @IOF,!! S LREND=0
W $$CJ^XLFSTR("This option will print tests and their RESULT NLT CODES",IOM)
W !,$$CJ^XLFSTR("assigned. Result NLT codes are required for LEDI and LOINC",IOM)
W !,$$CJ^XLFSTR("Mapping software to function properly.",IOM)
W !,$$CJ^XLFSTR("You may use the option 'Link Result NLT Manual' to make necessary changes.",IOM)
ASK ;
K DIR S DIR(0)="S^0:All Lab Tests;1:Lab Tests with Result NLT Codes;2:Lab Tests without Result NLT Codes"
S DIR("?")="All will print Lab Tests with and w/o result NLT codes tests"
D ^DIR K DIR
G END:$S($G(DIRUT):1,$G(DUOUT):1,$G(DTOUT):1,1:0)
S LRSEL=Y
K %ZIS S %ZIS="Q" D ^%ZIS
G END:POP
I IO'=IO(0) S ZTRTN="DQ^LRLNCNLT",ZTIO=ION,ZTDESC="Print Lab Tests and Result Codes",ZTSAVE("LRSEL")="" D ^%ZTLOAD I $D(ZTSK)'[0 W !!?5," Tasked to Print on : ",ION G END
W @IOF D DQ G END
Q
DQ ;
N DIR,LREND
S:$D(ZTQUEUED) ZTREQ="@" S LRPDT=$$FMTE^XLFDT($$NOW^XLFDT,1)
S (LRPAGE,LRCNT,LREND)=0
D HDR
S LRNODE="^LAB(60,""B"",0)",LRCNT=0
F S LRNODE=$Q(@LRNODE) Q:$QS(LRNODE,2)'="B" Q:$G(LREND) D
. Q:$G(@LRNODE)!($G(LREND))
. S LRIEN=$QS(LRNODE,4),LRNAME=$QS(LRNODE,3),LRC=$P($G(^LAB(60,LRIEN,64)),U,2)
. S LRX=$G(^LAB(60,+$G(LRIEN),0)) Q:$P(LRX,U,3)=""
. Q:$P(LRX,"^",4)'="CH" ;only CH tests are relevant
. Q:$O(^LAB(60,LRIEN,2,0))'="" ;only atomic tests are relevant
. Q:"BO"'[$P(LRX,U,3)
. I $G(LRSEL)=2,LRC Q
. I $G(LRSEL)=1,'LRC Q
. S LRCNT=$G(LRCNT)+1
. D TOF Q:$G(LREND)
. W !,$$RJ^XLFSTR(LRIEN,5),?8,LRNAME
. I $G(LRC) D NLTPRT(LRC)
Q
NLTPRT(LRC) ;
D TOF Q:LREND
N LRSPEC
I '$D(^LAM(LRC,0))#2 W !?15," **** Corrupt DATABASE ****" Q
W !?5,"[ ",$P(^LAM(LRC,0),U,2),?18,$P(^(0),U)," ]",!
S LRSPEC=0 F S LRSPEC=$O(^LAB(60,LRIEN,1,LRSPEC)) Q:LRSPEC<1!($G(LREND)) D
. S LRX=+$G(^LAB(60,LRIEN,1,LRSPEC,95.3)) Q:'LRX
. I $Y>(IOSL-4) D TOF1 Q:$G(LREND) W !,$$RJ^XLFSTR(LRIEN,5),?8,LRNAME
. W !?10,"Specimen [ ",$P($G(^LAB(61,LRSPEC,0)),U),"] Mapped to LOINC CODE"
. W !,$G(^LAB(95.3,LRX,80)),!
Q
END ;
I $G(LRCNT) W !?20,"Total Printed Tests: ",LRCNT,!
I $E(IOST)="P-" W @IOF
D ^%ZISC
K DIR,DIRUT,DUOUT,LRC,LRCNT,LREND,LRIEN,LRNAME,LRNODE,LRPAGE
K LRPDT,LRSEL,LRX,POP,ZTIO,ZTDESC,ZTRTN,ZTSAVE
;
Q
TOF ;
Q:$Y<(IOSL-3)
TOF1 I $E(IOST,1,2)="C-" D Q:$G(LREND)
. S DIR(0)="E" D ^DIR
. S:$S($G(DIRUT):1,$G(DUOUT):1,1:0) LREND=1
HDR ;
I $G(LRPAGE) W @IOF
S LRPAGE=$G(LRPAGE)+1 W !,?5,LRPDT,?60,"Page: ",LRPAGE
W !,$$CJ^XLFSTR("Alphabetical Listing of CH Subscripted Lab Tests",IOM)
I $G(LRSEL)=1 W !,$$CJ^XLFSTR("That have RESULT NLT CODES assigned",IOM),!
I $G(LRSEL)=2 W !,$$CJ^XLFSTR("That do not have RESULT NLT CODES assigned",IOM),!
W !," IEN Lab Test Name " I $G(LRSEL)=2 W ! Q
W !," NLT # Result NLT Code Name ",!
Q
LRLNCNLT ;DALOI/FHS-PRINT LAB TEST W/O RESULT NLT CODE ;1-OCT-1998
+1 ;;5.2;LAB SERVICE;**215,278,418**;NOV 01, 1997;Build 31
EN ;
+1 WRITE @IOF,!!
SET LREND=0
+2 WRITE $$CJ^XLFSTR("This option will print tests and their RESULT NLT CODES",IOM)
+3 WRITE !,$$CJ^XLFSTR("assigned. Result NLT codes are required for LEDI and LOINC",IOM)
+4 WRITE !,$$CJ^XLFSTR("Mapping software to function properly.",IOM)
+5 WRITE !,$$CJ^XLFSTR("You may use the option 'Link Result NLT Manual' to make necessary changes.",IOM)
ASK ;
+1 KILL DIR
SET DIR(0)="S^0:All Lab Tests;1:Lab Tests with Result NLT Codes;2:Lab Tests without Result NLT Codes"
+2 SET DIR("?")="All will print Lab Tests with and w/o result NLT codes tests"
+3 DO ^DIR
KILL DIR
+4 IF $SELECT($GET(DIRUT):1,$GET(DUOUT):1,$GET(DTOUT):1,1:0)
GOTO END
+5 SET LRSEL=Y
+6 KILL %ZIS
SET %ZIS="Q"
DO ^%ZIS
+7 IF POP
GOTO END
+8 IF IO'=IO(0)
SET ZTRTN="DQ^LRLNCNLT"
SET ZTIO=ION
SET ZTDESC="Print Lab Tests and Result Codes"
SET ZTSAVE("LRSEL")=""
DO ^%ZTLOAD
IF $DATA(ZTSK)'[0
WRITE !!?5," Tasked to Print on : ",ION
GOTO END
+9 WRITE @IOF
DO DQ
GOTO END
+10 QUIT
DQ ;
+1 NEW DIR,LREND
+2 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
SET LRPDT=$$FMTE^XLFDT($$NOW^XLFDT,1)
+3 SET (LRPAGE,LRCNT,LREND)=0
+4 DO HDR
+5 SET LRNODE="^LAB(60,""B"",0)"
SET LRCNT=0
+6 FOR
SET LRNODE=$QUERY(@LRNODE)
IF $QSUBSCRIPT(LRNODE,2)'="B"
QUIT
IF $GET(LREND)
QUIT
Begin DoDot:1
+7 IF $GET(@LRNODE)!($GET(LREND))
QUIT
+8 SET LRIEN=$QSUBSCRIPT(LRNODE,4)
SET LRNAME=$QSUBSCRIPT(LRNODE,3)
SET LRC=$PIECE($GET(^LAB(60,LRIEN,64)),U,2)
+9 SET LRX=$GET(^LAB(60,+$GET(LRIEN),0))
IF $PIECE(LRX,U,3)=""
QUIT
+10 ;only CH tests are relevant
IF $PIECE(LRX,"^",4)'="CH"
QUIT
+11 ;only atomic tests are relevant
IF $ORDER(^LAB(60,LRIEN,2,0))'=""
QUIT
+12 IF "BO"'[$PIECE(LRX,U,3)
QUIT
+13 IF $GET(LRSEL)=2
IF LRC
QUIT
+14 IF $GET(LRSEL)=1
IF 'LRC
QUIT
+15 SET LRCNT=$GET(LRCNT)+1
+16 DO TOF
IF $GET(LREND)
QUIT
+17 WRITE !,$$RJ^XLFSTR(LRIEN,5),?8,LRNAME
+18 IF $GET(LRC)
DO NLTPRT(LRC)
End DoDot:1
+19 QUIT
NLTPRT(LRC) ;
+1 DO TOF
IF LREND
QUIT
+2 NEW LRSPEC
+3 IF '$DATA(^LAM(LRC,0))#2
WRITE !?15," **** Corrupt DATABASE ****"
QUIT
+4 WRITE !?5,"[ ",$PIECE(^LAM(LRC,0),U,2),?18,$PIECE(^(0),U)," ]",!
+5 SET LRSPEC=0
FOR
SET LRSPEC=$ORDER(^LAB(60,LRIEN,1,LRSPEC))
IF LRSPEC<1!($GET(LREND))
QUIT
Begin DoDot:1
+6 SET LRX=+$GET(^LAB(60,LRIEN,1,LRSPEC,95.3))
IF 'LRX
QUIT
+7 IF $Y>(IOSL-4)
DO TOF1
IF $GET(LREND)
QUIT
WRITE !,$$RJ^XLFSTR(LRIEN,5),?8,LRNAME
+8 WRITE !?10,"Specimen [ ",$PIECE($GET(^LAB(61,LRSPEC,0)),U),"] Mapped to LOINC CODE"
+9 WRITE !,$GET(^LAB(95.3,LRX,80)),!
End DoDot:1
+10 QUIT
END ;
+1 IF $GET(LRCNT)
WRITE !?20,"Total Printed Tests: ",LRCNT,!
+2 IF $EXTRACT(IOST)="P-"
WRITE @IOF
+3 DO ^%ZISC
+4 KILL DIR,DIRUT,DUOUT,LRC,LRCNT,LREND,LRIEN,LRNAME,LRNODE,LRPAGE
+5 KILL LRPDT,LRSEL,LRX,POP,ZTIO,ZTDESC,ZTRTN,ZTSAVE
+6 ;
+7 QUIT
TOF ;
+1 IF $Y<(IOSL-3)
QUIT
TOF1 IF $EXTRACT(IOST,1,2)="C-"
Begin DoDot:1
+1 SET DIR(0)="E"
DO ^DIR
+2 IF $SELECT($GET(DIRUT)
SET LREND=1
End DoDot:1
IF $GET(LREND)
QUIT
HDR ;
+1 IF $GET(LRPAGE)
WRITE @IOF
+2 SET LRPAGE=$GET(LRPAGE)+1
WRITE !,?5,LRPDT,?60,"Page: ",LRPAGE
+3 WRITE !,$$CJ^XLFSTR("Alphabetical Listing of CH Subscripted Lab Tests",IOM)
+4 IF $GET(LRSEL)=1
WRITE !,$$CJ^XLFSTR("That have RESULT NLT CODES assigned",IOM),!
+5 IF $GET(LRSEL)=2
WRITE !,$$CJ^XLFSTR("That do not have RESULT NLT CODES assigned",IOM),!
+6 WRITE !," IEN Lab Test Name "
IF $GET(LRSEL)=2
WRITE !
QUIT
+7 WRITE !," NLT # Result NLT Code Name ",!
+8 QUIT
