LRLNCDEL ; DALOI/CA/FHS - UNMAP LAB TESTS TO LOINC CODES OR DELETE LOINC MAPPINGS ;1-OCT-1998
;;5.2;LAB SERVICE;**232,278**;Sep 27,1994
;Reference to ^DD supported by IA 10154
;=================================================================
; Ask VistA test to unmap-Lookup in Lab Test file #60
START ;entry point from option LR LOINC MAPPING
S LREND=0 D TEST
I $G(LREND) G EXIT
W @IOF,!! D SPEC
I $G(LREND) D EXIT G START
D UNMAP
D EXIT
G START
EXIT ;
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 LRNLTN,LRNLTNM,LRASPECT
K D,D0,DD,DO,DLAYGO,LRLNCNAM,LRNO,LROUT,X
QUIT
TEST W !!
N DIR,Y,X,LROUT,LRERR,DA,DIC,DIE,DR
S DIR(0)="PO^60:QENMZ,",DIR("A")="VistA Lab Test to delete/unmap to LOINC "
S DIR("?")="Select Lab test you wish to delete/unmap to a LOINC Code"
D ^DIR K DIR
I $D(DIRUT) K DIRUT S LREND=1 Q
S LRIEN=+Y,LRTEST=$P(Y,U,2)
;Check for RESULT NLT CODE and if not one let enter
L +^LAB(60,LRIEN):2 I '$T W !?4,"Locked by another user" H 5 G TEST
I '$P($G(^LAB(60,LRIEN,64)),U,2) D I $D(DUOUT)!($D(DTOUT)) S LREND=1 Q
. 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,DR,DA S DA=LRIEN,DIE="^LAB(60,",DR=64.1
. D ^DIE
. L -^LAB(60,LRIEN)
. I $D(DUOUT)!($D(DTOUT)) Q
. S DIC=DIE,DR=0 W !! W ?5,"IEN: [",DA,"] ",$P(^LAB(60,LRIEN,0),U) S S=$Y D EN^LRDIQ W !
L -^LAB(60,LRIEN)
S LRNLT=$P($G(^LAB(60,LRIEN,64)),U,2)
I 'LRNLT G TEST
D GETS^DIQ(64,LRNLT_",",".01;1","E","LROUT","LRERR")
S LRNLTNM=$G(LROUT(64,LRNLT_",",.01,"E"))
S LRNLTN=$G(LROUT(64,LRNLT_",",1,"E"))
Q
SPEC ; Ask Specimen- Lookup in Specimen multiple in Lab Test file #60
N DIR,DIRUT
S DIR(0)="PO^61:ENQNZ",LREND=0
S DIR("S")="I $P(^(0),U,9),$P(^(0),U,10)"
S DIR("?")="Enter a TOPOGRAPHY having a LEDI HL7 code defined."
S DIR("A")="Specimen Source: "
D ^DIR I $D(DIRUT) S LREND=1 Q
S LRSPEC=+Y,LRSPECN=$P(Y,U,2)
S LRELEC=$P(Y(0),U,9),LRASPECT=$P(Y(0),U,10)
D GETS^DIQ(64.061,LRELEC_",",1,"E","LROUT","LRERR")
S LRSPECL=$G(LROUT(64.061,LRELEC_",",1,"E"))
I '$L(LRSPECL) W !?5,LRSPECN_" has a broken pointer" S LREND=1
Q
UNMAP ;Check to see if already mapped to a LOINC code
N DA,DIC,DIK,DIR,DIRUT,DR
S DIR(0)="PO^64:EQNZM",DIR("S")="I $P($P(^(0),U,2),""."")="_$P(LRNLTN,".")
S DIR("B")=$P(LRNLTN,".")
D ^DIR I $D(DIRUT) S LREND=1 Q
S LRNLT=+Y
L +^LAM(LRNLT,5):1 I '$T W !,"Another user is editing this record",! H 5 Q
I '$D(^LAM(LRNLT,5,LRSPEC,1,LRASPECT)) D G INDEX60
. N LROUT
. D GETS^DIQ(64.061,LRASPECT_",",.01,"E","LROUT")
. W $C(7)
. W !!!?5,"Lab Test: "_LRTEST_" / "_LRSPECL_" is NOT mapped to "
. W !,"WKLD CODE: "_$P(Y,U,2)_" Time Aspect of: "_$G(LROUT(64.061,LRASPECT_",",.01,"E"))
DIS ;Show the data
K DA,DIC,DIK,DIR,DR
S DA(2)=LRNLT,DA(1)=LRSPEC,DA=LRASPECT,DIC="^LAM("_DA(2)_",5,"_DA(1)_",1,"
S S=0,DR="0:99"
W !!,LRSPECN,!
D EN^DIQ
S DIR(0)="Y",DIR("A")="Are You - SURE- you want to delete this mapping"
D ^DIR I $G(Y)'=1 L -^LAM(LRNLT,5) Q
S DIK=DIC D ^DIK
INDEX60 ;Stores LOINC code in Laboratory Test file (#60) so know what tests are mapped.
K DIE,DA,DR S DA=LRSPEC,DA(1)=LRIEN,DIE="^LAB(60,"_DA(1)_",1,",DR="95.3///@" D ^DIE
;S ^LAB(60,LRIEN,1,LRSPEC,95.3)=LRCODE
L -^LAM(LRNLT,5)
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 mapped to:"
W !,"LOINC code: ",LRLNC," ",$G(^LAB(95.3,+LRLNC,80))
W !!
S DIR(0)="Y",DIR("A")="Are you sure you want to delete this mapping"
S DIR("?")="If you enter yes, the current LOINC code mapping will be deleted."
D ^DIR K DIR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRLNCDEL 3818 printed Apr 09, 2024@21:15:41 Page 2
LRLNCDEL ; DALOI/CA/FHS - UNMAP LAB TESTS TO LOINC CODES OR DELETE LOINC MAPPINGS ;1-OCT-1998
+1 ;;5.2;LAB SERVICE;**232,278**;Sep 27,1994
+2 ;Reference to ^DD supported by IA 10154
+3 ;=================================================================
+4 ; Ask VistA test to unmap-Lookup in Lab Test file #60
START ;entry point from option LR LOINC MAPPING
+1 SET LREND=0
DO TEST
+2 IF $GET(LREND)
GOTO EXIT
+3 WRITE @IOF,!!
DO SPEC
+4 IF $GET(LREND)
DO EXIT
GOTO START
+5 DO UNMAP
+6 DO EXIT
+7 GOTO START
EXIT ;
+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 LRNLTN,LRNLTNM,LRASPECT
+3 KILL D,D0,DD,DO,DLAYGO,LRLNCNAM,LRNO,LROUT,X
+4 QUIT
TEST WRITE !!
+1 NEW DIR,Y,X,LROUT,LRERR,DA,DIC,DIE,DR
+2 SET DIR(0)="PO^60:QENMZ,"
SET DIR("A")="VistA Lab Test to delete/unmap to LOINC "
+3 SET DIR("?")="Select Lab test you wish to delete/unmap to a LOINC Code"
+4 DO ^DIR
KILL DIR
+5 IF $DATA(DIRUT)
KILL DIRUT
SET LREND=1
QUIT
+6 SET LRIEN=+Y
SET LRTEST=$PIECE(Y,U,2)
+7 ;Check for RESULT NLT CODE and if not one let enter
+8 LOCK +^LAB(60,LRIEN):2
IF '$TEST
WRITE !?4,"Locked by another user"
HANG 5
GOTO TEST
+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!",!
+12 KILL DIE,DR,DA
SET DA=LRIEN
SET DIE="^LAB(60,"
SET DR=64.1
+13 DO ^DIE
+14 LOCK -^LAB(60,LRIEN)
+15 IF $DATA(DUOUT)!($DATA(DTOUT))
QUIT
+16 SET DIC=DIE
SET DR=0
WRITE !!
WRITE ?5,"IEN: [",DA,"] ",$PIECE(^LAB(60,LRIEN,0),U)
SET S=$Y
DO EN^LRDIQ
WRITE !
End DoDot:1
IF $DATA(DUOUT)!($DATA(DTOUT))
SET LREND=1
QUIT
+17 LOCK -^LAB(60,LRIEN)
+18 SET LRNLT=$PIECE($GET(^LAB(60,LRIEN,64)),U,2)
+19 IF 'LRNLT
GOTO TEST
+20 DO GETS^DIQ(64,LRNLT_",",".01;1","E","LROUT","LRERR")
+21 SET LRNLTNM=$GET(LROUT(64,LRNLT_",",.01,"E"))
+22 SET LRNLTN=$GET(LROUT(64,LRNLT_",",1,"E"))
+23 QUIT
SPEC ; Ask Specimen- Lookup in Specimen multiple in Lab Test file #60
+1 NEW DIR,DIRUT
+2 SET DIR(0)="PO^61:ENQNZ"
SET LREND=0
+3 SET DIR("S")="I $P(^(0),U,9),$P(^(0),U,10)"
+4 SET DIR("?")="Enter a TOPOGRAPHY having a LEDI HL7 code defined."
+5 SET DIR("A")="Specimen Source: "
+6 DO ^DIR
IF $DATA(DIRUT)
SET LREND=1
QUIT
+7 SET LRSPEC=+Y
SET LRSPECN=$PIECE(Y,U,2)
+8 SET LRELEC=$PIECE(Y(0),U,9)
SET LRASPECT=$PIECE(Y(0),U,10)
+9 DO GETS^DIQ(64.061,LRELEC_",",1,"E","LROUT","LRERR")
+10 SET LRSPECL=$GET(LROUT(64.061,LRELEC_",",1,"E"))
+11 IF '$LENGTH(LRSPECL)
WRITE !?5,LRSPECN_" has a broken pointer"
SET LREND=1
+12 QUIT
UNMAP ;Check to see if already mapped to a LOINC code
+1 NEW DA,DIC,DIK,DIR,DIRUT,DR
+2 SET DIR(0)="PO^64:EQNZM"
SET DIR("S")="I $P($P(^(0),U,2),""."")="_$PIECE(LRNLTN,".")
+3 SET DIR("B")=$PIECE(LRNLTN,".")
+4 DO ^DIR
IF $DATA(DIRUT)
SET LREND=1
QUIT
+5 SET LRNLT=+Y
+6 LOCK +^LAM(LRNLT,5):1
IF '$TEST
WRITE !,"Another user is editing this record",!
HANG 5
QUIT
+7 IF '$DATA(^LAM(LRNLT,5,LRSPEC,1,LRASPECT))
Begin DoDot:1
+8 NEW LROUT
+9 DO GETS^DIQ(64.061,LRASPECT_",",.01,"E","LROUT")
+10 WRITE $CHAR(7)
+11 WRITE !!!?5,"Lab Test: "_LRTEST_" / "_LRSPECL_" is NOT mapped to "
+12 WRITE !,"WKLD CODE: "_$PIECE(Y,U,2)_" Time Aspect of: "_$GET(LROUT(64.061,LRASPECT_",",.01,"E"))
End DoDot:1
GOTO INDEX60
DIS ;Show the data
+1 KILL DA,DIC,DIK,DIR,DR
+2 SET DA(2)=LRNLT
SET DA(1)=LRSPEC
SET DA=LRASPECT
SET DIC="^LAM("_DA(2)_",5,"_DA(1)_",1,"
+3 SET S=0
SET DR="0:99"
+4 WRITE !!,LRSPECN,!
+5 DO EN^DIQ
+6 SET DIR(0)="Y"
SET DIR("A")="Are You - SURE- you want to delete this mapping"
+7 DO ^DIR
IF $GET(Y)'=1
LOCK -^LAM(LRNLT,5)
QUIT
+8 SET DIK=DIC
DO ^DIK
INDEX60 ;Stores LOINC code in Laboratory Test file (#60) so know what tests are mapped.
+1 KILL DIE,DA,DR
SET DA=LRSPEC
SET DA(1)=LRIEN
SET DIE="^LAB(60,"_DA(1)_",1,"
SET DR="95.3///@"
DO ^DIE
+2 ;S ^LAB(60,LRIEN,1,LRSPEC,95.3)=LRCODE
+3 LOCK -^LAM(LRNLT,5)
+4 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 mapped to:"
+3 WRITE !,"LOINC code: ",LRLNC," ",$GET(^LAB(95.3,+LRLNC,80))
+4 WRITE !!
+5 SET DIR(0)="Y"
SET DIR("A")="Are you sure you want to delete this mapping"
+6 SET DIR("?")="If you enter yes, the current LOINC code mapping will be deleted."
+7 DO ^DIR
KILL DIR
+8 QUIT
