PXRMLEXL ;SLC/PKR - List Manager routines for Taxonomies and Lexicon. ;08/16/2018
;;2.0;CLINICAL REMINDERS;**26,47,42**;Feb 04, 2005;Build 245
;
;=========================================
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)
Q
;
;=========================================
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")
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)
I NSEL=1 S VALMHDR(2)=VALMHDR(2)_" "_NSEL_" is selected."
I NSEL>1 S VALMHDR(2)=VALMHDR(2)_" "_NSEL_" are selected."
S PXRMLEXV="ALL"
I $D(PXRMBGS("ALL")) S VALMBG=PXRMBGS("ALL")
Q
;
;=========================================
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
Q
;
;=========================================
ENTRY ;Entry code
D INITMPG^PXRMLEXL
D BLDLIST^PXRMLEXL
D XQORM^PXRMLEXL
Q
;
;=========================================
EXIT ;Exit code
D INITMPG^PXRMLEXL
D FULL^VALM1
D CLEAN^VALM10
D KILL^VALM10
D CLEAR^VALM1
S VALMBCK="Q"
Q
;
;=========================================
EXITS ;Exit and save action.
D SAVE^PXRMLEXL
S VALMBCK="Q"
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)
Q
;
;=========================================
GETLIST(LIST) ;Let the user input a list of items.
N DIR,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)=""
Q
;
;=========================================
HDR ; Header code
S VALMHDR(1)="Select Lexicon items to include in the taxonomy."
S VALMSG="+ Next Screen - Prev Screen ?? More Actions"
Q
;
;=========================================
HELP ;Display help.
N DDS,DIR0,DONE,IND,TEXT
;DBIA #5746 covers kill and set of DDS. DDS needs to be set or the
;Browser will kill some ScreenMan variables.
S DDS=1,DONE=0
F IND=1:1 Q:DONE D
. S TEXT(IND)=$P($T(HTEXT+IND),";",3,99)
. I TEXT(IND)="**End Text**" K TEXT(IND) S DONE=1 Q
D BROWSE^DDBR("TEXT","NR","Lexicon Selection Help")
S VALMBCK="R"
Q
;
;=========================================
HLITE(ENUM,MODE,UID) ;Highlight/un-highlight 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,"")
Q
;
;=========================================
HTEXT ;Lexicon selection help text.
;;Select one of the following actions:
;;
;; ADD - adds selected codes to the taxonomy.
;; RFT - removes selected codes from the taxonomy.
;; RFD - removes selected codes from being used in a dialog.
;; UID - adds selected codes to the taxonomy and marks them for use in a dialog.
;; SAVE - saves all selected codes. Even if codes have been selected, they will
;; not be stored until they are saved. Finally, a save must be done when
;; exiting the ScreenMan form or no changes will be saved.
;; EXIT - saves then exits.
;;
;;Some coding systems cannot be used in a dialog; in those cases, the RFD and UID
;;actions cannot be selected. Actions that cannot be selected have their text
;;description surrounded by parentheses. For example, when a coding system can be
;;used in a dialog, the UID action will look like this:
;; UID Use in dialog
;;When the coding system cannot be used in a dialog, it will look like this:
;; UID (Use in dialog)
;;
;;You can select the action first and then be prompted for a list of codes or
;;you can input the list and then select the action. Because of the way List
;;Manager works, you may be able to select a larger list by selecting the action
;;first.
;;
;;**End Text**
Q
;
;=========================================
IMPLIST(TAXIEN,TERM,CODESYS,NCODES,NLINES,TEXT) ;Build the list for an
;imported set of codes.
N ACTDT,CODE,DESC,INACTDT,NUM,PDATA,RESULT
S CODE="",(NCODES,NLINES)=0
F S CODE=$O(^TMP("PXRMCODES",$J,TERM,CODESYS,CODE)) Q:CODE="" D
. K PDATA
.;DBIA #5679
. S RESULT=$$PERIOD^LEXU(CODE,CODESYS,.PDATA)
. I +RESULT=-1 Q
. S NCODES=NCODES+1
. S (ACTDT,NUM)=0
. F S ACTDT=$O(PDATA(ACTDT)) Q:ACTDT="" D
.. S INACTDT=$P(PDATA(ACTDT),U,1)
.. S DESC=PDATA(ACTDT,0)
.. I CODESYS="SCT" S DESC=DESC_" "_$$SCTHIER^PXRMTXIN(CODE,ACTDT)
.. S NUM=NUM+1
.. S NLINES=NLINES+1
.. I NUM=1 S TEXT(NLINES)=NCODES_U_CODE_U_ACTDT_U_INACTDT_U_DESC
.. E S TEXT(NLINES)=U_U_ACTDT_U_INACTDT_U_DESC
Q
;
;=========================================
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"
Q
;
;=========================================
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)
Q
;
;=========================================
INITMPG ;Initialize all the ^TMP globals.
K ^TMP("PXRMLEXL",$J)
Q
;
;=========================================
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)
Q
;
;=========================================
PEXIT ; Protocol exit code
S VALMSG="+ Next Screen - Prev Screen ?? More Actions"
;Reset after page up/down etc
D XQORM^PXRMLEXL
Q
;
;=========================================
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,"")
Q
;
;=========================================
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"
Q
;
;=========================================
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)
Q
;
;=========================================
RFT(ENUM) ;Remove entry ENUM from the selected list and un-highlight it.
K ^TMP("PXRMLEXL",$J,"SELECTED",ENUM)
D HLITE(ENUM,0,0)
Q
;
;=========================================
RFTL ;Remove the selected entries from the selected list and un-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 RFT(SEL)
S VALMBCK="R"
Q
;
;=========================================
RFTX(LIST) ;Remove the selected entries from the selected list and un-highlight
;them.
N ENUM,IND
F IND=1:1:$L(LIST,",") D
. S ENUM=$P(LIST,",",IND)
. D RFT(ENUM)
Q
;
;=========================================
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"
Q
;
;=========================================
SCTDESC(NODE) ;Append the SNOMED hierarchy to the description and then
;sort the list by description.
N ACTDT,CODEI,CODE,DESC,FSN,HE,HIER,HS,NUM,SRC
K ^TMP($J,"DESC"),^TMP($J,"SORT")
S SRC=$O(^TMP(NODE,$J,0))
S CODEI=""
F S CODEI=$O(^TMP(NODE,$J,SRC,CODEI)) Q:CODEI="" D
. S ACTDT=$P(^TMP(NODE,$J,SRC,CODEI,1),U,1)
. S CODE=$P(^TMP(NODE,$J,SRC,CODEI,1,0),U,1)
. S DESC=$P(^TMP(NODE,$J,SRC,CODEI,1,0),U,2)
.;DBIA #5007
. S FSN=$$GETFSN^LEXTRAN1(SRC,CODE,ACTDT)
. S HS=$F(FSN,"(")
. S HE=$F(FSN,")",HS)
. S HIER=$E(FSN,HS-1,HE-1)
. S DESC=DESC_" "_HIER
. S ^TMP($J,"DESC",DESC,CODEI)=""
S DESC="",NUM=0
F S DESC=$O(^TMP($J,"DESC",DESC)) Q:DESC="" D
. S CODEI=""
. F S CODEI=$O(^TMP($J,"DESC",DESC,CODEI)) Q:CODEI="" D
.. S NUM=NUM+1
.. M ^TMP($J,"SORT",SRC,NUM)=^TMP(NODE,$J,SRC,CODEI)
.. S $P(^TMP($J,"SORT",SRC,NUM,1,0),U,2)=DESC
K ^TMP(NODE,$J)
M ^TMP(NODE,$J)=^TMP($J,"SORT")
K ^TMP($J,"DESC"),^TMP($J,"SORT")
Q
;
;=========================================
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"
Q
;
;=========================================
UIDOK() ;Check the coding system to determine if it can be used in a dialog.
N CODESYS,UIDOK
S CODESYS=^TMP("PXRMLEXTC",$J,"CODESYS")
S UIDOK=$$UIDOK^PXRMUID(CODESYS)
I UIDOK Q 1
S (XQORQUIT,XQORPOP)=1
Q 0
;
;=========================================
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: "
Q
;
;=========================================
XSEL ;Entry action for protocol PXRM LEXICON SELECT ENTRY.
N ENUM,IND,LIST,LVALID
S LIST=$P(XQORNOD(0),"=",2)
;Remove trailing ,
I $E(LIST,$L(LIST))="," S LIST=$E(LIST,1,$L(LIST)-1)
S LVALID=1
F IND=1:1:$L(LIST,",") D
. S ENUM=$P(LIST,",",IND)
. I (ENUM<1)!(ENUM>VALMCNT)!('$D(^TMP("PXRMLEXL",$J,"LINES",ENUM))) D
.. W !,ENUM," is not a valid selection."
.. W !,"The range is 1 to ",$O(^TMP("PXRMLEXL",$J,"LINES",""),-1),"."
.. H 2
.. S LVALID=0
I 'LVALID S VALMBCK="R" Q
;
;Full screen mode
D FULL^VALM1
;
;Possible actions.
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,OPTION,X,Y
S DIR(0)="SBM"_U_"ADD:Add to taxonomy;"
S DIR(0)=DIR(0)_"RFT:Remove from taxonomy;"
I $$UIDOK D
. S DIR(0)=DIR(0)_"RFD:Remove from dialog;"
. S DIR(0)=DIR(0)_"UID:Use in dialog;"
S DIR("A")="Select Action: "
S DIR("B")="ADD"
S DIR("?")="Select from the actions displayed."
D ^DIR
I $D(DIROUT)!$D(DIRUT) S VALMBCK="R" Q
I $D(DTOUT)!$D(DUOUT) S VALMBCK="R" Q
S OPTION=Y
D CLEAR^VALM1
;
I OPTION="ADD" D INCX^PXRMLEXL(.LIST,0)
I OPTION="RFD" D RFDX^PXRMLEXL(.LIST)
I OPTION="RFT" D RFTX^PXRMLEXL(.LIST)
I OPTION="UID" D INCX^PXRMLEXL(.LIST,1)
;
S VALMBCK="R"
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMLEXL 16309 printed Dec 13, 2024@01:46:24 Page 2
PXRMLEXL ;SLC/PKR - List Manager routines for Taxonomies and Lexicon. ;08/16/2018
+1 ;;2.0;CLINICAL REMINDERS;**26,47,42**;Feb 04, 2005;Build 245
+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 IF '$DATA(^TMP("PXRMLEXS",$JOB,TERM,CODESYS))
Begin DoDot:1
+13 DO LEXLIST(TAXIEN,TERM,CODESYS,.NCODES,.NLINES,.TEXT)
+14 MERGE ^TMP("PXRMTEXT",$JOB,TERM,CODESYS,"TEXT")=TEXT
+15 SET ^TMP("PXRMTEXT",$JOB,TERM,CODESYS,"NCODES")=NCODES
+16 SET ^TMP("PXRMTEXT",$JOB,TERM,CODESYS,"NLINES")=NLINES
End DoDot:1
+17 IF $DATA(^TMP("PXRMTEXT",$JOB,TERM,CODESYS))
Begin DoDot:1
+18 SET NCODES=^TMP("PXRMTEXT",$JOB,TERM,CODESYS,"NCODES")
+19 SET NLINES=^TMP("PXRMTEXT",$JOB,TERM,CODESYS,"NLINES")
End DoDot:1
+20 ;Get the coding system Lexicon information for building the display.
+21 ;DBIA #5679
+22 SET CODESYSP=$$CSYS^LEXU(CODESYS)
+23 SET TEXT=^TMP("PXRMLEXTC",$JOB,"LEX TERM")
+24 SET TEXT=$SELECT(($LENGTH(TEXT)'>66):TEXT,1:$EXTRACT(TEXT,1,63)_"...")
+25 SET VALMHDR(1)="Term/Code: "_TEXT
+26 SET VALMHDR(2)=NCODES_" "_$PIECE(CODESYSP,U,4)_$SELECT(NCODES=1:" code was found",1:" codes were found")
+27 IF NCODES=1
IF '$$UIDOK
SET VALMHDR(2)=VALMHDR(2)_", it cannot be used in a dialog."
+28 IF NCODES>1
IF '$$UIDOK
SET VALMHDR(2)=VALMHDR(2)_", these cannot be used in a dialog."
+29 ;Set these so LM shows Page 1 of 1 when there are no codes.
+30 IF NCODES=0
SET VALMHDR(2)=VALMHDR(2)_"."
SET ^TMP("PXRMLEXL",$JOB,1,0)=""
SET VALMCNT=1
QUIT
+31 ;
+32 ;If the display list has been saved restore it, if not build it.
+33 IF $DATA(^TMP("PXRMLEXS",$JOB,TERM,CODESYS))
Begin DoDot:1
+34 MERGE ^TMP("PXRMLEXL",$JOB)=^TMP("PXRMLEXS",$JOB,TERM,CODESYS)
+35 SET VALMCNT=^TMP("PXRMLEXS",$JOB,TERM,CODESYS,"VALMCNT")
End DoDot:1
+36 IF '$DATA(^TMP("PXRMLEXS",$JOB,TERM,CODESYS))
Begin DoDot:1
+37 SET VALMCNT=0
+38 FOR IND=1:1:NLINES
Begin DoDot:2
+39 SET NUM=$PIECE(TEXT(IND),U,1)
SET CODE=$PIECE(TEXT(IND),U,2)
+40 IF NUM'=""
IF CODE'=""
SET ENUM=NUM
SET ^TMP("PXRMLEXL",$JOB,"CODE",NUM)=CODE
SET START=VALMCNT+1
+41 DO FORMAT(TEXT(IND),FMTSTR,.NL,.OUTPUT)
+42 FOR JND=1:1:NL
Begin DoDot:3
+43 SET VALMCNT=VALMCNT+1
SET ^TMP("PXRMLEXL",$JOB,VALMCNT,0)=OUTPUT(JND)
+44 SET ^TMP("PXRMLEXL",$JOB,"IDX",VALMCNT,ENUM)=""
End DoDot:3
+45 SET ^TMP("PXRMLEXL",$JOB,"LINES",ENUM)=START_U_VALMCNT
End DoDot:2
+46 SET ^TMP("PXRMLEXL",$JOB,"NCODES")=NCODES
+47 SET ^TMP("PXRMLEXL",$JOB,"VALMCNT")=VALMCNT
End DoDot:1
+48 ;If the display list has not been saved, save it.
+49 IF '$DATA(^TMP("PXRMLEXS",$JOB,TERM,CODESYS))
MERGE ^TMP("PXRMLEXS",$JOB,TERM,CODESYS)=^TMP("PXRMLEXL",$JOB)
+50 ;
+51 ;Mark any entries that were previously selected.
+52 SET ENUM=""
SET (NSEL,NUID)=0
+53 FOR
SET ENUM=$ORDER(^TMP("PXRMLEXL",$JOB,"CODE",ENUM))
if ENUM=""
QUIT
Begin DoDot:1
+54 SET CODE=^TMP("PXRMLEXL",$JOB,"CODE",ENUM)
+55 IF CODE'=""
IF $DATA(^TMP("PXRMCODES",$JOB,TERM,CODESYS,CODE))
Begin DoDot:2
+56 SET NSEL=NSEL+1
+57 SET UID=+^TMP("PXRMCODES",$JOB,TERM,CODESYS,CODE)
+58 IF UID
SET NUID=NUID+1
+59 DO ADDSEL(ENUM,UID)
End DoDot:2
QUIT
End DoDot:1
+60 IF NSEL=1
SET VALMHDR(2)=VALMHDR(2)_" "_NSEL_" is selected."
+61 IF NSEL>1
SET VALMHDR(2)=VALMHDR(2)_" "_NSEL_" are selected."
+62 SET PXRMLEXV="ALL"
+63 IF $DATA(PXRMBGS("ALL"))
SET VALMBG=PXRMBGS("ALL")
+64 QUIT
+65 ;
+66 ;=========================================
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^PXRMLEXL
+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 DIR,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 NEW DDS,DIR0,DONE,IND,TEXT
+2 ;DBIA #5746 covers kill and set of DDS. DDS needs to be set or the
+3 ;Browser will kill some ScreenMan variables.
+4 SET DDS=1
SET DONE=0
+5 FOR IND=1:1
if DONE
QUIT
Begin DoDot:1
+6 SET TEXT(IND)=$PIECE($TEXT(HTEXT+IND),";",3,99)
+7 IF TEXT(IND)="**End Text**"
KILL TEXT(IND)
SET DONE=1
QUIT
End DoDot:1
+8 DO BROWSE^DDBR("TEXT","NR","Lexicon Selection Help")
+9 SET VALMBCK="R"
+10 QUIT
+11 ;
+12 ;=========================================
HLITE(ENUM,MODE,UID) ;Highlight/un-highlight 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 ;=========================================
HTEXT ;Lexicon selection help text.
+1 ;;Select one of the following actions:
+2 ;;
+3 ;; ADD - adds selected codes to the taxonomy.
+4 ;; RFT - removes selected codes from the taxonomy.
+5 ;; RFD - removes selected codes from being used in a dialog.
+6 ;; UID - adds selected codes to the taxonomy and marks them for use in a dialog.
+7 ;; SAVE - saves all selected codes. Even if codes have been selected, they will
+8 ;; not be stored until they are saved. Finally, a save must be done when
+9 ;; exiting the ScreenMan form or no changes will be saved.
+10 ;; EXIT - saves then exits.
+11 ;;
+12 ;;Some coding systems cannot be used in a dialog; in those cases, the RFD and UID
+13 ;;actions cannot be selected. Actions that cannot be selected have their text
+14 ;;description surrounded by parentheses. For example, when a coding system can be
+15 ;;used in a dialog, the UID action will look like this:
+16 ;; UID Use in dialog
+17 ;;When the coding system cannot be used in a dialog, it will look like this:
+18 ;; UID (Use in dialog)
+19 ;;
+20 ;;You can select the action first and then be prompted for a list of codes or
+21 ;;you can input the list and then select the action. Because of the way List
+22 ;;Manager works, you may be able to select a larger list by selecting the action
+23 ;;first.
+24 ;;
+25 ;;**End Text**
+26 QUIT
+27 ;
+28 ;=========================================
IMPLIST(TAXIEN,TERM,CODESYS,NCODES,NLINES,TEXT) ;Build the list for an
+1 ;imported set of codes.
+2 NEW ACTDT,CODE,DESC,INACTDT,NUM,PDATA,RESULT
+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 PDATA
+6 ;DBIA #5679
+7 SET RESULT=$$PERIOD^LEXU(CODE,CODESYS,.PDATA)
+8 IF +RESULT=-1
QUIT
+9 SET NCODES=NCODES+1
+10 SET (ACTDT,NUM)=0
+11 FOR
SET ACTDT=$ORDER(PDATA(ACTDT))
if ACTDT=""
QUIT
Begin DoDot:2
+12 SET INACTDT=$PIECE(PDATA(ACTDT),U,1)
+13 SET DESC=PDATA(ACTDT,0)
+14 IF CODESYS="SCT"
SET DESC=DESC_" "_$$SCTHIER^PXRMTXIN(CODE,ACTDT)
+15 SET NUM=NUM+1
+16 SET NLINES=NLINES+1
+17 IF NUM=1
SET TEXT(NLINES)=NCODES_U_CODE_U_ACTDT_U_INACTDT_U_DESC
+18 IF '$TEST
SET TEXT(NLINES)=U_U_ACTDT_U_INACTDT_U_DESC
End DoDot:2
End DoDot:1
+19 QUIT
+20 ;
+21 ;=========================================
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^PXRMLEXL
+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 un-highlight 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 un-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 RFT(SEL)
+8 SET VALMBCK="R"
+9 QUIT
+10 ;
+11 ;=========================================
RFTX(LIST) ;Remove the selected entries from the selected list and un-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 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 NEW ACTDT,CODEI,CODE,DESC,FSN,HE,HIER,HS,NUM,SRC
+3 KILL ^TMP($JOB,"DESC"),^TMP($JOB,"SORT")
+4 SET SRC=$ORDER(^TMP(NODE,$JOB,0))
+5 SET CODEI=""
+6 FOR
SET CODEI=$ORDER(^TMP(NODE,$JOB,SRC,CODEI))
if CODEI=""
QUIT
Begin DoDot:1
+7 SET ACTDT=$PIECE(^TMP(NODE,$JOB,SRC,CODEI,1),U,1)
+8 SET CODE=$PIECE(^TMP(NODE,$JOB,SRC,CODEI,1,0),U,1)
+9 SET DESC=$PIECE(^TMP(NODE,$JOB,SRC,CODEI,1,0),U,2)
+10 ;DBIA #5007
+11 SET FSN=$$GETFSN^LEXTRAN1(SRC,CODE,ACTDT)
+12 SET HS=$FIND(FSN,"(")
+13 SET HE=$FIND(FSN,")",HS)
+14 SET HIER=$EXTRACT(FSN,HS-1,HE-1)
+15 SET DESC=DESC_" "_HIER
+16 SET ^TMP($JOB,"DESC",DESC,CODEI)=""
End DoDot:1
+17 SET DESC=""
SET NUM=0
+18 FOR
SET DESC=$ORDER(^TMP($JOB,"DESC",DESC))
if DESC=""
QUIT
Begin DoDot:1
+19 SET CODEI=""
+20 FOR
SET CODEI=$ORDER(^TMP($JOB,"DESC",DESC,CODEI))
if CODEI=""
QUIT
Begin DoDot:2
+21 SET NUM=NUM+1
+22 MERGE ^TMP($JOB,"SORT",SRC,NUM)=^TMP(NODE,$JOB,SRC,CODEI)
+23 SET $PIECE(^TMP($JOB,"SORT",SRC,NUM,1,0),U,2)=DESC
End DoDot:2
End DoDot:1
+24 KILL ^TMP(NODE,$JOB)
+25 MERGE ^TMP(NODE,$JOB)=^TMP($JOB,"SORT")
+26 KILL ^TMP($JOB,"DESC"),^TMP($JOB,"SORT")
+27 QUIT
+28 ;
+29 ;=========================================
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 NEW CODESYS,UIDOK
+2 SET CODESYS=^TMP("PXRMLEXTC",$JOB,"CODESYS")
+3 SET UIDOK=$$UIDOK^PXRMUID(CODESYS)
+4 IF UIDOK
QUIT 1
+5 SET (XQORQUIT,XQORPOP)=1
+6 QUIT 0
+7 ;
+8 ;=========================================
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 NEW ENUM,IND,LIST,LVALID
+2 SET LIST=$PIECE(XQORNOD(0),"=",2)
+3 ;Remove trailing ,
+4 IF $EXTRACT(LIST,$LENGTH(LIST))=","
SET LIST=$EXTRACT(LIST,1,$LENGTH(LIST)-1)
+5 SET LVALID=1
+6 FOR IND=1:1:$LENGTH(LIST,",")
Begin DoDot:1
+7 SET ENUM=$PIECE(LIST,",",IND)
+8 IF (ENUM<1)!(ENUM>VALMCNT)!('$DATA(^TMP("PXRMLEXL",$JOB,"LINES",ENUM)))
Begin DoDot:2
+9 WRITE !,ENUM," is not a valid selection."
+10 WRITE !,"The range is 1 to ",$ORDER(^TMP("PXRMLEXL",$JOB,"LINES",""),-1),"."
+11 HANG 2
+12 SET LVALID=0
End DoDot:2
End DoDot:1
+13 IF 'LVALID
SET VALMBCK="R"
QUIT
+14 ;
+15 ;Full screen mode
+16 DO FULL^VALM1
+17 ;
+18 ;Possible actions.
+19 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,OPTION,X,Y
+20 SET DIR(0)="SBM"_U_"ADD:Add to taxonomy;"
+21 SET DIR(0)=DIR(0)_"RFT:Remove from taxonomy;"
+22 IF $$UIDOK
Begin DoDot:1
+23 SET DIR(0)=DIR(0)_"RFD:Remove from dialog;"
+24 SET DIR(0)=DIR(0)_"UID:Use in dialog;"
End DoDot:1
+25 SET DIR("A")="Select Action: "
+26 SET DIR("B")="ADD"
+27 SET DIR("?")="Select from the actions displayed."
+28 DO ^DIR
+29 IF $DATA(DIROUT)!$DATA(DIRUT)
SET VALMBCK="R"
QUIT
+30 IF $DATA(DTOUT)!$DATA(DUOUT)
SET VALMBCK="R"
QUIT
+31 SET OPTION=Y
+32 DO CLEAR^VALM1
+33 ;
+34 IF OPTION="ADD"
DO INCX^PXRMLEXL(.LIST,0)
+35 IF OPTION="RFD"
DO RFDX^PXRMLEXL(.LIST)
+36 IF OPTION="RFT"
DO RFTX^PXRMLEXL(.LIST)
+37 IF OPTION="UID"
DO INCX^PXRMLEXL(.LIST,1)
+38 ;
+39 SET VALMBCK="R"
+40 QUIT
+41 ;
