- LRLNCST ;VA/DALOI/FHS-LIST OF LOINC DEPRECIATED CODES ; 5/14/07 12:56pm
- ;;5.2;LAB SERVICE;**1028**;NOV 01, 1997;Build 53
- ;;5.2;LAB SERVICE;**334**;Sep 27, 1994;Build 45
- EN ;
- K LRIO,%ZIS,LRIO
- K DIR,LRANS,Y
- S DIR(0)="SO^L: List of Deprecated codes;M: Mapped Deprecated codes in use"
- S DIR("?")="Listing of LOINC deprecated codes"
- S DIR("?",1)="L = List of all LOINC deprecated codes"
- S DIR("?",2)="M = List of mapped LOINC deprecated codes"
- D ^DIR G END:$G(DIRUT)!($G(Y)="")
- S LRANS=Y
- DEVICE ;
- S %ZIS="NQO",%ZIS("A")="Select Device: ",%ZIS("B")=""
- D ^%ZIS I $G(POP) D END Q
- I IO'=IO(0) D LOAD D END Q
- I LRANS="M" D LNK,END Q
- I LRANS="L" D LST,END
- Q
- LOAD ;
- N ZTRTN,ZTIO,ZTDESC,ZTDTH
- S ZTRTN=$S(LRANS="L":"LST^LRLNCST",1:"LNK^LRLNCST")
- S ZTDTH=$H,ZTDESC="Print laboratory LOINC deprecated codes"
- S ZTIO=IO
- D ^%ZTLOAD
- W !,$S($G(ZTSK):"Tasked to "_ION_" "_ZTSK,1:"Not Tasked")
- Q
- LST ;Print list of deprecated code
- I $D(ZTQUEUED) S ZTREQ="@"
- S LRHDR="List of deprecated codes"
- S (LRPG,LRLNC)=0 D HDR
- F S LRLNC=$O(^LAB(95.3,"AD",1,LRLNC)) Q:LRLNC<1 D
- . K LRANS,ERR
- . D GETS^DIQ(95.3,LRLNC,".01;80","E","LRANS","ERR")
- . Q:$D(ERR)
- . W !,$G(LRANS(95.3,LRLNC_",",.01,"E"))," ",$E($G(LRANS(95.3,LRLNC_",",80,"E")),1,60)
- . I $Y>(IOSL-4) D HDR
- D END Q
- LNK ;Provide list of mapped deprecated LOINC codes
- I $D(ZTQUEUED) S ZTREQ="@"
- S (LRPG,LRIEN)=0,LRNM="",LRPLINE=0
- S LRHDR="List of mapped LOINC deprecated codes" D HDR
- S $P(LRPLN,"+",79)=""
- F S LRNM=$O(^LAB(60,"B",LRNM)) Q:LRNM="" D
- . S LRIEN=0 F S LRIEN=$O(^LAB(60,"B",LRNM,LRIEN)) Q:LRIEN<1 D
- . . Q:$G(^LAB(60,"B",LRNM,LRIEN))
- . . S LR60NM="["_LRIEN_"] "_LRNM_" ",LRPLINE=0
- . . D LK64
- D END Q
- LK64 ;Start looking for NLT linked fields.
- S LR64=$G(^LAB(60,LRIEN,64)),LRONLT=+LR64,LRRNLT=$P(LR64,U,2)
- I LRONLT D ORDER
- I LRRNLT D RESULT
- Q
- RESULT ;Look up result NLT codes
- S LRFLD=1
- D CHK(LRRNLT,LRFLD) Q:$G(LRNOP)
- D LNC(LRRNLT,LRFLD)
- Q
- ORDER ;Look up NLT order codes
- S LRFLD=2
- D CHK(LRONLT,LRFLD) Q:$G(LRNOP)
- D DEF(LRONLT,LRFLD)
- Q
- DEF(LRNLT,FLD) ;Check LOINC default code
- S LRDEF=+$G(^LAM(LRNLT,9)) I LRDEF D
- . S LRNLTNM=$P(^LAM(LRNLT,0),U)_" "_$P(^(0),U,2)
- . I $G(^LAB(95.3,LRDEF,4)) D
- . . I $Y>(IOSL-6) D HDR
- . . D:'$G(LRPLINE) PLN
- . . W !,"Test Name: ",LR60NM
- . . W !,$S(FLD=1:"RESULT NLT Code LOINC Default ",1:"ORDER NLT Code LOINC Default ")
- . . W !,"NLT Code: ",LRNLTNM
- . . W !,LRDEF_"-"_$P(^LAB(95.3,LRDEF,0),U,15)_" "_$G(^LAB(95.3,LRDEF,80)),!
- Q
- CHK(LRP,FLD) ;Check for valid node
- S LRNOP=0 I '$D(^LAM(LRP,0)) D Q
- . D:'$G(LRPLINE) PLN
- . S LRTXT="is not valid"
- . S LRMSG="["_LRIEN_"] "_LRNM_$S(FLD=2:" Order NLT ",1:" Result NLT ")_LRTXT
- . D MSG(LRMSG) S LRNOP=1
- S LRNODE=^LAM(LRP,0),LRCC=$P($P(^(0),U,2),".")
- Q
- MSG(MSG) ;Print
- W !,$$CJ^XLFSTR(MSG,IOM)
- Q
- LNC(LRNLT,LRFLD) ;Check for LOINC in suffixed NLT codes
- S:'LRFLD LRFLD=1
- K LRNOP,LRCC,LRQ,LRQB,NODE
- S LRCC=$P(^LAM(LRNLT,0),U,2) Q:'LRCC!($G(LRNOP)) D
- . S LRQB=$P(LRCC,".")
- . S LRQ=""""_$P(LRCC,".")_".0""",NODE="^LAM(""E"","_LRQ_")"
- . S NODE=$Q(@NODE) I $P($QS(NODE,2),".")'=LRQB S LRNOP=1 Q
- . S LRINLT=$QS(NODE,3) D DEF(LRINLT,LRFLD)
- . D SPEC(LRINLT,3)
- Q
- SPEC(LRNLT,LRFLD) ;Check specimen time aspect LOINC
- S LRSPEC=0 F S LRSPEC=$O(^LAM(LRNLT,5,LRSPEC)) Q:LRSPEC<1 D
- . S LRSPECN=$P($G(^LAB(61,LRSPEC,0)),U)
- . S LRTASP=0 F S LRTASP=$O(^LAM(LRNLT,5,LRSPEC,1,LRTASP)) Q:LRTASP<1 D
- . . S LRTASPN=$P($G(^LAB(64.061,LRTASP,0)),U)
- . . S LRLNC=+$G(^LAM(LRNLT,5,LRSPEC,1,LRTASP,1))
- . . I LRLNC,$G(^LAB(95.3,LRLNC,4)) D DISP
- Q
- DISP ;
- I $Y>(IOSL-5) D HDR
- D:'$G(LRPLINE) PLN
- W !,"Test Name: ",LR60NM
- W !,"NLT Code: ",$P($G(^LAM(LRNLT,0)),U)," ",$P(^(0),U,2)
- W !," ("_LRSPEC_") "_LRSPECN
- W !,"LOINC Code: ",LRTASPN_" ["_LRLNC_"-"_$P(^LAB(95.3,LRLNC,0),U,15)_"]"
- W !,"LOINC Name: ",$G(^LAB(95.3,LRLNC,80))
- Q
- PLN ;
- I $Y>(IOSL-6) D HDR
- W !,LRPLN,!
- S LRPLINE=1
- Q
- END ;
- W !
- W:$E($G(IOST),1,2)="P-" @IOF
- D ^%ZISC
- K ZTSK,ERR,DIRUT,LR64,LRMSG,LRNM,LRNODE,LRNOPE,LRSPEC,LRTXT
- K DIR,LR60NM,LRANS,LRCC,LRDEF,LRFLD,LRHDR,LRIEN,LRINLT,LRNLTNM,LRONLT,LRPG,LRPLINE
- K LRLNC,LRPLN,LRQ,LRQB,LRRNLT,LRSPECN,LRTASP,LRTASPN,NODE,POP,X,Y
- Q
- HDR ;
- S LRPG=$G(LRPG)+1
- W @IOF,LRHDR," Page: ",LRPG,!
- Q
- LRLNCST ;VA/DALOI/FHS-LIST OF LOINC DEPRECIATED CODES ; 5/14/07 12:56pm
- +1 ;;5.2;LAB SERVICE;**1028**;NOV 01, 1997;Build 53
- +2 ;;5.2;LAB SERVICE;**334**;Sep 27, 1994;Build 45
- EN ;
- +1 KILL LRIO,%ZIS,LRIO
- +2 KILL DIR,LRANS,Y
- +3 SET DIR(0)="SO^L: List of Deprecated codes;M: Mapped Deprecated codes in use"
- +4 SET DIR("?")="Listing of LOINC deprecated codes"
- +5 SET DIR("?",1)="L = List of all LOINC deprecated codes"
- +6 SET DIR("?",2)="M = List of mapped LOINC deprecated codes"
- +7 DO ^DIR
- IF $GET(DIRUT)!($GET(Y)="")
- GOTO END
- +8 SET LRANS=Y
- DEVICE ;
- +1 SET %ZIS="NQO"
- SET %ZIS("A")="Select Device: "
- SET %ZIS("B")=""
- +2 DO ^%ZIS
- IF $GET(POP)
- DO END
- QUIT
- +3 IF IO'=IO(0)
- DO LOAD
- DO END
- QUIT
- +4 IF LRANS="M"
- DO LNK
- DO END
- QUIT
- +5 IF LRANS="L"
- DO LST
- DO END
- +6 QUIT
- LOAD ;
- +1 NEW ZTRTN,ZTIO,ZTDESC,ZTDTH
- +2 SET ZTRTN=$SELECT(LRANS="L":"LST^LRLNCST",1:"LNK^LRLNCST")
- +3 SET ZTDTH=$HOROLOG
- SET ZTDESC="Print laboratory LOINC deprecated codes"
- +4 SET ZTIO=IO
- +5 DO ^%ZTLOAD
- +6 WRITE !,$SELECT($GET(ZTSK):"Tasked to "_ION_" "_ZTSK,1:"Not Tasked")
- +7 QUIT
- LST ;Print list of deprecated code
- +1 IF $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +2 SET LRHDR="List of deprecated codes"
- +3 SET (LRPG,LRLNC)=0
- DO HDR
- +4 FOR
- SET LRLNC=$ORDER(^LAB(95.3,"AD",1,LRLNC))
- IF LRLNC<1
- QUIT
- Begin DoDot:1
- +5 KILL LRANS,ERR
- +6 DO GETS^DIQ(95.3,LRLNC,".01;80","E","LRANS","ERR")
- +7 IF $DATA(ERR)
- QUIT
- +8 WRITE !,$GET(LRANS(95.3,LRLNC_",",.01,"E"))," ",$EXTRACT($GET(LRANS(95.3,LRLNC_",",80,"E")),1,60)
- +9 IF $Y>(IOSL-4)
- DO HDR
- End DoDot:1
- +10 DO END
- QUIT
- LNK ;Provide list of mapped deprecated LOINC codes
- +1 IF $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +2 SET (LRPG,LRIEN)=0
- SET LRNM=""
- SET LRPLINE=0
- +3 SET LRHDR="List of mapped LOINC deprecated codes"
- DO HDR
- +4 SET $PIECE(LRPLN,"+",79)=""
- +5 FOR
- SET LRNM=$ORDER(^LAB(60,"B",LRNM))
- IF LRNM=""
- QUIT
- Begin DoDot:1
- +6 SET LRIEN=0
- FOR
- SET LRIEN=$ORDER(^LAB(60,"B",LRNM,LRIEN))
- IF LRIEN<1
- QUIT
- Begin DoDot:2
- +7 IF $GET(^LAB(60,"B",LRNM,LRIEN))
- QUIT
- +8 SET LR60NM="["_LRIEN_"] "_LRNM_" "
- SET LRPLINE=0
- +9 DO LK64
- End DoDot:2
- End DoDot:1
- +10 DO END
- QUIT
- LK64 ;Start looking for NLT linked fields.
- +1 SET LR64=$GET(^LAB(60,LRIEN,64))
- SET LRONLT=+LR64
- SET LRRNLT=$PIECE(LR64,U,2)
- +2 IF LRONLT
- DO ORDER
- +3 IF LRRNLT
- DO RESULT
- +4 QUIT
- RESULT ;Look up result NLT codes
- +1 SET LRFLD=1
- +2 DO CHK(LRRNLT,LRFLD)
- IF $GET(LRNOP)
- QUIT
- +3 DO LNC(LRRNLT,LRFLD)
- +4 QUIT
- ORDER ;Look up NLT order codes
- +1 SET LRFLD=2
- +2 DO CHK(LRONLT,LRFLD)
- IF $GET(LRNOP)
- QUIT
- +3 DO DEF(LRONLT,LRFLD)
- +4 QUIT
- DEF(LRNLT,FLD) ;Check LOINC default code
- +1 SET LRDEF=+$GET(^LAM(LRNLT,9))
- IF LRDEF
- Begin DoDot:1
- +2 SET LRNLTNM=$PIECE(^LAM(LRNLT,0),U)_" "_$PIECE(^(0),U,2)
- +3 IF $GET(^LAB(95.3,LRDEF,4))
- Begin DoDot:2
- +4 IF $Y>(IOSL-6)
- DO HDR
- +5 IF '$GET(LRPLINE)
- DO PLN
- +6 WRITE !,"Test Name: ",LR60NM
- +7 WRITE !,$SELECT(FLD=1:"RESULT NLT Code LOINC Default ",1:"ORDER NLT Code LOINC Default ")
- +8 WRITE !,"NLT Code: ",LRNLTNM
- +9 WRITE !,LRDEF_"-"_$PIECE(^LAB(95.3,LRDEF,0),U,15)_" "_$GET(^LAB(95.3,LRDEF,80)),!
- End DoDot:2
- End DoDot:1
- +10 QUIT
- CHK(LRP,FLD) ;Check for valid node
- +1 SET LRNOP=0
- IF '$DATA(^LAM(LRP,0))
- Begin DoDot:1
- +2 IF '$GET(LRPLINE)
- DO PLN
- +3 SET LRTXT="is not valid"
- +4 SET LRMSG="["_LRIEN_"] "_LRNM_$SELECT(FLD=2:" Order NLT ",1:" Result NLT ")_LRTXT
- +5 DO MSG(LRMSG)
- SET LRNOP=1
- End DoDot:1
- QUIT
- +6 SET LRNODE=^LAM(LRP,0)
- SET LRCC=$PIECE($PIECE(^(0),U,2),".")
- +7 QUIT
- MSG(MSG) ;Print
- +1 WRITE !,$$CJ^XLFSTR(MSG,IOM)
- +2 QUIT
- LNC(LRNLT,LRFLD) ;Check for LOINC in suffixed NLT codes
- +1 IF 'LRFLD
- SET LRFLD=1
- +2 KILL LRNOP,LRCC,LRQ,LRQB,NODE
- +3 SET LRCC=$PIECE(^LAM(LRNLT,0),U,2)
- IF 'LRCC!($GET(LRNOP))
- QUIT
- Begin DoDot:1
- +4 SET LRQB=$PIECE(LRCC,".")
- +5 SET LRQ=""""_$PIECE(LRCC,".")_".0"""
- SET NODE="^LAM(""E"","_LRQ_")"
- +6 SET NODE=$QUERY(@NODE)
- IF $PIECE($QSUBSCRIPT(NODE,2),".")'=LRQB
- SET LRNOP=1
- QUIT
- +7 SET LRINLT=$QSUBSCRIPT(NODE,3)
- DO DEF(LRINLT,LRFLD)
- +8 DO SPEC(LRINLT,3)
- End DoDot:1
- +9 QUIT
- SPEC(LRNLT,LRFLD) ;Check specimen time aspect LOINC
- +1 SET LRSPEC=0
- FOR
- SET LRSPEC=$ORDER(^LAM(LRNLT,5,LRSPEC))
- IF LRSPEC<1
- QUIT
- Begin DoDot:1
- +2 SET LRSPECN=$PIECE($GET(^LAB(61,LRSPEC,0)),U)
- +3 SET LRTASP=0
- FOR
- SET LRTASP=$ORDER(^LAM(LRNLT,5,LRSPEC,1,LRTASP))
- IF LRTASP<1
- QUIT
- Begin DoDot:2
- +4 SET LRTASPN=$PIECE($GET(^LAB(64.061,LRTASP,0)),U)
- +5 SET LRLNC=+$GET(^LAM(LRNLT,5,LRSPEC,1,LRTASP,1))
- +6 IF LRLNC
- IF $GET(^LAB(95.3,LRLNC,4))
- DO DISP
- End DoDot:2
- End DoDot:1
- +7 QUIT
- DISP ;
- +1 IF $Y>(IOSL-5)
- DO HDR
- +2 IF '$GET(LRPLINE)
- DO PLN
- +3 WRITE !,"Test Name: ",LR60NM
- +4 WRITE !,"NLT Code: ",$PIECE($GET(^LAM(LRNLT,0)),U)," ",$PIECE(^(0),U,2)
- +5 WRITE !," ("_LRSPEC_") "_LRSPECN
- +6 WRITE !,"LOINC Code: ",LRTASPN_" ["_LRLNC_"-"_$PIECE(^LAB(95.3,LRLNC,0),U,15)_"]"
- +7 WRITE !,"LOINC Name: ",$GET(^LAB(95.3,LRLNC,80))
- +8 QUIT
- PLN ;
- +1 IF $Y>(IOSL-6)
- DO HDR
- +2 WRITE !,LRPLN,!
- +3 SET LRPLINE=1
- +4 QUIT
- END ;
- +1 WRITE !
- +2 IF $EXTRACT($GET(IOST),1,2)="P-"
- WRITE @IOF
- +3 DO ^%ZISC
- +4 KILL ZTSK,ERR,DIRUT,LR64,LRMSG,LRNM,LRNODE,LRNOPE,LRSPEC,LRTXT
- +5 KILL DIR,LR60NM,LRANS,LRCC,LRDEF,LRFLD,LRHDR,LRIEN,LRINLT,LRNLTNM,LRONLT,LRPG,LRPLINE
- +6 KILL LRLNC,LRPLN,LRQ,LRQB,LRRNLT,LRSPECN,LRTASP,LRTASPN,NODE,POP,X,Y
- +7 QUIT
- HDR ;
- +1 SET LRPG=$GET(LRPG)+1
- +2 WRITE @IOF,LRHDR," Page: ",LRPG,!
- +3 QUIT
