- 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
