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

LRLNCMD.m

Go to the documentation of this file.
  1. 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
  1. ;=================================================================
  1. ; Ask VistA test to map-Lookup in Lab Test file #60
  1. START ;entry point from option LR LOINC MAPPING
  1. Q:$D(LRDFONLY)
  1. S LREND=0 D TEST
  1. I $G(LREND) G EXIT
  1. I '$G(LRNLT) G START
  1. DEFAULT ;ENTRY POINT FROM LRLNC0
  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),$G(LRLNC1) Q
  1. I $D(DIRUT) D EXIT G START
  1. I 'Y D ENTERLNC^LRLNCC
  1. I $G(LREND),$G(LRLNC1) K LREND Q
  1. I $G(LREND) D EXIT G START
  1. I '$G(LRCODE) D LOINC
  1. I $G(LRNO),$G(LRLNC1) K LREND Q
  1. I $G(LRNO) D EXIT G START
  1. I $G(LREND),$G(LRLNC1) K LREND Q
  1. I $G(LREND) D EXIT G START
  1. I $G(LRNO) D ENTERLNC^LRLNCC
  1. I $G(LREND),$G(LRLNC1) K LREND Q
  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)),$G(LRLNC1) K LREND Q
  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),$G(LRLNC1) K LREND Q
  1. I $G(LREND) D EXIT G START
  1. D LINK
  1. I $G(LREND),$G(LRLNC1) K LREND Q
  1. I $G(LREND) D EXIT G START
  1. D CHECK
  1. I $G(LREND),$G(LRLNC1) K LREND Q
  1. I $G(LREND) D EXIT G START
  1. D MAP
  1. I $G(LRLNC1) K LRCODE Q
  1. D EXIT
  1. G START
  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,LRSPEC,LRSPECL,LRSPECN,LRTIME,LRTEST,LRUNITS,S,Y
  1. K DD,DO,DLAYGO,LRLNCNAM,LRNO,X,LRNUM,LROLDCD
  1. QUIT
  1. TEST D TEST^LRLNC0
  1. Q
  1. LOINC ;Lookup possible LOINC matches in LAB LOINC file #95.3
  1. D FIND^DIC(95.3,"","80","M",LRTEST,"","","I '$G(^(4))","","LRLOINC","")
  1. CODE ;ask which code to map
  1. I +LRLOINC("DILIST",0)=0 D Q
  1. .W !!,"No matches found."
  1. .S LRNO=1
  1. W ! S I=0
  1. F S I=$O(LRLOINC("DILIST","ID",I)) Q:'I!$G(LREND) D
  1. .I $E(IOST,1,2)="C-",'(I#18) D Q:$G(LREND)
  1. ..S DIR(0)="E" D ^DIR
  1. ..S:$S($G(DIRUT):1,$G(DUOUT):1,1:0) LREND=1
  1. .W !,I,":",LRLOINC("DILIST","ID",I,80)
  1. K DIRUT,DUOUT
  1. W !!
  1. S DIR(0)="N^1:"_$S($G(LREND):I-2,1:$P(LRLOINC("DILIST",0),U),1:0)
  1. S DIR("A")="LOINC code to map this test"
  1. D ^DIR K DIR,LREND
  1. I $D(DIRUT) S LREND=1 Q
  1. S LRCODE=LRLOINC("DILIST",1,+Y)
  1. D DISPL^LRLNCC
  1. Q
  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(DTOUT))!($D(DUOUT)) K DTOUT,DUOUT S LREND=1 Q
  1. S LRNLT=+Y
  1. Q
  1. CHECK ;Check to see if already mapped to a LOINC code
  1. Q:'$P($G(^LAM(LRNLT,9)),U)
  1. D SHOWPRE
  1. I $D(DIRUT)!'Y S LREND=1 Q
  1. ;DELETE EXISTING DEFAULT MAPPING
  1. S DA=LRNLT
  1. S DIE="^LAM(",DR="25////@"
  1. D ^DIE
  1. K DA,DIE
  1. Q
  1. MAP ;DIE call to add DEFAULT LOINC CODE
  1. I '$D(LRDFONLY) S LRDATA=$P(^LAB(60,LRIEN,0),U,12) ;DATA NAME
  1. I '$L(LRDATA) S LRDATA=$P(^LAB(60,LRIEN,0),U,4)
  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. L +^LAM(LRNLT):1 I '$T W !,"Another user is editing this record!!" H 5 Q
  1. S DIE="^LAM(",DA=LRNLT,DR="25////"_LRCODE_";25.2////"_LRTIME_";25.3////"_LRUNITS_";25.4////"_LRDATA_";25.5////"_$S($D(LRDFONLY):"@",1:LRIEN)
  1. D ^DIE
  1. L -^LAM(LRNLT)
  1. MAP2 ;HERE SHOW WHAT WAS MAPPED
  1. Q:'$D(^LAM(+$G(LRNLT),0))#2
  1. W !!
  1. W !,"NLT: ",$P($G(^LAM(LRNLT,0)),U)
  1. W !,"WKLD CODE: ",$P($G(^LAM(LRNLT,0)),U,2)
  1. K DIC,DR
  1. S DIC="^LAM(",DA=LRNLT
  1. S S=$Y
  1. D EN^DIQ
  1. Q
  1. SHOWPRE ;DISPLAY LOINC CODE ALREADY MAPPED TO NLT
  1. S LROLDCD=$P(^LAM(LRNLT,9),U)
  1. W !!,"This test is already mapped to:"
  1. W !,"Default LOINC code: ",LROLDCD_"-"_$P(^LAB(95.3,+$G(LROLDCD),0),U,15)," ",$G(^LAB(95.3,LROLDCD,80))
  1. W !!
  1. S DIR(0)="Y",DIR("A")="Do you want to "_$S($D(LRDEL):"delete",1:"change")_" this default mapping",DIR("B")="NO"
  1. 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."
  1. S:$D(LRDEL) DIR("?")="If you enter yes, the current default LOINC code will be deleted."
  1. D ^DIR K DIR
  1. Q
  1. DELETE ;DELETE/UNMAP DEFAULT LOINC CODE
  1. S LREND=0,LRDEL=1 D TEST
  1. I $G(LREND) G EXIT
  1. D CHECK
  1. K LRDEL
  1. G EXIT
  1. Q
  1. Q