- 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 Jan 18, 2025@03:17:22 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