LRLNCPRT ;DALOI/FHS - PRINT WKLD/NLT CODE LOINC MAPPINGS ;1-OCT-1998
;;5.2;LAB SERVICE;**215,278**;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^LRLNCPRT",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 G 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
D HDR
S LRNODE="^LAM(""B"",0)",LRCNT=0
F S LRNODE=$Q(@LRNODE) Q:$QS(LRNODE,1)'="B" Q:$G(LREND) D
. Q:$G(@LRNODE)!($G(LREND))
. S LRIEN=+$QS(LRNODE,3)
. S LRX=$G(^LAM(LRIEN,0)) Q:$P(LRX,U,2)=""
. D SPEC(LRIEN,1)
D END
Q
SPEC(LRIEN,LRTOP) ;
N LRCK
Q:'$D(^LAM(LRIEN,0))#2!($P($G(^LAM(LRIEN,0)),U,2)="") S LRNAME=$P(^(0),U),LRCN=$P(^(0),U,2)
Q:'$O(^LAM(LRIEN,5,0))
D TOP Q:$G(LREND)
S LRSPEC=0 F S LRSPEC=+$O(^LAM(LRIEN,5,LRSPEC)) Q:LRSPEC<1!($G(LREND)) D
. D TOP Q:$G(LREND)
. S (LRCK,LRASP)=0 F S LRASP=+$O(^LAM(LRIEN,5,LRSPEC,1,LRASP)) Q:LRASP<1 D
. . D TOP Q:$G(LREND) S LRCK=1
. . S LRX=+$G(^LAM(LRIEN,5,LRSPEC,1,LRASP,1))
. . I '$D(^LAB(95.3,LRX,0))!('$D(^LAB(95.3,LRX,80))) D Q
. . . W !?5,"*** WKLD CODE ",LRCN," ***",!?10," [ ",LRNAME," ] IS CORRUPTED ",!
. . D TOP Q:$G(LREND)
. . W !?2,LRIEN,?12,LRCN_" "_LRNAME
. . W !?5,"Specimen: ",$P($G(^LAB(61,LRSPEC,0)),U)
. . W !?10,"Collection Type: ",$P($G(^LAB(64.061,LRASP,0)),U)
. . W !,"LOINC= ",LRX," [",$G(^LAB(95.3,LRX,80)),"]"
. . S LRCNT=LRCNT+1
W:$G(LRCK) !,LRLINE
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,LRC,LRCNT,LREND,LRIEN,LRNAME,LRNODE,LRPAGE
K LRPDT,LRSEL,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 Workload (WKLD) CODES ",IOM)
W !,$$CJ^XLFSTR("that are Mapped to LOINC Codes.",IOM)
W !,?5,LRPDT,?60,"Page: ",LRPAGE
W !!,"NLT IEN # WKLD CODE Name ",!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRLNCPRT 2635 printed Dec 13, 2024@02:16:40 Page 2
LRLNCPRT ;DALOI/FHS - PRINT WKLD/NLT CODE LOINC MAPPINGS ;1-OCT-1998
+1 ;;5.2;LAB SERVICE;**215,278**;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^LRLNCPRT"
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
GOTO END
+8 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 DO HDR
+6 SET LRNODE="^LAM(""B"",0)"
SET LRCNT=0
+7 FOR
SET LRNODE=$QUERY(@LRNODE)
if $QSUBSCRIPT(LRNODE,1)'="B"
QUIT
if $GET(LREND)
QUIT
Begin DoDot:1
+8 if $GET(@LRNODE)!($GET(LREND))
QUIT
+9 SET LRIEN=+$QSUBSCRIPT(LRNODE,3)
+10 SET LRX=$GET(^LAM(LRIEN,0))
if $PIECE(LRX,U,2)=""
QUIT
+11 DO SPEC(LRIEN,1)
End DoDot:1
+12 DO END
+13 QUIT
SPEC(LRIEN,LRTOP) ;
+1 NEW LRCK
+2 if '$DATA(^LAM(LRIEN,0))#2!($PIECE($GET(^LAM(LRIEN,0)),U,2)="")
QUIT
SET LRNAME=$PIECE(^(0),U)
SET LRCN=$PIECE(^(0),U,2)
+3 if '$ORDER(^LAM(LRIEN,5,0))
QUIT
+4 DO TOP
if $GET(LREND)
QUIT
+5 SET LRSPEC=0
FOR
SET LRSPEC=+$ORDER(^LAM(LRIEN,5,LRSPEC))
if LRSPEC<1!($GET(LREND))
QUIT
Begin DoDot:1
+6 DO TOP
if $GET(LREND)
QUIT
+7 SET (LRCK,LRASP)=0
FOR
SET LRASP=+$ORDER(^LAM(LRIEN,5,LRSPEC,1,LRASP))
if LRASP<1
QUIT
Begin DoDot:2
+8 DO TOP
if $GET(LREND)
QUIT
SET LRCK=1
+9 SET LRX=+$GET(^LAM(LRIEN,5,LRSPEC,1,LRASP,1))
+10 IF '$DATA(^LAB(95.3,LRX,0))!('$DATA(^LAB(95.3,LRX,80)))
Begin DoDot:3
+11 WRITE !?5,"*** WKLD CODE ",LRCN," ***",!?10," [ ",LRNAME," ] IS CORRUPTED ",!
End DoDot:3
QUIT
+12 DO TOP
if $GET(LREND)
QUIT
+13 WRITE !?2,LRIEN,?12,LRCN_" "_LRNAME
+14 WRITE !?5,"Specimen: ",$PIECE($GET(^LAB(61,LRSPEC,0)),U)
+15 WRITE !?10,"Collection Type: ",$PIECE($GET(^LAB(64.061,LRASP,0)),U)
+16 WRITE !,"LOINC= ",LRX," [",$GET(^LAB(95.3,LRX,80)),"]"
+17 SET LRCNT=LRCNT+1
End DoDot:2
End DoDot:1
+18 if $GET(LRCK)
WRITE !,LRLINE
+19 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,LRC,LRCNT,LREND,LRIEN,LRNAME,LRNODE,LRPAGE
+5 KILL LRPDT,LRSEL,LRX,POP,ZTIO,ZTDESC,ZTRTN,ZTSAVE
+6 ;
+7 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 Workload (WKLD) CODES ",IOM)
+5 WRITE !,$$CJ^XLFSTR("that are Mapped to LOINC Codes.",IOM)
+6 WRITE !,?5,LRPDT,?60,"Page: ",LRPAGE
+7 WRITE !!,"NLT IEN # WKLD CODE Name ",!
+8 QUIT
