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

BLSMIT.m

Go to the documentation of this file. 
  1. BLSMIT ;IHS/CMI/LAB - map individual test; [ SEP 10, 2010  6:48 AM ]
  1.  ;;5.2;IHS LABORATORY;**1015,1028**;NOV 01, 1997;Build 46
  1.  ;;5.2;LAB SERVICE;**215**;Sep 27,1994
  1.  ;=================================================================
  1.  ; Ask VistA test to map-Lookup in Lab Test file #60
  1.  ;
  1.  ; This routine has been modified extensively since patch 1015 for patch 1028.  
  1.  ; It has been altered to allow mapping of panels and non-CH subscripted tests.
  1.  ; Corrected undefined error during lookup.
  1.  ;
  1. START ;entry point from option BLS LOINC MAPPING
  1.  S BLSEND=0 D TEST
  1.  I $G(BLSEND) G EXIT
  1.  D SPEC
  1.  I $G(BLSEND) D EXIT G START
  1.  W !!
  1.  D ENTERLNC
  1.  I $G(BLSEND) D EXIT G START
  1. CORRECT W !!
  1.  S DIR(0)="Y",DIR("A")="Is this the correct one",DIR("B")="N"
  1.  S DIR("?")="Enter 'NO' to select a different code."
  1.  D ^DIR K DIR
  1.  I $D(DIRUT)!($G(BLSEND)) D EXIT G START
  1.  ;I 'Y,$G(BLSNO) D ENTERLNC
  1.  ;I 'Y,'$G(BLSNO) D LOINC
  1.  I 'Y D ENTERLNC
  1.  I $G(BLSEND) D EXIT G START
  1.  D MAP
  1.  D EXIT
  1.  G START
  1. EXIT K DA,DIC,DIE,DINUM,DIR,DIRUT,DR,DTOUT,I,BLSCODE,BLSDATA,BLSEND,BLSLNC,BLSLNC0,BLSLOINC,BLSELEC,BLSIEN,BLSNLT,BLSSPEC,BLSSPECL,BLSSPECN,BLSTIME,BLSTEST,BLSUNITS,S,Y
  1.  K DD,DO,DLAYGO,BLSNAM,BLSNO,X
  1.  QUIT
  1. TEST W !!
  1.  K DIR
  1.  ;[LR*5.2*1028;09/10/10;IHS/OIT/MPW]S DIR(0)="P^60:QEMZ,",DIR("A")="Enter Lab Test to Link/Map to LOINC ",DIR("S")="I ""BO""[$P(^(0),U,3),$L($P(^(0),U,12)),$P(^(0),U,4)=""CH"""
  1.  S DIR(0)="P^60:QEMZ,",DIR("A")="Enter Lab Test to Link/Map to LOINC "
  1.  S DIR("?")="Select Lab test you wish to link/map to a LOINC Code"
  1.  D ^DIR K DIR
  1.  I $D(DIRUT)!'Y K DIRUT S BLSEND=1 Q
  1.  S BLSIEN=+Y,BLSTEST=$P(Y,U,2)
  1.  W !
  1.  Q
  1. SPEC ; Ask Specimen- Lookup in Specimen multiple in Lab Test file #60
  1.  S BLSEND=0
  1.  ;display test in 60 and select specimen in multiple
  1.  ;display all site specimens
  1.  W !!,"You have selected the following test:"
  1.  K DIC,DR,DIQ
  1.  S DIC="^LAB(60,",DA=BLSIEN,DIQ(0)="R" D EN^DIQ
  1. SPEC1 ;
  1.  ;[LR*5.2*1028;09/10/10;IHS/OIT/MPW]I '$O(^LAB(60,BLSIEN,1,0)) W !!,"There are no site/specimens defined for this test.",!! S BLSEND=1 H 2 Q
  1.  I '$O(^LAB(60,BLSIEN,1,0)) W !!,"There are no site/specimens defined for this test.",!! H 2 Q
  1.  W !,"Select from the available site/specimens:",!
  1.  W !?4,"SITE/SPECIMEN",?35,"UNITS",?50,"LOINC CODE"
  1.  W !?4,"-------------",?35,"-----",?50,"----------"
  1.  K BLSSS
  1.  S (BLSC,BLSX)=0 F  S BLSX=$O(^LAB(60,BLSIEN,1,BLSX)) Q:BLSX'=+BLSX  D
  1.  .S BLSC=BLSC+1
  1.  .S BLSS=^LAB(60,BLSIEN,1,BLSX,0),BLSSS(BLSC)=BLSX
  1.  .;[LR*5.2*1028;09/10/10;IHS/OIT/MPW]W !,BLSC,")",?4,$P(^LAB(61,$P(BLSS,U),0),U),?35,$P(BLSS,U,7),?50,$P($G(^LAB(60,BLSIEN,1,BLSX,95.3)),U)
  1.  .;[LR*5.2*1028;09/28/10;IHS/OIT/MPW]Broke up previous line into 3 new lines.
  1.  .W !,BLSC,")",?4,$P(^LAB(61,$P(BLSS,U),0),U),?35
  1.  .W:$P(BLSS,U,7)?1N.N $P(^BLRUCUM($P(BLSS,U,7),0),U,1)
  1.  .W ?50,$P($G(^LAB(60,BLSIEN,1,BLSX,95.3)),U)
  1.  .Q
  1.  K DIR
  1.  S DIR(0)="N^1:"_BLSC_":0",DIR("A")="Select the Site/Specimen Entry for this test" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) S BLSEND=1 Q
  1.  S BLSSPEC=BLSSS(+Y)
  1.  Q
  1. LOINC ;Lookup possible LOINC matches in LAB LOINC file #95.3
  1.  ;[LR*5.2*1028;09/14/10;IHS/OIT/MPW]D FIND^DIC(95.3,"","80","M",BLSTEST,"","","I $P(^(0),U,8)=$G(BLSELEC)!(BLSELEC=74!(BLSELEC=83)!(BLSELEC=114)!(BLSELEC=1376)&(""SER PLAS BLD""[$P(^(80),"":"",4)))","","BLSLOINC","")
  1.  D FIND^DIC(95.3,"","80","M",BLSTEST,"","","I $G(BLSELEC),$P(^(0),U,8)=$G(BLSELEC)!(BLSELEC=74!(BLSELEC=83)!(BLSELEC=114)!(BLSELEC=1376)&(""SER PLAS BLD""[$P(^(80),"":"",4)))","","BLSLOINC","")
  1. CODE ;ask which code to map
  1.  I +BLSLOINC("DILIST",0)=0 D  Q
  1.  .W !!,"No matches found."
  1.  .S BLSNO=1
  1.  W !! S I=0
  1.  F  S I=$O(BLSLOINC("DILIST","ID",I)) Q:'I!$G(BLSEND)  D
  1.  .I $E(IOST,1,2)="C-",'(I#18) D  Q:$G(BLSEND)
  1.  ..S DIR(0)="E" D ^DIR
  1.  ..S:$S($G(DIRUT):1,$G(DUOUT):1,1:0) BLSEND=1
  1.  .W !,I,":",BLSLOINC("DILIST","ID",I,80)
  1.  K DIRUT,DUOUT
  1.  W !!
  1.  S DIR(0)="N^1:"_$S($G(BLSEND):I-2,1:$P(BLSLOINC("DILIST",0),U),1:0)
  1.  S DIR("A")="LOINC code to map this test"
  1.  D ^DIR K DIR,BLSEND
  1.  I $D(DIRUT) S BLSEND=1 Q
  1.  S BLSCODE=BLSLOINC("DILIST",1,+Y)
  1. DISPL ;Show LOINC entry selected in file 95.3
  1.  ;display header-system and class
  1.  ;display LOINC code, component, property, time aspect, scale type and method type
  1.  S DA=BLSCODE
  1.  S BLSLNC0=^LAB(95.3,DA,0)
  1.  F I=2,6,7,8,9,10,11,14 S BLSLNC0(I)=$P(BLSLNC0,U,I)
  1.  S BLSNAM=$P($G(^LAB(95.3,DA,80)),U)
  1.  W @IOF
  1.  W !,"LOINC CODE: ",BLSCODE,"   ",BLSNAM
  1.  W !,"SYSTEM: ",$P($G(^LAB(64.061,+BLSLNC0(8),0)),U),?40,"CLASS: ",$P($G(^LAB(64.061,+BLSLNC0(11),0)),U)
  1.  W:BLSLNC0(2) !,"COMPONENT: ",$P($G(^LAB(95.31,+BLSLNC0(2),0)),U)
  1.  W:BLSLNC0(6) !,"PROPERTY: ",$P($G(^LAB(64.061,+BLSLNC0(6),0)),U)
  1.  W:BLSLNC0(7) !,"TIME ASPECT: ",$P($G(^LAB(64.061,+BLSLNC0(7),0)),U)
  1.  W:BLSLNC0(9) !,"SCALE TYPE: ",$P($G(^LAB(64.061,+BLSLNC0(9),0)),U)
  1.  W:BLSLNC0(10) !,"METHOD TYPE: ",$P($G(^LAB(64.2,+BLSLNC0(10),0)),U)
  1.  ;[LR*5.2*1028;09/14/10;IHS/OIT/MPW]W:BLSLNC0(14) !,"UNITS: ",$P($G(^LAB(64.061,+BLSLNC0(14),0)),U)
  1.  W:BLSLNC0(14) !,"UNITS: ",$P($G(^BLRUCUM(+BLSLNC0(14),0)),U,3)
  1.  Q
  1. MAP ;DIE call to add data name,time aspect,units, LOINC code, and lab test fields
  1.  W !!,"LOINC Code ",$P(^LAB(95.3,BLSCODE,0),U)," will be mapped to test ",$P(^LAB(60,BLSIEN,0),U),!
  1.  S DIR(0)="Y",DIR("A")="Are you sure you want to Map this code to this test"
  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.  I $D(DIRUT) S BLSEND=1 Q
  1.  I 'Y S BLSEND=1 Q
  1. INDEX60 ;Stores LOINC code in Laboratory Test file (#60) so know what tests are mapped.
  1.  ;[LR*5.2*1028;09/10/10;IHS/OIT/MPW]K DIE,DA,DR S DA=BLSSPEC,DA(1)=BLSIEN,DIE="^LAB(60,"_DA(1)_",1,",DR="95.3///"_BLSCODE D ^DIE
  1.  I $G(BLSSPEC) K DIE,DA,DR S DA=BLSSPEC,DA(1)=BLSIEN,DIE="^LAB(60,"_DA(1)_",1,",DR="95.3///"_BLSCODE D ^DIE
  1.  I '$G(BLSSPEC) K DIE,DA,DR S DA=BLSIEN,DIE="^LAB(60,",DR="999999902///"_BLSCODE D ^DIE
  1.  ;[LR*5.2*1028;09/10/10;IHS/OIT/MPW]S ^LAB(60,BLSIEN,1,BLSSPEC,95.3)=BLSCODE
  1.  I $D(Y) W !!,"LOINC CODE mapping failed.",! H 2 Q
  1.  W !!,"Loinc Code has been successfully mapped.",!
  1.  K DIC,DR,DIQ
  1.  S DIC="^LAB(60,",DA=BLSIEN,DIQ(0)="R" D EN^DIQ
  1.  Q
  1. SHOWPRE ;DISPLAY LOINC CODE ABLSEADY MAPPED TO NLT
  1.  S BLSLNC=$P($G(^LAM(BLSNLT,5,BLSSPEC,1,BLSTIME,1)),U)
  1.  W !!,"This test and specimen is already mapped to:"
  1.  W !,"LOINC code: ",BLSLNC,"  ",$G(^LAB(95.3,+BLSLNC,80))
  1.  W !!
  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. ENTERLNC ;Enter LOINC code when already know the LOINC code
  1.  W !! K DIR S BLSEND=0,DIR(0)="P^95.3:AEMZ",DIR("A")="Enter LOINC Code/Name "
  1.  S DIR("?")="Enter LOINC Code Name or LOINC Number"
  1.  S DIR("?",1)="You can see possible LOINC CODES/Specimen by entering the"
  1.  ;[LR*5.2*1028;10/14/10;IHS/OIT/MPW] Begin changes
  1.  ;S DIR("?",2)="LOINC Test Name..Specimen   example( GLUCOSE..UR )"
  1.  S DIR("?",2)="LOINC Test Name   example( GLUCOSE )"
  1.  ;S DIR("?",3)=" "
  1.   ;[LR*5.2*1028;10/14/10;IHS/OIT/MPW] End changes
  1.  D ^DIR K DIR
  1.  I $D(DUOUT)!($D(DTOUT))!(Y=-1) K DTOUT,DUOUT S BLSEND=1 Q
  1.  S BLSCODE=+Y
  1.  D DISPL
  1.  Q