PXLEXS ;SLC/PKR - List Manager routines for Lexicon code selection. ;08/01/2017
;;1.0;PCE PATIENT CARE ENCOUNTER;**211**;Aug 12, 1996;Build 454
;
;=========================================
ADDSEL(ENUM) ;Add entry ENUM to the selected list and highlight it.
N CODE
S CODE=^TMP("PXLEXL",$J,"CODE",ENUM)
S ^TMP("PXLEXL",$J,"SELECTED",ENUM)=CODE
D HLITE(ENUM,1)
Q
;
;=========================================
BLDLIST ;Build the Lexicon list.
N ACTIVE,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")
;List Manager selection.
;Clear the display.
D KILL^VALM10
K ^TMP("PXLEXL",$J)
S CODESYS=^TMP("PXLEXT",$J,"CODING SYSTEM")
S TERM=^TMP("PXLEXT",$J,"SEARCH TERM")
S EVENTDT=^TMP("PXLEXT",$J,"EVENT D/T")
S ACTIVE=^TMP("PXLEXT",$J,"ACTIVE")
;Clear the display.
D KILL^VALM10
K ^TMP("PXLEXL",$J)
D LEXLIST(TERM,CODESYS,EVENTDT,.NCODES,.NLINES,.TEXT,ACTIVE)
;Get the coding system Lexicon information for building the display.
;ICR #5679
S CODESYSP=$$CSYS^LEXU(CODESYS)
S TEXT=^TMP("PXLEXT",$J,"SEARCH 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")
;Set these so LM shows Page 1 of 1 when there are no codes.
I NCODES=0 S VALMHDR(2)=VALMHDR(2)_".",^TMP("PXLEXL",$J,1,0)="",VALMCNT=1 Q
;
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("PXLEXL",$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("PXLEXL",$J,VALMCNT,0)=OUTPUT(JND)
.. S ^TMP("PXLEXL",$J,"IDX",VALMCNT,ENUM)=""
. S ^TMP("PXLEXL",$J,"LINES",ENUM)=START_U_VALMCNT
S ^TMP("PXLEXL",$J,"NCODES")=NCODES
S ^TMP("PXLEXL",$J,"VALMCNT")=VALMCNT
Q
;
;=========================================
ENTRY ;Entry code
D INITMPG^PXLEXS
D BLDLIST^PXLEXS
D XQORM
Q
;
;=========================================
EXIT ;Exit code
M ^TMP("PXLEXT",$J,"SELECTED CODES")=^TMP("PXLEXL",$J,"SELECTED")
D INITMPG^PXLEXS
D FULL^VALM1
D CLEAN^VALM10
D KILL^VALM10
D CLEAR^VALM1
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
;
;=========================================
GETCODE(CODESYS,SRCHTERM,EVENTDT,ACTIVE) ;Given a coding system and search term,
;display a list of matches so the user can make a single selection.
N CODE,SELECTED
K ^TMP("PXLEXT",$J)
S ^TMP("PXLEXT",$J,"CODING SYSTEM")=CODESYS
S ^TMP("PXLEXT",$J,"SEARCH TERM")=SRCHTERM
S ^TMP("PXLEXT",$J,"EVENT D/T")=EVENTDT
S ^TMP("PXLEXT",$J,"SINGLE")=1
;ACTIVE=1, return only active codes; ACTIVE=0, active and inactive.
S ^TMP("PXLEXT",$J,"ACTIVE")=ACTIVE
D EN^VALM("PXCE STANDARD CODES SELECT")
S SELECTED=$O(^TMP("PXLEXT",$J,"SELECTED CODES",""))
S CODE=$S(SELECTED="":"",1:^TMP("PXLEXT",$J,"SELECTED CODES",SELECTED))
K ^TMP("PXLEXT",$J)
Q CODE
;
;=========================================
GETCODES(CODESYS,SRCHTERM,EVENTDT,CODELIST,ACTIVE) ;Given a coding system and
;a search term, display a list of matches so the user can make a
;selection.
K ^TMP("PXLEXT",$J)
S ^TMP("PXLEXT",$J,"CODING SYSTEM")=CODESYS
S ^TMP("PXLEXT",$J,"SEARCH TERM")=SRCHTERM
S ^TMP("PXLEXT",$J,"EVENT D/T")=EVENTDT
S ^TMP("PXLEXT",$J,"ACTIVE")=ACTIVE
D EN^VALM("PXCE STANDARD CODES SELECT")
M CODELIST=^TMP("PXLEXT",$J,"SELECTED CODES")
K ^TMP("PXLEXT",$J)
Q
;
;=========================================
GETLIST(LIST) ;Let the user input a list of items.
N DIR,DIR0,INUM,ITEM,LEND,LELEM,NCODES,LSTART,X,Y
S NCODES=+$G(^TMP("PXLEXL",$J,"NCODES"))
I NCODES=0 Q
I NCODES=1 S LIST(1)="" Q
S DIR0=$S($D(^TMP("PXLEXT",$J,"SINGLE")):"N^1:"_NCODES_":0",1:"LC^1:"_NCODES)
S DIR(0)=DIR0
D ^DIR
I $E(Y,1)="^" Q
I Y?1.N S LIST(Y)="" 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 the standard code(s)."
S VALMSG="+ Next Screen - Prev Screen ?? More Actions"
Q
;
;=========================================
HELP ;Display help.
N DDS,DIR0,DONE,IND,HTEXT,TEXT
;DBIA #5746 covers kill and set of DDS. DDS needs to be set or the
;Browser will kill some ScreenMan variables.
S HTEXT=$S($D(^TMP("PXLEXT",$J,"SINGLE")):"HTEXTS",1:"HTEXT")
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) ;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("PXLEXL",$J,"LINES",ENUM),U,1)
S STOP=$P(^TMP("PXLEXL",$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=0 D FLDCTRL^VALM10(START,"CODE",IORVOFF,IORVOFF,"")
Q
;
;=========================================
HTEXT ;Lexicon selection help text.
;;Select one of the following actions:
;;
;; SEL - Select codes to add to the encounter.
;; REM - Removes selected codes from the encounter.
;;
;;When you exit by typing 'Q' the selected codes will be added to or removed
;;from the encounter depending on the chosen action.
;;
;;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
;=========================================
HTEXTS ;Lexicon single selection help text.
;;Select one of the following actions:
;;
;; SEL - Select a code to add to the encounter.
;; REM - Remove a code from the encounter.
;;
;;When you exit by typing 'Q' the selected code will be added to or removed
;;from the encounter depending on the chosen action.
;;
;;You can select the action first and then be prompted for a code or you
;;can select a code and then select the action.
;;
;;**End Text**
Q
;
;=========================================
INITMPG ;Initialize all the ^TMP globals.
K ^TMP("PXLEXL",$J)
Q
;
;=========================================
LEXLIST(TERM,CODESYS,EVENTDT,NCODES,NLINES,TEXT,ACTIVE) ;Call Lexicon to get
;the list of codes.
N ACTDT,CODE,CODEI,INACTDT,IND,NUM
N RESULT,SRC,SDESC,TEMP
W @IOF,"Searching Lexicon ..."
K ^TMP("PXLEX",$J)
;DBIA #5681
S RESULT=$$TAX^LEX10CS(TERM,CODESYS,EVENTDT,"PXLEX",ACTIVE)
S NCODES=+RESULT
I NCODES=-1 S (NCODES,NLINES)=0 K ^TMP("PXLEX",$J) Q
I CODESYS="SCT" D SCTDESC("PXLEX")
S SRC=0
S (NLINES,NUM)=0
F S SRC=$O(^TMP("PXLEX",$J,SRC)) Q:SRC="" D
. S CODEI=""
. F S CODEI=$O(^TMP("PXLEX",$J,SRC,CODEI)) Q:CODEI="" D
.. S NUM=NUM+1,IND=0
.. F S IND=$O(^TMP("PXLEX",$J,SRC,CODEI,IND)) Q:IND="" D
... S TEMP=^TMP("PXLEX",$J,SRC,CODEI,IND)
... S ACTDT=$P(TEMP,U,1),INACTDT=$P(TEMP,U,2)
... S TEMP=^TMP("PXLEX",$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("PXLEX",$J)
Q
;
;=========================================
PEXIT ; Protocol exit code
S VALMSG="+ Next Screen - Prev Screen ?? More Actions"
;Reset after page up/down etc
D XQORM
Q
;
;=========================================
REM(ENUM) ;Remove entry ENUM from the selected list and un-highlight it.
K ^TMP("PXLEXL",$J,"SELECTED",ENUM)
D HLITE(ENUM,0)
Q
;
;=========================================
REML ;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 REM(SEL)
S VALMBCK="R"
Q
;
;=========================================
REMX(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 REM(ENUM)
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
;
;=========================================
SELL ;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
;
;=========================================
SELX(LIST) ;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)
Q
;
;=========================================
XQORM ; Set range for selection.
N NCODES
S NCODES=+$G(^TMP("PXLEXL",$J,"NCODES"))
I NCODES=0 Q
S XQORM("#")=$O(^ORD(101,"B","PXCE LEXICON SELECT ENTRY",0))_U_"1:"_NCODES
S XQORM("A")="Select Action: "
Q
;
;=========================================
XSEL ;Entry action for protocol PXCE 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("PXLEXL",$J,"LINES",ENUM))) D
.. W !,ENUM," is not a valid selection."
.. W !,"The range is 1 to ",$O(^TMP("PXLEXL",$J,"LINES",""),-1),"."
.. H 2
.. S LVALID=0
I $D(^TMP("PXLEXT",$J,"SINGLE")),LIST'?1.N D
. W !,"Only a single code can be selected."
. S LVALID=0
. H 2
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_"SEL:Select code(s);"
S DIR(0)=DIR(0)_"REM:Remove code(s);"
S DIR("A")="Select Action: "
S DIR("B")="SEL"
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="SEL" D SELX^PXLEXS(.LIST)
I OPTION="REM" D REMX^PXLEXS(.LIST)
;
S VALMBCK="R"
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXLEXS 11993 printed Oct 16, 2024@18:30:13 Page 2
PXLEXS ;SLC/PKR - List Manager routines for Lexicon code selection. ;08/01/2017
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**211**;Aug 12, 1996;Build 454
+2 ;
+3 ;=========================================
ADDSEL(ENUM) ;Add entry ENUM to the selected list and highlight it.
+1 NEW CODE
+2 SET CODE=^TMP("PXLEXL",$JOB,"CODE",ENUM)
+3 SET ^TMP("PXLEXL",$JOB,"SELECTED",ENUM)=CODE
+4 DO HLITE(ENUM,1)
+5 QUIT
+6 ;
+7 ;=========================================
BLDLIST ;Build the Lexicon list.
+1 NEW ACTIVE,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 ;List Manager selection.
+5 ;Clear the display.
+6 DO KILL^VALM10
+7 KILL ^TMP("PXLEXL",$JOB)
+8 SET CODESYS=^TMP("PXLEXT",$JOB,"CODING SYSTEM")
+9 SET TERM=^TMP("PXLEXT",$JOB,"SEARCH TERM")
+10 SET EVENTDT=^TMP("PXLEXT",$JOB,"EVENT D/T")
+11 SET ACTIVE=^TMP("PXLEXT",$JOB,"ACTIVE")
+12 ;Clear the display.
+13 DO KILL^VALM10
+14 KILL ^TMP("PXLEXL",$JOB)
+15 DO LEXLIST(TERM,CODESYS,EVENTDT,.NCODES,.NLINES,.TEXT,ACTIVE)
+16 ;Get the coding system Lexicon information for building the display.
+17 ;ICR #5679
+18 SET CODESYSP=$$CSYS^LEXU(CODESYS)
+19 SET TEXT=^TMP("PXLEXT",$JOB,"SEARCH TERM")
+20 SET TEXT=$SELECT(($LENGTH(TEXT)'>66):TEXT,1:$EXTRACT(TEXT,1,63)_"...")
+21 SET VALMHDR(1)="Term/Code: "_TEXT
+22 SET VALMHDR(2)=NCODES_" "_$PIECE(CODESYSP,U,4)_$SELECT(NCODES=1:" code was found",1:" codes were found")
+23 ;Set these so LM shows Page 1 of 1 when there are no codes.
+24 IF NCODES=0
SET VALMHDR(2)=VALMHDR(2)_"."
SET ^TMP("PXLEXL",$JOB,1,0)=""
SET VALMCNT=1
QUIT
+25 ;
+26 SET VALMCNT=0
+27 FOR IND=1:1:NLINES
Begin DoDot:1
+28 SET NUM=$PIECE(TEXT(IND),U,1)
SET CODE=$PIECE(TEXT(IND),U,2)
+29 IF NUM'=""
IF CODE'=""
SET ENUM=NUM
SET ^TMP("PXLEXL",$JOB,"CODE",NUM)=CODE
SET START=VALMCNT+1
+30 DO FORMAT(TEXT(IND),FMTSTR,.NL,.OUTPUT)
+31 FOR JND=1:1:NL
Begin DoDot:2
+32 SET VALMCNT=VALMCNT+1
SET ^TMP("PXLEXL",$JOB,VALMCNT,0)=OUTPUT(JND)
+33 SET ^TMP("PXLEXL",$JOB,"IDX",VALMCNT,ENUM)=""
End DoDot:2
+34 SET ^TMP("PXLEXL",$JOB,"LINES",ENUM)=START_U_VALMCNT
End DoDot:1
+35 SET ^TMP("PXLEXL",$JOB,"NCODES")=NCODES
+36 SET ^TMP("PXLEXL",$JOB,"VALMCNT")=VALMCNT
+37 QUIT
+38 ;
+39 ;=========================================
ENTRY ;Entry code
+1 DO INITMPG^PXLEXS
+2 DO BLDLIST^PXLEXS
+3 DO XQORM
+4 QUIT
+5 ;
+6 ;=========================================
EXIT ;Exit code
+1 MERGE ^TMP("PXLEXT",$JOB,"SELECTED CODES")=^TMP("PXLEXL",$JOB,"SELECTED")
+2 DO INITMPG^PXLEXS
+3 DO FULL^VALM1
+4 DO CLEAN^VALM10
+5 DO KILL^VALM10
+6 DO CLEAR^VALM1
+7 SET VALMBCK="Q"
+8 QUIT
+9 ;
+10 ;=========================================
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 ;=========================================
GETCODE(CODESYS,SRCHTERM,EVENTDT,ACTIVE) ;Given a coding system and search term,
+1 ;display a list of matches so the user can make a single selection.
+2 NEW CODE,SELECTED
+3 KILL ^TMP("PXLEXT",$JOB)
+4 SET ^TMP("PXLEXT",$JOB,"CODING SYSTEM")=CODESYS
+5 SET ^TMP("PXLEXT",$JOB,"SEARCH TERM")=SRCHTERM
+6 SET ^TMP("PXLEXT",$JOB,"EVENT D/T")=EVENTDT
+7 SET ^TMP("PXLEXT",$JOB,"SINGLE")=1
+8 ;ACTIVE=1, return only active codes; ACTIVE=0, active and inactive.
+9 SET ^TMP("PXLEXT",$JOB,"ACTIVE")=ACTIVE
+10 DO EN^VALM("PXCE STANDARD CODES SELECT")
+11 SET SELECTED=$ORDER(^TMP("PXLEXT",$JOB,"SELECTED CODES",""))
+12 SET CODE=$SELECT(SELECTED="":"",1:^TMP("PXLEXT",$JOB,"SELECTED CODES",SELECTED))
+13 KILL ^TMP("PXLEXT",$JOB)
+14 QUIT CODE
+15 ;
+16 ;=========================================
GETCODES(CODESYS,SRCHTERM,EVENTDT,CODELIST,ACTIVE) ;Given a coding system and
+1 ;a search term, display a list of matches so the user can make a
+2 ;selection.
+3 KILL ^TMP("PXLEXT",$JOB)
+4 SET ^TMP("PXLEXT",$JOB,"CODING SYSTEM")=CODESYS
+5 SET ^TMP("PXLEXT",$JOB,"SEARCH TERM")=SRCHTERM
+6 SET ^TMP("PXLEXT",$JOB,"EVENT D/T")=EVENTDT
+7 SET ^TMP("PXLEXT",$JOB,"ACTIVE")=ACTIVE
+8 DO EN^VALM("PXCE STANDARD CODES SELECT")
+9 MERGE CODELIST=^TMP("PXLEXT",$JOB,"SELECTED CODES")
+10 KILL ^TMP("PXLEXT",$JOB)
+11 QUIT
+12 ;
+13 ;=========================================
GETLIST(LIST) ;Let the user input a list of items.
+1 NEW DIR,DIR0,INUM,ITEM,LEND,LELEM,NCODES,LSTART,X,Y
+2 SET NCODES=+$GET(^TMP("PXLEXL",$JOB,"NCODES"))
+3 IF NCODES=0
QUIT
+4 IF NCODES=1
SET LIST(1)=""
QUIT
+5 SET DIR0=$SELECT($DATA(^TMP("PXLEXT",$JOB,"SINGLE")):"N^1:"_NCODES_":0",1:"LC^1:"_NCODES)
+6 SET DIR(0)=DIR0
+7 DO ^DIR
+8 IF $EXTRACT(Y,1)="^"
QUIT
+9 IF Y?1.N
SET LIST(Y)=""
QUIT
+10 ;Populate the list.
+11 FOR INUM=1:1:($LENGTH(Y,",")-1)
Begin DoDot:1
+12 SET LELEM=$PIECE(Y,",",INUM)
+13 IF LELEM?1.N
SET LIST(LELEM)=""
+14 SET LSTART=$PIECE(LELEM,"-",1)
SET LEND=$PIECE(LELEM,"-",2)
+15 FOR ITEM=LSTART:1:LEND
SET LIST(ITEM)=""
End DoDot:1
+16 QUIT
+17 ;
+18 ;=========================================
HDR ; Header code
+1 SET VALMHDR(1)="Select the standard code(s)."
+2 SET VALMSG="+ Next Screen - Prev Screen ?? More Actions"
+3 QUIT
+4 ;
+5 ;=========================================
HELP ;Display help.
+1 NEW DDS,DIR0,DONE,IND,HTEXT,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 HTEXT=$SELECT($DATA(^TMP("PXLEXT",$JOB,"SINGLE")):"HTEXTS",1:"HTEXT")
+5 SET DDS=1
SET DONE=0
+6 FOR IND=1:1
if DONE
QUIT
Begin DoDot:1
+7 SET TEXT(IND)=$PIECE($TEXT(@HTEXT+IND),";",3,99)
+8 IF TEXT(IND)="**End Text**"
KILL TEXT(IND)
SET DONE=1
QUIT
End DoDot:1
+9 DO BROWSE^DDBR("TEXT","NR","Lexicon Selection Help")
+10 SET VALMBCK="R"
+11 QUIT
+12 ;
+13 ;=========================================
HLITE(ENUM,MODE) ;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("PXLEXL",$JOB,"LINES",ENUM),U,1)
+5 SET STOP=$PIECE(^TMP("PXLEXL",$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=0
DO FLDCTRL^VALM10(START,"CODE",IORVOFF,IORVOFF,"")
+9 QUIT
+10 ;
+11 ;=========================================
HTEXT ;Lexicon selection help text.
+1 ;;Select one of the following actions:
+2 ;;
+3 ;; SEL - Select codes to add to the encounter.
+4 ;; REM - Removes selected codes from the encounter.
+5 ;;
+6 ;;When you exit by typing 'Q' the selected codes will be added to or removed
+7 ;;from the encounter depending on the chosen action.
+8 ;;
+9 ;;You can select the action first and then be prompted for a list of codes or
+10 ;;you can input the list and then select the action. Because of the way List
+11 ;;Manager works, you may be able to select a larger list by selecting the action
+12 ;;first.
+13 ;;
+14 ;;**End Text**
+15 QUIT
+16 ;=========================================
HTEXTS ;Lexicon single selection help text.
+1 ;;Select one of the following actions:
+2 ;;
+3 ;; SEL - Select a code to add to the encounter.
+4 ;; REM - Remove a code from the encounter.
+5 ;;
+6 ;;When you exit by typing 'Q' the selected code will be added to or removed
+7 ;;from the encounter depending on the chosen action.
+8 ;;
+9 ;;You can select the action first and then be prompted for a code or you
+10 ;;can select a code and then select the action.
+11 ;;
+12 ;;**End Text**
+13 QUIT
+14 ;
+15 ;=========================================
INITMPG ;Initialize all the ^TMP globals.
+1 KILL ^TMP("PXLEXL",$JOB)
+2 QUIT
+3 ;
+4 ;=========================================
LEXLIST(TERM,CODESYS,EVENTDT,NCODES,NLINES,TEXT,ACTIVE) ;Call Lexicon to get
+1 ;the list of codes.
+2 NEW ACTDT,CODE,CODEI,INACTDT,IND,NUM
+3 NEW RESULT,SRC,SDESC,TEMP
+4 WRITE @IOF,"Searching Lexicon ..."
+5 KILL ^TMP("PXLEX",$JOB)
+6 ;DBIA #5681
+7 SET RESULT=$$TAX^LEX10CS(TERM,CODESYS,EVENTDT,"PXLEX",ACTIVE)
+8 SET NCODES=+RESULT
+9 IF NCODES=-1
SET (NCODES,NLINES)=0
KILL ^TMP("PXLEX",$JOB)
QUIT
+10 IF CODESYS="SCT"
DO SCTDESC("PXLEX")
+11 SET SRC=0
+12 SET (NLINES,NUM)=0
+13 FOR
SET SRC=$ORDER(^TMP("PXLEX",$JOB,SRC))
if SRC=""
QUIT
Begin DoDot:1
+14 SET CODEI=""
+15 FOR
SET CODEI=$ORDER(^TMP("PXLEX",$JOB,SRC,CODEI))
if CODEI=""
QUIT
Begin DoDot:2
+16 SET NUM=NUM+1
SET IND=0
+17 FOR
SET IND=$ORDER(^TMP("PXLEX",$JOB,SRC,CODEI,IND))
if IND=""
QUIT
Begin DoDot:3
+18 SET TEMP=^TMP("PXLEX",$JOB,SRC,CODEI,IND)
+19 SET ACTDT=$PIECE(TEMP,U,1)
SET INACTDT=$PIECE(TEMP,U,2)
+20 SET TEMP=^TMP("PXLEX",$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:3
End DoDot:2
End DoDot:1
+25 KILL ^TMP("PXLEX",$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 ;=========================================
REM(ENUM) ;Remove entry ENUM from the selected list and un-highlight it.
+1 KILL ^TMP("PXLEXL",$JOB,"SELECTED",ENUM)
+2 DO HLITE(ENUM,0)
+3 QUIT
+4 ;
+5 ;=========================================
REML ;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 REM(SEL)
+8 SET VALMBCK="R"
+9 QUIT
+10 ;
+11 ;=========================================
REMX(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 REM(ENUM)
End DoDot:1
+6 QUIT
+7 ;
+8 ;=========================================
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 ;=========================================
SELL ;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 ;=========================================
SELX(LIST) ;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)
End DoDot:1
+6 QUIT
+7 ;
+8 ;=========================================
XQORM ; Set range for selection.
+1 NEW NCODES
+2 SET NCODES=+$GET(^TMP("PXLEXL",$JOB,"NCODES"))
+3 IF NCODES=0
QUIT
+4 SET XQORM("#")=$ORDER(^ORD(101,"B","PXCE LEXICON SELECT ENTRY",0))_U_"1:"_NCODES
+5 SET XQORM("A")="Select Action: "
+6 QUIT
+7 ;
+8 ;=========================================
XSEL ;Entry action for protocol PXCE 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("PXLEXL",$JOB,"LINES",ENUM)))
Begin DoDot:2
+9 WRITE !,ENUM," is not a valid selection."
+10 WRITE !,"The range is 1 to ",$ORDER(^TMP("PXLEXL",$JOB,"LINES",""),-1),"."
+11 HANG 2
+12 SET LVALID=0
End DoDot:2
End DoDot:1
+13 IF $DATA(^TMP("PXLEXT",$JOB,"SINGLE"))
IF LIST'?1.N
Begin DoDot:1
+14 WRITE !,"Only a single code can be selected."
+15 SET LVALID=0
+16 HANG 2
End DoDot:1
+17 IF 'LVALID
SET VALMBCK="R"
QUIT
+18 ;
+19 ;Full screen mode
+20 DO FULL^VALM1
+21 ;
+22 ;Possible actions.
+23 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,OPTION,X,Y
+24 SET DIR(0)="SBM"_U_"SEL:Select code(s);"
+25 SET DIR(0)=DIR(0)_"REM:Remove code(s);"
+26 SET DIR("A")="Select Action: "
+27 SET DIR("B")="SEL"
+28 SET DIR("?")="Select from the actions displayed."
+29 DO ^DIR
+30 IF $DATA(DIROUT)!$DATA(DIRUT)
SET VALMBCK="R"
QUIT
+31 IF $DATA(DTOUT)!$DATA(DUOUT)
SET VALMBCK="R"
QUIT
+32 SET OPTION=Y
+33 DO CLEAR^VALM1
+34 ;
+35 IF OPTION="SEL"
DO SELX^PXLEXS(.LIST)
+36 IF OPTION="REM"
DO REMX^PXLEXS(.LIST)
+37 ;
+38 SET VALMBCK="R"
+39 QUIT
+40 ;
