LRLNCX ;DAL/OI/FS - ROUTINE TO EXTRACT VISTA TEST NAMES FOR LOINC MAPPING ; 1-FEB-2001; [Aug 06, 2010 ]
;;5.2;LR;**1018,1028**;NOV 01, 1997;Build 46
;;5.2;LAB SERVICE;**232,278**;Sep 27,1994
;;
; Field Separator = "|"
;LR60 = IEN from ^LAB(60
;LRSP = SPECIMEN pointer to ^LAB(61
;LR60N = TEST NAME FOR ^LAB(60 - *? are translated to spaces for RELMA
;LRSPN = SPECIMEN NAME - attempt to get LOINC Abbrv if linked
;LRUNIT = REPORTING UNITS FROM ^LAB(60,IEN,1,LRSP,0)
;1-70|WBC BLD K/cmm
;Capture the output into a text file to import into Relma.
;Remove 1st and last lines before importing into Relma
EN ;
K ^TMP("LR LOINC",$J),LREND,LRAA
D MSG W !
G END:$G(LREND)
S LRFS="|",LR60=0,LR60N=""
G @LRANS
3 ;Selected all tests
2 ;Selected accession area - screen on LRAA(#)
D ASK G END:$G(LREND)
;[LR*5.2*1028,MPW,08/09/10]Rewrite loop to go directly through File 60 rather than "B" cross-reference.
;F S LR60N=$O(^LAB(60,"B",LR60N)) Q:LR60N="" D
;S LR60=0 F S LR60=$O(^LAB(60,"B",LR60N,LR60)) Q:LR60<1 D
;Q:$G(^LAB(60,"B",LR60N,LR60))
;I '$D(^LAB(60,LR60,0))#2 K ^LAB(60,"B",LR60N,LR60) Q
;Q:$P(^LAB(60,LR60,0),U,3)="N"!($P(^(0),U,3)="") D OUT
;[LR*5.2*1028,MPW,08/09/10]Added next 6 lines.
S LR60=0
F S LR60=$O(^LAB(60,LR60)) Q:LR60'=+LR60 D
.S LR60N=$P(^LAB(60,LR60,0),U,1)
.;skip inactive tests
.Q:$E(LR60N,1,2)="ZZ"!($E(LR60N,1,2)="zz")
.F I=1:1 Q:$E(LR60N,1)'="_" S LR60N=$E(LR60N,2,$L(LR60N)) ;strip leading underscores from test name
.I $E(LR60N,1)="x" S LR60N=$E(LR60N,2,$L(LR60N)) ;strip leading 'x' on interface test name
.Q:$P(^LAB(60,LR60,0),U,3)="N"!($P(^(0),U,3)="") D OUT
Q
1 ;create individual test list.
K ^TMP("LR LOINC",$J)
S ^TMP("LR LOINC",$J,0)=DT_U_DT_U_"LRLNCX TEST LIST"
K DIR
S DIR(0)="PO^60:NQEMZ"
S DIR("S")="I $L($P(^(0),U,3)),$P(^(0),U,3)'=""N"",$P($P(^(0),U,5),"";"",2)"
F D ^DIR Q:Y<1 S ^TMP("LR LOINC",$J,Y(0,0)_+Y,0)=+Y_U_Y(0,0)
I $O(^TMP("LR LOINC",0))'="" D ASK G END:$G(LREND)
S LRNX=0
;W !,$TR($$SITE^VASITE,U,"|")_"|"_$$FMTE^XLFDT($$NOW^XLFDT,1)
F S LRNX=$O(^TMP("LR LOINC",$J,LRNX)) Q:LRNX="" D
. S LR60=$G(^TMP("LR LOINC",$J,LRNX,0))
. Q:'$G(LR60)
. I $L($P(LR60,U,2)) S LR60N=$P(LR60,U,2),LR60=+LR60 D OUT
G END
Q
OUT ;
I $G(LRAA) S LRNOP=1 D Q:LRNOP
. S LR8=0 F S LR8=$O(^LAB(60,LR60,8,LR8)) Q:LR8<1!('$G(LRNOP)) D
. . I $D(LRAA(+$P($G(^LAB(60,LR60,8,LR8,0)),U,2)))#2 S LRNOP=0
;[LR*5.2*1028,MPW,08/09/10]Added next 1 line.
I '$D(^LAB(60,LR60,1)) S (LRSP,LRSPN,LRUNIT)="" D WRT Q
S LRSP=0 F S LRSP=$O(^LAB(60,LR60,1,LRSP)) Q:LRSP<1 D
.;[LR*5.2*1028,MPW,08/06/10]S LRSP0=$G(^(LRSP,0)),LR61=$G(^LAB(61,LRSP,0)),LRUNIT=$P(LRSP0,U,7)
. S LRSP0=$G(^(LRSP,0)),LR61=$G(^LAB(61,LRSP,0)),LRUNIT=$P(LRSP0,U,7) I LRUNIT=+LRUNIT S LRUNIT=$P(^BLRUCUM(LRUNIT,0),U,1)
. ;[LR*5.2*1028;08/23/10;IHS/OIT/MPW]Added next 1 line to skip specimens already mapped
. Q:$G(^LAB(60,LR60,1,LRSP,95.3))'=""
. S LRSPN=$P(LR61,U),LR64061=$P(LR61,U,9),LRLSPN=$P(LR61,U,8)
. K LR64N I LR64061 S LR64N=$P($G(^LAB(64.061,LR64061,0)),U,2)
. S LRSPN=$S($D(LR64N):LR64N,$L(LRLSPN):LRLSPN,1:LRSPN)
. D WRT
Q
WRT ;LR60N [test name] - translate "*" or "?" to spaces
;[LR*5.2*1028,MPW,08/09/10]W !,$E(LR60_"-"_LRSP_LRFS_$TR(LR60N,"*?"," ")_" "_LRSPN_LRFS_LRUNIT,1,80)
W !,$E(LR60_$S(LRSP'="":"-",1:"")_LRSP_LRFS_$TR(LR60N,"*?"," ")_$S(LRSPN'="":" ",1:"")_LRSPN_LRFS_LRUNIT,1,80)
Q
ASK ;
K DIR S DIR(0)="Y",DIR("A")="Ready to Capture"
D ^DIR S:$D(DIRUT) LREND=1
Q
MSG ;
W @IOF
W !,"(NOTE) You should use the Add/Edit Topography Specimen HL7 Code"
W !,"[LR LOINC LEDI HL7 CODE] option before you proceed."
W !," ----- ----- ----- ----"
W !,"This option will create a Local Master Observation File (LMOF)"
W !,"from your local LABORATORY TEST (#60) file."
;W !!,"Only 'CH' subscripted test having a dataname and having a type"
;W !,"of 'BOTH', 'INPUT' or 'OUTPUT' will be extracted."
W !,"The LMOF file will use the vertical bar '|' as the field separator."
W !,"The 1st. field is the test internal number and internal number"
W !,"of the spec. (i.e. 1-72 will represent test 1 and specimen 72)."
W !,"The 2nd field contains |test name<SP>specimen."
W !,"The 3rd field is the reporting unit only (if any)."
W !!,"You will need to capture this printout into a text file."
W !,"Using a text editor, remove extraneous lines from the beginning"
W !,"and the end of the file so that only extracted test names remain."
W !,"Save the edited file. Use this file in the import function of the"
W !,"Regenstrief LOINC Mapping Assistant (RELMA)."
W !,"Consult the Regenstrief RELMA documentation for specifics."
K DIR S DIR(0)="E" D ^DIR S:$D(DIRUT) LREND=1 Q:$G(LREND)
SEL ;Select method of extraction
K DIR,LRAA
S (LRANS,LREND)=0
S DIR(0)="SO^1:Individual single test;2:By Accession Area;3:All Test"
S DIR("A")="Select extraction criteria"
D ^DIR S:$D(DIRUT) LREND=1
I Y>0 S LRANS=Y
I LRANS=2 D
. K DIR
. S DIR(0)="PO^68:ENZM",DIR("A")="Select accession area "
. S DIR("S")="I $P(^(0),U,17)'=""S"""
. F D ^DIR Q:Y<1 D
. . S LRAA=Y
. . S LRAA(+LRAA)=LRAA,DIR("A")="Select another accession area "
Q
END ;
K DIR,DIRUT,LR60,LR60N,LR61,LR64061,LR64N,LR8,LRAA,LRANS,LREND,LRFS,LRLSPN,LRNOP,LRNX,LRSITE,LRSP,LRSP0,LRSPN,LRUNIT,Y
Q
LRLNCX ;DAL/OI/FS - ROUTINE TO EXTRACT VISTA TEST NAMES FOR LOINC MAPPING ; 1-FEB-2001; [Aug 06, 2010 ]
+1 ;;5.2;LR;**1018,1028**;NOV 01, 1997;Build 46
+2 ;;5.2;LAB SERVICE;**232,278**;Sep 27,1994
+3 ;;
+4 ; Field Separator = "|"
+5 ;LR60 = IEN from ^LAB(60
+6 ;LRSP = SPECIMEN pointer to ^LAB(61
+7 ;LR60N = TEST NAME FOR ^LAB(60 - *? are translated to spaces for RELMA
+8 ;LRSPN = SPECIMEN NAME - attempt to get LOINC Abbrv if linked
+9 ;LRUNIT = REPORTING UNITS FROM ^LAB(60,IEN,1,LRSP,0)
+10 ;1-70|WBC BLD K/cmm
+11 ;Capture the output into a text file to import into Relma.
+12 ;Remove 1st and last lines before importing into Relma
EN ;
+1 KILL ^TMP("LR LOINC",$JOB),LREND,LRAA
+2 DO MSG
WRITE !
+3 IF $GET(LREND)
GOTO END
+4 SET LRFS="|"
SET LR60=0
SET LR60N=""
+5 GOTO @LRANS
3 ;Selected all tests
2 ;Selected accession area - screen on LRAA(#)
+1 DO ASK
IF $GET(LREND)
GOTO END
+2 ;[LR*5.2*1028,MPW,08/09/10]Rewrite loop to go directly through File 60 rather than "B" cross-reference.
+3 ;F S LR60N=$O(^LAB(60,"B",LR60N)) Q:LR60N="" D
+4 ;S LR60=0 F S LR60=$O(^LAB(60,"B",LR60N,LR60)) Q:LR60<1 D
+5 ;Q:$G(^LAB(60,"B",LR60N,LR60))
+6 ;I '$D(^LAB(60,LR60,0))#2 K ^LAB(60,"B",LR60N,LR60) Q
+7 ;Q:$P(^LAB(60,LR60,0),U,3)="N"!($P(^(0),U,3)="") D OUT
+8 ;[LR*5.2*1028,MPW,08/09/10]Added next 6 lines.
+9 SET LR60=0
+10 FOR
SET LR60=$ORDER(^LAB(60,LR60))
IF LR60'=+LR60
QUIT
Begin DoDot:1
+11 SET LR60N=$PIECE(^LAB(60,LR60,0),U,1)
+12 ;skip inactive tests
+13 IF $EXTRACT(LR60N,1,2)="ZZ"!($EXTRACT(LR60N,1,2)="zz")
QUIT
+14 ;strip leading underscores from test name
FOR I=1:1
IF $EXTRACT(LR60N,1)'="_"
QUIT
SET LR60N=$EXTRACT(LR60N,2,$LENGTH(LR60N))
+15 ;strip leading 'x' on interface test name
IF $EXTRACT(LR60N,1)="x"
SET LR60N=$EXTRACT(LR60N,2,$LENGTH(LR60N))
+16 IF $PIECE(^LAB(60,LR60,0),U,3)="N"!($PIECE(^(0),U,3)="")
QUIT
DO OUT
End DoDot:1
+17 QUIT
1 ;create individual test list.
+1 KILL ^TMP("LR LOINC",$JOB)
+2 SET ^TMP("LR LOINC",$JOB,0)=DT_U_DT_U_"LRLNCX TEST LIST"
+3 KILL DIR
+4 SET DIR(0)="PO^60:NQEMZ"
+5 SET DIR("S")="I $L($P(^(0),U,3)),$P(^(0),U,3)'=""N"",$P($P(^(0),U,5),"";"",2)"
+6 FOR
DO ^DIR
IF Y<1
QUIT
SET ^TMP("LR LOINC",$JOB,Y(0,0)_+Y,0)=+Y_U_Y(0,0)
+7 IF $ORDER(^TMP("LR LOINC",0))'=""
DO ASK
IF $GET(LREND)
GOTO END
+8 SET LRNX=0
+9 ;W !,$TR($$SITE^VASITE,U,"|")_"|"_$$FMTE^XLFDT($$NOW^XLFDT,1)
+10 FOR
SET LRNX=$ORDER(^TMP("LR LOINC",$JOB,LRNX))
IF LRNX=""
QUIT
Begin DoDot:1
+11 SET LR60=$GET(^TMP("LR LOINC",$JOB,LRNX,0))
+12 IF '$GET(LR60)
QUIT
+13 IF $LENGTH($PIECE(LR60,U,2))
SET LR60N=$PIECE(LR60,U,2)
SET LR60=+LR60
DO OUT
End DoDot:1
+14 GOTO END
+15 QUIT
OUT ;
+1 IF $GET(LRAA)
SET LRNOP=1
Begin DoDot:1
+2 SET LR8=0
FOR
SET LR8=$ORDER(^LAB(60,LR60,8,LR8))
IF LR8<1!('$GET(LRNOP))
QUIT
Begin DoDot:2
+3 IF $DATA(LRAA(+$PIECE($GET(^LAB(60,LR60,8,LR8,0)),U,2)))#2
SET LRNOP=0
End DoDot:2
End DoDot:1
IF LRNOP
QUIT
+4 ;[LR*5.2*1028,MPW,08/09/10]Added next 1 line.
+5 IF '$DATA(^LAB(60,LR60,1))
SET (LRSP,LRSPN,LRUNIT)=""
DO WRT
QUIT
+6 SET LRSP=0
FOR
SET LRSP=$ORDER(^LAB(60,LR60,1,LRSP))
IF LRSP<1
QUIT
Begin DoDot:1
+7 ;[LR*5.2*1028,MPW,08/06/10]S LRSP0=$G(^(LRSP,0)),LR61=$G(^LAB(61,LRSP,0)),LRUNIT=$P(LRSP0,U,7)
+8 SET LRSP0=$GET(^(LRSP,0))
SET LR61=$GET(^LAB(61,LRSP,0))
SET LRUNIT=$PIECE(LRSP0,U,7)
IF LRUNIT=+LRUNIT
SET LRUNIT=$PIECE(^BLRUCUM(LRUNIT,0),U,1)
+9 ;[LR*5.2*1028;08/23/10;IHS/OIT/MPW]Added next 1 line to skip specimens already mapped
+10 IF $GET(^LAB(60,LR60,1,LRSP,95.3))'=""
QUIT
+11 SET LRSPN=$PIECE(LR61,U)
SET LR64061=$PIECE(LR61,U,9)
SET LRLSPN=$PIECE(LR61,U,8)
+12 KILL LR64N
IF LR64061
SET LR64N=$PIECE($GET(^LAB(64.061,LR64061,0)),U,2)
+13 SET LRSPN=$SELECT($DATA(LR64N):LR64N,$LENGTH(LRLSPN):LRLSPN,1:LRSPN)
+14 DO WRT
End DoDot:1
+15 QUIT
WRT ;LR60N [test name] - translate "*" or "?" to spaces
+1 ;[LR*5.2*1028,MPW,08/09/10]W !,$E(LR60_"-"_LRSP_LRFS_$TR(LR60N,"*?"," ")_" "_LRSPN_LRFS_LRUNIT,1,80)
+2 WRITE !,$EXTRACT(LR60_$SELECT(LRSP'="":"-",1:"")_LRSP_LRFS_$TRANSLATE(LR60N,"*?"," ")_$SELECT(LRSPN'="":" ",1:"")_LRSPN_LRFS_LRUNIT,1,80)
+3 QUIT
ASK ;
+1 KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Ready to Capture"
+2 DO ^DIR
IF $DATA(DIRUT)
SET LREND=1
+3 QUIT
MSG ;
+1 WRITE @IOF
+2 WRITE !,"(NOTE) You should use the Add/Edit Topography Specimen HL7 Code"
+3 WRITE !,"[LR LOINC LEDI HL7 CODE] option before you proceed."
+4 WRITE !," ----- ----- ----- ----"
+5 WRITE !,"This option will create a Local Master Observation File (LMOF)"
+6 WRITE !,"from your local LABORATORY TEST (#60) file."
+7 ;W !!,"Only 'CH' subscripted test having a dataname and having a type"
+8 ;W !,"of 'BOTH', 'INPUT' or 'OUTPUT' will be extracted."
+9 WRITE !,"The LMOF file will use the vertical bar '|' as the field separator."
+10 WRITE !,"The 1st. field is the test internal number and internal number"
+11 WRITE !,"of the spec. (i.e. 1-72 will represent test 1 and specimen 72)."
+12 WRITE !,"The 2nd field contains |test name<SP>specimen."
+13 WRITE !,"The 3rd field is the reporting unit only (if any)."
+14 WRITE !!,"You will need to capture this printout into a text file."
+15 WRITE !,"Using a text editor, remove extraneous lines from the beginning"
+16 WRITE !,"and the end of the file so that only extracted test names remain."
+17 WRITE !,"Save the edited file. Use this file in the import function of the"
+18 WRITE !,"Regenstrief LOINC Mapping Assistant (RELMA)."
+19 WRITE !,"Consult the Regenstrief RELMA documentation for specifics."
+20 KILL DIR
SET DIR(0)="E"
DO ^DIR
IF $DATA(DIRUT)
SET LREND=1
IF $GET(LREND)
QUIT
SEL ;Select method of extraction
+1 KILL DIR,LRAA
+2 SET (LRANS,LREND)=0
+3 SET DIR(0)="SO^1:Individual single test;2:By Accession Area;3:All Test"
+4 SET DIR("A")="Select extraction criteria"
+5 DO ^DIR
IF $DATA(DIRUT)
SET LREND=1
+6 IF Y>0
SET LRANS=Y
+7 IF LRANS=2
Begin DoDot:1
+8 KILL DIR
+9 SET DIR(0)="PO^68:ENZM"
SET DIR("A")="Select accession area "
+10 SET DIR("S")="I $P(^(0),U,17)'=""S"""
+11 FOR
DO ^DIR
IF Y<1
QUIT
Begin DoDot:2
+12 SET LRAA=Y
+13 SET LRAA(+LRAA)=LRAA
SET DIR("A")="Select another accession area "
End DoDot:2
End DoDot:1
+14 QUIT
END ;
+1 KILL DIR,DIRUT,LR60,LR60N,LR61,LR64061,LR64N,LR8,LRAA,LRANS,LREND,LRFS,LRLSPN,LRNOP,LRNX,LRSITE,LRSP,LRSP0,LRSPN,LRUNIT,Y
+2 QUIT
