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