- LRLNCV ;DALOI/CA-VALIDATE LOINC MAPPING ;18-JUL-2001
- ;;5.2T9;LR;**1018**;Nov 17, 2004
- ;;5.2;LAB SERVICE;**232,278**;Sep 27,1994
- ;
- ;=================================================================
- ; 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
- S LRLOINC=$$LNC^LRVER1(LRNLTN,LRCDEF,LRSPEC)
- 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
- LRLNCV ;DALOI/CA-VALIDATE LOINC MAPPING ;18-JUL-2001
- +1 ;;5.2T9;LR;**1018**;Nov 17, 2004
- +2 ;;5.2;LAB SERVICE;**232,278**;Sep 27,1994
- +3 ;
- +4 ;=================================================================
- +5 ; 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 SET LRLOINC=$$LNC^LRVER1(LRNLTN,LRCDEF,LRSPEC)
- +2 IF LRLOINC
- SET LRLOINC=LRLOINC_"-"_$PIECE($GET(^LAB(95.3,LRLOINC,0)),U,15)
- +3 IF 'LRLOINC
- WRITE !!,"TEST NOT MAPPED",!!
- DO EXIT
- GOTO START
- +4 SET LRDA=$PIECE(LRMSGM,"-",2)
- SET LRDA=+$ORDER(^LAM("C",LRDA,0))
- +5 SET LRDAN="Unknown code number"
- +6 IF $GET(LRDA)
- IF $DATA(^LAM(LRDA,0))
- SET LRDAN=$PIECE($GET(^LAM(LRDA,0)),U)
- +7 WRITE !!,"LOINC Code: ",LRLOINC,!,$GET(^LAB(95.3,+LRLOINC,80)),!
- +8 WRITE !,$$CJ^XLFSTR("LOINC code was located @ NLT CODE: "_LRDAN,IOM)
- +9 WRITE !,$$CJ^XLFSTR($PIECE(LRMSGM,"-",2,99),IOM)
- +10 DO EXIT
- GOTO START
- +11 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
