LRLNC0 ;DALOI/CA/FHS-MAP LAB TESTS TO LOINC CODES ;1-OCT-1998
;;5.2;LAB SERVICE;**215,232,278,280,399,407**;Sep 27,1994;Build 1
;Reference to ^DD supported by IA # 10154
;=================================================================
; Ask VistA test to map-Lookup in Lab Test file #60
START ;entry point from option LR LOINC MAPPING
S LREND=0,LRLNC1=1 D TEST
I $G(LREND) G EXIT
I '$G(LRNLT) G START
;MAP DEFAULT
DEFAULT ;
N LRNLTX
Q:'$D(^LAM(+$G(LRNLT),0))#2
S LRNLTX=LRNLT
L +^LAM(LRNLTX,9):2 I '$T W !!?5,"Locked by another user",! H 5 Q
W !
K DIR S DIR("B")="No"
S DIR(0)="Y",DIR("A")="Do you want to edit/delete the Default LOINC code"
S DIR("?")="Enter yes to map/change the default LOINC code."
D ^DIR K DIR
L -^LAM(LRNLTX,9)
I $D(DIRUT) Q
I $G(LRDFONLY),$D(DIRUT) Q
I '$G(LRDFONLY),$D(DIRUT) D EXIT G START
I Y D D DEFAULT^LRLNCMD
. Q:'$G(^LAM(LRNLT,9))
. W !!?5,"Deleting LOINC Default Code",!
. N DA,DR,X,DIE
. S DIE="^LAM(",DA=+LRNLT,DR="25///^S X=""@""" D ^DIE
L -^LAM(LRNLTX,9)
I $G(LRDFONLY) Q
I '$P($P($G(^LAB(60,LRIEN,0)),U,5),";",2) Q
ASKSPEC D SPEC
I $G(LREND) D EXIT G START
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) D EXIT G START
I 'Y D ENTERLNC^LRLNCC
I $G(LREND) D EXIT G START
I '$G(LRCODE) D LOINC
I $G(LRNO) D EXIT G START
I $G(LREND) D EXIT G START
I $G(LRNO) D ENTERLNC^LRLNCC
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)) 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) D EXIT G START
D CHKSPEC
I $G(LRNO) D EXIT G START
I $G(LRNEXT) G NEXTSP
I $G(LREND) D EXIT G START
D LINK
I $G(LRNEXT) G NEXTSP
I $G(LREND) D EXIT G START
D CHECK
I $G(LRNEXT) G NEXTSP
I $G(LREND) D EXIT G START
D MAP
NEXTSP D KILL1
G ASKSPEC
KILL1 I $G(LRNLT) L -^LAM(LRNLT,9)
K DA,DIC,DIE,DINUM,DIR,DIRUT,DR,DTOUT,I,LRLNC,LRLNC0,LRLOINC,LRELEC,LRCODE,LRSPEC,LRSPECL,LRSPECN,LRTIME,LRUNTIS,S,Y
K DD,D0,DLAYGO,LRLNCNAM,LRNO,LRNOP,LRLNC1,LRNEXT,LRODLCD,X
Q
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
K LRSPEC,LRSPECL,LRSPECN,LRTIME,LRTEST,LRUNITS,S,Y
K DD,DO,DLAYGO,LRLNCNAM,LRNO,LRNOP,LRDEF,LRLNC1,LRNEXT,LROLDCD,X
QUIT
TEST W @IOF
K DIR,LRNLT
S DIR(0)="PO^60:QENMZ,",DIR("A")="VistA Lab Test to "_$S($D(LRDEL):"Delete/Unmap",1:"Link/Map")_" to LOINC "
S DIR("?")="Select Lab test you wish to "_$S($D(LRDEL):"delete/unmap",1:"link/map")_" to a LOINC Code"
D ^DIR K DIR
I $D(DIRUT)!'Y K DIRUT S LREND=1 K LRDEL Q
S LRIEN=+Y,LRTEST=$P(Y,U,2)
L +^LAB(60,LRIEN):2 I '$T W !?4,"Another user is editing this entry",! H 5 Q
;Check for RESULT NLT CODE and if not one let enter
S LRNLT=+$P($G(^LAB(60,LRIEN,64)),U,2)
DIS64 D Q:$G(LR64DIS)
. Q:'$G(LRNLT)
. N LRLNC,LRANS
. S LRLNC=$P($G(^LAM(LRNLT,9)),U) Q:'LRLNC
. D GETS^DIQ(64,LRNLT_",",".01;1","E","LRANS")
. D GETS^DIQ(95.3,LRLNC_",",".01;80","E","LRANS")
. W !,!?5,$G(LRANS(64,LRNLT_",",.01,"E"))_" "_$G(LRANS(64,LRNLT_",",1,"E"))
. W !?4,"Default LOINC Already Mapped to:"
. W !,$G(LRANS(95.3,LRLNC_",",.01,"E"))_" "_$G(LRANS(95.3,LRLNC_",",80,"E"))
I '$P($G(^LAB(60,LRIEN,64)),U,2) D
.W !!,"There is not a RESULT NLT CODE for "_LRTEST,".",!
.W !,"You must select one now to continue with the mapping of this test!",!
K DIE,DA,DR S DIE="^LAB(60,",DA=+LRIEN,DR=64.1 D ^DIE K DIE,DA,DR
L -^LAB(60,LRIEN)
I $G(X)<1!($D(Y)) S LRNLT="",LREND=1 K LRDEL Q
I $P($G(^LAB(60,+LRIEN,64)),U,2) D
. N DIC,DA,DR
. S DIC="^LAB(60,",DA=+LRIEN,DR=64 W !! W ?5,"IEN: [",DA,"] ",$P(^LAB(60,LRIEN,0),U) S S=$Y D EN^DIQ
W !
S LRNLT=$P($G(^LAB(60,LRIEN,64)),U,2)
I 'LRNLT G TEST
Q
SPEC ; Ask Specimen- Lookup in Specimen multiple in Lab Test file #60
W !!
LOOK61 K DIC,DA
N LRANS
Q:'$G(LRIEN)
S DIC=61,DIC(0)="AENMZQ"
S DIC("A")="Specimen source: "
D ^DIC
I $D(DUOUT)!($D(DTOUT))!(Y<1) D Q
.K DIC,DA,DTOUT,DUOUT S LREND=1 Q
Q:$G(LREND)
S LRSPEC=+Y,LRSPECN=Y(0,0)
K DA,DIC,DIE,DR
I '$L($P($G(^LAB(60,LRIEN,0)),U,5)) G OVER
I '$D(^LAB(60,LRIEN,1)) D
.S DIC("P")=$P(^DD(60,100,0),"^",2)
I '$D(^LAB(60,LRIEN,1,LRSPEC)) D G:$G(LRNOP) LOOK61
. N DIR
. W !," Are you sure you want to add this specimen"
. S DIR(0)="Y" D ^DIR I Y<1 S LRNOP=1 Q
. K DD,DO
. S DA(1)=LRIEN,X=LRSPEC,DINUM=X
. S DIC="^LAB(60,"_DA(1)_",1,"
. S DIC(0)="LMZ",DLAYGO=60.01
. D FILE^DICN S LRANS=Y
;A DIE call is made to edit fields in subfile
I $P($G(LRANS),U,3) D
.S DIE=DIC K DIC
.S DA=+Y
.S DR="1:9.3"
.D ^DIE
K DIE,DR,DA
OVER ;Check to see if linked to file 64.061. If not, then let enter link.
I '$P($G(^LAB(61,LRSPEC,0)),U,9) D
.W !!,"There is not a LEDI HL7 code for "_LRSPECN,"."
.W !,"You must select one now to continue with the mapping of this test and specimen!",!
I '$P($G(^LAB(61,LRSPEC,0)),U,10) D G:$G(LRNOP) LOOK61
.W !!,"There is not a TIME ASPECT for "_LRSPECN,".",!
.K DIE,DR,DA S DA=LRSPEC,DIE="^LAB(61,",DR=".09:.0961"
.D ^DIE
.S:$D(DIRUT) LRNOP=1
S LRELEC=$P($G(^LAB(61,LRSPEC,0)),U,9)
I 'LRELEC G SPEC
S LRSPECL=$P(^LAB(64.061,LRELEC,0),U,2)
Q
LOINC ;Lookup possible LOINC matches in LAB LOINC file #95.3
D FIND^DIC(95.3,"","80","M",LRTEST,"","","I $P(^(0),U,8)=$G(LRELEC)!(LRELEC=74!(LRELEC=83)!(LRELEC=114)!(LRELEC=1376)&(""SER PLAS BLD""[$P(^(80),"":"",4)))","","LRLOINC","")
CODE ;ask which code to map
D CODE^LRLNCC
Q
LINK ;Link the code with file 64
S LRDATA=$P(^LAB(60,LRIEN,0),U,12) ;DATA NAME
I '$L(LRDATA) S LRDATA=$P($G(^LAB(60,+$G(LRIEN),0)),U,4) ;Set to subscript of test.
S LRTIME=$P(^LAB(95.3,LRCODE,0),U,7) ;TIME ASPECT
S LRUNITS=$P(^LAB(95.3,LRCODE,0),U,14) ;UNITS
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 EXIT S LREND=1 Q
I $D(DTOUT)!($D(DUOUT)) K DTOUT,DUOUT D EXIT S LREND=1 Q
I 'Y S LRNEXT=1 Q
S LRNLT=+Y
Q
CHECK ;Check to see if already mapped to a LOINC code
I $D(^LAM(LRNLT,5,LRSPEC,1,"B",LRTIME)) D SHOWPRE I $D(DIRUT) D EXIT S LREND=1 Q
I Y<1 S LRNEXT=1
Q
MAP ;DIE call to add data name,time aspect,units, LOINC code, and lab test fields
L +^LAM(LRNLT,5):1 I '$T W !,"Another user is editing this record" H 5 Q
I '$D(^LAM(LRNLT,5,0)) D
.S DIC("P")=$P(^DD(64,20,0),"^",2)
I '$D(^LAM(LRNLT,5,LRSPEC)) D
.K DD,DO
.S DA(1)=LRNLT,DA=LRSPEC
.S DIC="^LAM("_DA(1)_",5,",DIC(0)="L",DLAYGO=64,X=LRSPEC,DINUM=X
.D FILE^DICN
I '$D(^LAM(LRNLT,5,LRSPEC,1,0)) D
.S DIC("P")=$P(^DD(64.01,30,0),"^",2)
S DA(2)=LRNLT,DA(1)=LRSPEC,X=LRTIME,DINUM=X
S DIC="^LAM("_DA(2)_",5,"_DA(1)_",1,"
I '$D(^LAM(LRNLT,5,LRSPEC,1,LRTIME)) D
.K DD,DO
.S DIC(0)="L",DLAYGO=64
.D FILE^DICN
S DA=LRTIME
K DIE,DR S DIE=DIC K DIC
S DR="1////"_LRUNITS_";2////"_LRDATA_";3////"_LRIEN_";4////"_LRCODE
D ^DIE
L -^LAM(LRNLT,5)
;HERE SHOW WHAT WAS MAPPED
W @IOF
W !!
W !,"NLT: ",$P($G(^LAM(LRNLT,0)),U)
W !,"WKLD CODE: ",$P($G(^LAM(LRNLT,0)),U,2)
W !,"SPECIMEN: ",$P($G(^LAB(61,LRSPEC,0)),U)
K DIC,DR
S DIC=DIE
S S=$Y
D EN^DIQ
INDEX60 ;Stores LOINC code in Laboratory Test file (#60) so know what tests are mapped.
Q:'$L($P($G(^LAB(60,LRIEN,0)),U,5)) ;set only atomic tests
N LRDA,LRFDA,LRERR
I '$G(^LAB(60,LRIEN,1,LRSPEC,0)) D
. K LRFDA,LRDA
. S LRFDA(1,60.01,"+1,"_LRIEN_",",.01)=LRSPEC
. S LRDA(1)=LRSPEC
. D UPDATE^DIE("","LRFDA(1)","LRDA","LRERR")
Q:$D(LRERR)
K LRFDA
S LRFDA(2,60.01,LRSPEC_","_LRIEN_",",95.3)=LRCODE
D FILE^DIE("","LRFDA(2)","LRERR")
Q
SHOWPRE ;DISPLAY LOINC CODE ALREADY MAPPED TO NLT
S LRLNC=$P($G(^LAM(LRNLT,5,LRSPEC,1,LRTIME,1)),U)
W !!,"This test and specimen is already mapped to:"
W !,"LOINC code: ",LRLNC," ",$G(^LAB(95.3,+LRLNC,80))
W !
K DIR S DIR("B")="No"
S DIR(0)="Y",DIR("A")="Do you want to change this mapping"
S DIR("?")="If you enter yes, the current LOINC code will be overwritten with the LOINC code that you have chosen."
D ^DIR K DIR
Q
CHKSPEC ;Check that specimen of LOINC code same as specimen of test
I LRLNC0(8)=$G(LRELEC) Q
I (LRLNC0(8)=74!(LRLNC0(8)=83)!(LRLNC0(8)=114)!(LRLNC0(8)=1376))&($G(LRELEC)=74!($G(LRELEC)=83)!($G(LRELEC)=114)!($G(LRELEC)=1376)) Q
W !!,"The LOINC code that you have selected does not have the"
W !,"same specimen that you chose to map."
S DIR(0)="Y",DIR("A")="Are you sure you want to do this"
S DIR("?")="If you enter yes, the test will be mapped to this LOINC code."
S DIR("B")="Yes"
D ^DIR K DIR
I $D(DIRUT) S LREND=1 Q
I Y<1 S LRNO=1
Q
6206 ;LOINC mapping ANTIMICROBIAL [^LAB(62.060)]
W !!
D EXITMI
S (LRDEL,LRDFONLY)=1
S DIR(0)="PO^62.06:QENMZ",DIR("A")="Select Antimicrobial "
S DIR("?")="Select Antimicrobial Susceptibility Drug"
D ^DIR K DIR
I $D(DIRUT)!(Y<1) K DIRUT D EXITMI Q
S LRIEN=Y,LRTEST=$P(Y(0),U,2)
L +^LAB(62.06,LRIEN):2 I '$T W !?4,"Being edited by another user" H 5 G 6206
;Display Mapped code
S (LRNLTX,LRNLT)=+$P($G(^LAB(62.06,+LRIEN,64)),U)
I LRNLT D
. N LR64DIS
. S LR64DIS=1 D DIS64
D
. N DIE,DA,DR
. S DIE="^LAB(62.06,",DIC=DIE,DA=+LRIEN,DR=64 D ^DIE
L -^LAB(62.06,LRIEN)
I '$G(^LAB(62.06,+LRIEN,64))!($D(DTOUT))!($D(DUOUT)) G 6206
S LRDATA="LAB(62.06,"_+LRIEN_",",LRIEN=+LRIEN
S LRNLT=$P($G(^LAB(62.06,+LRIEN,64)),U)
I LRNLT S LRTEST=$$GET1^DIQ(64,LRNLT_",",.01,"ERR","ANS")
I LRNLT W ! D DEFAULT
G 6206
Q
EXITMI ;Clean up 6206 variables.
K ANS,DA,DIC,DIE,DIR,DIRUT,DR,DTOUT,DUOUT,ERR,LRANS,LRDATA,LRDEF,LRDFONLY,LRNLT,LRNLTX,LRIEN,LRTEST
K LRDEL,LRDFONLY,X,Y
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRLNC0 9894 printed Dec 13, 2024@02:16:27 Page 2
LRLNC0 ;DALOI/CA/FHS-MAP LAB TESTS TO LOINC CODES ;1-OCT-1998
+1 ;;5.2;LAB SERVICE;**215,232,278,280,399,407**;Sep 27,1994;Build 1
+2 ;Reference to ^DD supported by IA # 10154
+3 ;=================================================================
+4 ; Ask VistA test to map-Lookup in Lab Test file #60
START ;entry point from option LR LOINC MAPPING
+1 SET LREND=0
SET LRLNC1=1
DO TEST
+2 IF $GET(LREND)
GOTO EXIT
+3 IF '$GET(LRNLT)
GOTO START
+4 ;MAP DEFAULT
DEFAULT ;
+1 NEW LRNLTX
+2 if '$DATA(^LAM(+$GET(LRNLT),0))#2
QUIT
+3 SET LRNLTX=LRNLT
+4 LOCK +^LAM(LRNLTX,9):2
IF '$TEST
WRITE !!?5,"Locked by another user",!
HANG 5
QUIT
+5 WRITE !
+6 KILL DIR
SET DIR("B")="No"
+7 SET DIR(0)="Y"
SET DIR("A")="Do you want to edit/delete the Default LOINC code"
+8 SET DIR("?")="Enter yes to map/change the default LOINC code."
+9 DO ^DIR
KILL DIR
+10 LOCK -^LAM(LRNLTX,9)
+11 IF $DATA(DIRUT)
QUIT
+12 IF $GET(LRDFONLY)
IF $DATA(DIRUT)
QUIT
+13 IF '$GET(LRDFONLY)
IF $DATA(DIRUT)
DO EXIT
GOTO START
+14 IF Y
Begin DoDot:1
+15 if '$GET(^LAM(LRNLT,9))
QUIT
+16 WRITE !!?5,"Deleting LOINC Default Code",!
+17 NEW DA,DR,X,DIE
+18 SET DIE="^LAM("
SET DA=+LRNLT
SET DR="25///^S X=""@"""
DO ^DIE
End DoDot:1
DO DEFAULT^LRLNCMD
+19 LOCK -^LAM(LRNLTX,9)
+20 IF $GET(LRDFONLY)
QUIT
+21 IF '$PIECE($PIECE($GET(^LAB(60,LRIEN,0)),U,5),";",2)
QUIT
ASKSPEC DO SPEC
+1 IF $GET(LREND)
DO EXIT
GOTO START
+2 WRITE !!
+3 SET DIR(0)="Y"
SET DIR("A")="Do you want to see possible LOINC code matches"
+4 SET DIR("?")="Enter no if you already know the LOINC code."
+5 SET DIR("B")="No"
+6 DO ^DIR
KILL DIR
+7 IF $DATA(DIRUT)
DO EXIT
GOTO START
+8 IF 'Y
DO ENTERLNC^LRLNCC
+9 IF $GET(LREND)
DO EXIT
GOTO START
+10 IF '$GET(LRCODE)
DO LOINC
+11 IF $GET(LRNO)
DO EXIT
GOTO START
+12 IF $GET(LREND)
DO EXIT
GOTO START
+13 IF $GET(LRNO)
DO ENTERLNC^LRLNCC
+14 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))
DO EXIT
GOTO START
+6 IF 'Y
IF $GET(LRNO)
DO ENTERLNC^LRLNCC
+7 IF 'Y
IF '$GET(LRNO)
DO LOINC
+8 IF $GET(LRNO)
DO EXIT
GOTO START
+9 IF $GET(LREND)
DO EXIT
GOTO START
+10 DO CHKSPEC
+11 IF $GET(LRNO)
DO EXIT
GOTO START
+12 IF $GET(LRNEXT)
GOTO NEXTSP
+13 IF $GET(LREND)
DO EXIT
GOTO START
+14 DO LINK
+15 IF $GET(LRNEXT)
GOTO NEXTSP
+16 IF $GET(LREND)
DO EXIT
GOTO START
+17 DO CHECK
+18 IF $GET(LRNEXT)
GOTO NEXTSP
+19 IF $GET(LREND)
DO EXIT
GOTO START
+20 DO MAP
NEXTSP DO KILL1
+1 GOTO ASKSPEC
KILL1 IF $GET(LRNLT)
LOCK -^LAM(LRNLT,9)
+1 KILL DA,DIC,DIE,DINUM,DIR,DIRUT,DR,DTOUT,I,LRLNC,LRLNC0,LRLOINC,LRELEC,LRCODE,LRSPEC,LRSPECL,LRSPECN,LRTIME,LRUNTIS,S,Y
+2 KILL DD,D0,DLAYGO,LRLNCNAM,LRNO,LRNOP,LRLNC1,LRNEXT,LRODLCD,X
+3 QUIT
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
+2 KILL LRSPEC,LRSPECL,LRSPECN,LRTIME,LRTEST,LRUNITS,S,Y
+3 KILL DD,DO,DLAYGO,LRLNCNAM,LRNO,LRNOP,LRDEF,LRLNC1,LRNEXT,LROLDCD,X
+4 QUIT
TEST WRITE @IOF
+1 KILL DIR,LRNLT
+2 SET DIR(0)="PO^60:QENMZ,"
SET DIR("A")="VistA Lab Test to "_$SELECT($DATA(LRDEL):"Delete/Unmap",1:"Link/Map")_" to LOINC "
+3 SET DIR("?")="Select Lab test you wish to "_$SELECT($DATA(LRDEL):"delete/unmap",1:"link/map")_" to a LOINC Code"
+4 DO ^DIR
KILL DIR
+5 IF $DATA(DIRUT)!'Y
KILL DIRUT
SET LREND=1
KILL LRDEL
QUIT
+6 SET LRIEN=+Y
SET LRTEST=$PIECE(Y,U,2)
+7 LOCK +^LAB(60,LRIEN):2
IF '$TEST
WRITE !?4,"Another user is editing this entry",!
HANG 5
QUIT
+8 ;Check for RESULT NLT CODE and if not one let enter
+9 SET LRNLT=+$PIECE($GET(^LAB(60,LRIEN,64)),U,2)
DIS64 Begin DoDot:1
+1 if '$GET(LRNLT)
QUIT
+2 NEW LRLNC,LRANS
+3 SET LRLNC=$PIECE($GET(^LAM(LRNLT,9)),U)
if 'LRLNC
QUIT
+4 DO GETS^DIQ(64,LRNLT_",",".01;1","E","LRANS")
+5 DO GETS^DIQ(95.3,LRLNC_",",".01;80","E","LRANS")
+6 WRITE !,!?5,$GET(LRANS(64,LRNLT_",",.01,"E"))_" "_$GET(LRANS(64,LRNLT_",",1,"E"))
+7 WRITE !?4,"Default LOINC Already Mapped to:"
+8 WRITE !,$GET(LRANS(95.3,LRLNC_",",.01,"E"))_" "_$GET(LRANS(95.3,LRLNC_",",80,"E"))
End DoDot:1
if $GET(LR64DIS)
QUIT
+9 IF '$PIECE($GET(^LAB(60,LRIEN,64)),U,2)
Begin DoDot:1
+10 WRITE !!,"There is not a RESULT NLT CODE for "_LRTEST,".",!
+11 WRITE !,"You must select one now to continue with the mapping of this test!",!
End DoDot:1
+12 KILL DIE,DA,DR
SET DIE="^LAB(60,"
SET DA=+LRIEN
SET DR=64.1
DO ^DIE
KILL DIE,DA,DR
+13 LOCK -^LAB(60,LRIEN)
+14 IF $GET(X)<1!($DATA(Y))
SET LRNLT=""
SET LREND=1
KILL LRDEL
QUIT
+15 IF $PIECE($GET(^LAB(60,+LRIEN,64)),U,2)
Begin DoDot:1
+16 NEW DIC,DA,DR
+17 SET DIC="^LAB(60,"
SET DA=+LRIEN
SET DR=64
WRITE !!
WRITE ?5,"IEN: [",DA,"] ",$PIECE(^LAB(60,LRIEN,0),U)
SET S=$Y
DO EN^DIQ
End DoDot:1
+18 WRITE !
+19 SET LRNLT=$PIECE($GET(^LAB(60,LRIEN,64)),U,2)
+20 IF 'LRNLT
GOTO TEST
+21 QUIT
SPEC ; Ask Specimen- Lookup in Specimen multiple in Lab Test file #60
+1 WRITE !!
LOOK61 KILL DIC,DA
+1 NEW LRANS
+2 if '$GET(LRIEN)
QUIT
+3 SET DIC=61
SET DIC(0)="AENMZQ"
+4 SET DIC("A")="Specimen source: "
+5 DO ^DIC
+6 IF $DATA(DUOUT)!($DATA(DTOUT))!(Y<1)
Begin DoDot:1
+7 KILL DIC,DA,DTOUT,DUOUT
SET LREND=1
QUIT
End DoDot:1
QUIT
+8 if $GET(LREND)
QUIT
+9 SET LRSPEC=+Y
SET LRSPECN=Y(0,0)
+10 KILL DA,DIC,DIE,DR
+11 IF '$LENGTH($PIECE($GET(^LAB(60,LRIEN,0)),U,5))
GOTO OVER
+12 IF '$DATA(^LAB(60,LRIEN,1))
Begin DoDot:1
+13 SET DIC("P")=$PIECE(^DD(60,100,0),"^",2)
End DoDot:1
+14 IF '$DATA(^LAB(60,LRIEN,1,LRSPEC))
Begin DoDot:1
+15 NEW DIR
+16 WRITE !," Are you sure you want to add this specimen"
+17 SET DIR(0)="Y"
DO ^DIR
IF Y<1
SET LRNOP=1
QUIT
+18 KILL DD,DO
+19 SET DA(1)=LRIEN
SET X=LRSPEC
SET DINUM=X
+20 SET DIC="^LAB(60,"_DA(1)_",1,"
+21 SET DIC(0)="LMZ"
SET DLAYGO=60.01
+22 DO FILE^DICN
SET LRANS=Y
End DoDot:1
if $GET(LRNOP)
GOTO LOOK61
+23 ;A DIE call is made to edit fields in subfile
+24 IF $PIECE($GET(LRANS),U,3)
Begin DoDot:1
+25 SET DIE=DIC
KILL DIC
+26 SET DA=+Y
+27 SET DR="1:9.3"
+28 DO ^DIE
End DoDot:1
+29 KILL DIE,DR,DA
OVER ;Check to see if linked to file 64.061. If not, then let enter link.
+1 IF '$PIECE($GET(^LAB(61,LRSPEC,0)),U,9)
Begin DoDot:1
+2 WRITE !!,"There is not a LEDI HL7 code for "_LRSPECN,"."
+3 WRITE !,"You must select one now to continue with the mapping of this test and specimen!",!
End DoDot:1
+4 IF '$PIECE($GET(^LAB(61,LRSPEC,0)),U,10)
Begin DoDot:1
+5 WRITE !!,"There is not a TIME ASPECT for "_LRSPECN,".",!
+6 KILL DIE,DR,DA
SET DA=LRSPEC
SET DIE="^LAB(61,"
SET DR=".09:.0961"
+7 DO ^DIE
+8 if $DATA(DIRUT)
SET LRNOP=1
End DoDot:1
if $GET(LRNOP)
GOTO LOOK61
+9 SET LRELEC=$PIECE($GET(^LAB(61,LRSPEC,0)),U,9)
+10 IF 'LRELEC
GOTO SPEC
+11 SET LRSPECL=$PIECE(^LAB(64.061,LRELEC,0),U,2)
+12 QUIT
LOINC ;Lookup possible LOINC matches in LAB LOINC file #95.3
+1 DO FIND^DIC(95.3,"","80","M",LRTEST,"","","I $P(^(0),U,8)=$G(LRELEC)!(LRELEC=74!(LRELEC=83)!(LRELEC=114)!(LRELEC=1376)&(""SER PLAS BLD""[$P(^(80),"":"",4)))","","LRLOINC","")
CODE ;ask which code to map
+1 DO CODE^LRLNCC
+2 QUIT
LINK ;Link the code with file 64
+1 ;DATA NAME
SET LRDATA=$PIECE(^LAB(60,LRIEN,0),U,12)
+2 ;Set to subscript of test.
IF '$LENGTH(LRDATA)
SET LRDATA=$PIECE($GET(^LAB(60,+$GET(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 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
DO EXIT
SET LREND=1
QUIT
+6 IF $DATA(DTOUT)!($DATA(DUOUT))
KILL DTOUT,DUOUT
DO EXIT
SET LREND=1
QUIT
+7 IF 'Y
SET LRNEXT=1
QUIT
+8 SET LRNLT=+Y
+9 QUIT
CHECK ;Check to see if already mapped to a LOINC code
+1 IF $DATA(^LAM(LRNLT,5,LRSPEC,1,"B",LRTIME))
DO SHOWPRE
IF $DATA(DIRUT)
DO EXIT
SET LREND=1
QUIT
+2 IF Y<1
SET LRNEXT=1
+3 QUIT
MAP ;DIE call to add data name,time aspect,units, LOINC code, and lab test fields
+1 LOCK +^LAM(LRNLT,5):1
IF '$TEST
WRITE !,"Another user is editing this record"
HANG 5
QUIT
+2 IF '$DATA(^LAM(LRNLT,5,0))
Begin DoDot:1
+3 SET DIC("P")=$PIECE(^DD(64,20,0),"^",2)
End DoDot:1
+4 IF '$DATA(^LAM(LRNLT,5,LRSPEC))
Begin DoDot:1
+5 KILL DD,DO
+6 SET DA(1)=LRNLT
SET DA=LRSPEC
+7 SET DIC="^LAM("_DA(1)_",5,"
SET DIC(0)="L"
SET DLAYGO=64
SET X=LRSPEC
SET DINUM=X
+8 DO FILE^DICN
End DoDot:1
+9 IF '$DATA(^LAM(LRNLT,5,LRSPEC,1,0))
Begin DoDot:1
+10 SET DIC("P")=$PIECE(^DD(64.01,30,0),"^",2)
End DoDot:1
+11 SET DA(2)=LRNLT
SET DA(1)=LRSPEC
SET X=LRTIME
SET DINUM=X
+12 SET DIC="^LAM("_DA(2)_",5,"_DA(1)_",1,"
+13 IF '$DATA(^LAM(LRNLT,5,LRSPEC,1,LRTIME))
Begin DoDot:1
+14 KILL DD,DO
+15 SET DIC(0)="L"
SET DLAYGO=64
+16 DO FILE^DICN
End DoDot:1
+17 SET DA=LRTIME
+18 KILL DIE,DR
SET DIE=DIC
KILL DIC
+19 SET DR="1////"_LRUNITS_";2////"_LRDATA_";3////"_LRIEN_";4////"_LRCODE
+20 DO ^DIE
+21 LOCK -^LAM(LRNLT,5)
+22 ;HERE SHOW WHAT WAS MAPPED
+23 WRITE @IOF
+24 WRITE !!
+25 WRITE !,"NLT: ",$PIECE($GET(^LAM(LRNLT,0)),U)
+26 WRITE !,"WKLD CODE: ",$PIECE($GET(^LAM(LRNLT,0)),U,2)
+27 WRITE !,"SPECIMEN: ",$PIECE($GET(^LAB(61,LRSPEC,0)),U)
+28 KILL DIC,DR
+29 SET DIC=DIE
+30 SET S=$Y
+31 DO EN^DIQ
INDEX60 ;Stores LOINC code in Laboratory Test file (#60) so know what tests are mapped.
+1 ;set only atomic tests
if '$LENGTH($PIECE($GET(^LAB(60,LRIEN,0)),U,5))
QUIT
+2 NEW LRDA,LRFDA,LRERR
+3 IF '$GET(^LAB(60,LRIEN,1,LRSPEC,0))
Begin DoDot:1
+4 KILL LRFDA,LRDA
+5 SET LRFDA(1,60.01,"+1,"_LRIEN_",",.01)=LRSPEC
+6 SET LRDA(1)=LRSPEC
+7 DO UPDATE^DIE("","LRFDA(1)","LRDA","LRERR")
End DoDot:1
+8 if $DATA(LRERR)
QUIT
+9 KILL LRFDA
+10 SET LRFDA(2,60.01,LRSPEC_","_LRIEN_",",95.3)=LRCODE
+11 DO FILE^DIE("","LRFDA(2)","LRERR")
+12 QUIT
SHOWPRE ;DISPLAY LOINC CODE ALREADY MAPPED TO NLT
+1 SET LRLNC=$PIECE($GET(^LAM(LRNLT,5,LRSPEC,1,LRTIME,1)),U)
+2 WRITE !!,"This test and specimen is already mapped to:"
+3 WRITE !,"LOINC code: ",LRLNC," ",$GET(^LAB(95.3,+LRLNC,80))
+4 WRITE !
+5 KILL DIR
SET DIR("B")="No"
+6 SET DIR(0)="Y"
SET DIR("A")="Do you want to change this mapping"
+7 SET DIR("?")="If you enter yes, the current LOINC code will be overwritten with the LOINC code that you have chosen."
+8 DO ^DIR
KILL DIR
+9 QUIT
CHKSPEC ;Check that specimen of LOINC code same as specimen of test
+1 IF LRLNC0(8)=$GET(LRELEC)
QUIT
+2 IF (LRLNC0(8)=74!(LRLNC0(8)=83)!(LRLNC0(8)=114)!(LRLNC0(8)=1376))&($GET(LRELEC)=74!($GET(LRELEC)=83)!($GET(LRELEC)=114)!($GET(LRELEC)=1376))
QUIT
+3 WRITE !!,"The LOINC code that you have selected does not have the"
+4 WRITE !,"same specimen that you chose to map."
+5 SET DIR(0)="Y"
SET DIR("A")="Are you sure you want to do this"
+6 SET DIR("?")="If you enter yes, the test will be mapped to this LOINC code."
+7 SET DIR("B")="Yes"
+8 DO ^DIR
KILL DIR
+9 IF $DATA(DIRUT)
SET LREND=1
QUIT
+10 IF Y<1
SET LRNO=1
+11 QUIT
6206 ;LOINC mapping ANTIMICROBIAL [^LAB(62.060)]
+1 WRITE !!
+2 DO EXITMI
+3 SET (LRDEL,LRDFONLY)=1
+4 SET DIR(0)="PO^62.06:QENMZ"
SET DIR("A")="Select Antimicrobial "
+5 SET DIR("?")="Select Antimicrobial Susceptibility Drug"
+6 DO ^DIR
KILL DIR
+7 IF $DATA(DIRUT)!(Y<1)
KILL DIRUT
DO EXITMI
QUIT
+8 SET LRIEN=Y
SET LRTEST=$PIECE(Y(0),U,2)
+9 LOCK +^LAB(62.06,LRIEN):2
IF '$TEST
WRITE !?4,"Being edited by another user"
HANG 5
GOTO 6206
+10 ;Display Mapped code
+11 SET (LRNLTX,LRNLT)=+$PIECE($GET(^LAB(62.06,+LRIEN,64)),U)
+12 IF LRNLT
Begin DoDot:1
+13 NEW LR64DIS
+14 SET LR64DIS=1
DO DIS64
End DoDot:1
+15 Begin DoDot:1
+16 NEW DIE,DA,DR
+17 SET DIE="^LAB(62.06,"
SET DIC=DIE
SET DA=+LRIEN
SET DR=64
DO ^DIE
End DoDot:1
+18 LOCK -^LAB(62.06,LRIEN)
+19 IF '$GET(^LAB(62.06,+LRIEN,64))!($DATA(DTOUT))!($DATA(DUOUT))
GOTO 6206
+20 SET LRDATA="LAB(62.06,"_+LRIEN_","
SET LRIEN=+LRIEN
+21 SET LRNLT=$PIECE($GET(^LAB(62.06,+LRIEN,64)),U)
+22 IF LRNLT
SET LRTEST=$$GET1^DIQ(64,LRNLT_",",.01,"ERR","ANS")
+23 IF LRNLT
WRITE !
DO DEFAULT
+24 GOTO 6206
+25 QUIT
EXITMI ;Clean up 6206 variables.
+1 KILL ANS,DA,DIC,DIE,DIR,DIRUT,DR,DTOUT,DUOUT,ERR,LRANS,LRDATA,LRDEF,LRDFONLY,LRNLT,LRNLTX,LRIEN,LRTEST
+2 KILL LRDEL,LRDFONLY,X,Y
+3 QUIT
