LRLNCDEL.m

LRLNCDEL ; DALOI/CA/FHS - UNMAP LAB TESTS TO LOINC CODES OR DELETE LOINC MAPPINGS ;1-OCT-1998

 ;;5.2T9;LR;**1018**;Nov 17, 2004

 ;;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 

LRLNCDEL  ; DALOI/CA/FHS - UNMAP LAB TESTS TO LOINC CODES OR DELETE LOINC MAPPINGS ;1-OCT-1998

 +1       ;;5.2T9;LR;**1018**;Nov 17, 2004

 +2       ;;5.2;LAB SERVICE;**232,278**;Sep 27,1994

 +3       ;Reference to ^DD supported by IA 10154

 +4       ;=================================================================

 +5       ; 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