- 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 Jan 18, 2025@02:47:38 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 ;