LRLNCSUF ;DALOI/RSH-PRINT WKLD/NLT CODE LOINC MAPPINGS ;1-OCT-1998
;;5.2T9;LR;**1018**;Nov 17, 2004
;;5.2;LAB SERVICE;**232**;Sep 27,1994
EN ;
W @IOF,!! S LREND=0
W $$CJ^XLFSTR("This option will print WORKLOAD CODES and their LOINC CODES.",IOM)
W !,$$CJ^XLFSTR("You may use the option 'MAP LOINC TEST TO NLT' to make necessary changes.",IOM)
ASK ;
K DIR S DIR(0)="S^1:Ready to print WORKLOAD CODES MAPPED TO LOINC;2:Abort"
D ^DIR K DIR
G END:$S($G(DIRUT):1,$G(DUOUT):1,$G(DTOUT):1,Y=2:1,1:0)
S LRSEL=Y K %ZIS S %ZIS="Q" D ^%ZIS
G END:POP
I IO'=IO(0) S ZTRTN="DQ^LRLNCSUF",ZTIO=ION,ZTDESC="Print WKLD CODES MAPPED TO LOINC",ZTSAVE("LRSEL")="" D ^%ZTLOAD I $D(ZTSK)'[0 W !!?5," Tasked to Print on : ",ION G END
W @IOF D DQ
D END
Q
DQ ;
N DIR,LREND
S $P(LRLINE,"=",IOM)="",LRTOP=1
S:$D(ZTQUEUED) ZTREQ="@" S LRPDT=$$FMTE^XLFDT($$NOW^XLFDT,"1P")
S (LRPAGE,LRCNT,LREND)=0
S LRDEF=""
D HDR
;SORT BY TEST
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 LRTSTNM=$QS(LRNODE,3)
. S LRIEN=+$QS(LRNODE,4)
. S (LRLOINC,LRSMPIEN,LRVWKIEN,LRACCIEN)=""
. S LRX=$G(^LAB(60,LRIEN,0)) Q:$P(LRX,U,3)="N"
. S LRVACD=$P($G(^LAB(60,LRIEN,64)),U)
. S LRRNLT=$P($G(^LAB(60,LRIEN,64)),U,2)
. D SMPCD D:$G(LRSMPIEN) GRNLT(LRSMPIEN)
. D VRWKD D:$G(LRVWKIEN) GRNLT(LRVWKIEN)
. D ACWK D:$G(LRACCIEN) GRNLT(LRACCIEN)
. I LRSMPIEN=""&(LRVWKIEN="")&(LRACCIEN="") D
. . I ($G(LRRNLT)) D GRNLT(LRRNLT)
. . I LRRNLT="" D
. . . W !,LRTSTNM,?45,"THERE IS NO RESULT NLT CODE"
. . . W !,LRLINE
. . . I $Y>24 D HDR,TOP Q:$G(LREND)
Q
SMPCD ;GET SAMPLE WORKLOAD CODE
S (LRD1,LRD2)=0
F S LRD1=+$O(^LAB(60,LRIEN,3,LRD1)) Q:LRD1<1 D
. Q:'$O(^LAB(60,LRIEN,3,LRD1,9,0))
. F S LRD2=+$O(^LAB(60,LRIEN,3,LRD1,9,LRD2)) Q:LRD2<1 D
. . S LRSREC=$G(^LAB(60,LRIEN,LRD1,9,LRD2,0))
. . S LRSMPIEN=$P(LRSREC,U)
Q
VRWKD ;GET VERIFY WORKLOAD CODE
S LRD1=0 Q:'$O(^LAB(60,LRIEN,9,0))
F S LRD1=+$O(^LAB(60,LRIEN,9,LRD1)) Q:'LRD1 D
. S LRVREC=$G(^LAB(60,LRIEN,9,LRD1,0))
. S LRVWKIEN=$P(LRVREC,U)
Q
ACWK ;GET ACCESSION WORKLOAD CODE
S LRSUB=0
Q:'$O(^LAB(60,LRIEN,9.1,0))
F S LRSUB=+$O(^LAB(60,LRIEN,9.1,LRSUB)) Q:LRSUB<1 D
. S LRREC=$G(^LAB(60,LRIEN,9.1,LRSUB,0))
. S LRACCIEN=$P(LRREC,U)
Q
GRNLT(LRNLTIEN) ;GET RESULT NLT CODE
Q:$G(^LAM(LRNLTIEN,0))=""
Q:'$D(^LAM(LRNLTIEN,0))#2!($P($G(^LAM(LRNLTIEN,0)),U,2)="") S LRNAME=$P(^(0),U),LRCODE=$P(^(0),U,2)
D TOP Q:$G(LREND)
I $O(^LAM(LRNLTIEN,5,0)) D GTLNC
SDEFCD ;SET DEFAULT LOINC CODE
I $G(^LAM(LRNLTIEN,9)) S LRDEF=$P(^(0),U)
E S LRDEF="" ;USE GENERIC SUFFIX CODE
I '$O(^LAM(LRNLTIEN,5,0)) D PRT
Q
GTLNC ;GET LOINC CODE BASED ON THE SPECIMEN
S LRSPEC=0 F S LRSPEC=+$O(^LAM(LRNLTIEN,5,LRSPEC)) Q:LRSPEC<1!($G(LREND)) D
. D TOP Q:$G(LREND)
. S LRASP=0 F S LRASP=+$O(^LAM(LRNLTIEN,5,LRSPEC,1,LRASP)) Q:LRASP<1 D
. . D TOP Q:$G(LREND)
. . S LRX=+$G(^LAM(LRNLTIEN,5,LRSPEC,1,LRASP,1))
. . I $D(^LAB(95.3,LRX,0))#2 S LRLOINC=$P(^(0),U)
. . S LRSPNM=$P($G(^LAB(61,LRSPEC,0)),U),LRFULL=$G(^LAB(95.3,LRX,80))
. . I $G(LRLOINC) D PRT
. . S (LRLOINC,LRFULL)=""
Q
PRT ;PRINT INFO
D TOP Q:$G(LREND)
W !?2,$G(LRTSTNM),?47,$G(LRSPNM)
W !?2,$G(LRNLTIEN),?12,LRCODE_" "_$G(LRNAME)
I LRLOINC'="" W !,"LOINC CODE = ",LRLOINC," ",$G(LRFULL)
I LRDEF'="" W !,"DEFAULT LOINC CODE = ",$G(LRDEF)
I LRLOINC!LRDEF S LRCNT=LRCNT+1
W !,LRLINE
I $Y>24 D HDR,TOP Q:$G(LREND)
Q
END ;
I $G(LRCNT) W !?15,"Total Number of Mapped WKLD CODES/Specimens: ",LRCNT,!
I $E(IOST)="P-" W @IOF
D ^%ZISC
K DIR,DIRUT,DUOUT,LRACCIEN,LRASP,LRCODE,LRCNT,LRD1,LRD2,LRDEF
K LREND,LRFULL,LRIEN,LRLINE,LRLOINC,LRNAME,LRNLTIEN,LRNODE,LRPAGE
K LRPDT,LRREC,LRRNLT,LRSEL,LRSMPIEN,LRSPEC,LRSPNM,LRSREC,LRSUB
K LRTOP,LRTSTNM,LRVACD,LRVREC,LRVWKIEN,LRX,POP,ZTIO,ZTDESC,ZTRTN,ZTSAVE
;
Q
TOP ;
Q:$G(LREND)
Q:$Y<(IOSL-4)
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
Q:'$G(LRTOP)
W !,$$CJ^XLFSTR("Alphabetical Listing of Laboratory Tests ",IOM)
W !,$$CJ^XLFSTR("that are Mapped to LOINC Codes.",IOM)
W !,?5,LRPDT,?60,"Page: ",LRPAGE
W !!,"LABORATORY TEST NAME",?45,"SPECIMEN"
W !,"NLT IEN # WKLD CODE Name ",!
Q
LRLNCSUF ;DALOI/RSH-PRINT WKLD/NLT CODE LOINC MAPPINGS ;1-OCT-1998
+1 ;;5.2T9;LR;**1018**;Nov 17, 2004
+2 ;;5.2;LAB SERVICE;**232**;Sep 27,1994
EN ;
+1 WRITE @IOF,!!
SET LREND=0
+2 WRITE $$CJ^XLFSTR("This option will print WORKLOAD CODES and their LOINC CODES.",IOM)
+3 WRITE !,$$CJ^XLFSTR("You may use the option 'MAP LOINC TEST TO NLT' to make necessary changes.",IOM)
ASK ;
+1 KILL DIR
SET DIR(0)="S^1:Ready to print WORKLOAD CODES MAPPED TO LOINC;2:Abort"
+2 DO ^DIR
KILL DIR
+3 IF $SELECT($GET(DIRUT):1,$GET(DUOUT):1,$GET(DTOUT):1,Y=2:1,1:0)
GOTO END
+4 SET LRSEL=Y
KILL %ZIS
SET %ZIS="Q"
DO ^%ZIS
+5 IF POP
GOTO END
+6 IF IO'=IO(0)
SET ZTRTN="DQ^LRLNCSUF"
SET ZTIO=ION
SET ZTDESC="Print WKLD CODES MAPPED TO LOINC"
SET ZTSAVE("LRSEL")=""
DO ^%ZTLOAD
IF $DATA(ZTSK)'[0
WRITE !!?5," Tasked to Print on : ",ION
GOTO END
+7 WRITE @IOF
DO DQ
+8 DO END
+9 QUIT
DQ ;
+1 NEW DIR,LREND
+2 SET $PIECE(LRLINE,"=",IOM)=""
SET LRTOP=1
+3 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
SET LRPDT=$$FMTE^XLFDT($$NOW^XLFDT,"1P")
+4 SET (LRPAGE,LRCNT,LREND)=0
+5 SET LRDEF=""
+6 DO HDR
+7 ;SORT BY TEST
+8 SET LRNODE="^LAB(60,""B"",0)"
SET LRCNT=0
+9 FOR
SET LRNODE=$QUERY(@LRNODE)
IF $QSUBSCRIPT(LRNODE,2)'="B"
QUIT
IF $GET(LREND)
QUIT
Begin DoDot:1
+10 IF $GET(@LRNODE)!($GET(LREND))
QUIT
+11 SET LRTSTNM=$QSUBSCRIPT(LRNODE,3)
+12 SET LRIEN=+$QSUBSCRIPT(LRNODE,4)
+13 SET (LRLOINC,LRSMPIEN,LRVWKIEN,LRACCIEN)=""
+14 SET LRX=$GET(^LAB(60,LRIEN,0))
IF $PIECE(LRX,U,3)="N"
QUIT
+15 SET LRVACD=$PIECE($GET(^LAB(60,LRIEN,64)),U)
+16 SET LRRNLT=$PIECE($GET(^LAB(60,LRIEN,64)),U,2)
+17 DO SMPCD
IF $GET(LRSMPIEN)
DO GRNLT(LRSMPIEN)
+18 DO VRWKD
IF $GET(LRVWKIEN)
DO GRNLT(LRVWKIEN)
+19 DO ACWK
IF $GET(LRACCIEN)
DO GRNLT(LRACCIEN)
+20 IF LRSMPIEN=""&(LRVWKIEN="")&(LRACCIEN="")
Begin DoDot:2
+21 IF ($GET(LRRNLT))
DO GRNLT(LRRNLT)
+22 IF LRRNLT=""
Begin DoDot:3
+23 WRITE !,LRTSTNM,?45,"THERE IS NO RESULT NLT CODE"
+24 WRITE !,LRLINE
+25 IF $Y>24
DO HDR
DO TOP
IF $GET(LREND)
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+26 QUIT
SMPCD ;GET SAMPLE WORKLOAD CODE
+1 SET (LRD1,LRD2)=0
+2 FOR
SET LRD1=+$ORDER(^LAB(60,LRIEN,3,LRD1))
IF LRD1<1
QUIT
Begin DoDot:1
+3 IF '$ORDER(^LAB(60,LRIEN,3,LRD1,9,0))
QUIT
+4 FOR
SET LRD2=+$ORDER(^LAB(60,LRIEN,3,LRD1,9,LRD2))
IF LRD2<1
QUIT
Begin DoDot:2
+5 SET LRSREC=$GET(^LAB(60,LRIEN,LRD1,9,LRD2,0))
+6 SET LRSMPIEN=$PIECE(LRSREC,U)
End DoDot:2
End DoDot:1
+7 QUIT
VRWKD ;GET VERIFY WORKLOAD CODE
+1 SET LRD1=0
IF '$ORDER(^LAB(60,LRIEN,9,0))
QUIT
+2 FOR
SET LRD1=+$ORDER(^LAB(60,LRIEN,9,LRD1))
IF 'LRD1
QUIT
Begin DoDot:1
+3 SET LRVREC=$GET(^LAB(60,LRIEN,9,LRD1,0))
+4 SET LRVWKIEN=$PIECE(LRVREC,U)
End DoDot:1
+5 QUIT
ACWK ;GET ACCESSION WORKLOAD CODE
+1 SET LRSUB=0
+2 IF '$ORDER(^LAB(60,LRIEN,9.1,0))
QUIT
+3 FOR
SET LRSUB=+$ORDER(^LAB(60,LRIEN,9.1,LRSUB))
IF LRSUB<1
QUIT
Begin DoDot:1
+4 SET LRREC=$GET(^LAB(60,LRIEN,9.1,LRSUB,0))
+5 SET LRACCIEN=$PIECE(LRREC,U)
End DoDot:1
+6 QUIT
GRNLT(LRNLTIEN) ;GET RESULT NLT CODE
+1 IF $GET(^LAM(LRNLTIEN,0))=""
QUIT
+2 IF '$DATA(^LAM(LRNLTIEN,0))#2!($PIECE($GET(^LAM(LRNLTIEN,0)),U,2)="")
QUIT
SET LRNAME=$PIECE(^(0),U)
SET LRCODE=$PIECE(^(0),U,2)
+3 DO TOP
IF $GET(LREND)
QUIT
+4 IF $ORDER(^LAM(LRNLTIEN,5,0))
DO GTLNC
SDEFCD ;SET DEFAULT LOINC CODE
+1 IF $GET(^LAM(LRNLTIEN,9))
SET LRDEF=$PIECE(^(0),U)
+2 ;USE GENERIC SUFFIX CODE
IF '$TEST
SET LRDEF=""
+3 IF '$ORDER(^LAM(LRNLTIEN,5,0))
DO PRT
+4 QUIT
GTLNC ;GET LOINC CODE BASED ON THE SPECIMEN
+1 SET LRSPEC=0
FOR
SET LRSPEC=+$ORDER(^LAM(LRNLTIEN,5,LRSPEC))
IF LRSPEC<1!($GET(LREND))
QUIT
Begin DoDot:1
+2 DO TOP
IF $GET(LREND)
QUIT
+3 SET LRASP=0
FOR
SET LRASP=+$ORDER(^LAM(LRNLTIEN,5,LRSPEC,1,LRASP))
IF LRASP<1
QUIT
Begin DoDot:2
+4 DO TOP
IF $GET(LREND)
QUIT
+5 SET LRX=+$GET(^LAM(LRNLTIEN,5,LRSPEC,1,LRASP,1))
+6 IF $DATA(^LAB(95.3,LRX,0))#2
SET LRLOINC=$PIECE(^(0),U)
+7 SET LRSPNM=$PIECE($GET(^LAB(61,LRSPEC,0)),U)
SET LRFULL=$GET(^LAB(95.3,LRX,80))
+8 IF $GET(LRLOINC)
DO PRT
+9 SET (LRLOINC,LRFULL)=""
End DoDot:2
End DoDot:1
+10 QUIT
PRT ;PRINT INFO
+1 DO TOP
IF $GET(LREND)
QUIT
+2 WRITE !?2,$GET(LRTSTNM),?47,$GET(LRSPNM)
+3 WRITE !?2,$GET(LRNLTIEN),?12,LRCODE_" "_$GET(LRNAME)
+4 IF LRLOINC'=""
WRITE !,"LOINC CODE = ",LRLOINC," ",$GET(LRFULL)
+5 IF LRDEF'=""
WRITE !,"DEFAULT LOINC CODE = ",$GET(LRDEF)
+6 IF LRLOINC!LRDEF
SET LRCNT=LRCNT+1
+7 WRITE !,LRLINE
+8 IF $Y>24
DO HDR
DO TOP
IF $GET(LREND)
QUIT
+9 QUIT
END ;
+1 IF $GET(LRCNT)
WRITE !?15,"Total Number of Mapped WKLD CODES/Specimens: ",LRCNT,!
+2 IF $EXTRACT(IOST)="P-"
WRITE @IOF
+3 DO ^%ZISC
+4 KILL DIR,DIRUT,DUOUT,LRACCIEN,LRASP,LRCODE,LRCNT,LRD1,LRD2,LRDEF
+5 KILL LREND,LRFULL,LRIEN,LRLINE,LRLOINC,LRNAME,LRNLTIEN,LRNODE,LRPAGE
+6 KILL LRPDT,LRREC,LRRNLT,LRSEL,LRSMPIEN,LRSPEC,LRSPNM,LRSREC,LRSUB
+7 KILL LRTOP,LRTSTNM,LRVACD,LRVREC,LRVWKIEN,LRX,POP,ZTIO,ZTDESC,ZTRTN,ZTSAVE
+8 ;
+9 QUIT
TOP ;
+1 IF $GET(LREND)
QUIT
+2 IF $Y<(IOSL-4)
QUIT
+3 IF $EXTRACT(IOST,1,2)="C-"
Begin DoDot:1
+4 SET DIR(0)="E"
DO ^DIR
+5 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
+3 IF '$GET(LRTOP)
QUIT
+4 WRITE !,$$CJ^XLFSTR("Alphabetical Listing of Laboratory Tests ",IOM)
+5 WRITE !,$$CJ^XLFSTR("that are Mapped to LOINC Codes.",IOM)
+6 WRITE !,?5,LRPDT,?60,"Page: ",LRPAGE
+7 WRITE !!,"LABORATORY TEST NAME",?45,"SPECIMEN"
+8 WRITE !,"NLT IEN # WKLD CODE Name ",!
+9 QUIT
