Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LRLNC0

LRLNC0.m

Go to the documentation of this file.
  1. 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
  1. ;Reference to ^DD supported by IA # 10154
  1. ;=================================================================
  1. ; Ask VistA test to map-Lookup in Lab Test file #60
  1. START ;entry point from option LR LOINC MAPPING
  1. S LREND=0,LRLNC1=1 D TEST
  1. I $G(LREND) G EXIT
  1. I '$G(LRNLT) G START
  1. ;MAP DEFAULT
  1. DEFAULT ;
  1. N LRNLTX
  1. Q:'$D(^LAM(+$G(LRNLT),0))#2
  1. S LRNLTX=LRNLT
  1. L +^LAM(LRNLTX,9):2 I '$T W !!?5,"Locked by another user",! H 5 Q
  1. W !
  1. K DIR S DIR("B")="No"
  1. S DIR(0)="Y",DIR("A")="Do you want to edit/delete the Default LOINC code"
  1. S DIR("?")="Enter yes to map/change the default LOINC code."
  1. D ^DIR K DIR
  1. L -^LAM(LRNLTX,9)
  1. I $D(DIRUT) Q
  1. I $G(LRDFONLY),$D(DIRUT) Q
  1. I '$G(LRDFONLY),$D(DIRUT) D EXIT G START
  1. I Y D D DEFAULT^LRLNCMD
  1. . Q:'$G(^LAM(LRNLT,9))
  1. . W !!?5,"Deleting LOINC Default Code",!
  1. . N DA,DR,X,DIE
  1. . S DIE="^LAM(",DA=+LRNLT,DR="25///^S X=""@""" D ^DIE
  1. L -^LAM(LRNLTX,9)
  1. I $G(LRDFONLY) Q
  1. I '$P($P($G(^LAB(60,LRIEN,0)),U,5),";",2) Q
  1. ASKSPEC D SPEC
  1. I $G(LREND) D EXIT G START
  1. W !!
  1. S DIR(0)="Y",DIR("A")="Do you want to see possible LOINC code matches"
  1. S DIR("?")="Enter no if you already know the LOINC code."
  1. S DIR("B")="No"
  1. D ^DIR K DIR
  1. I $D(DIRUT) D EXIT G START
  1. I 'Y D ENTERLNC^LRLNCC
  1. I $G(LREND) D EXIT G START
  1. I '$G(LRCODE) D LOINC
  1. I $G(LRNO) D EXIT G START
  1. I $G(LREND) D EXIT G START
  1. I $G(LRNO) D ENTERLNC^LRLNCC
  1. I $G(LREND) D EXIT G START
  1. CORRECT W !!
  1. S DIR(0)="Y",DIR("A")="Is this the correct one"
  1. S DIR("B")="Yes"
  1. S DIR("?")="Enter no to select a different code."
  1. D ^DIR K DIR
  1. I $D(DIRUT)!($G(LREND)) D EXIT G START
  1. I 'Y,$G(LRNO) D ENTERLNC^LRLNCC
  1. I 'Y,'$G(LRNO) D LOINC
  1. I $G(LRNO) D EXIT G START
  1. I $G(LREND) D EXIT G START
  1. D CHKSPEC
  1. I $G(LRNO) D EXIT G START
  1. I $G(LRNEXT) G NEXTSP
  1. I $G(LREND) D EXIT G START
  1. D LINK
  1. I $G(LRNEXT) G NEXTSP
  1. I $G(LREND) D EXIT G START
  1. D CHECK
  1. I $G(LRNEXT) G NEXTSP
  1. I $G(LREND) D EXIT G START
  1. D MAP
  1. NEXTSP D KILL1
  1. G ASKSPEC
  1. KILL1 I $G(LRNLT) L -^LAM(LRNLT,9)
  1. K DA,DIC,DIE,DINUM,DIR,DIRUT,DR,DTOUT,I,LRLNC,LRLNC0,LRLOINC,LRELEC,LRCODE,LRSPEC,LRSPECL,LRSPECN,LRTIME,LRUNTIS,S,Y
  1. K DD,D0,DLAYGO,LRLNCNAM,LRNO,LRNOP,LRLNC1,LRNEXT,LRODLCD,X
  1. Q
  1. EXIT I $G(LRNLT) L -^LAM(LRNLT,9)
  1. K DA,DIC,DIE,DINUM,DIR,DIRUT,DR,DTOUT,I,LRCODE,LRDATA,LREND,LRLNC,LRLNC0,LRLOINC,LRELEC,LRIEN,LRNLT
  1. K LRSPEC,LRSPECL,LRSPECN,LRTIME,LRTEST,LRUNITS,S,Y
  1. K DD,DO,DLAYGO,LRLNCNAM,LRNO,LRNOP,LRDEF,LRLNC1,LRNEXT,LROLDCD,X
  1. QUIT
  1. TEST W @IOF
  1. K DIR,LRNLT
  1. S DIR(0)="PO^60:QENMZ,",DIR("A")="VistA Lab Test to "_$S($D(LRDEL):"Delete/Unmap",1:"Link/Map")_" to LOINC "
  1. S DIR("?")="Select Lab test you wish to "_$S($D(LRDEL):"delete/unmap",1:"link/map")_" to a LOINC Code"
  1. D ^DIR K DIR
  1. I $D(DIRUT)!'Y K DIRUT S LREND=1 K LRDEL Q
  1. S LRIEN=+Y,LRTEST=$P(Y,U,2)
  1. L +^LAB(60,LRIEN):2 I '$T W !?4,"Another user is editing this entry",! H 5 Q
  1. ;Check for RESULT NLT CODE and if not one let enter
  1. S LRNLT=+$P($G(^LAB(60,LRIEN,64)),U,2)
  1. DIS64 D Q:$G(LR64DIS)
  1. . Q:'$G(LRNLT)
  1. . N LRLNC,LRANS
  1. . S LRLNC=$P($G(^LAM(LRNLT,9)),U) Q:'LRLNC
  1. . D GETS^DIQ(64,LRNLT_",",".01;1","E","LRANS")
  1. . D GETS^DIQ(95.3,LRLNC_",",".01;80","E","LRANS")
  1. . W !,!?5,$G(LRANS(64,LRNLT_",",.01,"E"))_" "_$G(LRANS(64,LRNLT_",",1,"E"))
  1. . W !?4,"Default LOINC Already Mapped to:"
  1. . W !,$G(LRANS(95.3,LRLNC_",",.01,"E"))_" "_$G(LRANS(95.3,LRLNC_",",80,"E"))
  1. I '$P($G(^LAB(60,LRIEN,64)),U,2) D
  1. .W !!,"There is not a RESULT NLT CODE for "_LRTEST,".",!
  1. .W !,"You must select one now to continue with the mapping of this test!",!
  1. K DIE,DA,DR S DIE="^LAB(60,",DA=+LRIEN,DR=64.1 D ^DIE K DIE,DA,DR
  1. L -^LAB(60,LRIEN)
  1. I $G(X)<1!($D(Y)) S LRNLT="",LREND=1 K LRDEL Q
  1. I $P($G(^LAB(60,+LRIEN,64)),U,2) D
  1. . N DIC,DA,DR
  1. . 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
  1. W !
  1. S LRNLT=$P($G(^LAB(60,LRIEN,64)),U,2)
  1. I 'LRNLT G TEST
  1. Q
  1. SPEC ; Ask Specimen- Lookup in Specimen multiple in Lab Test file #60
  1. W !!
  1. LOOK61 K DIC,DA
  1. N LRANS
  1. Q:'$G(LRIEN)
  1. S DIC=61,DIC(0)="AENMZQ"
  1. S DIC("A")="Specimen source: "
  1. D ^DIC
  1. I $D(DUOUT)!($D(DTOUT))!(Y<1) D Q
  1. .K DIC,DA,DTOUT,DUOUT S LREND=1 Q
  1. Q:$G(LREND)
  1. S LRSPEC=+Y,LRSPECN=Y(0,0)
  1. K DA,DIC,DIE,DR
  1. I '$L($P($G(^LAB(60,LRIEN,0)),U,5)) G OVER
  1. I '$D(^LAB(60,LRIEN,1)) D
  1. .S DIC("P")=$P(^DD(60,100,0),"^",2)
  1. I '$D(^LAB(60,LRIEN,1,LRSPEC)) D G:$G(LRNOP) LOOK61
  1. . N DIR
  1. . W !," Are you sure you want to add this specimen"
  1. . S DIR(0)="Y" D ^DIR I Y<1 S LRNOP=1 Q
  1. . K DD,DO
  1. . S DA(1)=LRIEN,X=LRSPEC,DINUM=X
  1. . S DIC="^LAB(60,"_DA(1)_",1,"
  1. . S DIC(0)="LMZ",DLAYGO=60.01
  1. . D FILE^DICN S LRANS=Y
  1. ;A DIE call is made to edit fields in subfile
  1. I $P($G(LRANS),U,3) D
  1. .S DIE=DIC K DIC
  1. .S DA=+Y
  1. .S DR="1:9.3"
  1. .D ^DIE
  1. K DIE,DR,DA
  1. OVER ;Check to see if linked to file 64.061. If not, then let enter link.
  1. I '$P($G(^LAB(61,LRSPEC,0)),U,9) D
  1. .W !!,"There is not a LEDI HL7 code for "_LRSPECN,"."
  1. .W !,"You must select one now to continue with the mapping of this test and specimen!",!
  1. I '$P($G(^LAB(61,LRSPEC,0)),U,10) D G:$G(LRNOP) LOOK61
  1. .W !!,"There is not a TIME ASPECT for "_LRSPECN,".",!
  1. .K DIE,DR,DA S DA=LRSPEC,DIE="^LAB(61,",DR=".09:.0961"
  1. .D ^DIE
  1. .S:$D(DIRUT) LRNOP=1
  1. S LRELEC=$P($G(^LAB(61,LRSPEC,0)),U,9)
  1. I 'LRELEC G SPEC
  1. S LRSPECL=$P(^LAB(64.061,LRELEC,0),U,2)
  1. Q
  1. LOINC ;Lookup possible LOINC matches in LAB LOINC file #95.3
  1. 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","")
  1. CODE ;ask which code to map
  1. D CODE^LRLNCC
  1. Q
  1. S LRDATA=$P(^LAB(60,LRIEN,0),U,12) ;DATA NAME
  1. I '$L(LRDATA) S LRDATA=$P($G(^LAB(60,+$G(LRIEN),0)),U,4) ;Set to subscript of test.
  1. S LRTIME=$P(^LAB(95.3,LRCODE,0),U,7) ;TIME ASPECT
  1. S LRUNITS=$P(^LAB(95.3,LRCODE,0),U,14) ;UNITS
  1. S LRNLT=+$P(^LAM(LRNLT,0),U,2)
  1. LR64 ;
  1. K DIC,DA
  1. W !!
  1. S DIC=64,DIC(0)="ENMZ",X=LRNLT
  1. D ^DIC
  1. I Y<1 D EXIT S LREND=1 Q
  1. I $D(DTOUT)!($D(DUOUT)) K DTOUT,DUOUT D EXIT S LREND=1 Q
  1. I 'Y S LRNEXT=1 Q
  1. S LRNLT=+Y
  1. Q
  1. CHECK ;Check to see if already mapped to a LOINC code
  1. I $D(^LAM(LRNLT,5,LRSPEC,1,"B",LRTIME)) D SHOWPRE I $D(DIRUT) D EXIT S LREND=1 Q
  1. I Y<1 S LRNEXT=1
  1. Q
  1. MAP ;DIE call to add data name,time aspect,units, LOINC code, and lab test fields
  1. L +^LAM(LRNLT,5):1 I '$T W !,"Another user is editing this record" H 5 Q
  1. I '$D(^LAM(LRNLT,5,0)) D
  1. .S DIC("P")=$P(^DD(64,20,0),"^",2)
  1. I '$D(^LAM(LRNLT,5,LRSPEC)) D
  1. .K DD,DO
  1. .S DA(1)=LRNLT,DA=LRSPEC
  1. .S DIC="^LAM("_DA(1)_",5,",DIC(0)="L",DLAYGO=64,X=LRSPEC,DINUM=X
  1. .D FILE^DICN
  1. I '$D(^LAM(LRNLT,5,LRSPEC,1,0)) D
  1. .S DIC("P")=$P(^DD(64.01,30,0),"^",2)
  1. S DA(2)=LRNLT,DA(1)=LRSPEC,X=LRTIME,DINUM=X
  1. S DIC="^LAM("_DA(2)_",5,"_DA(1)_",1,"
  1. I '$D(^LAM(LRNLT,5,LRSPEC,1,LRTIME)) D
  1. .K DD,DO
  1. .S DIC(0)="L",DLAYGO=64
  1. .D FILE^DICN
  1. S DA=LRTIME
  1. K DIE,DR S DIE=DIC K DIC
  1. S DR="1////"_LRUNITS_";2////"_LRDATA_";3////"_LRIEN_";4////"_LRCODE
  1. D ^DIE
  1. L -^LAM(LRNLT,5)
  1. ;HERE SHOW WHAT WAS MAPPED
  1. W @IOF
  1. W !!
  1. W !,"NLT: ",$P($G(^LAM(LRNLT,0)),U)
  1. W !,"WKLD CODE: ",$P($G(^LAM(LRNLT,0)),U,2)
  1. W !,"SPECIMEN: ",$P($G(^LAB(61,LRSPEC,0)),U)
  1. K DIC,DR
  1. S DIC=DIE
  1. S S=$Y
  1. D EN^DIQ
  1. INDEX60 ;Stores LOINC code in Laboratory Test file (#60) so know what tests are mapped.
  1. Q:'$L($P($G(^LAB(60,LRIEN,0)),U,5)) ;set only atomic tests
  1. N LRDA,LRFDA,LRERR
  1. I '$G(^LAB(60,LRIEN,1,LRSPEC,0)) D
  1. . K LRFDA,LRDA
  1. . S LRFDA(1,60.01,"+1,"_LRIEN_",",.01)=LRSPEC
  1. . S LRDA(1)=LRSPEC
  1. . D UPDATE^DIE("","LRFDA(1)","LRDA","LRERR")
  1. Q:$D(LRERR)
  1. K LRFDA
  1. S LRFDA(2,60.01,LRSPEC_","_LRIEN_",",95.3)=LRCODE
  1. D FILE^DIE("","LRFDA(2)","LRERR")
  1. Q
  1. SHOWPRE ;DISPLAY LOINC CODE ALREADY MAPPED TO NLT
  1. S LRLNC=$P($G(^LAM(LRNLT,5,LRSPEC,1,LRTIME,1)),U)
  1. W !!,"This test and specimen is already mapped to:"
  1. W !,"LOINC code: ",LRLNC," ",$G(^LAB(95.3,+LRLNC,80))
  1. W !
  1. K DIR S DIR("B")="No"
  1. S DIR(0)="Y",DIR("A")="Do you want to change this mapping"
  1. S DIR("?")="If you enter yes, the current LOINC code will be overwritten with the LOINC code that you have chosen."
  1. D ^DIR K DIR
  1. Q
  1. CHKSPEC ;Check that specimen of LOINC code same as specimen of test
  1. I LRLNC0(8)=$G(LRELEC) Q
  1. 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
  1. W !!,"The LOINC code that you have selected does not have the"
  1. W !,"same specimen that you chose to map."
  1. S DIR(0)="Y",DIR("A")="Are you sure you want to do this"
  1. S DIR("?")="If you enter yes, the test will be mapped to this LOINC code."
  1. S DIR("B")="Yes"
  1. D ^DIR K DIR
  1. I $D(DIRUT) S LREND=1 Q
  1. I Y<1 S LRNO=1
  1. Q
  1. 6206 ;LOINC mapping ANTIMICROBIAL [^LAB(62.060)]
  1. W !!
  1. D EXITMI
  1. S (LRDEL,LRDFONLY)=1
  1. S DIR(0)="PO^62.06:QENMZ",DIR("A")="Select Antimicrobial "
  1. S DIR("?")="Select Antimicrobial Susceptibility Drug"
  1. D ^DIR K DIR
  1. I $D(DIRUT)!(Y<1) K DIRUT D EXITMI Q
  1. S LRIEN=Y,LRTEST=$P(Y(0),U,2)
  1. L +^LAB(62.06,LRIEN):2 I '$T W !?4,"Being edited by another user" H 5 G 6206
  1. ;Display Mapped code
  1. S (LRNLTX,LRNLT)=+$P($G(^LAB(62.06,+LRIEN,64)),U)
  1. I LRNLT D
  1. . N LR64DIS
  1. . S LR64DIS=1 D DIS64
  1. D
  1. . N DIE,DA,DR
  1. . S DIE="^LAB(62.06,",DIC=DIE,DA=+LRIEN,DR=64 D ^DIE
  1. L -^LAB(62.06,LRIEN)
  1. I '$G(^LAB(62.06,+LRIEN,64))!($D(DTOUT))!($D(DUOUT)) G 6206
  1. S LRDATA="LAB(62.06,"_+LRIEN_",",LRIEN=+LRIEN
  1. S LRNLT=$P($G(^LAB(62.06,+LRIEN,64)),U)
  1. I LRNLT S LRTEST=$$GET1^DIQ(64,LRNLT_",",.01,"ERR","ANS")
  1. I LRNLT W ! D DEFAULT
  1. G 6206
  1. Q
  1. EXITMI ;Clean up 6206 variables.
  1. K ANS,DA,DIC,DIE,DIR,DIRUT,DR,DTOUT,DUOUT,ERR,LRANS,LRDATA,LRDEF,LRDFONLY,LRNLT,LRNLTX,LRIEN,LRTEST
  1. K LRDEL,LRDFONLY,X,Y
  1. Q