- 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 Jan 18, 2025@03:17:10 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