- LRLNCMD ;DALOI/CA/FHS-MAP LAB TESTS TO DEFAULT LOINC CODES ;1-MAY-1999
- ;;5.2;LAB SERVICE;**232,278,280,407**;Sep 27,1994;Build 1
- ;=================================================================
- ; Ask VistA test to map-Lookup in Lab Test file #60
- START ;entry point from option LR LOINC MAPPING
- Q:$D(LRDFONLY)
- S LREND=0 D TEST
- I $G(LREND) G EXIT
- I '$G(LRNLT) G START
- DEFAULT ;ENTRY POINT FROM LRLNC0
- 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),$G(LRLNC1) Q
- I $D(DIRUT) D EXIT G START
- I 'Y D ENTERLNC^LRLNCC
- I $G(LREND),$G(LRLNC1) K LREND Q
- I $G(LREND) D EXIT G START
- I '$G(LRCODE) D LOINC
- I $G(LRNO),$G(LRLNC1) K LREND Q
- I $G(LRNO) D EXIT G START
- I $G(LREND),$G(LRLNC1) K LREND Q
- I $G(LREND) D EXIT G START
- I $G(LRNO) D ENTERLNC^LRLNCC
- I $G(LREND),$G(LRLNC1) K LREND Q
- 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)),$G(LRLNC1) K LREND Q
- 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),$G(LRLNC1) K LREND Q
- I $G(LREND) D EXIT G START
- D LINK
- I $G(LREND),$G(LRLNC1) K LREND Q
- I $G(LREND) D EXIT G START
- D CHECK
- I $G(LREND),$G(LRLNC1) K LREND Q
- I $G(LREND) D EXIT G START
- D MAP
- I $G(LRLNC1) K LRCODE Q
- D EXIT
- G START
- 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,LRSPEC,LRSPECL,LRSPECN,LRTIME,LRTEST,LRUNITS,S,Y
- K DD,DO,DLAYGO,LRLNCNAM,LRNO,X,LRNUM,LROLDCD
- QUIT
- TEST D TEST^LRLNC0
- Q
- LOINC ;Lookup possible LOINC matches in LAB LOINC file #95.3
- D FIND^DIC(95.3,"","80","M",LRTEST,"","","I '$G(^(4))","","LRLOINC","")
- CODE ;ask which code to map
- I +LRLOINC("DILIST",0)=0 D Q
- .W !!,"No matches found."
- .S LRNO=1
- W ! S I=0
- F S I=$O(LRLOINC("DILIST","ID",I)) Q:'I!$G(LREND) D
- .I $E(IOST,1,2)="C-",'(I#18) D Q:$G(LREND)
- ..S DIR(0)="E" D ^DIR
- ..S:$S($G(DIRUT):1,$G(DUOUT):1,1:0) LREND=1
- .W !,I,":",LRLOINC("DILIST","ID",I,80)
- K DIRUT,DUOUT
- W !!
- S DIR(0)="N^1:"_$S($G(LREND):I-2,1:$P(LRLOINC("DILIST",0),U),1:0)
- S DIR("A")="LOINC code to map this test"
- D ^DIR K DIR,LREND
- I $D(DIRUT) S LREND=1 Q
- S LRCODE=LRLOINC("DILIST",1,+Y)
- D DISPL^LRLNCC
- Q
- LINK ;Link the code with file 64
- 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(DTOUT))!($D(DUOUT)) K DTOUT,DUOUT S LREND=1 Q
- S LRNLT=+Y
- Q
- CHECK ;Check to see if already mapped to a LOINC code
- Q:'$P($G(^LAM(LRNLT,9)),U)
- D SHOWPRE
- I $D(DIRUT)!'Y S LREND=1 Q
- ;DELETE EXISTING DEFAULT MAPPING
- S DA=LRNLT
- S DIE="^LAM(",DR="25////@"
- D ^DIE
- K DA,DIE
- Q
- MAP ;DIE call to add DEFAULT LOINC CODE
- I '$D(LRDFONLY) S LRDATA=$P(^LAB(60,LRIEN,0),U,12) ;DATA NAME
- I '$L(LRDATA) S LRDATA=$P(^LAB(60,LRIEN,0),U,4)
- S LRTIME=$P(^LAB(95.3,LRCODE,0),U,7) ;TIME ASPECT
- S LRUNITS=$P(^LAB(95.3,LRCODE,0),U,14) ;UNITS
- L +^LAM(LRNLT):1 I '$T W !,"Another user is editing this record!!" H 5 Q
- S DIE="^LAM(",DA=LRNLT,DR="25////"_LRCODE_";25.2////"_LRTIME_";25.3////"_LRUNITS_";25.4////"_LRDATA_";25.5////"_$S($D(LRDFONLY):"@",1:LRIEN)
- D ^DIE
- L -^LAM(LRNLT)
- MAP2 ;HERE SHOW WHAT WAS MAPPED
- Q:'$D(^LAM(+$G(LRNLT),0))#2
- W !!
- W !,"NLT: ",$P($G(^LAM(LRNLT,0)),U)
- W !,"WKLD CODE: ",$P($G(^LAM(LRNLT,0)),U,2)
- K DIC,DR
- S DIC="^LAM(",DA=LRNLT
- S S=$Y
- D EN^DIQ
- Q
- SHOWPRE ;DISPLAY LOINC CODE ALREADY MAPPED TO NLT
- S LROLDCD=$P(^LAM(LRNLT,9),U)
- W !!,"This test is already mapped to:"
- W !,"Default LOINC code: ",LROLDCD_"-"_$P(^LAB(95.3,+$G(LROLDCD),0),U,15)," ",$G(^LAB(95.3,LROLDCD,80))
- W !!
- S DIR(0)="Y",DIR("A")="Do you want to "_$S($D(LRDEL):"delete",1:"change")_" this default mapping",DIR("B")="NO"
- S:'$D(LRDEL) DIR("?")="If you enter yes, the current default LOINC code will be overwritten with the default LOINC code that you have chosen."
- S:$D(LRDEL) DIR("?")="If you enter yes, the current default LOINC code will be deleted."
- D ^DIR K DIR
- Q
- DELETE ;DELETE/UNMAP DEFAULT LOINC CODE
- S LREND=0,LRDEL=1 D TEST
- I $G(LREND) G EXIT
- D CHECK
- K LRDEL
- G EXIT
- Q
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRLNCMD 4416 printed Jan 18, 2025@03:17:19 Page 2
- LRLNCMD ;DALOI/CA/FHS-MAP LAB TESTS TO DEFAULT LOINC CODES ;1-MAY-1999
- +1 ;;5.2;LAB SERVICE;**232,278,280,407**;Sep 27,1994;Build 1
- +2 ;=================================================================
- +3 ; Ask VistA test to map-Lookup in Lab Test file #60
- START ;entry point from option LR LOINC MAPPING
- +1 if $DATA(LRDFONLY)
- QUIT
- +2 SET LREND=0
- DO TEST
- +3 IF $GET(LREND)
- GOTO EXIT
- +4 IF '$GET(LRNLT)
- GOTO START
- DEFAULT ;ENTRY POINT FROM LRLNC0
- +1 WRITE !
- +2 SET DIR(0)="Y"
- SET DIR("A")="Do you want to see possible LOINC code matches"
- +3 SET DIR("?")="Enter no if you already know the LOINC code."
- +4 SET DIR("B")="No"
- +5 DO ^DIR
- KILL DIR
- +6 IF $DATA(DIRUT)
- IF $GET(LRLNC1)
- QUIT
- +7 IF $DATA(DIRUT)
- DO EXIT
- GOTO START
- +8 IF 'Y
- DO ENTERLNC^LRLNCC
- +9 IF $GET(LREND)
- IF $GET(LRLNC1)
- KILL LREND
- QUIT
- +10 IF $GET(LREND)
- DO EXIT
- GOTO START
- +11 IF '$GET(LRCODE)
- DO LOINC
- +12 IF $GET(LRNO)
- IF $GET(LRLNC1)
- KILL LREND
- QUIT
- +13 IF $GET(LRNO)
- DO EXIT
- GOTO START
- +14 IF $GET(LREND)
- IF $GET(LRLNC1)
- KILL LREND
- QUIT
- +15 IF $GET(LREND)
- DO EXIT
- GOTO START
- +16 IF $GET(LRNO)
- DO ENTERLNC^LRLNCC
- +17 IF $GET(LREND)
- IF $GET(LRLNC1)
- KILL LREND
- QUIT
- +18 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))
- IF $GET(LRLNC1)
- KILL LREND
- QUIT
- +6 IF $DATA(DIRUT)!($GET(LREND))
- DO EXIT
- GOTO START
- +7 IF 'Y
- IF $GET(LRNO)
- DO ENTERLNC^LRLNCC
- +8 IF 'Y
- IF '$GET(LRNO)
- DO LOINC
- +9 IF $GET(LRNO)
- DO EXIT
- GOTO START
- +10 IF $GET(LREND)
- IF $GET(LRLNC1)
- KILL LREND
- QUIT
- +11 IF $GET(LREND)
- DO EXIT
- GOTO START
- +12 DO LINK
- +13 IF $GET(LREND)
- IF $GET(LRLNC1)
- KILL LREND
- QUIT
- +14 IF $GET(LREND)
- DO EXIT
- GOTO START
- +15 DO CHECK
- +16 IF $GET(LREND)
- IF $GET(LRLNC1)
- KILL LREND
- QUIT
- +17 IF $GET(LREND)
- DO EXIT
- GOTO START
- +18 DO MAP
- +19 IF $GET(LRLNC1)
- KILL LRCODE
- QUIT
- +20 DO EXIT
- +21 GOTO START
- 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,LRSPEC,LRSPECL,LRSPECN,LRTIME,LRTEST,LRUNITS,S,Y
- +2 KILL DD,DO,DLAYGO,LRLNCNAM,LRNO,X,LRNUM,LROLDCD
- +3 QUIT
- TEST DO TEST^LRLNC0
- +1 QUIT
- LOINC ;Lookup possible LOINC matches in LAB LOINC file #95.3
- +1 DO FIND^DIC(95.3,"","80","M",LRTEST,"","","I '$G(^(4))","","LRLOINC","")
- CODE ;ask which code to map
- +1 IF +LRLOINC("DILIST",0)=0
- Begin DoDot:1
- +2 WRITE !!,"No matches found."
- +3 SET LRNO=1
- End DoDot:1
- QUIT
- +4 WRITE !
- SET I=0
- +5 FOR
- SET I=$ORDER(LRLOINC("DILIST","ID",I))
- if 'I!$GET(LREND)
- QUIT
- Begin DoDot:1
- +6 IF $EXTRACT(IOST,1,2)="C-"
- IF '(I#18)
- Begin DoDot:2
- +7 SET DIR(0)="E"
- DO ^DIR
- +8 if $SELECT($GET(DIRUT)
- SET LREND=1
- End DoDot:2
- if $GET(LREND)
- QUIT
- +9 WRITE !,I,":",LRLOINC("DILIST","ID",I,80)
- End DoDot:1
- +10 KILL DIRUT,DUOUT
- +11 WRITE !!
- +12 SET DIR(0)="N^1:"_$SELECT($GET(LREND):I-2,1:$PIECE(LRLOINC("DILIST",0),U),1:0)
- +13 SET DIR("A")="LOINC code to map this test"
- +14 DO ^DIR
- KILL DIR,LREND
- +15 IF $DATA(DIRUT)
- SET LREND=1
- QUIT
- +16 SET LRCODE=LRLOINC("DILIST",1,+Y)
- +17 DO DISPL^LRLNCC
- +18 QUIT
- LINK ;Link the code with file 64
- +1 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!($DATA(DTOUT))!($DATA(DUOUT))
- KILL DTOUT,DUOUT
- SET LREND=1
- QUIT
- +6 SET LRNLT=+Y
- +7 QUIT
- CHECK ;Check to see if already mapped to a LOINC code
- +1 if '$PIECE($GET(^LAM(LRNLT,9)),U)
- QUIT
- +2 DO SHOWPRE
- +3 IF $DATA(DIRUT)!'Y
- SET LREND=1
- QUIT
- +4 ;DELETE EXISTING DEFAULT MAPPING
- +5 SET DA=LRNLT
- +6 SET DIE="^LAM("
- SET DR="25////@"
- +7 DO ^DIE
- +8 KILL DA,DIE
- +9 QUIT
- MAP ;DIE call to add DEFAULT LOINC CODE
- +1 ;DATA NAME
- IF '$DATA(LRDFONLY)
- SET LRDATA=$PIECE(^LAB(60,LRIEN,0),U,12)
- +2 IF '$LENGTH(LRDATA)
- SET LRDATA=$PIECE(^LAB(60,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 LOCK +^LAM(LRNLT):1
- IF '$TEST
- WRITE !,"Another user is editing this record!!"
- HANG 5
- QUIT
- +6 SET DIE="^LAM("
- SET DA=LRNLT
- SET DR="25////"_LRCODE_";25.2////"_LRTIME_";25.3////"_LRUNITS_";25.4////"_LRDATA_";25.5////"_$SELECT($DATA(LRDFONLY):"@",1:LRIEN)
- +7 DO ^DIE
- +8 LOCK -^LAM(LRNLT)
- MAP2 ;HERE SHOW WHAT WAS MAPPED
- +1 if '$DATA(^LAM(+$GET(LRNLT),0))#2
- QUIT
- +2 WRITE !!
- +3 WRITE !,"NLT: ",$PIECE($GET(^LAM(LRNLT,0)),U)
- +4 WRITE !,"WKLD CODE: ",$PIECE($GET(^LAM(LRNLT,0)),U,2)
- +5 KILL DIC,DR
- +6 SET DIC="^LAM("
- SET DA=LRNLT
- +7 SET S=$Y
- +8 DO EN^DIQ
- +9 QUIT
- SHOWPRE ;DISPLAY LOINC CODE ALREADY MAPPED TO NLT
- +1 SET LROLDCD=$PIECE(^LAM(LRNLT,9),U)
- +2 WRITE !!,"This test is already mapped to:"
- +3 WRITE !,"Default LOINC code: ",LROLDCD_"-"_$PIECE(^LAB(95.3,+$GET(LROLDCD),0),U,15)," ",$GET(^LAB(95.3,LROLDCD,80))
- +4 WRITE !!
- +5 SET DIR(0)="Y"
- SET DIR("A")="Do you want to "_$SELECT($DATA(LRDEL):"delete",1:"change")_" this default mapping"
- SET DIR("B")="NO"
- +6 if '$DATA(LRDEL)
- SET DIR("?")="If you enter yes, the current default LOINC code will be overwritten with the default LOINC code that you have chosen."
- +7 if $DATA(LRDEL)
- SET DIR("?")="If you enter yes, the current default LOINC code will be deleted."
- +8 DO ^DIR
- KILL DIR
- +9 QUIT
- DELETE ;DELETE/UNMAP DEFAULT LOINC CODE
- +1 SET LREND=0
- SET LRDEL=1
- DO TEST
- +2 IF $GET(LREND)
- GOTO EXIT
- +3 DO CHECK
- +4 KILL LRDEL
- +5 GOTO EXIT
- +6 QUIT
- +7 QUIT