LRLNCV ;DALOI/CA-VALIDATE LOINC MAPPING ;18-JUL-2001
;;5.2;LAB SERVICE;**232,278,468,484**;Sep 27,1994;Build 2
;
; 5.2;LAB SERVICE; CHANGE FOR PATCH LR*5.2*468; Feb 10 2016
;
;=================================================================
; Ask VistA test in Lab Test file #60
START ;entry point from option LR LOINC VALIDATE
S LREND=0 D TEST
I $G(LREND) G EXIT
;
W !!,"NAME OF NLT CODE: ",$P(^LAM(LRNLT,0),U)
W !,"NLT CODE: ",$P(^LAM(LRNLT,0),U,2) S LRNLTN=$P($G(^LAM(LRNLT,0)),U,2)
S LRDEF=+$G(^LAM(LRNLT,9))
I LRDEF W !,"DEFAULT LOINC CODE: ",$S(LRDEF:LRDEF_" "_$P(^LAB(95.3,LRDEF,80),U),1:"NONE")
ASKSPEC ; Ask Specimen- Lookup in Specimen multiple in Lab Test file #60
W !!
LOOK61 K DIR,DA
S DIR(0)="PO^61:EZMN",DIR("S")="I $P(^(0),U,9)"
S DIR("A")="Select a Specimen source that has a LEDI HL7 code"
S DIC("A")="Specimen source: "
D ^DIR
I $D(DUOUT)!($D(DTOUT))!(Y<1) G START
S LRSPEC=+Y
SUFFIX ;Set LRCDEF Value
S LREND=0,DIC="^LRO(68.2,",DIC(0)="AQEM",DIC("A")="Work Load Area: ",DIC("S")="I $D(^(""SUF"")),+^(""SUF"")" D ^DIC S:Y<1 LREND=1 K DIC
I $G(LREND) G START
S LRCDEF=$P(^LRO(68.2,+Y,"SUF"),U,3)
LOINC S LRMSG=1
;START OF CHANGE FOR LR*5.2*468
;S LRLOINC=$$LNC^LRVER1(LRNLTN,LRCDEF,LRSPEC)
; START OF CHANGE FOR LR*5.2*484
; S LRLOINC=$$LNC^LRVER1(LRNLTN,LRCDEF,LRSPEC,$G(LRIEN))
S LRLOINC=$$LNCM^LRVER1(LRNLTN,LRCDEF,LRSPEC,$G(LRIEN))
;END OF CHANGE FOR LR*5.2*484
;END OF CHANGE FOR LR*5.2*468
I LRLOINC S LRLOINC=LRLOINC_"-"_$P($G(^LAB(95.3,LRLOINC,0)),U,15)
I 'LRLOINC W !!,"TEST NOT MAPPED",!! D EXIT G START
S LRDA=$P(LRMSGM,"-",2),LRDA=+$O(^LAM("C",LRDA,0))
S LRDAN="Unknown code number"
I $G(LRDA),$D(^LAM(LRDA,0)) S LRDAN=$P($G(^LAM(LRDA,0)),U)
W !!,"LOINC Code: ",LRLOINC,!,$G(^LAB(95.3,+LRLOINC,80)),!
W !,$$CJ^XLFSTR("LOINC code was located @ NLT CODE: "_LRDAN,IOM)
W !,$$CJ^XLFSTR($P(LRMSGM,"-",2,99),IOM)
D EXIT G START
Q
EXIT K DA,DIC,DIE,DINUM,DIR,DIRUT,DR,DTOUT,DUOUT,LREND,LRLOINC,LRIEN,LRMSG,LRNLT,LRSPEC,LRSPECN,LRSUF,LRTEST,S,Y
K DD,DO,DLAYGO,LRDEF,X
QUIT
TEST W !!
K DIR
S DIR(0)="PO^60:QENMZ,",DIR("A")="VistA Lab Test"
S DIR("?")="Select Lab test"
D ^DIR K DIR
I $D(DIRUT)!'Y K DIRUT S LREND=1 Q
S LRIEN=+Y,LRTEST=$P(Y,U,2)
;Check for RESULT NLT CODE and if not one let enter
I '$P($G(^LAB(60,+$G(LRIEN),64)),U,2) D
.W $$CJ^XLFSTR("There is not a RESULT NLT CODE for "_LRTEST,IOM)
.W $$CJ^XLFSTR("You MAY select one now to continue with the LOINC lookup",IOM),!
K DIE,DR,DA S DA=LRIEN,DIE="^LAB(60,",DR=64.1
D ^DIE
I $D(DUOUT)!($D(DTOUT)) G START
I '$P($G(^LAB(60,+$G(LRIEN),64)),U,2) D
.S DIC=DIE,DR=0 W !! W ?5,"IEN: [",DA,"] ",$P(^LAB(60,LRIEN,0),U) S S=$Y D EN^LRDIQ W !
W !
S LRNLT=$P($G(^LAB(60,+$G(LRIEN),64)),U,2)
I 'LRNLT G TEST
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRLNCV 2814 printed Apr 09, 2024@21:25:48 Page 2
LRLNCV ;DALOI/CA-VALIDATE LOINC MAPPING ;18-JUL-2001
+1 ;;5.2;LAB SERVICE;**232,278,468,484**;Sep 27,1994;Build 2
+2 ;
+3 ; 5.2;LAB SERVICE; CHANGE FOR PATCH LR*5.2*468; Feb 10 2016
+4 ;
+5 ;=================================================================
+6 ; Ask VistA test in Lab Test file #60
START ;entry point from option LR LOINC VALIDATE
+1 SET LREND=0
DO TEST
+2 IF $GET(LREND)
GOTO EXIT
+3 ;
+4 WRITE !!,"NAME OF NLT CODE: ",$PIECE(^LAM(LRNLT,0),U)
+5 WRITE !,"NLT CODE: ",$PIECE(^LAM(LRNLT,0),U,2)
SET LRNLTN=$PIECE($GET(^LAM(LRNLT,0)),U,2)
+6 SET LRDEF=+$GET(^LAM(LRNLT,9))
+7 IF LRDEF
WRITE !,"DEFAULT LOINC CODE: ",$SELECT(LRDEF:LRDEF_" "_$PIECE(^LAB(95.3,LRDEF,80),U),1:"NONE")
ASKSPEC ; Ask Specimen- Lookup in Specimen multiple in Lab Test file #60
+1 WRITE !!
LOOK61 KILL DIR,DA
+1 SET DIR(0)="PO^61:EZMN"
SET DIR("S")="I $P(^(0),U,9)"
+2 SET DIR("A")="Select a Specimen source that has a LEDI HL7 code"
+3 SET DIC("A")="Specimen source: "
+4 DO ^DIR
+5 IF $DATA(DUOUT)!($DATA(DTOUT))!(Y<1)
GOTO START
+6 SET LRSPEC=+Y
SUFFIX ;Set LRCDEF Value
+1 SET LREND=0
SET DIC="^LRO(68.2,"
SET DIC(0)="AQEM"
SET DIC("A")="Work Load Area: "
SET DIC("S")="I $D(^(""SUF"")),+^(""SUF"")"
DO ^DIC
if Y<1
SET LREND=1
KILL DIC
+2 IF $GET(LREND)
GOTO START
+3 SET LRCDEF=$PIECE(^LRO(68.2,+Y,"SUF"),U,3)
LOINC SET LRMSG=1
+1 ;START OF CHANGE FOR LR*5.2*468
+2 ;S LRLOINC=$$LNC^LRVER1(LRNLTN,LRCDEF,LRSPEC)
+3 ; START OF CHANGE FOR LR*5.2*484
+4 ; S LRLOINC=$$LNC^LRVER1(LRNLTN,LRCDEF,LRSPEC,$G(LRIEN))
+5 SET LRLOINC=$$LNCM^LRVER1(LRNLTN,LRCDEF,LRSPEC,$GET(LRIEN))
+6 ;END OF CHANGE FOR LR*5.2*484
+7 ;END OF CHANGE FOR LR*5.2*468
+8 IF LRLOINC
SET LRLOINC=LRLOINC_"-"_$PIECE($GET(^LAB(95.3,LRLOINC,0)),U,15)
+9 IF 'LRLOINC
WRITE !!,"TEST NOT MAPPED",!!
DO EXIT
GOTO START
+10 SET LRDA=$PIECE(LRMSGM,"-",2)
SET LRDA=+$ORDER(^LAM("C",LRDA,0))
+11 SET LRDAN="Unknown code number"
+12 IF $GET(LRDA)
IF $DATA(^LAM(LRDA,0))
SET LRDAN=$PIECE($GET(^LAM(LRDA,0)),U)
+13 WRITE !!,"LOINC Code: ",LRLOINC,!,$GET(^LAB(95.3,+LRLOINC,80)),!
+14 WRITE !,$$CJ^XLFSTR("LOINC code was located @ NLT CODE: "_LRDAN,IOM)
+15 WRITE !,$$CJ^XLFSTR($PIECE(LRMSGM,"-",2,99),IOM)
+16 DO EXIT
GOTO START
+17 QUIT
EXIT KILL DA,DIC,DIE,DINUM,DIR,DIRUT,DR,DTOUT,DUOUT,LREND,LRLOINC,LRIEN,LRMSG,LRNLT,LRSPEC,LRSPECN,LRSUF,LRTEST,S,Y
+1 KILL DD,DO,DLAYGO,LRDEF,X
+2 QUIT
TEST WRITE !!
+1 KILL DIR
+2 SET DIR(0)="PO^60:QENMZ,"
SET DIR("A")="VistA Lab Test"
+3 SET DIR("?")="Select Lab test"
+4 DO ^DIR
KILL DIR
+5 IF $DATA(DIRUT)!'Y
KILL DIRUT
SET LREND=1
QUIT
+6 SET LRIEN=+Y
SET LRTEST=$PIECE(Y,U,2)
+7 ;Check for RESULT NLT CODE and if not one let enter
+8 IF '$PIECE($GET(^LAB(60,+$GET(LRIEN),64)),U,2)
Begin DoDot:1
+9 WRITE $$CJ^XLFSTR("There is not a RESULT NLT CODE for "_LRTEST,IOM)
+10 WRITE $$CJ^XLFSTR("You MAY select one now to continue with the LOINC lookup",IOM),!
End DoDot:1
+11 KILL DIE,DR,DA
SET DA=LRIEN
SET DIE="^LAB(60,"
SET DR=64.1
+12 DO ^DIE
+13 IF $DATA(DUOUT)!($DATA(DTOUT))
GOTO START
+14 IF '$PIECE($GET(^LAB(60,+$GET(LRIEN),64)),U,2)
Begin DoDot:1
+15 SET DIC=DIE
SET DR=0
WRITE !!
WRITE ?5,"IEN: [",DA,"] ",$PIECE(^LAB(60,LRIEN,0),U)
SET S=$Y
DO EN^LRDIQ
WRITE !
End DoDot:1
+16 WRITE !
+17 SET LRNLT=$PIECE($GET(^LAB(60,+$GET(LRIEN),64)),U,2)
+18 IF 'LRNLT
GOTO TEST
+19 QUIT
