LRLNC63B ;DALOI/FHS-HISTORICAL LOINC MAPPING MODIFIER ;01/30/2001 15:19
;;5.2;LAB SERVICE;**279**;Sep 27, 1994
EN ;
K DIR W @IOF
W !!,$$CJ^XLFSTR("This option will allow you to manage how specific DataNames",80)
W !,$$CJ^XLFSTR("will be mapped to LOINC Codes for historical data.",80)
W !!,$$LJ^XLFSTR("You are able to override file definitions to correct past LOINC mappings.",80)
W !,$$LJ^XLFSTR("Select the CH subsripted test, indicate the suffix to be used.",80)
W !,$$LJ^XLFSTR("You can indicate if this suffix should override previous LOINC Mapping.",80),!
W !,$$LJ^XLFSTR("This option will REMAP your entire database.",80),!!
W !,$$LJ^XLFSTR("This option should only be run on weekends after hours.",80),!
S DIR(0)="Y",DIR("A")=" Do you wish to continue "
D ^DIR Q:$G(Y)'=1
K ^XTMP("LRLNC63",2),^XTMP("LRLNC63","LST"),^TMP("LR",$J),^TMP("LRLNC63",$J),LRCNT,LROX
SELECT ;Indicate which DATANAMES LOINC definition to be changed.
K LRMOD,LRY,NODE
S LRY=1
F W !! Q:$G(LRY)<1 D
. K DIR,X
. W !,$$CJ^XLFSTR("Selection can be a 'CH' Atomic or Panel test.",80),!
. S DIR("?")="Selection can be an Atomic or Panel test."
. S DIR("?",1)="Only those tests with a Result code will be stored."
. S DIR(0)="PO^60:EMZ",DIR("S")="I $P(^(0),U,4)=""CH"""
. S DIR("A")="Select test you want to modify mapping"
. D ^DIR
. S LRY=Y Q:Y<1
. S LRYY=$P($P(Y(0),U,5),";",2)_U_LRY
. D EXPAND
;
DISPLAY ;Show what has been recorded
K DIRUT,LRY
I '$O(^TMP("LRLNC63",$J,0)) W !?5,"Nothing was selected, Process Aborted",! Q
W @IOF
W !,$$CJ^XLFSTR("Here is a list of what you have selected.",80)
W !,$$CJ^XLFSTR("[O] indicates override current mapping.",80),!
D
. D ^%ZIS Q:POP
. U IO
. N DIR
. S DIR="E"
. S NODE="^TMP(""LRLNC63"","_$J_",0)" F S NODE=$Q(@NODE) Q:$S(NODE="":1,$QS(NODE,2)'=$J:1,1:0) D Q:$D(DIRUT)
. . I $Y>(IOSL-3) D
. . . I $E(IOST,1.2)="C-" D ^DIR Q:$D(DIRUT)
. . . W @IOF
. . . W !,"Here is a list of what you have selected."
. . . W !,"[O] indicates override current mapping.",!
. . D SHO
. W:$E(IOST,1)="P" @IOF
. D ^%ZISC
CHK ;
; K ^TMP("LR",$J)
W !
I $D(DIRUT) S DIR(0)="Y",DIR("A")=" Do you want to STOP" D ^DIR G:$G(Y)=1 END
K DIR S DIR(0)="YO",DIR("A")="You wish to add more" D ^DIR I $G(Y)=1 G SELECT
I $G(Y)=U G END
;
W !
S DIR("A")=" Do you want to delete an entry" D ^DIR G END:$G(Y)=U
I $G(Y)=1 D EDIT G DISPLAY
I $O(^TMP("LRLNC63",$J,0)) D
. S LRMOD=1,ZTSAVE("LRMOD")=""
. S NODE="^TMP(""LRLNC63"",0)"
. F S NODE=$Q(@NODE) Q:$S($QS(NODE,2)'=$J:1,1:0) D
. . S ^XTMP("LRLNC63",2,$QS(NODE,5))=@NODE
FIRE ;Run the mapping tasking function
D QUE^LRLNC63
Q
END ;
K DIRUT
K ^XTMP("LRLNC63",2)
Q
SHO ;
N LRX,LRXY
S LRX=@NODE
W !,$QS(NODE,3)_" "_$S($P(LRX,U,6):"[O]",1:" "),?7,$E($P(LRX,U,3),1,30),?40,$E($P(LRX,U,4),1,25),?70,"/ ",$P(LRX,U,5)
;S LRXY=$QS(NODE,1)_" "_$P(LRX,U,3)_" - "_$P(LRX,U,4)_" / "_$P(LRX,U,5)_" "_$S($P(LRX,U,6):"Override Yes",1:"")
;W !,LRXY
Q
EDIT ;
K DIR,DIRUT
S DIR("A")="Delete this entry"
S DIR(0)="NO^1:"_LRCNT D ^DIR
Q:$D(DIRUT)
S LRY=Y I '$D(^TMP("LRLNC63",$J,Y)) W !?5,Y_" Entry not Valid",! G EDIT
S NODE="^TMP(""LRLNC63"","_$J_","_Y_",0)"
S NODE=$Q(@NODE) I $QS(NODE,2)'=$J W !?5,Y_" Entry not Valid",! G EDIT
D SHO
S DIR(0)="YO" D ^DIR Q:$D(DIRUT)
I $G(Y)=1 K ^TMP("LRLNC63",$J,LRY)
G EDIT
Q
EXPAND ;If panel test expand to get parts
K ^TMP("LR",$J) S LRCFL=""
K DIR,LRTEST,LRX,T1
S LRTEST(+LRY)=+LRY_U_^LAB(60,+LRY,0),T1=+LRY
S LRNX=0
D EX1^LREXPD
S DIR(0)="PO^64.2:EMZ",DIR("A")=" Select Suffix Code"
D ^DIR Q:Y<1
S LRSUF=$P(Y(0),U)_U_$P($P(Y(0),U,2),".",2)
K DIR S DIR(0)="YO",DIR("A")="Override previous LOINC mapping"
D ^DIR I Y=1 S LRSUF=LRSUF_U_1
I $O(^TMP("LR",$J,"TMP",0)) D
. S LRN=0 F S LRN=$O(^TMP("LR",$J,"TMP",LRN)) Q:LRN<1 S LRNX=^(LRN) D
. . Q:'$P($G(^LAB(60,LRNX,64)),U,2)
. . S LRCNT=$G(LRCNT)+1
. . S ^TMP("LRLNC63",$J,LRCNT,$P(^LAB(60,LRNX,0),U),LRN)=LRN_U_+LRNX_U_$P(^(0),U)_U_LRSUF
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRLNC63B 4062 printed Dec 13, 2024@02:16:32 Page 2
LRLNC63B ;DALOI/FHS-HISTORICAL LOINC MAPPING MODIFIER ;01/30/2001 15:19
+1 ;;5.2;LAB SERVICE;**279**;Sep 27, 1994
EN ;
+1 KILL DIR
WRITE @IOF
+2 WRITE !!,$$CJ^XLFSTR("This option will allow you to manage how specific DataNames",80)
+3 WRITE !,$$CJ^XLFSTR("will be mapped to LOINC Codes for historical data.",80)
+4 WRITE !!,$$LJ^XLFSTR("You are able to override file definitions to correct past LOINC mappings.",80)
+5 WRITE !,$$LJ^XLFSTR("Select the CH subsripted test, indicate the suffix to be used.",80)
+6 WRITE !,$$LJ^XLFSTR("You can indicate if this suffix should override previous LOINC Mapping.",80),!
+7 WRITE !,$$LJ^XLFSTR("This option will REMAP your entire database.",80),!!
+8 WRITE !,$$LJ^XLFSTR("This option should only be run on weekends after hours.",80),!
+9 SET DIR(0)="Y"
SET DIR("A")=" Do you wish to continue "
+10 DO ^DIR
if $GET(Y)'=1
QUIT
+11 KILL ^XTMP("LRLNC63",2),^XTMP("LRLNC63","LST"),^TMP("LR",$JOB),^TMP("LRLNC63",$JOB),LRCNT,LROX
SELECT ;Indicate which DATANAMES LOINC definition to be changed.
+1 KILL LRMOD,LRY,NODE
+2 SET LRY=1
+3 FOR
WRITE !!
if $GET(LRY)<1
QUIT
Begin DoDot:1
+4 KILL DIR,X
+5 WRITE !,$$CJ^XLFSTR("Selection can be a 'CH' Atomic or Panel test.",80),!
+6 SET DIR("?")="Selection can be an Atomic or Panel test."
+7 SET DIR("?",1)="Only those tests with a Result code will be stored."
+8 SET DIR(0)="PO^60:EMZ"
SET DIR("S")="I $P(^(0),U,4)=""CH"""
+9 SET DIR("A")="Select test you want to modify mapping"
+10 DO ^DIR
+11 SET LRY=Y
if Y<1
QUIT
+12 SET LRYY=$PIECE($PIECE(Y(0),U,5),";",2)_U_LRY
+13 DO EXPAND
End DoDot:1
+14 ;
DISPLAY ;Show what has been recorded
+1 KILL DIRUT,LRY
+2 IF '$ORDER(^TMP("LRLNC63",$JOB,0))
WRITE !?5,"Nothing was selected, Process Aborted",!
QUIT
+3 WRITE @IOF
+4 WRITE !,$$CJ^XLFSTR("Here is a list of what you have selected.",80)
+5 WRITE !,$$CJ^XLFSTR("[O] indicates override current mapping.",80),!
+6 Begin DoDot:1
+7 DO ^%ZIS
if POP
QUIT
+8 USE IO
+9 NEW DIR
+10 SET DIR="E"
+11 SET NODE="^TMP(""LRLNC63"","_$JOB_",0)"
FOR
SET NODE=$QUERY(@NODE)
if $SELECT(NODE=""
QUIT
Begin DoDot:2
+12 IF $Y>(IOSL-3)
Begin DoDot:3
+13 IF $EXTRACT(IOST,1.2)="C-"
DO ^DIR
if $DATA(DIRUT)
QUIT
+14 WRITE @IOF
+15 WRITE !,"Here is a list of what you have selected."
+16 WRITE !,"[O] indicates override current mapping.",!
End DoDot:3
+17 DO SHO
End DoDot:2
if $DATA(DIRUT)
QUIT
+18 if $EXTRACT(IOST,1)="P"
WRITE @IOF
+19 DO ^%ZISC
End DoDot:1
CHK ;
+1 ; K ^TMP("LR",$J)
+2 WRITE !
+3 IF $DATA(DIRUT)
SET DIR(0)="Y"
SET DIR("A")=" Do you want to STOP"
DO ^DIR
if $GET(Y)=1
GOTO END
+4 KILL DIR
SET DIR(0)="YO"
SET DIR("A")="You wish to add more"
DO ^DIR
IF $GET(Y)=1
GOTO SELECT
+5 IF $GET(Y)=U
GOTO END
+6 ;
+7 WRITE !
+8 SET DIR("A")=" Do you want to delete an entry"
DO ^DIR
if $GET(Y)=U
GOTO END
+9 IF $GET(Y)=1
DO EDIT
GOTO DISPLAY
+10 IF $ORDER(^TMP("LRLNC63",$JOB,0))
Begin DoDot:1
+11 SET LRMOD=1
SET ZTSAVE("LRMOD")=""
+12 SET NODE="^TMP(""LRLNC63"",0)"
+13 FOR
SET NODE=$QUERY(@NODE)
if $SELECT($QSUBSCRIPT(NODE,2)'=$JOB
QUIT
Begin DoDot:2
+14 SET ^XTMP("LRLNC63",2,$QSUBSCRIPT(NODE,5))=@NODE
End DoDot:2
End DoDot:1
FIRE ;Run the mapping tasking function
+1 DO QUE^LRLNC63
+2 QUIT
END ;
+1 KILL DIRUT
+2 KILL ^XTMP("LRLNC63",2)
+3 QUIT
SHO ;
+1 NEW LRX,LRXY
+2 SET LRX=@NODE
+3 WRITE !,$QSUBSCRIPT(NODE,3)_" "_$SELECT($PIECE(LRX,U,6):"[O]",1:" "),?7,$EXTRACT($PIECE(LRX,U,3),1,30),?40,$EXTRACT($PIECE(LRX,U,4),1,25),?70,"/ ",$PIECE(LRX,U,5)
+4 ;S LRXY=$QS(NODE,1)_" "_$P(LRX,U,3)_" - "_$P(LRX,U,4)_" / "_$P(LRX,U,5)_" "_$S($P(LRX,U,6):"Override Yes",1:"")
+5 ;W !,LRXY
+6 QUIT
EDIT ;
+1 KILL DIR,DIRUT
+2 SET DIR("A")="Delete this entry"
+3 SET DIR(0)="NO^1:"_LRCNT
DO ^DIR
+4 if $DATA(DIRUT)
QUIT
+5 SET LRY=Y
IF '$DATA(^TMP("LRLNC63",$JOB,Y))
WRITE !?5,Y_" Entry not Valid",!
GOTO EDIT
+6 SET NODE="^TMP(""LRLNC63"","_$JOB_","_Y_",0)"
+7 SET NODE=$QUERY(@NODE)
IF $QSUBSCRIPT(NODE,2)'=$JOB
WRITE !?5,Y_" Entry not Valid",!
GOTO EDIT
+8 DO SHO
+9 SET DIR(0)="YO"
DO ^DIR
if $DATA(DIRUT)
QUIT
+10 IF $GET(Y)=1
KILL ^TMP("LRLNC63",$JOB,LRY)
+11 GOTO EDIT
+12 QUIT
EXPAND ;If panel test expand to get parts
+1 KILL ^TMP("LR",$JOB)
SET LRCFL=""
+2 KILL DIR,LRTEST,LRX,T1
+3 SET LRTEST(+LRY)=+LRY_U_^LAB(60,+LRY,0)
SET T1=+LRY
+4 SET LRNX=0
+5 DO EX1^LREXPD
+6 SET DIR(0)="PO^64.2:EMZ"
SET DIR("A")=" Select Suffix Code"
+7 DO ^DIR
if Y<1
QUIT
+8 SET LRSUF=$PIECE(Y(0),U)_U_$PIECE($PIECE(Y(0),U,2),".",2)
+9 KILL DIR
SET DIR(0)="YO"
SET DIR("A")="Override previous LOINC mapping"
+10 DO ^DIR
IF Y=1
SET LRSUF=LRSUF_U_1
+11 IF $ORDER(^TMP("LR",$JOB,"TMP",0))
Begin DoDot:1
+12 SET LRN=0
FOR
SET LRN=$ORDER(^TMP("LR",$JOB,"TMP",LRN))
if LRN<1
QUIT
SET LRNX=^(LRN)
Begin DoDot:2
+13 if '$PIECE($GET(^LAB(60,LRNX,64)),U,2)
QUIT
+14 SET LRCNT=$GET(LRCNT)+1
+15 SET ^TMP("LRLNC63",$JOB,LRCNT,$PIECE(^LAB(60,LRNX,0),U),LRN)=LRN_U_+LRNX_U_$PIECE(^(0),U)_U_LRSUF
End DoDot:2
End DoDot:1
+16 QUIT
