LRLNCMD ;DALOI/CA/FHS-MAP LAB TESTS TO DEFAULT LOINC CODES ;1-MAY-1999
;;5.2;LAB SERVICE;**232,278,280,407**;Sep 27,1994;Build 1
;=================================================================
; Ask VistA test to map-Lookup in Lab Test file #60
START ;entry point from option LR LOINC MAPPING
Q:$D(LRDFONLY)
S LREND=0 D TEST
I $G(LREND) G EXIT
I '$G(LRNLT) G START
DEFAULT ;ENTRY POINT FROM LRLNC0
W !
S DIR(0)="Y",DIR("A")="Do you want to see possible LOINC code matches"
S DIR("?")="Enter no if you already know the LOINC code."
S DIR("B")="No"
D ^DIR K DIR
I $D(DIRUT),$G(LRLNC1) Q
I $D(DIRUT) D EXIT G START
I 'Y D ENTERLNC^LRLNCC
I $G(LREND),$G(LRLNC1) K LREND Q
I $G(LREND) D EXIT G START
I '$G(LRCODE) D LOINC
I $G(LRNO),$G(LRLNC1) K LREND Q
I $G(LRNO) D EXIT G START
I $G(LREND),$G(LRLNC1) K LREND Q
I $G(LREND) D EXIT G START
I $G(LRNO) D ENTERLNC^LRLNCC
I $G(LREND),$G(LRLNC1) K LREND Q
I $G(LREND) D EXIT G START
CORRECT W !!
S DIR(0)="Y",DIR("A")="Is this the correct one"
S DIR("B")="Yes"
S DIR("?")="Enter no to select a different code."
D ^DIR K DIR
I $D(DIRUT)!($G(LREND)),$G(LRLNC1) K LREND Q
I $D(DIRUT)!($G(LREND)) D EXIT G START
I 'Y,$G(LRNO) D ENTERLNC^LRLNCC
I 'Y,'$G(LRNO) D LOINC
I $G(LRNO) D EXIT G START
I $G(LREND),$G(LRLNC1) K LREND Q
I $G(LREND) D EXIT G START
D LINK
I $G(LREND),$G(LRLNC1) K LREND Q
I $G(LREND) D EXIT G START
D CHECK
I $G(LREND),$G(LRLNC1) K LREND Q
I $G(LREND) D EXIT G START
D MAP
I $G(LRLNC1) K LRCODE Q
D EXIT
G START
EXIT I $G(LRNLT) L -^LAM(LRNLT,9)
K DA,DIC,DIE,DINUM,DIR,DIRUT,DR,DTOUT,I,LRCODE,LRDATA,LREND,LRLNC,LRLNC0,LRLOINC,LRELEC,LRIEN,LRNLT,LRSPEC,LRSPECL,LRSPECN,LRTIME,LRTEST,LRUNITS,S,Y
K DD,DO,DLAYGO,LRLNCNAM,LRNO,X,LRNUM,LROLDCD
QUIT
TEST D TEST^LRLNC0
Q
LOINC ;Lookup possible LOINC matches in LAB LOINC file #95.3
D FIND^DIC(95.3,"","80","M",LRTEST,"","","I '$G(^(4))","","LRLOINC","")
CODE ;ask which code to map
I +LRLOINC("DILIST",0)=0 D Q
.W !!,"No matches found."
.S LRNO=1
W ! S I=0
F S I=$O(LRLOINC("DILIST","ID",I)) Q:'I!$G(LREND) D
.I $E(IOST,1,2)="C-",'(I#18) D Q:$G(LREND)
..S DIR(0)="E" D ^DIR
..S:$S($G(DIRUT):1,$G(DUOUT):1,1:0) LREND=1
.W !,I,":",LRLOINC("DILIST","ID",I,80)
K DIRUT,DUOUT
W !!
S DIR(0)="N^1:"_$S($G(LREND):I-2,1:$P(LRLOINC("DILIST",0),U),1:0)
S DIR("A")="LOINC code to map this test"
D ^DIR K DIR,LREND
I $D(DIRUT) S LREND=1 Q
S LRCODE=LRLOINC("DILIST",1,+Y)
D DISPL^LRLNCC
Q
LINK ;Link the code with file 64
S LRNLT=+$P(^LAM(LRNLT,0),U,2)
LR64 ;
K DIC,DA
W !!
S DIC=64,DIC(0)="ENMZ",X=LRNLT
D ^DIC
I Y=-1!($D(DTOUT))!($D(DUOUT)) K DTOUT,DUOUT S LREND=1 Q
S LRNLT=+Y
Q
CHECK ;Check to see if already mapped to a LOINC code
Q:'$P($G(^LAM(LRNLT,9)),U)
D SHOWPRE
I $D(DIRUT)!'Y S LREND=1 Q
;DELETE EXISTING DEFAULT MAPPING
S DA=LRNLT
S DIE="^LAM(",DR="25////@"
D ^DIE
K DA,DIE
Q
MAP ;DIE call to add DEFAULT LOINC CODE
I '$D(LRDFONLY) S LRDATA=$P(^LAB(60,LRIEN,0),U,12) ;DATA NAME
I '$L(LRDATA) S LRDATA=$P(^LAB(60,LRIEN,0),U,4)
S LRTIME=$P(^LAB(95.3,LRCODE,0),U,7) ;TIME ASPECT
S LRUNITS=$P(^LAB(95.3,LRCODE,0),U,14) ;UNITS
L +^LAM(LRNLT):1 I '$T W !,"Another user is editing this record!!" H 5 Q
S DIE="^LAM(",DA=LRNLT,DR="25////"_LRCODE_";25.2////"_LRTIME_";25.3////"_LRUNITS_";25.4////"_LRDATA_";25.5////"_$S($D(LRDFONLY):"@",1:LRIEN)
D ^DIE
L -^LAM(LRNLT)
MAP2 ;HERE SHOW WHAT WAS MAPPED
Q:'$D(^LAM(+$G(LRNLT),0))#2
W !!
W !,"NLT: ",$P($G(^LAM(LRNLT,0)),U)
W !,"WKLD CODE: ",$P($G(^LAM(LRNLT,0)),U,2)
K DIC,DR
S DIC="^LAM(",DA=LRNLT
S S=$Y
D EN^DIQ
Q
SHOWPRE ;DISPLAY LOINC CODE ALREADY MAPPED TO NLT
S LROLDCD=$P(^LAM(LRNLT,9),U)
W !!,"This test is already mapped to:"
W !,"Default LOINC code: ",LROLDCD_"-"_$P(^LAB(95.3,+$G(LROLDCD),0),U,15)," ",$G(^LAB(95.3,LROLDCD,80))
W !!
S DIR(0)="Y",DIR("A")="Do you want to "_$S($D(LRDEL):"delete",1:"change")_" this default mapping",DIR("B")="NO"
S:'$D(LRDEL) DIR("?")="If you enter yes, the current default LOINC code will be overwritten with the default LOINC code that you have chosen."
S:$D(LRDEL) DIR("?")="If you enter yes, the current default LOINC code will be deleted."
D ^DIR K DIR
Q
DELETE ;DELETE/UNMAP DEFAULT LOINC CODE
S LREND=0,LRDEL=1 D TEST
I $G(LREND) G EXIT
D CHECK
K LRDEL
G EXIT
Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRLNCMD 4416 printed Dec 13, 2024@02:16:37 Page 2
LRLNCMD ;DALOI/CA/FHS-MAP LAB TESTS TO DEFAULT LOINC CODES ;1-MAY-1999
+1 ;;5.2;LAB SERVICE;**232,278,280,407**;Sep 27,1994;Build 1
+2 ;=================================================================
+3 ; Ask VistA test to map-Lookup in Lab Test file #60
START ;entry point from option LR LOINC MAPPING
+1 if $DATA(LRDFONLY)
QUIT
+2 SET LREND=0
DO TEST
+3 IF $GET(LREND)
GOTO EXIT
+4 IF '$GET(LRNLT)
GOTO START
DEFAULT ;ENTRY POINT FROM LRLNC0
+1 WRITE !
+2 SET DIR(0)="Y"
SET DIR("A")="Do you want to see possible LOINC code matches"
+3 SET DIR("?")="Enter no if you already know the LOINC code."
+4 SET DIR("B")="No"
+5 DO ^DIR
KILL DIR
+6 IF $DATA(DIRUT)
IF $GET(LRLNC1)
QUIT
+7 IF $DATA(DIRUT)
DO EXIT
GOTO START
+8 IF 'Y
DO ENTERLNC^LRLNCC
+9 IF $GET(LREND)
IF $GET(LRLNC1)
KILL LREND
QUIT
+10 IF $GET(LREND)
DO EXIT
GOTO START
+11 IF '$GET(LRCODE)
DO LOINC
+12 IF $GET(LRNO)
IF $GET(LRLNC1)
KILL LREND
QUIT
+13 IF $GET(LRNO)
DO EXIT
GOTO START
+14 IF $GET(LREND)
IF $GET(LRLNC1)
KILL LREND
QUIT
+15 IF $GET(LREND)
DO EXIT
GOTO START
+16 IF $GET(LRNO)
DO ENTERLNC^LRLNCC
+17 IF $GET(LREND)
IF $GET(LRLNC1)
KILL LREND
QUIT
+18 IF $GET(LREND)
DO EXIT
GOTO START
CORRECT WRITE !!
+1 SET DIR(0)="Y"
SET DIR("A")="Is this the correct one"
+2 SET DIR("B")="Yes"
+3 SET DIR("?")="Enter no to select a different code."
+4 DO ^DIR
KILL DIR
+5 IF $DATA(DIRUT)!($GET(LREND))
IF $GET(LRLNC1)
KILL LREND
QUIT
+6 IF $DATA(DIRUT)!($GET(LREND))
DO EXIT
GOTO START
+7 IF 'Y
IF $GET(LRNO)
DO ENTERLNC^LRLNCC
+8 IF 'Y
IF '$GET(LRNO)
DO LOINC
+9 IF $GET(LRNO)
DO EXIT
GOTO START
+10 IF $GET(LREND)
IF $GET(LRLNC1)
KILL LREND
QUIT
+11 IF $GET(LREND)
DO EXIT
GOTO START
+12 DO LINK
+13 IF $GET(LREND)
IF $GET(LRLNC1)
KILL LREND
QUIT
+14 IF $GET(LREND)
DO EXIT
GOTO START
+15 DO CHECK
+16 IF $GET(LREND)
IF $GET(LRLNC1)
KILL LREND
QUIT
+17 IF $GET(LREND)
DO EXIT
GOTO START
+18 DO MAP
+19 IF $GET(LRLNC1)
KILL LRCODE
QUIT
+20 DO EXIT
+21 GOTO START
EXIT IF $GET(LRNLT)
LOCK -^LAM(LRNLT,9)
+1 KILL DA,DIC,DIE,DINUM,DIR,DIRUT,DR,DTOUT,I,LRCODE,LRDATA,LREND,LRLNC,LRLNC0,LRLOINC,LRELEC,LRIEN,LRNLT,LRSPEC,LRSPECL,LRSPECN,LRTIME,LRTEST,LRUNITS,S,Y
+2 KILL DD,DO,DLAYGO,LRLNCNAM,LRNO,X,LRNUM,LROLDCD
+3 QUIT
TEST DO TEST^LRLNC0
+1 QUIT
LOINC ;Lookup possible LOINC matches in LAB LOINC file #95.3
+1 DO FIND^DIC(95.3,"","80","M",LRTEST,"","","I '$G(^(4))","","LRLOINC","")
CODE ;ask which code to map
+1 IF +LRLOINC("DILIST",0)=0
Begin DoDot:1
+2 WRITE !!,"No matches found."
+3 SET LRNO=1
End DoDot:1
QUIT
+4 WRITE !
SET I=0
+5 FOR
SET I=$ORDER(LRLOINC("DILIST","ID",I))
if 'I!$GET(LREND)
QUIT
Begin DoDot:1
+6 IF $EXTRACT(IOST,1,2)="C-"
IF '(I#18)
Begin DoDot:2
+7 SET DIR(0)="E"
DO ^DIR
+8 if $SELECT($GET(DIRUT)
SET LREND=1
End DoDot:2
if $GET(LREND)
QUIT
+9 WRITE !,I,":",LRLOINC("DILIST","ID",I,80)
End DoDot:1
+10 KILL DIRUT,DUOUT
+11 WRITE !!
+12 SET DIR(0)="N^1:"_$SELECT($GET(LREND):I-2,1:$PIECE(LRLOINC("DILIST",0),U),1:0)
+13 SET DIR("A")="LOINC code to map this test"
+14 DO ^DIR
KILL DIR,LREND
+15 IF $DATA(DIRUT)
SET LREND=1
QUIT
+16 SET LRCODE=LRLOINC("DILIST",1,+Y)
+17 DO DISPL^LRLNCC
+18 QUIT
LINK ;Link the code with file 64
+1 SET LRNLT=+$PIECE(^LAM(LRNLT,0),U,2)
LR64 ;
+1 KILL DIC,DA
+2 WRITE !!
+3 SET DIC=64
SET DIC(0)="ENMZ"
SET X=LRNLT
+4 DO ^DIC
+5 IF Y=-1!($DATA(DTOUT))!($DATA(DUOUT))
KILL DTOUT,DUOUT
SET LREND=1
QUIT
+6 SET LRNLT=+Y
+7 QUIT
CHECK ;Check to see if already mapped to a LOINC code
+1 if '$PIECE($GET(^LAM(LRNLT,9)),U)
QUIT
+2 DO SHOWPRE
+3 IF $DATA(DIRUT)!'Y
SET LREND=1
QUIT
+4 ;DELETE EXISTING DEFAULT MAPPING
+5 SET DA=LRNLT
+6 SET DIE="^LAM("
SET DR="25////@"
+7 DO ^DIE
+8 KILL DA,DIE
+9 QUIT
MAP ;DIE call to add DEFAULT LOINC CODE
+1 ;DATA NAME
IF '$DATA(LRDFONLY)
SET LRDATA=$PIECE(^LAB(60,LRIEN,0),U,12)
+2 IF '$LENGTH(LRDATA)
SET LRDATA=$PIECE(^LAB(60,LRIEN,0),U,4)
+3 ;TIME ASPECT
SET LRTIME=$PIECE(^LAB(95.3,LRCODE,0),U,7)
+4 ;UNITS
SET LRUNITS=$PIECE(^LAB(95.3,LRCODE,0),U,14)
+5 LOCK +^LAM(LRNLT):1
IF '$TEST
WRITE !,"Another user is editing this record!!"
HANG 5
QUIT
+6 SET DIE="^LAM("
SET DA=LRNLT
SET DR="25////"_LRCODE_";25.2////"_LRTIME_";25.3////"_LRUNITS_";25.4////"_LRDATA_";25.5////"_$SELECT($DATA(LRDFONLY):"@",1:LRIEN)
+7 DO ^DIE
+8 LOCK -^LAM(LRNLT)
MAP2 ;HERE SHOW WHAT WAS MAPPED
+1 if '$DATA(^LAM(+$GET(LRNLT),0))#2
QUIT
+2 WRITE !!
+3 WRITE !,"NLT: ",$PIECE($GET(^LAM(LRNLT,0)),U)
+4 WRITE !,"WKLD CODE: ",$PIECE($GET(^LAM(LRNLT,0)),U,2)
+5 KILL DIC,DR
+6 SET DIC="^LAM("
SET DA=LRNLT
+7 SET S=$Y
+8 DO EN^DIQ
+9 QUIT
SHOWPRE ;DISPLAY LOINC CODE ALREADY MAPPED TO NLT
+1 SET LROLDCD=$PIECE(^LAM(LRNLT,9),U)
+2 WRITE !!,"This test is already mapped to:"
+3 WRITE !,"Default LOINC code: ",LROLDCD_"-"_$PIECE(^LAB(95.3,+$GET(LROLDCD),0),U,15)," ",$GET(^LAB(95.3,LROLDCD,80))
+4 WRITE !!
+5 SET DIR(0)="Y"
SET DIR("A")="Do you want to "_$SELECT($DATA(LRDEL):"delete",1:"change")_" this default mapping"
SET DIR("B")="NO"
+6 if '$DATA(LRDEL)
SET DIR("?")="If you enter yes, the current default LOINC code will be overwritten with the default LOINC code that you have chosen."
+7 if $DATA(LRDEL)
SET DIR("?")="If you enter yes, the current default LOINC code will be deleted."
+8 DO ^DIR
KILL DIR
+9 QUIT
DELETE ;DELETE/UNMAP DEFAULT LOINC CODE
+1 SET LREND=0
SET LRDEL=1
DO TEST
+2 IF $GET(LREND)
GOTO EXIT
+3 DO CHECK
+4 KILL LRDEL
+5 GOTO EXIT
+6 QUIT
+7 QUIT
