- 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 Feb 18, 2025@23:42:25 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
