Routine: PXRMLEXL

PXRMLEXL ;SLC/PKR - List Manager routines for Taxonomies and Lexicon. ;14-Aug-2015 08:20;du

 ;;2.0;CLINICAL REMINDERS;**26,1005**;Feb 04, 2005;Build 23

 ;=========================================

ADDSEL(ENUM,UID) ;Add entry ENUM to the selected list and highlight it.

 N CODE

 S CODE=^TMP("PXRMLEXL",$J,"CODE",ENUM)

 S ^TMP("PXRMLEXL",$J,"SELECTED",ENUM)=CODE_U_UID

 D HLITE(ENUM,1,UID)

 ;=========================================

BLDLIST ;Build the Lexicon list.

 N CODE,CODESYS,CODESYSP,DESC,ENUM,FMTSTR,IND,JND

 N NCODES,NL,NLINES,NSEL,NUID,NUM,OUTPUT,START,TAXIEN,TERM,TEXT,UID

 S FMTSTR=$$LMFMTSTR^PXRMTEXT(.VALMDDF,"RLLLL")

 ;^TMP("PXRMLEXTC",$J) nodes are set in PXRMTXSM which calls this

 ;List Manager selection.

 ;Clear the display.

 D KILL^VALM10

 K ^TMP("PXRMLEXL",$J)

 S CODESYS=^TMP("PXRMLEXTC",$J,"CODESYS")

 S TAXIEN=^TMP("PXRMLEXTC",$J,"TAX IEN")

 S TERM=^TMP("PXRMLEXTC",$J,"LEX TERM")

 ;Clear the display.

 D KILL^VALM10

 K ^TMP("PXRMLEXL",$J)

 I '$D(^TMP("PXRMLEXS",$J,TERM,CODESYS)) D

 . D LEXLIST(TAXIEN,TERM,CODESYS,.NCODES,.NLINES,.TEXT)

 . M ^TMP("PXRMTEXT",$J,TERM,CODESYS,"TEXT")=TEXT

 . S ^TMP("PXRMTEXT",$J,TERM,CODESYS,"NCODES")=NCODES

 . S ^TMP("PXRMTEXT",$J,TERM,CODESYS,"NLINES")=NLINES

 I $D(^TMP("PXRMTEXT",$J,TERM,CODESYS)) D

 . S NCODES=^TMP("PXRMTEXT",$J,TERM,CODESYS,"NCODES")

 . S NLINES=^TMP("PXRMTEXT",$J,TERM,CODESYS,"NLINES")

 ;Get the coding system Lexicon information for building the display.

 ;DBIA #5679

 S CODESYSP=$$CSYS^LEXU(CODESYS)

 S TEXT=^TMP("PXRMLEXTC",$J,"LEX TERM")

 S TEXT=$S(($L(TEXT)'>66):TEXT,1:$E(TEXT,1,63)_"...")

 S VALMHDR(1)="Term/Code: "_TEXT

 S VALMHDR(2)=NCODES_" "_$P(CODESYSP,U,4)_$S(NCODES=1:" code was found",1:" codes were found")

 I NCODES=1,'$$UIDOK S VALMHDR(2)=VALMHDR(2)_" It cannot be used in a dialog."

 I NCODES>1,'$$UIDOK S VALMHDR(2)=VALMHDR(2)_" These cannot be used in a dialog."

 ;Set these so LM shows Page 1 of 1 when there are no codes.

 I NCODES=0 S VALMHDR(2)=VALMHDR(2)_".",^TMP("PXRMLEXL",$J,1,0)="",VALMCNT=1 Q

 ;If the display list has been saved restore it, if not build it.

 I $D(^TMP("PXRMLEXS",$J,TERM,CODESYS)) D

 . M ^TMP("PXRMLEXL",$J)=^TMP("PXRMLEXS",$J,TERM,CODESYS)

 . S VALMCNT=^TMP("PXRMLEXS",$J,TERM,CODESYS,"VALMCNT")

 I '$D(^TMP("PXRMLEXS",$J,TERM,CODESYS)) D

 . S VALMCNT=0

 . F IND=1:1:NLINES D

 .. S NUM=$P(TEXT(IND),U,1),CODE=$P(TEXT(IND),U,2)

 .. I NUM'="",CODE'="" S ENUM=NUM,^TMP("PXRMLEXL",$J,"CODE",NUM)=CODE,START=VALMCNT+1

 .. D FORMAT(TEXT(IND),FMTSTR,.NL,.OUTPUT)

 .. F JND=1:1:NL D

 ... S VALMCNT=VALMCNT+1,^TMP("PXRMLEXL",$J,VALMCNT,0)=OUTPUT(JND)

 ... S ^TMP("PXRMLEXL",$J,"IDX",VALMCNT,ENUM)=""

 .. S ^TMP("PXRMLEXL",$J,"LINES",ENUM)=START_U_VALMCNT

 . S ^TMP("PXRMLEXL",$J,"NCODES")=NCODES

 . S ^TMP("PXRMLEXL",$J,"VALMCNT")=VALMCNT

 ;If the display list has not been saved, save it.

 I '$D(^TMP("PXRMLEXS",$J,TERM,CODESYS)) M ^TMP("PXRMLEXS",$J,TERM,CODESYS)=^TMP("PXRMLEXL",$J)

 ;Mark any entries that were previously selected.

 S ENUM="",(NSEL,NUID)=0

 F  S ENUM=$O(^TMP("PXRMLEXL",$J,"CODE",ENUM)) Q:ENUM=""  D

 . S CODE=^TMP("PXRMLEXL",$J,"CODE",ENUM)

 . I CODE'="",$D(^TMP("PXRMCODES",$J,TERM,CODESYS,CODE)) D  Q

 .. S NSEL=NSEL+1

 .. S UID=+^TMP("PXRMCODES",$J,TERM,CODESYS,CODE)

 .. I UID S NUID=NUID+1

 .. D ADDSEL(ENUM,UID)

 S VALMHDR(2)=VALMHDR(2)_", "_NSEL_" are selected."

 S PXRMLEXV="ALL"

 I $D(PXRMBGS("ALL")) S VALMBG=PXRMBGS("ALL")

 ;=========================================

BLDSLIST ;Build the Lexicon list, selected or UID codes only.

 N CODE,CODESYS,CODESYSP,DONE,FMTSTR,IND,JND,KND

 N NL,NSEL,NUID,OUTPUT,START,TERM,TEXT,UID

 S FMTSTR=$$LMFMTSTR^PXRMTEXT(.VALMDDF,"RLLLL")

 ;^TMP("PXRMLEXTC",$J) nodes are set in PXRMTXSM which calls this

 ;List Manager selection.

 ;Clear the display.

 D KILL^VALM10

 K ^TMP("PXRMLEXL",$J)

 S CODESYS=^TMP("PXRMLEXTC",$J,"CODESYS")

 ;DBIA #5679

 S CODESYSP=$$CSYS^LEXU(CODESYS)

 S TERM=^TMP("PXRMLEXTC",$J,"LEX TERM")

 S TEXT=^TMP("PXRMLEXTC",$J,"LEX TERM")

 S TEXT=$S(($L(TEXT)'>66):TEXT,1:$E(TEXT,1,63)_"...")

 ;Get the entries that were previously selected.

 S NLINES=^TMP("PXRMTEXT",$J,TERM,CODESYS,"NLINES")

 S (NSEL,NUID,VALMCNT)=0

 F IND=1:1:NLINES D

 . S TEMP=^TMP("PXRMTEXT",$J,TERM,CODESYS,"TEXT",IND)

 . S CODE=$P(TEMP,U,2)

 . I (CODE'=""),'$D(^TMP("PXRMCODES",$J,TERM,CODESYS,CODE)) Q

 .;Skip additional activation/inactivation lines for non-selected codes.

 . I CODE="" Q

 . I CODE'="" S UID=^TMP("PXRMCODES",$J,TERM,CODESYS,CODE)

 . I UID S NUID=NUID+1

 . S NSEL=NSEL+1

 . S ^TMP("PXRMLEXL",$J,"CODE",NSEL)=CODE,START=VALMCNT+1

 . S TEXT=NSEL_U_CODE_U_$P(TEMP,U,3,5)

 . D FORMAT(TEXT,FMTSTR,.NL,.OUTPUT)

 . F JND=1:1:NL D

 .. S VALMCNT=VALMCNT+1,^TMP("PXRMLEXL",$J,VALMCNT,0)=OUTPUT(JND)

 .. S ^TMP("PXRMLEXL",$J,"IDX",VALMCNT,NSEL)=""

 . ;S ^TMP("PXRMLEXL",$J,"LINES",NSEL)=START_U_VALMCNT

 . ;D ADDSEL(NSEL,UID)

 .;Check for additional activation/inactivation lines.

 . S KND=IND

 . S DONE=$S(IND<NLINES:0,1:1)

 . F  Q:DONE  D

 .. S KND=KND+1

 .. S TEMP=^TMP("PXRMTEXT",$J,TERM,CODESYS,"TEXT",KND)

 .. I $P(TEMP,U,2)'="" S DONE=1 Q

 .. I KND=NLINES S DONE=1

 .. S IND=KND

 .. D FORMAT(TEMP,FMTSTR,.NL,.OUTPUT)

 .. F JND=1:1:NL D

 ... S VALMCNT=VALMCNT+1,^TMP("PXRMLEXL",$J,VALMCNT,0)=OUTPUT(JND)

 ... S ^TMP("PXRMLEXL",$J,"IDX",VALMCNT,NSEL)=""

 . S ^TMP("PXRMLEXL",$J,"LINES",NSEL)=START_U_VALMCNT

 . D ADDSEL(NSEL,UID)

 S ^TMP("PXRMLEXL",$J,"NCODES")=NSEL

 S ^TMP("PXRMLEXL",$J,"VALMCNT")=VALMCNT

 S VALMHDR(1)="Term/Code: "_TERM

 S VALMHDR(2)="Selected "_$P(CODESYSP,U,4)_": "_NSEL_" selected codes, "_NUID_" UID codes."

 S PXRMLEXV="SEL"

 S VALMBG=$S($D(PXRMBGS("SEL")):PXRMBGS("SEL"),1:1)

 ;=========================================

CPLIST(TAXIEN,TERM,CODESYS,NCODES,NLINES,TEXT) ;Build the list for a copy from

 ;a range list of codes.

 N ACTDT,CODE,DATA,INACTDT,NUM,SDESC,TEMP

 S CODE="",(NCODES,NLINES)=0

 F  S CODE=$O(^TMP("PXRMCODES",$J,TERM,CODESYS,CODE)) Q:CODE=""  D

 . K DATA

 .;DBIA #1997, #3991

 . I CODESYS="CPC" D PERIOD^ICPTAPIU(CODE,.DATA)

 . I CODESYS="CPT" D PERIOD^ICPTAPIU(CODE,.DATA)

 . I CODESYS="ICD" D PERIOD^ICDAPIU(CODE,.DATA)

 . I CODESYS="ICP" D PERIOD^ICDAPIU(CODE,.DATA)

 . I +DATA(0)=-1 Q

 . S NCODES=NCODES+1

 . S (ACTDT,NUM)=0

 . F  S ACTDT=$O(DATA(ACTDT)) Q:ACTDT=""  D

 .. S TEMP=DATA(ACTDT)

 .. S NUM=NUM+1

 .. S INACTDT=$P(TEMP,U,1)

 .. S SDESC=$P(TEMP,U,2)

 .. S NLINES=NLINES+1

 .. I NUM=1 S TEXT(NLINES)=NCODES_U_CODE_U_ACTDT_U_INACTDT_U_SDESC

 .. E  S TEXT(NLINES)=U_U_ACTDT_U_INACTDT_U_SDESC

 ;=========================================

ENTRY ;Entry code

 D INITMPG^PXRMLEXL

 D BLDLIST^PXRMLEXL

 D XQORM

 ;=========================================

EXIT ;Exit code

 D INITMPG^PXRMLEXL

 D FULL^VALM1

 D CLEAN^VALM10

 D KILL^VALM10

 D CLEAR^VALM1

 S VALMBCK="Q"

 ;=========================================

EXITS ;Exit and save action.

 D SAVE^PXRMLEXL

 S VALMBCK="Q"

 ;=========================================

FORMAT(TEXT,FMTSTR,NL,OUTPUT) ;Format  entry number, code,

 ;activation date, inactivation date, short text for LM display.

 N ACTDT,INACTDT

 S ACTDT=$P(TEXT,U,3),INACTDT=$P(TEXT,U,4)

 S ACTDT=$$FMTE^XLFDT(ACTDT,5)

 S INACTDT=$$FMTE^XLFDT(INACTDT,5)

 S $P(TEXT,U,3)=ACTDT,$P(TEXT,U,4)=INACTDT

 D COLFMT^PXRMTEXT(FMTSTR,TEXT," ",.NL,.OUTPUT)

 ;=========================================

GETLIST(LIST) ;Let the user input a list of items.

 N INUM,ITEM,LEND,LELEM,NCODES,LSTART,X,Y

 S NCODES=+$G(^TMP("PXRMLEXL",$J,"NCODES"))

 I NCODES=0 Q

 I NCODES=1 S LIST(1)="" Q

 S DIR(0)="LC^1:"_NCODES

 D ^DIR

 I $E(Y,1)="^" Q

 ;Populate the list.

 F INUM=1:1:($L(Y,",")-1) D

 . S LELEM=$P(Y,",",INUM)

 . I LELEM?1.N  S LIST(LELEM)=""

 . S LSTART=$P(LELEM,"-",1),LEND=$P(LELEM,"-",2)

 . F ITEM=LSTART:1:LEND S LIST(ITEM)=""

 ;=========================================

HDR ; Header code

 S VALMHDR(1)="Select Lexicon items to include in the taxonomy."

 S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"

 ;=========================================

HELP ;Display help.

 D HELP^BPXRMEXT

 ;=========================================

HLITE(ENUM,MODE,UID) ;Highlight/unhighlight an entry. MODE=1 turns on

 ;highlighting, MODE=0 turns it off.

 N LINE,START,STOP,VCTRL

 S VCTRL=$S(MODE=1:IOINHI,1:IOINORM)

 S START=$P(^TMP("PXRMLEXL",$J,"LINES",ENUM),U,1)

 S STOP=$P(^TMP("PXRMLEXL",$J,"LINES",ENUM),U,2)

 F LINE=START:1:STOP D CNTRL^VALM10(LINE,1,80,VCTRL,IOINORM)

 ;If the entry is marked Use In Dialog turn on marker.

 I MODE=1,UID=1 D FLDCTRL^VALM10(START,"CODE",IORVON,IORVOFF,"")

 I MODE=0 D FLDCTRL^VALM10(START,"CODE",IORVOFF,IORVOFF,"")

 ;=========================================

IMPLIST(TAXIEN,TERM,CODESYS,NCODES,NLINES,TEXT) ;Build the list for an

 ;imported set of codes.

 D IMPLIST^BPXRMEXT(TAXIEN,TERM,CODESYS,.NCODES,.NLINES,.TEXT)

 ;=========================================

INCL ;Put the selected entries on the selected list and highlight them.

 N SEL,SELLIST

 ;Get the list.

 D GETLIST(.SELLIST)

 ;If there is no list quit.

 I '$D(SELLIST) Q

 S SEL=""

 F  S SEL=$O(SELLIST(SEL)) Q:SEL=""  D ADDSEL(SEL,"")

 S VALMBCK="R"

 ;=========================================

INCX(LIST,UID) ;Put the selected entries on the selected list and highlight

 ;them.

 N ENUM,IND

 F IND=1:1:$L(LIST,",") D

 . S ENUM=$P(LIST,",",IND)

 . D ADDSEL(ENUM,UID)

 ;=========================================

INITMPG ;Initialize all the ^TMP globals.

 K ^TMP("PXRMLEXL",$J)

 ;=========================================

LEXLIST(TAXIEN,TERM,CODESYS,NCODES,NLINES,TEXT) ;Call Lexicon to get the list

 ;of codes.

 I $E(TERM,1,9)="Copy from" D CPLIST(TAXIEN,TERM,CODESYS,.NCODES,.NLINES,.TEXT) Q

 I TERM["(imported)" D IMPLIST(TAXIEN,TERM,CODESYS,.NCODES,.NLINES,.TEXT) Q

 N ACTDT,CODE,CODEI,INACTDT,IND,NUM

 N RESULT,SRC,SDESC,TEMP

 W @IOF,"Searching Lexicon ..."

 K ^TMP("LEXTAX",$J)

 ;DBIA #5681

 S RESULT=$$TAX^LEX10CS(TERM,CODESYS,DT,"LEXTAX",0)

 S NCODES=+RESULT

 I NCODES=-1 S (NCODES,NLINES)=0 K ^TMP("LEXTAX",$J) Q

 S SRC=+$O(^TMP("LEXTAX",$J,0))

 I CODESYS="SCT" D SCTDESC("LEXTAX")

 S CODEI="",(NLINES,NUM)=0

 F  S CODEI=$O(^TMP("LEXTAX",$J,SRC,CODEI)) Q:CODEI=""  D

 . S NUM=NUM+1,IND=0

 . F  S IND=$O(^TMP("LEXTAX",$J,SRC,CODEI,IND)) Q:IND=""  D

 .. S TEMP=^TMP("LEXTAX",$J,SRC,CODEI,IND)

 .. S ACTDT=$P(TEMP,U,1),INACTDT=$P(TEMP,U,2)

 .. S TEMP=^TMP("LEXTAX",$J,SRC,CODEI,IND,0)

 .. S CODE=$P(TEMP,U,1),SDESC=$P(TEMP,U,2)

 .. S NLINES=NLINES+1

 .. I IND=1 S TEXT(NLINES)=NUM_U_CODE_U_ACTDT_U_INACTDT_U_SDESC

 .. E  S TEXT(NLINES)=U_U_ACTDT_U_INACTDT_U_SDESC

 K ^TMP("LEXTAX",$J)

 ;=========================================

PEXIT ; Protocol exit code

 S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"

 ;Reset after page up/down etc

 D XQORM

 ;=========================================

RFD(ENUM) ;Remove UID from the selected entry.

 N START

 S $P(^TMP("PXRMLEXL",$J,"SELECTED",ENUM),U,2)=0

 S START=$P(^TMP("PXRMLEXL",$J,"LINES",ENUM),U,1)

 D FLDCTRL^VALM10(START,"CODE",IORVOFF,IORVOFF,"")

 ;=========================================

RFDL ;Remove UID from the selected entries.

 N SEL,SELLIST

 ;Get the list.

 D GETLIST(.SELLIST)

 ;If there is no list quit.

 I '$D(SELLIST) Q

 S SEL=""

 F  S SEL=$O(SELLIST(SEL)) Q:SEL=""  D RFD(SEL)

 S VALMBCK="R"

 ;=========================================

RFDX(LIST) ;Remove UID from the selected entries.

 N ENUM,IND

 F IND=1:1:$L(LIST,",") D

 . S ENUM=$P(LIST,",",IND)

 . D RFD(ENUM)

 ;=========================================

RFT(ENUM) ;Remove entry ENUM from the selected list and unhighlight it.

 K ^TMP("PXRMLEXL",$J,"SELECTED",ENUM)

 D HLITE(ENUM,0,0)

 ;=========================================

RFTL ;Remove the selected entries from the selected list and unhighlight them.

 N SEL,SELLIST

 ;Get the list.

 D GETLIST(.SELLIST)

 ;If there is no list quit.

 I '$D(SELLIST) Q

 S SEL=""

 F  S SEL=$O(SELLIST(SEL)) Q:SEL=""  D RFT(SEL)

 S VALMBCK="R"

 ;=========================================

RFTX(LIST) ;Remove the selected entries from the selected list and unhighlight

 ;them.

 N ENUM,IND

 F IND=1:1:$L(LIST,",") D

 . S ENUM=$P(LIST,",",IND)

 . D RFT(ENUM)

 ;=========================================

SAVE ;Save the selected entries in the taxonomy.

 N CODE,CODESYS,ENUM,TEMP,TERM,UID

 ;^TMP("PXRMLEXTC",$J) nodes are set in PXRMTXSM which calls this

 ;List Manager selection.

 S CODESYS=^TMP("PXRMLEXTC",$J,"CODESYS")

 S TERM=^TMP("PXRMLEXTC",$J,"LEX TERM")

 K ^TMP("PXRMCODES",$J,TERM,CODESYS)

 ;Mark this coding system as having been edited so it is not reloaded

 ;from the taxonomy in CODELIST^PXRMTXSM.

 S ^TMP("PXRMCODES",$J,TERM,CODESYS)=""

 S ENUM=0,NSEL=0

 F  S ENUM=$O(^TMP("PXRMLEXL",$J,"SELECTED",ENUM)) Q:ENUM=""  D

 . S TEMP=^TMP("PXRMLEXL",$J,"SELECTED",ENUM)

 . S CODE=$P(TEMP,U,1),UID=$P(TEMP,U,2)

 . S ^TMP("PXRMCODES",$J,TERM,CODESYS,CODE)=UID

 S VALMBCK="R"

 ;=========================================

SCTDESC(NODE) ;Append the SNOMED hierarchy to the description and then

 ;sort the list by description.

 D SCTDESC^BPXRMEXT(NODE)

 ;=========================================

UIDL ;Mark selected entries as UID.

 N SEL,SELLIST

 ;Get the list.

 D GETLIST(.SELLIST)

 ;If there is no list quit.

 I '$D(SELLIST) Q

 S SEL=""

 F  S SEL=$O(SELLIST(SEL)) Q:SEL=""  D ADDSEL(SEL,1)

 S VALMBCK="R"

 ;=========================================

UIDOK() ;Check the coding system to determine if it can be used in a dialog.

 ;IHS/MSC/MGH ICD and SNOMEDs turned off to be used in dialogs P1005

 N CODESYS

 S CODESYS=^TMP("PXRMLEXTC",$J,"CODESYS")

 ;I CODESYS="10D" Q 1

 I CODESYS="CPC" Q 1

 I CODESYS="CPT" Q 1

 ;I CODESYS="ICD" Q 1

 ;I CODESYS="SCT" Q 1

 S (XQORQUIT,XQORPOP)=1

Q 0

 ;=========================================

VIEW() ;Select the view.

 S VALMBCK="R"

 ;I PXRMLEXV="ALL" S PXRMBGS("ALL")=VALMBG D BLDSLIST Q

 ;I PXRMLEXV="SEL" S PXRMBGS("SEL")=VALMBG D BLDLIST Q

;Q

 ;=========================================

XQORM ; Set range for selection.

 N NCODES

 S NCODES=+$G(^TMP("PXRMLEXL",$J,"NCODES"))

 I NCODES=0 Q

 S XQORM("#")=$O(^ORD(101,"B","PXRM LEXICON SELECT ENTRY",0))_U_"1:"_NCODES

 S XQORM("A")="Select Action: "

 ;=========================================

XSEL ;Entry action for protocol PXRM LEXICON SELECT ENTRY.

 D XSEL^BPXRMEXT

PXRMLEXL  ;SLC/PKR - List Manager routines for Taxonomies and Lexicon. ;14-Aug-2015 08:20;du

 +1       ;;2.0;CLINICAL REMINDERS;**26,1005**;Feb 04, 2005;Build 23

 +2       ;

 +3       ;=========================================

ADDSEL(ENUM,UID) ;Add entry ENUM to the selected list and highlight it.

 +1        NEW CODE

 +2        SET CODE=^TMP("PXRMLEXL",$JOB,"CODE",ENUM)

 +3        SET ^TMP("PXRMLEXL",$JOB,"SELECTED",ENUM)=CODE_U_UID

 +4        DO HLITE(ENUM,1,UID)

 +5        QUIT

 +6       ;

 +7       ;=========================================

BLDLIST   ;Build the Lexicon list.

 +1        NEW CODE,CODESYS,CODESYSP,DESC,ENUM,FMTSTR,IND,JND

 +2        NEW NCODES,NL,NLINES,NSEL,NUID,NUM,OUTPUT,START,TAXIEN,TERM,TEXT,UID

 +3        SET FMTSTR=$$LMFMTSTR^PXRMTEXT(.VALMDDF,"RLLLL")

 +4       ;^TMP("PXRMLEXTC",$J) nodes are set in PXRMTXSM which calls this

 +5       ;List Manager selection.

 +6       ;Clear the display.

 +7        DO KILL^VALM10

 +8        KILL ^TMP("PXRMLEXL",$JOB)

 +9        SET CODESYS=^TMP("PXRMLEXTC",$JOB,"CODESYS")

 +10       SET TAXIEN=^TMP("PXRMLEXTC",$JOB,"TAX IEN")

 +11       SET TERM=^TMP("PXRMLEXTC",$JOB,"LEX TERM")

 +12      ;Clear the display.

 +13       DO KILL^VALM10

 +14       KILL ^TMP("PXRMLEXL",$JOB)

 +15       IF '$DATA(^TMP("PXRMLEXS",$JOB,TERM,CODESYS))

               Begin DoDot:1

 +16               DO LEXLIST(TAXIEN,TERM,CODESYS,.NCODES,.NLINES,.TEXT)

 +17               MERGE ^TMP("PXRMTEXT",$JOB,TERM,CODESYS,"TEXT")=TEXT

 +18               SET ^TMP("PXRMTEXT",$JOB,TERM,CODESYS,"NCODES")=NCODES

 +19               SET ^TMP("PXRMTEXT",$JOB,TERM,CODESYS,"NLINES")=NLINES

               End DoDot:1

 +20       IF $DATA(^TMP("PXRMTEXT",$JOB,TERM,CODESYS))

               Begin DoDot:1

 +21               SET NCODES=^TMP("PXRMTEXT",$JOB,TERM,CODESYS,"NCODES")

 +22               SET NLINES=^TMP("PXRMTEXT",$JOB,TERM,CODESYS,"NLINES")

               End DoDot:1

 +23      ;Get the coding system Lexicon information for building the display.

 +24      ;DBIA #5679

 +25       SET CODESYSP=$$CSYS^LEXU(CODESYS)

 +26       SET TEXT=^TMP("PXRMLEXTC",$JOB,"LEX TERM")

 +27       SET TEXT=$SELECT(($LENGTH(TEXT)'>66):TEXT,1:$EXTRACT(TEXT,1,63)_"...")

 +28       SET VALMHDR(1)="Term/Code: "_TEXT

 +29       SET VALMHDR(2)=NCODES_" "_$PIECE(CODESYSP,U,4)_$SELECT(NCODES=1:" code was found",1:" codes were found")

 +30       IF NCODES=1

               IF '$$UIDOK

                   SET VALMHDR(2)=VALMHDR(2)_" It cannot be used in a dialog."

 +31       IF NCODES>1

               IF '$$UIDOK

                   SET VALMHDR(2)=VALMHDR(2)_" These cannot be used in a dialog."

 +32      ;Set these so LM shows Page 1 of 1 when there are no codes.

 +33       IF NCODES=0

               SET VALMHDR(2)=VALMHDR(2)_"."

               SET ^TMP("PXRMLEXL",$JOB,1,0)=""

               SET VALMCNT=1

               QUIT

 +34      ;

 +35      ;If the display list has been saved restore it, if not build it.

 +36       IF $DATA(^TMP("PXRMLEXS",$JOB,TERM,CODESYS))

               Begin DoDot:1

 +37               MERGE ^TMP("PXRMLEXL",$JOB)=^TMP("PXRMLEXS",$JOB,TERM,CODESYS)

 +38               SET VALMCNT=^TMP("PXRMLEXS",$JOB,TERM,CODESYS,"VALMCNT")

               End DoDot:1

 +39       IF '$DATA(^TMP("PXRMLEXS",$JOB,TERM,CODESYS))

               Begin DoDot:1

 +40               SET VALMCNT=0

 +41               FOR IND=1:1:NLINES

                       Begin DoDot:2

 +42                       SET NUM=$PIECE(TEXT(IND),U,1)

                           SET CODE=$PIECE(TEXT(IND),U,2)

 +43                       IF NUM'=""

                               IF CODE'=""

                                   SET ENUM=NUM

                                   SET ^TMP("PXRMLEXL",$JOB,"CODE",NUM)=CODE

                                   SET START=VALMCNT+1

 +44                       DO FORMAT(TEXT(IND),FMTSTR,.NL,.OUTPUT)

 +45                       FOR JND=1:1:NL

                               Begin DoDot:3

 +46                               SET VALMCNT=VALMCNT+1

                                   SET ^TMP("PXRMLEXL",$JOB,VALMCNT,0)=OUTPUT(JND)

 +47                               SET ^TMP("PXRMLEXL",$JOB,"IDX",VALMCNT,ENUM)=""

                               End DoDot:3

 +48                       SET ^TMP("PXRMLEXL",$JOB,"LINES",ENUM)=START_U_VALMCNT

                       End DoDot:2

 +49               SET ^TMP("PXRMLEXL",$JOB,"NCODES")=NCODES

 +50               SET ^TMP("PXRMLEXL",$JOB,"VALMCNT")=VALMCNT

               End DoDot:1

 +51      ;If the display list has not been saved, save it.

 +52       IF '$DATA(^TMP("PXRMLEXS",$JOB,TERM,CODESYS))

               MERGE ^TMP("PXRMLEXS",$JOB,TERM,CODESYS)=^TMP("PXRMLEXL",$JOB)

 +53      ;

 +54      ;Mark any entries that were previously selected.

 +55       SET ENUM=""

           SET (NSEL,NUID)=0

 +56       FOR

               SET ENUM=$ORDER(^TMP("PXRMLEXL",$JOB,"CODE",ENUM))

               IF ENUM=""

                   QUIT

               Begin DoDot:1

 +57               SET CODE=^TMP("PXRMLEXL",$JOB,"CODE",ENUM)

 +58               IF CODE'=""

                       IF $DATA(^TMP("PXRMCODES",$JOB,TERM,CODESYS,CODE))

                           Begin DoDot:2

 +59                           SET NSEL=NSEL+1

 +60                           SET UID=+^TMP("PXRMCODES",$JOB,TERM,CODESYS,CODE)

 +61                           IF UID

                                   SET NUID=NUID+1

 +62                           DO ADDSEL(ENUM,UID)

                           End DoDot:2

                           QUIT

               End DoDot:1

 +63       SET VALMHDR(2)=VALMHDR(2)_", "_NSEL_" are selected."

 +64       SET PXRMLEXV="ALL"

 +65       IF $DATA(PXRMBGS("ALL"))

               SET VALMBG=PXRMBGS("ALL")

 +66       QUIT

 +67      ;

 +68      ;=========================================

BLDSLIST  ;Build the Lexicon list, selected or UID codes only.

 +1        NEW CODE,CODESYS,CODESYSP,DONE,FMTSTR,IND,JND,KND

 +2        NEW NL,NSEL,NUID,OUTPUT,START,TERM,TEXT,UID

 +3        SET FMTSTR=$$LMFMTSTR^PXRMTEXT(.VALMDDF,"RLLLL")

 +4       ;^TMP("PXRMLEXTC",$J) nodes are set in PXRMTXSM which calls this

 +5       ;List Manager selection.

 +6       ;Clear the display.

 +7        DO KILL^VALM10

 +8        KILL ^TMP("PXRMLEXL",$JOB)

 +9        SET CODESYS=^TMP("PXRMLEXTC",$JOB,"CODESYS")

 +10      ;DBIA #5679

 +11       SET CODESYSP=$$CSYS^LEXU(CODESYS)

 +12       SET TERM=^TMP("PXRMLEXTC",$JOB,"LEX TERM")

 +13       SET TEXT=^TMP("PXRMLEXTC",$JOB,"LEX TERM")

 +14       SET TEXT=$SELECT(($LENGTH(TEXT)'>66):TEXT,1:$EXTRACT(TEXT,1,63)_"...")

 +15      ;Get the entries that were previously selected.

 +16       SET NLINES=^TMP("PXRMTEXT",$JOB,TERM,CODESYS,"NLINES")

 +17       SET (NSEL,NUID,VALMCNT)=0

 +18       FOR IND=1:1:NLINES

               Begin DoDot:1

 +19               SET TEMP=^TMP("PXRMTEXT",$JOB,TERM,CODESYS,"TEXT",IND)

 +20               SET CODE=$PIECE(TEMP,U,2)

 +21               IF (CODE'="")

                       IF '$DATA(^TMP("PXRMCODES",$JOB,TERM,CODESYS,CODE))

                           QUIT

 +22      ;Skip additional activation/inactivation lines for non-selected codes.

 +23               IF CODE=""

                       QUIT

 +24               IF CODE'=""

                       SET UID=^TMP("PXRMCODES",$JOB,TERM,CODESYS,CODE)

 +25               IF UID

                       SET NUID=NUID+1

 +26               SET NSEL=NSEL+1

 +27               SET ^TMP("PXRMLEXL",$JOB,"CODE",NSEL)=CODE

                   SET START=VALMCNT+1

 +28               SET TEXT=NSEL_U_CODE_U_$PIECE(TEMP,U,3,5)

 +29               DO FORMAT(TEXT,FMTSTR,.NL,.OUTPUT)

 +30               FOR JND=1:1:NL

                       Begin DoDot:2

 +31                       SET VALMCNT=VALMCNT+1

                           SET ^TMP("PXRMLEXL",$JOB,VALMCNT,0)=OUTPUT(JND)

 +32                       SET ^TMP("PXRMLEXL",$JOB,"IDX",VALMCNT,NSEL)=""

                       End DoDot:2

 +33      ;S ^TMP("PXRMLEXL",$J,"LINES",NSEL)=START_U_VALMCNT

 +34      ;D ADDSEL(NSEL,UID)

 +35      ;Check for additional activation/inactivation lines.

 +36               SET KND=IND

 +37               SET DONE=$SELECT(IND<NLINES:0,1:1)

 +38               FOR

                       IF DONE

                           QUIT

                       Begin DoDot:2

 +39                       SET KND=KND+1

 +40                       SET TEMP=^TMP("PXRMTEXT",$JOB,TERM,CODESYS,"TEXT",KND)

 +41                       IF $PIECE(TEMP,U,2)'=""

                               SET DONE=1

                               QUIT

 +42                       IF KND=NLINES

                               SET DONE=1

 +43                       SET IND=KND

 +44                       DO FORMAT(TEMP,FMTSTR,.NL,.OUTPUT)

 +45                       FOR JND=1:1:NL

                               Begin DoDot:3

 +46                               SET VALMCNT=VALMCNT+1

                                   SET ^TMP("PXRMLEXL",$JOB,VALMCNT,0)=OUTPUT(JND)

 +47                               SET ^TMP("PXRMLEXL",$JOB,"IDX",VALMCNT,NSEL)=""

                               End DoDot:3

                       End DoDot:2

 +48               SET ^TMP("PXRMLEXL",$JOB,"LINES",NSEL)=START_U_VALMCNT

 +49               DO ADDSEL(NSEL,UID)

               End DoDot:1

 +50       SET ^TMP("PXRMLEXL",$JOB,"NCODES")=NSEL

 +51       SET ^TMP("PXRMLEXL",$JOB,"VALMCNT")=VALMCNT

 +52       SET VALMHDR(1)="Term/Code: "_TERM

 +53       SET VALMHDR(2)="Selected "_$PIECE(CODESYSP,U,4)_": "_NSEL_" selected codes, "_NUID_" UID codes."

 +54       SET PXRMLEXV="SEL"

 +55       SET VALMBG=$SELECT($DATA(PXRMBGS("SEL")):PXRMBGS("SEL"),1:1)

 +56       QUIT

 +57      ;

 +58      ;=========================================

CPLIST(TAXIEN,TERM,CODESYS,NCODES,NLINES,TEXT) ;Build the list for a copy from

 +1       ;a range list of codes.

 +2        NEW ACTDT,CODE,DATA,INACTDT,NUM,SDESC,TEMP

 +3        SET CODE=""

           SET (NCODES,NLINES)=0

 +4        FOR

               SET CODE=$ORDER(^TMP("PXRMCODES",$JOB,TERM,CODESYS,CODE))

               IF CODE=""

                   QUIT

               Begin DoDot:1

 +5                KILL DATA

 +6       ;DBIA #1997, #3991

 +7                IF CODESYS="CPC"

                       DO PERIOD^ICPTAPIU(CODE,.DATA)

 +8                IF CODESYS="CPT"

                       DO PERIOD^ICPTAPIU(CODE,.DATA)

 +9                IF CODESYS="ICD"

                       DO PERIOD^ICDAPIU(CODE,.DATA)

 +10               IF CODESYS="ICP"

                       DO PERIOD^ICDAPIU(CODE,.DATA)

 +11               IF +DATA(0)=-1

                       QUIT

 +12               SET NCODES=NCODES+1

 +13               SET (ACTDT,NUM)=0

 +14               FOR

                       SET ACTDT=$ORDER(DATA(ACTDT))

                       IF ACTDT=""

                           QUIT

                       Begin DoDot:2

 +15                       SET TEMP=DATA(ACTDT)

 +16                       SET NUM=NUM+1

 +17                       SET INACTDT=$PIECE(TEMP,U,1)

 +18                       SET SDESC=$PIECE(TEMP,U,2)

 +19                       SET NLINES=NLINES+1

 +20                       IF NUM=1

                               SET TEXT(NLINES)=NCODES_U_CODE_U_ACTDT_U_INACTDT_U_SDESC

 +21                      IF '$TEST

                               SET TEXT(NLINES)=U_U_ACTDT_U_INACTDT_U_SDESC

                       End DoDot:2

               End DoDot:1

 +22       QUIT

 +23      ;

 +24      ;=========================================

ENTRY     ;Entry code

 +1        DO INITMPG^PXRMLEXL

 +2        DO BLDLIST^PXRMLEXL

 +3        DO XQORM

 +4        QUIT

 +5       ;

 +6       ;=========================================

EXIT      ;Exit code

 +1        DO INITMPG^PXRMLEXL

 +2        DO FULL^VALM1

 +3        DO CLEAN^VALM10

 +4        DO KILL^VALM10

 +5        DO CLEAR^VALM1

 +6        SET VALMBCK="Q"

 +7        QUIT

 +8       ;

 +9       ;=========================================

EXITS     ;Exit and save action.

 +1        DO SAVE^PXRMLEXL

 +2        SET VALMBCK="Q"

 +3        QUIT

 +4       ;

 +5       ;=========================================

FORMAT(TEXT,FMTSTR,NL,OUTPUT) ;Format  entry number, code,

 +1       ;activation date, inactivation date, short text for LM display.

 +2        NEW ACTDT,INACTDT

 +3        SET ACTDT=$PIECE(TEXT,U,3)

           SET INACTDT=$PIECE(TEXT,U,4)

 +4        SET ACTDT=$$FMTE^XLFDT(ACTDT,5)

 +5        SET INACTDT=$$FMTE^XLFDT(INACTDT,5)

 +6        SET $PIECE(TEXT,U,3)=ACTDT

           SET $PIECE(TEXT,U,4)=INACTDT

 +7        DO COLFMT^PXRMTEXT(FMTSTR,TEXT," ",.NL,.OUTPUT)

 +8        QUIT

 +9       ;

 +10      ;=========================================

GETLIST(LIST) ;Let the user input a list of items.

 +1        NEW INUM,ITEM,LEND,LELEM,NCODES,LSTART,X,Y

 +2        SET NCODES=+$GET(^TMP("PXRMLEXL",$JOB,"NCODES"))

 +3        IF NCODES=0

               QUIT

 +4        IF NCODES=1

               SET LIST(1)=""

               QUIT

 +5        SET DIR(0)="LC^1:"_NCODES

 +6        DO ^DIR

 +7        IF $EXTRACT(Y,1)="^"

               QUIT

 +8       ;Populate the list.

 +9        FOR INUM=1:1:($LENGTH(Y,",")-1)

               Begin DoDot:1

 +10               SET LELEM=$PIECE(Y,",",INUM)

 +11               IF LELEM?1.N

                       SET LIST(LELEM)=""

 +12               SET LSTART=$PIECE(LELEM,"-",1)

                   SET LEND=$PIECE(LELEM,"-",2)

 +13               FOR ITEM=LSTART:1:LEND

                       SET LIST(ITEM)=""

               End DoDot:1

 +14       QUIT

 +15      ;

 +16      ;=========================================

HDR       ; Header code

 +1        SET VALMHDR(1)="Select Lexicon items to include in the taxonomy."

 +2        SET VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"

 +3        QUIT

 +4       ;

 +5       ;=========================================

HELP      ;Display help.

 +1        DO HELP^BPXRMEXT

 +2        QUIT

 +3       ;

 +4       ;=========================================

HLITE(ENUM,MODE,UID) ;Highlight/unhighlight an entry. MODE=1 turns on

 +1       ;highlighting, MODE=0 turns it off.

 +2        NEW LINE,START,STOP,VCTRL

 +3        SET VCTRL=$SELECT(MODE=1:IOINHI,1:IOINORM)

 +4        SET START=$PIECE(^TMP("PXRMLEXL",$JOB,"LINES",ENUM),U,1)

 +5        SET STOP=$PIECE(^TMP("PXRMLEXL",$JOB,"LINES",ENUM),U,2)

 +6        FOR LINE=START:1:STOP

               DO CNTRL^VALM10(LINE,1,80,VCTRL,IOINORM)

 +7       ;If the entry is marked Use In Dialog turn on marker.

 +8        IF MODE=1

               IF UID=1

                   DO FLDCTRL^VALM10(START,"CODE",IORVON,IORVOFF,"")

 +9        IF MODE=0

               DO FLDCTRL^VALM10(START,"CODE",IORVOFF,IORVOFF,"")

 +10       QUIT

 +11      ;

 +12      ;=========================================

IMPLIST(TAXIEN,TERM,CODESYS,NCODES,NLINES,TEXT) ;Build the list for an

 +1       ;imported set of codes.

 +2        DO IMPLIST^BPXRMEXT(TAXIEN,TERM,CODESYS,.NCODES,.NLINES,.TEXT)

 +3        QUIT

 +4       ;

 +5       ;=========================================

INCL      ;Put the selected entries on the selected list and highlight them.

 +1        NEW SEL,SELLIST

 +2       ;Get the list.

 +3        DO GETLIST(.SELLIST)

 +4       ;If there is no list quit.

 +5        IF '$DATA(SELLIST)

               QUIT

 +6        SET SEL=""

 +7        FOR

               SET SEL=$ORDER(SELLIST(SEL))

               IF SEL=""

                   QUIT

               DO ADDSEL(SEL,"")

 +8        SET VALMBCK="R"

 +9        QUIT

 +10      ;

 +11      ;=========================================

INCX(LIST,UID) ;Put the selected entries on the selected list and highlight

 +1       ;them.

 +2        NEW ENUM,IND

 +3        FOR IND=1:1:$LENGTH(LIST,",")

               Begin DoDot:1

 +4                SET ENUM=$PIECE(LIST,",",IND)

 +5                DO ADDSEL(ENUM,UID)

               End DoDot:1

 +6        QUIT

 +7       ;

 +8       ;=========================================

INITMPG   ;Initialize all the ^TMP globals.

 +1        KILL ^TMP("PXRMLEXL",$JOB)

 +2        QUIT

 +3       ;

 +4       ;=========================================

LEXLIST(TAXIEN,TERM,CODESYS,NCODES,NLINES,TEXT) ;Call Lexicon to get the list

 +1       ;of codes.

 +2        IF $EXTRACT(TERM,1,9)="Copy from"

               DO CPLIST(TAXIEN,TERM,CODESYS,.NCODES,.NLINES,.TEXT)

               QUIT

 +3        IF TERM["(imported)"

               DO IMPLIST(TAXIEN,TERM,CODESYS,.NCODES,.NLINES,.TEXT)

               QUIT

 +4        NEW ACTDT,CODE,CODEI,INACTDT,IND,NUM

 +5        NEW RESULT,SRC,SDESC,TEMP

 +6        WRITE @IOF,"Searching Lexicon ..."

 +7        KILL ^TMP("LEXTAX",$JOB)

 +8       ;DBIA #5681

 +9        SET RESULT=$$TAX^LEX10CS(TERM,CODESYS,DT,"LEXTAX",0)

 +10       SET NCODES=+RESULT

 +11       IF NCODES=-1

               SET (NCODES,NLINES)=0

               KILL ^TMP("LEXTAX",$JOB)

               QUIT

 +12       SET SRC=+$ORDER(^TMP("LEXTAX",$JOB,0))

 +13       IF CODESYS="SCT"

               DO SCTDESC("LEXTAX")

 +14       SET CODEI=""

           SET (NLINES,NUM)=0

 +15       FOR

               SET CODEI=$ORDER(^TMP("LEXTAX",$JOB,SRC,CODEI))

               IF CODEI=""

                   QUIT

               Begin DoDot:1

 +16               SET NUM=NUM+1

                   SET IND=0

 +17               FOR

                       SET IND=$ORDER(^TMP("LEXTAX",$JOB,SRC,CODEI,IND))

                       IF IND=""

                           QUIT

                       Begin DoDot:2

 +18                       SET TEMP=^TMP("LEXTAX",$JOB,SRC,CODEI,IND)

 +19                       SET ACTDT=$PIECE(TEMP,U,1)

                           SET INACTDT=$PIECE(TEMP,U,2)

 +20                       SET TEMP=^TMP("LEXTAX",$JOB,SRC,CODEI,IND,0)

 +21                       SET CODE=$PIECE(TEMP,U,1)

                           SET SDESC=$PIECE(TEMP,U,2)

 +22                       SET NLINES=NLINES+1

 +23                       IF IND=1

                               SET TEXT(NLINES)=NUM_U_CODE_U_ACTDT_U_INACTDT_U_SDESC

 +24                      IF '$TEST

                               SET TEXT(NLINES)=U_U_ACTDT_U_INACTDT_U_SDESC

                       End DoDot:2

               End DoDot:1

 +25       KILL ^TMP("LEXTAX",$JOB)

 +26       QUIT

 +27      ;

 +28      ;=========================================

PEXIT     ; Protocol exit code

 +1        SET VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"

 +2       ;Reset after page up/down etc

 +3        DO XQORM

 +4        QUIT

 +5       ;

 +6       ;=========================================

RFD(ENUM) ;Remove UID from the selected entry.

 +1        NEW START

 +2        SET $PIECE(^TMP("PXRMLEXL",$JOB,"SELECTED",ENUM),U,2)=0

 +3        SET START=$PIECE(^TMP("PXRMLEXL",$JOB,"LINES",ENUM),U,1)

 +4        DO FLDCTRL^VALM10(START,"CODE",IORVOFF,IORVOFF,"")

 +5        QUIT

 +6       ;

 +7       ;=========================================

RFDL      ;Remove UID from the selected entries.

 +1        NEW SEL,SELLIST

 +2       ;Get the list.

 +3        DO GETLIST(.SELLIST)

 +4       ;If there is no list quit.

 +5        IF '$DATA(SELLIST)

               QUIT

 +6        SET SEL=""

 +7        FOR

               SET SEL=$ORDER(SELLIST(SEL))

               IF SEL=""

                   QUIT

               DO RFD(SEL)

 +8        SET VALMBCK="R"

 +9        QUIT

 +10      ;

 +11      ;=========================================

RFDX(LIST) ;Remove UID from the selected entries.

 +1        NEW ENUM,IND

 +2        FOR IND=1:1:$LENGTH(LIST,",")

               Begin DoDot:1

 +3                SET ENUM=$PIECE(LIST,",",IND)

 +4                DO RFD(ENUM)

               End DoDot:1

 +5        QUIT

 +6       ;

 +7       ;=========================================

RFT(ENUM) ;Remove entry ENUM from the selected list and unhighlight it.

 +1        KILL ^TMP("PXRMLEXL",$JOB,"SELECTED",ENUM)

 +2        DO HLITE(ENUM,0,0)

 +3        QUIT

 +4       ;

 +5       ;=========================================

RFTL      ;Remove the selected entries from the selected list and unhighlight them.

 +1        NEW SEL,SELLIST

 +2       ;Get the list.

 +3        DO GETLIST(.SELLIST)

 +4       ;If there is no list quit.

 +5        IF '$DATA(SELLIST)

               QUIT

 +6        SET SEL=""

 +7        FOR

               SET SEL=$ORDER(SELLIST(SEL))

               IF SEL=""

                   QUIT

               DO RFT(SEL)

 +8        SET VALMBCK="R"

 +9        QUIT

 +10      ;

 +11      ;=========================================

RFTX(LIST) ;Remove the selected entries from the selected list and unhighlight

 +1       ;them.

 +2        NEW ENUM,IND

 +3        FOR IND=1:1:$LENGTH(LIST,",")

               Begin DoDot:1

 +4                SET ENUM=$PIECE(LIST,",",IND)

 +5                DO RFT(ENUM)

               End DoDot:1

 +6        QUIT

 +7       ;

 +8       ;=========================================

SAVE      ;Save the selected entries in the taxonomy.

 +1        NEW CODE,CODESYS,ENUM,TEMP,TERM,UID

 +2       ;^TMP("PXRMLEXTC",$J) nodes are set in PXRMTXSM which calls this

 +3       ;List Manager selection.

 +4        SET CODESYS=^TMP("PXRMLEXTC",$JOB,"CODESYS")

 +5        SET TERM=^TMP("PXRMLEXTC",$JOB,"LEX TERM")

 +6        KILL ^TMP("PXRMCODES",$JOB,TERM,CODESYS)

 +7       ;Mark this coding system as having been edited so it is not reloaded

 +8       ;from the taxonomy in CODELIST^PXRMTXSM.

 +9        SET ^TMP("PXRMCODES",$JOB,TERM,CODESYS)=""

 +10       SET ENUM=0

           SET NSEL=0

 +11       FOR

               SET ENUM=$ORDER(^TMP("PXRMLEXL",$JOB,"SELECTED",ENUM))

               IF ENUM=""

                   QUIT

               Begin DoDot:1

 +12               SET TEMP=^TMP("PXRMLEXL",$JOB,"SELECTED",ENUM)

 +13               SET CODE=$PIECE(TEMP,U,1)

                   SET UID=$PIECE(TEMP,U,2)

 +14               SET ^TMP("PXRMCODES",$JOB,TERM,CODESYS,CODE)=UID

               End DoDot:1

 +15       SET VALMBCK="R"

 +16       QUIT

 +17      ;

 +18      ;=========================================

SCTDESC(NODE) ;Append the SNOMED hierarchy to the description and then

 +1       ;sort the list by description.

 +2        DO SCTDESC^BPXRMEXT(NODE)

 +3        QUIT

 +4       ;

 +5       ;=========================================

UIDL      ;Mark selected entries as UID.

 +1        NEW SEL,SELLIST

 +2       ;Get the list.

 +3        DO GETLIST(.SELLIST)

 +4       ;If there is no list quit.

 +5        IF '$DATA(SELLIST)

               QUIT

 +6        SET SEL=""

 +7        FOR

               SET SEL=$ORDER(SELLIST(SEL))

               IF SEL=""

                   QUIT

               DO ADDSEL(SEL,1)

 +8        SET VALMBCK="R"

 +9        QUIT

 +10      ;

 +11      ;=========================================

UIDOK()   ;Check the coding system to determine if it can be used in a dialog.

 +1       ;IHS/MSC/MGH ICD and SNOMEDs turned off to be used in dialogs P1005

 +2        NEW CODESYS

 +3        SET CODESYS=^TMP("PXRMLEXTC",$JOB,"CODESYS")

 +4       ;I CODESYS="10D" Q 1

 +5        IF CODESYS="CPC"

               QUIT 1

 +6        IF CODESYS="CPT"

               QUIT 1

 +7       ;I CODESYS="ICD" Q 1

 +8       ;I CODESYS="SCT" Q 1

 +9        SET (XQORQUIT,XQORPOP)=1

 +10       QUIT 0

 +11      ;

 +12      ;=========================================

VIEW()    ;Select the view.

 +1        SET VALMBCK="R"

 +2        QUIT

 +3       ;I PXRMLEXV="ALL" S PXRMBGS("ALL")=VALMBG D BLDSLIST Q

 +4       ;I PXRMLEXV="SEL" S PXRMBGS("SEL")=VALMBG D BLDLIST Q

 +5       ;Q

 +6       ;

 +7       ;=========================================

XQORM     ; Set range for selection.

 +1        NEW NCODES

 +2        SET NCODES=+$GET(^TMP("PXRMLEXL",$JOB,"NCODES"))

 +3        IF NCODES=0

               QUIT

 +4        SET XQORM("#")=$ORDER(^ORD(101,"B","PXRM LEXICON SELECT ENTRY",0))_U_"1:"_NCODES

 +5        SET XQORM("A")="Select Action: "

 +6        QUIT

 +7       ;

 +8       ;=========================================

XSEL      ;Entry action for protocol PXRM LEXICON SELECT ENTRY.

 +1        DO XSEL^BPXRMEXT

 +2        QUIT

 +3       ;

PXRMLEXL.m