- LRLNC63A ;DALOI/FHS-HISTORICAL LOINC MAPPER UTILITY ;01/30/2001 15:19
- ;;5.2;LAB SERVICE;**279**;Sep 27, 1994
- XQA ;Send alert message
- S XQA("G.LMI")=""
- D SETUP^XQALERT
- Q
- RANGE ; Change for high/low ranges $S( statement to a numeric value
- K LRP,VAL,VALX
- I 'LR5 S AGE=+$$DATE^LRDAGE(DOB,LRCDT) I AGE<1 S AGE=99
- F LRP=2:1:5 D
- . S VAL=$P(LRDATA5,"!",LRP)
- . Q:'$L(VAL)
- . Q:VAL'["$S("
- . S VALX="S VALX="_VAL
- . X VALX
- . S $P(LRDATA5,"!",LRP)=VALX,LR5=1
- Q
- XTMP(LRSUB) ;Setup XTMP("LRLNC",1,LRSUB)=Result NLT code
- Q:$D(^XTMP("LRLNC63",1,LRSUB))
- N LRCHK,LRTST
- S (LRCHK,LRTST)=0
- F S LRTST=$O(^LAB(60,"C","CH;"_LRSUB_";1",LRTST)) Q:LRTST<1!($G(LRCHK)) D
- . Q:'$P($G(^LAB(60,LRTST,64)),U,2)
- . S ^XTMP("LRLNC63",1,LRSUB)=$$NLT(LRTST),LRCHK=^(LRSUB)
- I '$G(LRCHK) S ^XTMP("LRLNC63",1,LRSUB)="-1"
- Q
- NLT(X) ;
- N Y
- S Y=$S($D(^LAM(+$P($G(^LAB(60,+X,64)),U,2),0)):$P(^(0),U,2),1:"")
- Q Y
- LIST ;List those test not have result NLT codes defined
- K ^TMP("LRLNC63",$J)
- N LRANS,LRSB,LRCNT,LRX
- S ^TMP("LRLNC63",$J,"LST",1,0)="List of tests missing RNLT codes in LABORTORY TEST (#60) file,"
- S ^TMP("LRLNC63",$J,"LST",2,0)="found during LOINC Historical Mapping process."
- S ^TMP("LRLNC63",$J,"LST",3,0)="These test(s) will have no historical LOINC mapping performed."
- S ^TMP("LRLNC63",$J,"LST",4,0)=" "
- S ^TMP("LRLNC63",$J,"LST",5,0)="[Test IEN] Test Name Type "
- S ^TMP("LRLNC63",$J,"LST",6,0)=""
- S LRCNT=6,LRSB=0 F S LRSB=$O(^XTMP("LRLNC63",1,LRSB)) Q:LRSB<1 S LRX=^(LRSB) D
- . Q:LRX>0
- . S LRCH="CH;"_LRSB_";1",LRTST=0
- . F S LRTST=$O(^LAB(60,"C",LRCH,LRTST)) Q:LRTST<1 D
- . . Q:'$D(^LAB(60,LRTST,0))#2
- . . N LRANS,LRV,LRANS
- . . S LRV=LRTST_","
- . . D GETS^DIQ(60,LRV,".01;3","E","LRANS")
- . . S LRCNT=LRCNT+1
- . . S ^TMP("LRLNC63",$J,"LST",LRCNT,0)="["_LRTST_"] "_$G(LRANS(60,LRV,.01,"E"))_" -- Type: "_$G(LRANS(60,LRV,3,"E"))
- MAIL ;Send mail message containing tests not having RNLT codes.
- ;Therefore not historical LOINC mapping could be done.
- D
- . I '$O(^TMP("LRLNC63",$J,"LST",6)) D
- . . S ^TMP("LRLNC63",$J,"LST",7,0)="Negative Report - All test have RNLT codes definded"
- . N XMDUZ,XMTEXT,XMY,XMSUB
- . S XMSUB="LOINC Historical Mapping Exception Report"
- . S XMTEXT="^TMP(""LRLNC63"","_$J_",""LST"","
- . S XMDUZ=.5
- . S XMY("G.LMI")=""
- . D ^XMD
- MAP ;Provide a list of mapped test in ^ delimited format
- N NODE,LRSB,LRNLT,LRSPECN,LRCDEF,LRLNC,LRTST
- S LRMCNT=0
- S ^TMP("LRLNC63",$J,"MAP",1,0)="List of test mapped to LOINC codes formatted with '^' as field delimiter."
- S ^TMP("LRLNC63",$J,"MAP",2,0)=" "
- S ^TMP("LRLNC63",$J,"MAP",3,0)="DataName#^Test Name^Specimen^Specimen IEN^RNLT^NLT suffix^LOINC Code"
- S LRMCNT=3
- S NODE="^XTMP(""LRLNC63"","_$J_",""MAP"")"
- F S NODE=$Q(@NODE) Q:$QS(NODE,2)'="MAP" D
- . S LRSB=$QS(NODE,3),LRSPEC=$QS(NODE,4)
- . S LRNLT=$QS(NODE,5)
- . S LRSPECN=$S($D(^LAB(61,+LRSPEC,0)):$P(^(0),U),1:"Missing")
- . S LRCDEF=$QS(NODE,6)
- . S LRLNC=$QS(NODE,7),LRLNC=$$GET1^DIQ(95.3,LRLNC_",",.01,"E")
- . S LRTST=+$O(^LAB(60,"C","CH;"_LRSB_";1",0))
- . S LRTST=$S($D(^LAB(60,LRTST,0))#2:$P(^(0),U),1:"Unknown")
- . S LRMCNT=+$G(LRMCNT)+1
- . S ^TMP("LRLNC63",$J,"MAP",LRMCNT,0)=LRSB_U_LRTST_U_LRSPECN_U_LRSPEC_U_LRNLT_U_LRCDEF_U_LRLNC
- MAPMAIL ;Send mail message containing mapped test
- D
- . N XMDUZ,XMTEXT,XMY,XMSUB
- . S XMSUB="LOINC Historical Mapped LOINC tests"
- . S XMTEXT="^TMP(""LRLNC63"","_$J_",""MAP"","
- . S XMDUZ=.5
- . S XMY("G.LMI")=""
- . D ^XMD
- CLEAN ;
- K ^TMP("LRLNC63",$J)
- Q
- DECIMAL ;Check for possible LRDFN's >999999 - LRDFN maybe set to LRIDT format
- S (LRNXT,LRSEQ)=999999
- Q:'$O(^LR(LRSEQ))
- S ^XTMP("LRLNC63","SEQ",LRSEQ,"START")=$$NOW^XLFDT
- F S LRNXT=$O(^LR(LRNXT)) Q:$S(LRNXT<1:1,$G(^XTMP("LRLNC63","STOP")):1,1:0) D I $$S^%ZTLOAD(LRSEQ_" Stopped at "_LRNXT) S ZTSTOP=1 Q
- . I '$G(^LR(LRNXT,0)) S ^XTMP("LRLNC63","SEQ",LRSEQ)=LRNXT Q
- . D LK6304^LRLNC63(LRNXT)
- . S ^XTMP("LRLNC63","SEQ",LRSEQ)=LRNXT
- I $G(^XTMP("LRLNC63","STOP")) D Q
- . N LRNOW
- . S LRNOW=$$FMTE^XLFDT($$NOW^XLFDT,1)
- . S ^XTMP("LRLNC63","SEQ",LRSEQ,"END")="USER STOP"_U_$$NOW^XLFDT
- . S XQAMSG="LOINC Historical Mapper Sequence "_LRSEQ_" STOPPED @ "_LRNOW
- . D XQA
- . L -^XTMP("LRLNC63","TASK",LRSEQ)
- S XQAMSG="LOINC Historical Mapper LRDFN sequence "_LRSEQ_" completed @ "_$$FMTE^XLFDT($$NOW^XLFDT,1)
- DONE ; Send alert message when LRDFN sequence range mapping is finished
- L -^XTMP("LRLNC63","TASK",LRSEQ)
- S ^XTMP("LRLNC63","SEQ",LRSEQ,"END")=$$NOW^XLFDT
- D XQA
- UPDATE ;If mapping complete, send list of tests not having result NLT codes
- ;Update fields 95.3,95.31 in LAB(69.9 file with date and last LRDFN
- K LRSEQX,LRNOP,LRFDA,LRERR
- S LRNOP=0
- F LRSEQX=1:20000:LRLST D Q:$G(LRNOP)
- . I '$G(^XTMP("LRLNC63","SEQ",LRSEQX,"END")) S LRNOP=1
- Q:$G(LRNOP)
- D LIST^LRLNC63A
- S LRFDA(95,69.9,"1,",95.3)=DT
- S LRFDA(95,69.9,"1,",95.31)=+$P($G(LRLST),".")
- D FILE^DIE("KS","LRFDA(95)","LRERR")
- Q
- RERUN ; This will restart the historical mapping from the beginning.
- ; To restart call QUE^LRLNC63
- N DIR,DIRUT,Y
- W !,$$CJ^XLFSTR(" This will re-run LOINC Historical Mapping from the beginning ",80)
- W !,$$CJ^XLFSTR("reseting all globals to zero.",80)
- W !,$$CJ^XLFSTR(" To restart from a stopping point use the",80)
- W !,$$CJ^XLFSTR("LAB DATA LOINC Mapping Option.",80),!!
- S DIR(0)="Y",DIR("A")="Are you certain you want to proceed" D ^DIR
- I $G(Y)'=1 Q
- K ^XTMP("LRLNC63")
- D QUE^LRLNC63
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRLNC63A 5465 printed Feb 18, 2025@23:42:24 Page 2
- LRLNC63A ;DALOI/FHS-HISTORICAL LOINC MAPPER UTILITY ;01/30/2001 15:19
- +1 ;;5.2;LAB SERVICE;**279**;Sep 27, 1994
- XQA ;Send alert message
- +1 SET XQA("G.LMI")=""
- +2 DO SETUP^XQALERT
- +3 QUIT
- RANGE ; Change for high/low ranges $S( statement to a numeric value
- +1 KILL LRP,VAL,VALX
- +2 IF 'LR5
- SET AGE=+$$DATE^LRDAGE(DOB,LRCDT)
- IF AGE<1
- SET AGE=99
- +3 FOR LRP=2:1:5
- Begin DoDot:1
- +4 SET VAL=$PIECE(LRDATA5,"!",LRP)
- +5 if '$LENGTH(VAL)
- QUIT
- +6 if VAL'["$S("
- QUIT
- +7 SET VALX="S VALX="_VAL
- +8 XECUTE VALX
- +9 SET $PIECE(LRDATA5,"!",LRP)=VALX
- SET LR5=1
- End DoDot:1
- +10 QUIT
- XTMP(LRSUB) ;Setup XTMP("LRLNC",1,LRSUB)=Result NLT code
- +1 if $DATA(^XTMP("LRLNC63",1,LRSUB))
- QUIT
- +2 NEW LRCHK,LRTST
- +3 SET (LRCHK,LRTST)=0
- +4 FOR
- SET LRTST=$ORDER(^LAB(60,"C","CH;"_LRSUB_";1",LRTST))
- if LRTST<1!($GET(LRCHK))
- QUIT
- Begin DoDot:1
- +5 if '$PIECE($GET(^LAB(60,LRTST,64)),U,2)
- QUIT
- +6 SET ^XTMP("LRLNC63",1,LRSUB)=$$NLT(LRTST)
- SET LRCHK=^(LRSUB)
- End DoDot:1
- +7 IF '$GET(LRCHK)
- SET ^XTMP("LRLNC63",1,LRSUB)="-1"
- +8 QUIT
- NLT(X) ;
- +1 NEW Y
- +2 SET Y=$SELECT($DATA(^LAM(+$PIECE($GET(^LAB(60,+X,64)),U,2),0)):$PIECE(^(0),U,2),1:"")
- +3 QUIT Y
- LIST ;List those test not have result NLT codes defined
- +1 KILL ^TMP("LRLNC63",$JOB)
- +2 NEW LRANS,LRSB,LRCNT,LRX
- +3 SET ^TMP("LRLNC63",$JOB,"LST",1,0)="List of tests missing RNLT codes in LABORTORY TEST (#60) file,"
- +4 SET ^TMP("LRLNC63",$JOB,"LST",2,0)="found during LOINC Historical Mapping process."
- +5 SET ^TMP("LRLNC63",$JOB,"LST",3,0)="These test(s) will have no historical LOINC mapping performed."
- +6 SET ^TMP("LRLNC63",$JOB,"LST",4,0)=" "
- +7 SET ^TMP("LRLNC63",$JOB,"LST",5,0)="[Test IEN] Test Name Type "
- +8 SET ^TMP("LRLNC63",$JOB,"LST",6,0)=""
- +9 SET LRCNT=6
- SET LRSB=0
- FOR
- SET LRSB=$ORDER(^XTMP("LRLNC63",1,LRSB))
- if LRSB<1
- QUIT
- SET LRX=^(LRSB)
- Begin DoDot:1
- +10 if LRX>0
- QUIT
- +11 SET LRCH="CH;"_LRSB_";1"
- SET LRTST=0
- +12 FOR
- SET LRTST=$ORDER(^LAB(60,"C",LRCH,LRTST))
- if LRTST<1
- QUIT
- Begin DoDot:2
- +13 if '$DATA(^LAB(60,LRTST,0))#2
- QUIT
- +14 NEW LRANS,LRV,LRANS
- +15 SET LRV=LRTST_","
- +16 DO GETS^DIQ(60,LRV,".01;3","E","LRANS")
- +17 SET LRCNT=LRCNT+1
- +18 SET ^TMP("LRLNC63",$JOB,"LST",LRCNT,0)="["_LRTST_"] "_$GET(LRANS(60,LRV,.01,"E"))_" -- Type: "_$GET(LRANS(60,LRV,3,"E"))
- End DoDot:2
- End DoDot:1
- MAIL ;Send mail message containing tests not having RNLT codes.
- +1 ;Therefore not historical LOINC mapping could be done.
- +2 Begin DoDot:1
- +3 IF '$ORDER(^TMP("LRLNC63",$JOB,"LST",6))
- Begin DoDot:2
- +4 SET ^TMP("LRLNC63",$JOB,"LST",7,0)="Negative Report - All test have RNLT codes definded"
- End DoDot:2
- +5 NEW XMDUZ,XMTEXT,XMY,XMSUB
- +6 SET XMSUB="LOINC Historical Mapping Exception Report"
- +7 SET XMTEXT="^TMP(""LRLNC63"","_$JOB_",""LST"","
- +8 SET XMDUZ=.5
- +9 SET XMY("G.LMI")=""
- +10 DO ^XMD
- End DoDot:1
- MAP ;Provide a list of mapped test in ^ delimited format
- +1 NEW NODE,LRSB,LRNLT,LRSPECN,LRCDEF,LRLNC,LRTST
- +2 SET LRMCNT=0
- +3 SET ^TMP("LRLNC63",$JOB,"MAP",1,0)="List of test mapped to LOINC codes formatted with '^' as field delimiter."
- +4 SET ^TMP("LRLNC63",$JOB,"MAP",2,0)=" "
- +5 SET ^TMP("LRLNC63",$JOB,"MAP",3,0)="DataName#^Test Name^Specimen^Specimen IEN^RNLT^NLT suffix^LOINC Code"
- +6 SET LRMCNT=3
- +7 SET NODE="^XTMP(""LRLNC63"","_$JOB_",""MAP"")"
- +8 FOR
- SET NODE=$QUERY(@NODE)
- if $QSUBSCRIPT(NODE,2)'="MAP"
- QUIT
- Begin DoDot:1
- +9 SET LRSB=$QSUBSCRIPT(NODE,3)
- SET LRSPEC=$QSUBSCRIPT(NODE,4)
- +10 SET LRNLT=$QSUBSCRIPT(NODE,5)
- +11 SET LRSPECN=$SELECT($DATA(^LAB(61,+LRSPEC,0)):$PIECE(^(0),U),1:"Missing")
- +12 SET LRCDEF=$QSUBSCRIPT(NODE,6)
- +13 SET LRLNC=$QSUBSCRIPT(NODE,7)
- SET LRLNC=$$GET1^DIQ(95.3,LRLNC_",",.01,"E")
- +14 SET LRTST=+$ORDER(^LAB(60,"C","CH;"_LRSB_";1",0))
- +15 SET LRTST=$SELECT($DATA(^LAB(60,LRTST,0))#2:$PIECE(^(0),U),1:"Unknown")
- +16 SET LRMCNT=+$GET(LRMCNT)+1
- +17 SET ^TMP("LRLNC63",$JOB,"MAP",LRMCNT,0)=LRSB_U_LRTST_U_LRSPECN_U_LRSPEC_U_LRNLT_U_LRCDEF_U_LRLNC
- End DoDot:1
- MAPMAIL ;Send mail message containing mapped test
- +1 Begin DoDot:1
- +2 NEW XMDUZ,XMTEXT,XMY,XMSUB
- +3 SET XMSUB="LOINC Historical Mapped LOINC tests"
- +4 SET XMTEXT="^TMP(""LRLNC63"","_$JOB_",""MAP"","
- +5 SET XMDUZ=.5
- +6 SET XMY("G.LMI")=""
- +7 DO ^XMD
- End DoDot:1
- CLEAN ;
- +1 KILL ^TMP("LRLNC63",$JOB)
- +2 QUIT
- DECIMAL ;Check for possible LRDFN's >999999 - LRDFN maybe set to LRIDT format
- +1 SET (LRNXT,LRSEQ)=999999
- +2 if '$ORDER(^LR(LRSEQ))
- QUIT
- +3 SET ^XTMP("LRLNC63","SEQ",LRSEQ,"START")=$$NOW^XLFDT
- +4 FOR
- SET LRNXT=$ORDER(^LR(LRNXT))
- if $SELECT(LRNXT<1
- QUIT
- Begin DoDot:1
- +5 IF '$GET(^LR(LRNXT,0))
- SET ^XTMP("LRLNC63","SEQ",LRSEQ)=LRNXT
- QUIT
- +6 DO LK6304^LRLNC63(LRNXT)
- +7 SET ^XTMP("LRLNC63","SEQ",LRSEQ)=LRNXT
- End DoDot:1
- IF $$S^%ZTLOAD(LRSEQ_" Stopped at "_LRNXT)
- SET ZTSTOP=1
- QUIT
- +8 IF $GET(^XTMP("LRLNC63","STOP"))
- Begin DoDot:1
- +9 NEW LRNOW
- +10 SET LRNOW=$$FMTE^XLFDT($$NOW^XLFDT,1)
- +11 SET ^XTMP("LRLNC63","SEQ",LRSEQ,"END")="USER STOP"_U_$$NOW^XLFDT
- +12 SET XQAMSG="LOINC Historical Mapper Sequence "_LRSEQ_" STOPPED @ "_LRNOW
- +13 DO XQA
- +14 LOCK -^XTMP("LRLNC63","TASK",LRSEQ)
- End DoDot:1
- QUIT
- +15 SET XQAMSG="LOINC Historical Mapper LRDFN sequence "_LRSEQ_" completed @ "_$$FMTE^XLFDT($$NOW^XLFDT,1)
- DONE ; Send alert message when LRDFN sequence range mapping is finished
- +1 LOCK -^XTMP("LRLNC63","TASK",LRSEQ)
- +2 SET ^XTMP("LRLNC63","SEQ",LRSEQ,"END")=$$NOW^XLFDT
- +3 DO XQA
- UPDATE ;If mapping complete, send list of tests not having result NLT codes
- +1 ;Update fields 95.3,95.31 in LAB(69.9 file with date and last LRDFN
- +2 KILL LRSEQX,LRNOP,LRFDA,LRERR
- +3 SET LRNOP=0
- +4 FOR LRSEQX=1:20000:LRLST
- Begin DoDot:1
- +5 IF '$GET(^XTMP("LRLNC63","SEQ",LRSEQX,"END"))
- SET LRNOP=1
- End DoDot:1
- if $GET(LRNOP)
- QUIT
- +6 if $GET(LRNOP)
- QUIT
- +7 DO LIST^LRLNC63A
- +8 SET LRFDA(95,69.9,"1,",95.3)=DT
- +9 SET LRFDA(95,69.9,"1,",95.31)=+$PIECE($GET(LRLST),".")
- +10 DO FILE^DIE("KS","LRFDA(95)","LRERR")
- +11 QUIT
- RERUN ; This will restart the historical mapping from the beginning.
- +1 ; To restart call QUE^LRLNC63
- +2 NEW DIR,DIRUT,Y
- +3 WRITE !,$$CJ^XLFSTR(" This will re-run LOINC Historical Mapping from the beginning ",80)
- +4 WRITE !,$$CJ^XLFSTR("reseting all globals to zero.",80)
- +5 WRITE !,$$CJ^XLFSTR(" To restart from a stopping point use the",80)
- +6 WRITE !,$$CJ^XLFSTR("LAB DATA LOINC Mapping Option.",80),!!
- +7 SET DIR(0)="Y"
- SET DIR("A")="Are you certain you want to proceed"
- DO ^DIR
- +8 IF $GET(Y)'=1
- QUIT
- +9 KILL ^XTMP("LRLNC63")
- +10 DO QUE^LRLNC63
- +11 QUIT