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
