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

BLSMAP.m

Go to the documentation of this file. 
  1. BLSMAP ; IHS/CMI/LAB - MASTER LOINC MAPPER ; [ JUL 20, 2010  2:00 PM ]
  1.  ;;5.2;IHS LABORATORY;**1015,1028**;NOV 01, 1997;Build 46
  1.  ;
  1.  ;This routine is a revised version of BLSMAP originally created for Patch 1015.  It has been modified extensively for Patch 1028.  
  1.  ;
  1.  ;Changes include:
  1.  ;1. Translate UCUM pointer in File60 to its UCUM format prior to lookup in the Master File and report displayed after mapping.
  1.  ;2. Map cosmic and non-CH subscripted tests to LOINC using newly created IHS LOINC field #999999902 in File 60. 
  1.  ;3. Add OK flag for successful matches and mapping.
  1.  ;4. Add ELOG tag to log failures in mapping and ILOG tag to log inactive tests NOT to map.
  1.  ;5. Add LOINC check digit and C80 indicator(*) to post-mapping report.
  1.  ;
  1. EN ;EP
  1.  ;[LR*5.2*1028;09/17/10;IHS/OIT/MPW]Added next 1 line to force UCUM conversion as prerequisite to mapping.
  1.  I +$G(^XTMP("BLRUCUM","DONE"))=0 W !!,"UCUM CONVERSION MUST BE DONE FIRST!" H 2 Q
  1.  ;go through all LAB 60 entries, site/specimen multiple and find 
  1.  ;all tests without a loinc code and attempt to find it in BLSLMAST
  1.  ;and set the LOINC Code into the LOINC field of the multiple
  1.  W:$D(IOF) @IOF
  1.  W !!,$$CTR($$LOC)
  1.  W !!,$$CTR("AUTO-MAP LOINC CODES INTO THE LABORATORY TEST FILE")
  1.  W !!,"This option is used to automatically map LOINC Codes from the IHS Master",!,"LOINC table to your Laboratory test file (file 60)."
  1.  W !,"The test must match the master by Test name, Site/Specimen and Units.  If a ",!,"match is found in the master file, that loinc code is added to your test",!,"in the Laboratory test file"
  1.  ;
  1. LIST ;
  1.  S BLSLIST=""
  1.  W ! S DIR(0)="Y",DIR("A")="Would you like a report of all tests that were assigned a LOINC Code during this mapping process",DIR("B")="Y" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) D EXIT Q
  1.  S BLSLIST=Y
  1. CONT ;
  1.  W !!
  1.  S DIR(0)="Y",DIR("A")="Do you want to continue",DIR("B")="N" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) D EXIT Q
  1.  I 'Y D EXIT Q
  1.  ;
  1. ZIS ;
  1.  S XBRP="PRINT^BLSMAP",XBRC="PROC^BLSMAP",XBRX="EXIT^BLSMAP",XBNS="BLS"
  1.  D ^XBDBQUE
  1.  D EXIT
  1.  Q
  1. EXIT ;
  1.  D EN^XBVK("BLS")
  1.  D ^XBFMK
  1.  Q
  1.  ;
  1. PROC ;
  1.  K ^XTMP("BLSMAP")
  1.  S BLSCNT=0,BLSQUIT=""
  1.  S BLSJ=$J,BLSH=$H
  1.  S ^XTMP("BLSLIST",0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^"_"LOINC MAPPER LIST"
  1.  K ^XTMP("BLSLIST",BLSJ,BLSH)
  1.  W:'$D(ZTQUEUED) ".... mapping codes..."
  1.  ;[LR*5.2*1028;08/13/10;IHS/OIT/MPW]Rewrote loop to go through File 60 directly
  1.  ;[LR*5.2*1028;08/13/10;IHS/OIT/MPW]S BLSNAME="" F  S BLSNAME=$O(^LAB(60,"B",BLSNAME)) Q:BLSNAME=""  D
  1.  ;[LR*5.2*1028;08/13/10;IHS/OIT/MPW]S BLSIEN=0 F  S BLSIEN=$O(^LAB(60,"B",BLSNAME,BLSIEN)) Q:BLSIEN'=+BLSIEN  D
  1.  S BLSIEN=0 F  S BLSIEN=$O(^LAB(60,BLSIEN)) Q:BLSIEN'=+BLSIEN  D
  1.  .S OK=0
  1.  .S BLSNAME=$P(^LAB(60,BLSIEN,0),U,1) Q:BLSNAME=""
  1.  .S BLSTYP=$P(^LAB(60,BLSIEN,0),U,3)
  1.   .; Skip inactive tests
  1.  .I $E(BLSNAME,1,2)="ZZ"!($E(BLSNAME,1,2)="zz") D ILOG Q
  1.  .I $E(BLSNAME,1)="x" S BLSNAME=$E(BLSNAME,2,$L(BLSNAME)) ;remove 'x' from ref lab test name
  1.  .I BLSNAME[" (R)" S BLSNAME=$P(BLSNAME," (R)",1)
  1.  .S BLSUNAME=$$TRIMN(BLSNAME) Q:BLSUNAME=""
  1.  .;if no specimen node (cosmic test), check for IHS LOINC, if not found, set default specimen for lookup
  1.  .I $O(^LAB(60,BLSIEN,1,0))="" D
  1.  ..I $P($G(^LAB(60,BLSIEN,9999999)),U,2)'="" S OK=1 Q
  1.  ..S BLSSS="SPECXXX",BLSUNITS="UNITXXX"
  1.  ..;check once with these values
  1.  ..I $O(^BLSLMAST("AA",BLSUNAME,BLSSS,BLSUNITS,0)) S OK=1,BLSUP=2 D UPDATE Q
  1.  ..;if no match try trimming all leading chars not number,alpha or %
  1.  ..S BLSUNAME=$$TRIMN(BLSUNAME)
  1.  ..Q:BLSUNAME=""
  1.  ..I $O(^BLSLMAST("AA",BLSUNAME,BLSSS,BLSUNITS,0)) S OK=1,BLSUP=2 D UPDATE Q
  1.  ..Q
  1.  .;if specimen node exists, check each for LOINC
  1.  .I $O(^LAB(60,BLSIEN,1,0))'="" S BLSSSIEN=0 F  S BLSSSIEN=$O(^LAB(60,BLSIEN,1,BLSSSIEN)) Q:BLSSSIEN'=+BLSSSIEN  D
  1.  ..;[LR*5.2*1028;09/27/10;IHS/OIT/MPW]I $P($G(^LAB(60,BLSIEN,1,BLSSSIEN,95.3)),U)]"" Q  ;already has Loinc
  1.  ..I $P($G(^LAB(60,BLSIEN,1,BLSSSIEN,95.3)),U)]"" S OK=1 Q  ;already has Loinc
  1.  ..S BLSSS=$P(^LAB(60,BLSIEN,1,BLSSSIEN,0),U),BLSSS=$P(^LAB(61,BLSSSIEN,0),U),BLSSS=$$CLEAN(BLSSS)
  1.  ..S BLSUNITS=$P(^LAB(60,BLSIEN,1,BLSSSIEN,0),U,7) I BLSUNITS="" S BLSUNITS="UNITXXX"
  1.  ..;check once with these values
  1.  ..I $O(^BLSLMAST("AA",BLSUNAME,BLSSS,BLSUNITS,0)) S (OK,BLSUP)=1 D UPDATE Q
  1.  ..;if no match try trimming all leading chars not number,alpha or %
  1.  ..S BLSUNAME=$$TRIMN(BLSUNAME)
  1.  ..Q:BLSUNAME=""
  1.  ..I $O(^BLSLMAST("AA",BLSUNAME,BLSSS,BLSUNITS,0)) S (OK,BLSUP)=1 D UPDATE Q
  1.  ..;check one last time for BLSUNAME,BLSSS combo for any units
  1.  ..S BLSUNITS=$O(^BLSLMAST("AA",BLSUNAME,BLSSS,""))
  1.  ..I BLSUNITS'="",$O(^BLSLMAST("AA",BLSUNAME,BLSSS,BLSUNITS,0)) S (OK,BLSUP)=1 D UPDATE Q
  1.  ..I 'OK D ELOG
  1.  ..Q
  1.  .Q
  1.  Q
  1.  ;
  1. UPDATE ;
  1.  S BLSL=$O(^BLSLMAST("AA",BLSUNAME,BLSSS,BLSUNITS,0))
  1.  S BLSLOI=$P(^BLSLMAST(BLSL,0),U,5)
  1.  Q:BLSLOI=""  ;no loinc
  1.  D ^XBFMK K DIADD,DLAYGO
  1.  W !,"Mapping loinc code ",BLSLOI," - ",$G(^LAB(95.3,BLSLOI,80))," to lab test ",BLSUNAME
  1.  ;[LR*5.2*1028;08/30/10;IHS/OIT/MPW] Begin changes
  1.  ;S DA(1)=BLSIEN,DA=BLSSSIEN,DIE="^LAB(60,"_BLSIEN_",1,",DR="95.3///"_BLSLOI D ^DIE
  1.  I BLSUP=1 S DA(1)=BLSIEN,DA=BLSSSIEN,DIE="^LAB(60,"_BLSIEN_",1,",DR="95.3///^S X=BLSLOI" D ^DIE
  1.  I BLSUP=2 S DA=BLSIEN,DIE="^LAB(60,",DR="999999902///^S X=BLSLOI" D ^DIE
  1.  ;[LR*5.2*1028;08/30/10;IHS/OIT/MPW] End changes
  1.  I $D(Y) Q
  1.  S BLSCNT=BLSCNT+1
  1.  Q:'BLSLIST
  1.  S ^XTMP("BLSLIST",BLSJ,BLSH,"MAPPED",BLSIEN,BLSSSIEN)=""
  1.  Q
  1.  ;
  1. ILOG ; Inactive tests - don't map
  1.  S ^XTMP("BLSMAP","INACT",BLSIEN)=""
  1.  S ^XTMP("BLSMAP","INACT")=+$G(^XTMP("BLSMAP","INACT"))
  1.  Q
  1.  ;
  1. ELOG ; Log error - tests that don't map
  1.  S ^XTMP("BLSMAP","ERR",BLSIEN,BLSSSIEN)=BLSUNAME_U_BLSSS_U_BLSUNITS
  1.  S ^XTMP("BLSMAP","ERR")=+$G(^XTMP("BLSMAP","ERR"))
  1.  Q
  1.  ;
  1. PRINT ;EP
  1.  S BLSPG=0 D HEADER S BLSQUIT=""
  1.  I '$D(^XTMP("BLSLIST",BLSJ,BLSH,"MAPPED")) W !!,"No Lab Tests were assigned LOINC Codes" D EOJ Q
  1.  W !!,"Total number of tests assigned LOINC codes: ",BLSCNT,!
  1.  S BLSIEN=0 F  S BLSIEN=$O(^XTMP("BLSLIST",BLSJ,BLSH,"MAPPED",BLSIEN)) Q:BLSIEN'=+BLSIEN!(BLSQUIT)  D
  1.  .S BLSSSIEN=0 F  S BLSSSIEN=$O(^XTMP("BLSLIST",BLSJ,BLSH,"MAPPED",BLSIEN,BLSSSIEN)) Q:BLSSSIEN'=+BLSSSIEN!(BLSQUIT)  D
  1.  ..I $Y>(IOSL-4) D HEADER Q:BLSQUIT
  1.  ..;[LR*5.2*1028;08/30/10;IHS/OIT/MPW] Begin changes
  1.  ..S BLSUNITS=$P(^LAB(60,BLSIEN,1,BLSSSIEN,0),U,7)
  1.  ..S BLSL=$P($G(^LAB(60,BLSIEN,1,BLSSSIEN,95.3)),U),BLSLNC=BLSL_"-"_$P(^LAB(95.3,BLSL,0),U,15)
  1.  ..;W !,$E($P(^LAB(60,BLSIEN,0),U),1,34),?35,$E($P(^LAB(61,BLSSSIEN,0),U),1,15),?52,$E($P(^LAB(60,BLSIEN,1,BLSSSIEN,0),U,7),1,15),?69,$P($G(^LAB(60,BLSIEN,1,BLSSSIEN,95.3)),U)
  1.  ..W !,$E($P(^LAB(60,BLSIEN,0),U),1,34),?35,$E($P(^LAB(61,BLSSSIEN,0),U),1,15),?52,$E(BLSUNITS,1,15),?69,BLSLNC
  1.  ..I $O(^BLSLMAST("C",BLSL,""))'="" S REC=$O(^BLSLMAST("C",BLSL,"")) W:$G(^BLSLMAST(REC,11))="C80" "*"
  1.  ..Q:'BLSL
  1.  ..W !?2,$P($G(^LAB(95.3,BLSL,80)),U)
  1.  Q
  1.  ;
  1. CTR(X,Y) ;EP - Center X in a field Y wide.
  1.  Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
  1.  ;----------
  1.  I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S BLSQUIT=1 Q
  1. HEAD1 ;
  1.  W:$D(IOF) @IOF S BLSPG=BLSPG+1
  1.  W !
  1.  W ?20,$$LOC,?72,"Page ",BLSPG,!
  1.  W !,$$CTR("LOINC CODES ASSIGNED WITH AUTO MAPPER",80)
  1.  W !,$$CTR("DATE: "_$$FMTE^XLFDT(DT),80)
  1.  W !,$TR($J("",80)," ","-"),!
  1.  Q
  1. EOJ ;
  1.  K ^XTMP("BLSLIST",BLSJ,BLSH)
  1.  K BLSJ,BLSH
  1.  D EOP
  1.  Q
  1. EOP ;EP - End of page.
  1.  Q:$E(IOST)'="C"
  1.  Q:$D(ZTQUEUED)!'(IOT="TRM")!$D(IO("S"))
  1.  NEW DIR
  1.  K DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
  1.  S DIR(0)="E" D ^DIR
  1.  Q
  1.  ;--------------------------------------------------------------------
  1. USR() ;EP - Return name of current user from ^VA(200.
  1.  Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
  1.  ;--------------------------------------------------------------------
  1. LOC() ;EP - Return location name from file 4 based on DUZ(2).
  1.  Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
  1.  ;--------------------------------------------------------------------
  1.  ;Trim Leading Spaces
  1. TRIMLSPC(X) ;
  1.  F  Q:$E(X,1)'=" "  S X=$E(X,2,$L(X))
  1.  Q X
  1.  ;--------------------------------------------------------------------
  1.  ;Trim Trailing Spaces
  1. TRIMTSPC(X) ;
  1.  F  Q:$E(X,$L(X))'=" "  S X=$E(X,1,$L(X)-1)
  1.  Q X
  1.  ;--------------------------------------------------------------------
  1.  ;Trim Leading Slashes
  1. TRIMLS(X) ;
  1.  F  Q:$E(X,1)'="/"  S X=$E(X,2,$L(X))
  1.  Q X
  1.  ;--------------------------------------------------------------------
  1.  ;Trim Trailing Colons
  1. TRIMTC(X) ;
  1.  F  Q:$E(X,$L(X))'=":"  S X=$E(X,1,$L(X)-1)
  1.  Q X
  1.  ;--------------------------------------------------------------------
  1.  ;Trim All Leading Non-Alphanumeric Characters Except the "%" Sign
  1. TRIMN(X) ;
  1.  F  Q:$E(X,1)?1N!($E(X)?1U)!($E(X)?1"%")!($L(X)=0)  S X=$E(X,2,$L(X))
  1.  Q X
  1.  ;--------------------------------------------------------------------
  1.  ;Trim All Leading and Trailing Spaces
  1. TRIMALL(X) ;
  1.  Q $$TRIMLSPC($$TRIMTSPC(X))
  1.  ;--------------------------------------------------------------------
  1.  ;Convert lowercase to uppercase
  1. UCASE(X) ;
  1.  Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
  1.  ;--------------------------------------------------------------------
  1.  ;Trim All Leading and Trailing Spaces and Convert from Lowercase to Uppercase
  1. CLEAN(X) ;
  1.  Q $$UCASE($$TRIMALL(X))
  1.  ;--------------------------------------------------------------------