PXRMTXLS ;SLC/PKR - List Manager routines for taxonomy all selected codes. ;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 CODESYS,NDUP,UIDT
S CODESYS=$P(^TMP("PXRMTXSC",$J,"CODE",ENUM,1),U,2)
S UIDT=$S('UID:0,1:$$UIDOK^PXRMUID(CODESYS))
D HLITE(ENUM,1,UIDT)
S NDUP=0
F S NDUP=$O(^TMP("PXRMTXSC",$J,"CODE",ENUM,NDUP)) Q:NDUP="" D
. S ^TMP("PXRMTXSC",$J,"SELECTED",ENUM,NDUP)=^TMP("PXRMTXSC",$J,"CODE",ENUM,NDUP)
. S $P(^TMP("PXRMTXSC",$J,"SELECTED",ENUM,NDUP),U,4)=UIDT
Q
;
;=========================================
BLDLIST ;Build the list of all selected codes.
N CODE,CODESYS,CODESYSP,ENUM,FMTSTR,IND,JND,NDUP,NL,NLINES
N NSEL,NUID,NUM,OUTPUT,START,TERM,TEXT,UID,UIDOK,UIDMSG
S FMTSTR=$$LMFMTSTR^PXRMTEXT(.VALMDDF,"RLLLL")
;^TMP("PXRMTAX",$J) is set in VEALLSEL^PXRMTXSM which invokes the List
;Manager screen PXRM TAXONOMY ALL SELECTED MENU. It is also set in
;UIDE^PXRMTAXL which starts the UID edit.
;Clear the display.
D KILL^VALM10
K ^TMP("PXRMTXSC",$J)
I '$D(^TMP("PXRMCODES",$J)) D Q
. S VALMHDR(2)="No codes have been selected.",^TMP("PXRMTXSC",$J,1,0)=""
. S VALMCNT=1,VALMBCK="R"
;Build the display list grouped by coding system.
S TERM=""
F S TERM=$O(^TMP("PXRMCODES",$J,TERM)) Q:TERM="" D
. S CODESYS=""
. F S CODESYS=$O(^TMP("PXRMCODES",$J,TERM,CODESYS)) Q:CODESYS="" D
.. S CODE=""
.. F S CODE=$O(^TMP("PXRMCODES",$J,TERM,CODESYS,CODE)) Q:CODE="" D
... S ^TMP("PXRMTXSC",$J,"CODES",CODESYS,CODE)=^TMP("PXRMCODES",$J,TERM,CODESYS,CODE)
... S ^TMP("PXRMTXSC",$J,"CODES",CODESYS,CODE,TERM)=^TMP("PXRMCODES",$J,TERM,CODESYS,CODE)
;
S (ENUM,NLINES,NUID,VALMCNT)=0
S CODESYS=""
F S CODESYS=$O(^TMP("PXRMTXSC",$J,"CODES",CODESYS)) Q:CODESYS="" D
.;Get the Lexicon coding system information for building the display.
.;DBIA #5679
. S CODESYSP=$$CSYS^LEXU(CODESYS)
. S UIDOK=$$UIDOK^PXRMUID(CODESYS)
. S UIDMSG=" (This coding system "_$S(UIDOK:"can",1:"cannot")_" be used in a dialog.)"
. S VALMCNT=VALMCNT+1,^TMP("PXRMTXSC",$J,VALMCNT,0)=""
. S VALMCNT=VALMCNT+1,^TMP("PXRMTXSC",$J,VALMCNT,0)=$P(CODESYSP,U,4)_UIDMSG
. S CODE=""
. F S CODE=$O(^TMP("PXRMTXSC",$J,"CODES",CODESYS,CODE)) Q:CODE="" D
.. S ENUM=ENUM+1,START=VALMCNT+1
.. D LEXPER(ENUM,CODE,CODESYS,.NLINES,.TEXT)
.. F IND=1:1:NLINES D
... D FORMAT(TEXT(IND),FMTSTR,.NL,.OUTPUT)
... F JND=1:1:NL S VALMCNT=VALMCNT+1,^TMP("PXRMTXSC",$J,VALMCNT,0)=OUTPUT(JND)
.. S ^TMP("PXRMTXSC",$J,"IDX",START,ENUM)=""
.. S ^TMP("PXRMTXSC",$J,"LINES",ENUM)=START_U_VALMCNT
.. S UID=+^TMP("PXRMTXSC",$J,"CODES",CODESYS,CODE)
.. I UID S NUID=NUID+1
.. D HLITE(ENUM,1,UID)
.. S TERM="",NDUP=0
.. F S TERM=$O(^TMP("PXRMTXSC",$J,"CODES",CODESYS,CODE,TERM)) Q:TERM="" D
... S NDUP=NDUP+1
... S TEMP=TERM_U_CODESYS_U_CODE_U_UID
... S ^TMP("PXRMTXSC",$J,"SELECTED",ENUM,NDUP)=TEMP
... S ^TMP("PXRMTXSC",$J,"CODE",ENUM,NDUP)=TEMP
S ^TMP("PXRMTXSC",$J,"NCODES")=ENUM
S ^TMP("PXRMTXSC",$J,"VALMCNT")=VALMCNT
;Set these so LM shows Page 1 of 1 when there are no codes.
I ENUM=0 S VALMHDR(2)="No codes have been selected.",^TMP("PXRMTXSC",$J,1,0)="",VALMCNT=1 Q
S VALMHDR(2)=ENUM_" codes have been selected, "_NUID_" are marked UID."
Q
;
;=========================================
ENTRY ;Entry code
D INITMPG^PXRMTXLS
D HDR^PXRMTXLS
D BLDLIST^PXRMTXLS
D XQORM^PXRMTXLS
Q
;
;=========================================
EXIT ;Exit code
D INITMPG^PXRMTXLS
D FULL^VALM1
D CLEAN^VALM10
D KILL^VALM10
D CLEAR^VALM1
S VALMBCK="Q"
Q
;
;=========================================
EXITS ;Exit and save action.
D SAVE^PXRMTXLS
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 INUM,ITEM,LEND,LELEM,NCODES,LSTART,X,Y
S NCODES=+$G(^TMP("PXRMTXSC",$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)="All selected codes in this 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("PXRMTXSC",$J,"LINES",ENUM),U,1)
S STOP=$P(^TMP("PXRMTXSC",$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. PROBABLY CAN REMOVE AND USE ORIGINAL
;;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
;
;=========================================
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 CODESYS,ENUM,IND,NDUP
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("PXRMTXSC",$J)
Q
;
;=========================================
LEXPER(ENUM,CODE,CODESYS,NLINES,TEXT) ;Call PERIOD^LEXU to get the code
;information.
N ACTDT,DESC,INACTDT,PDATA,RESULT
;DBIA #5679
S RESULT=$$PERIOD^LEXU(CODE,CODESYS,.PDATA)
I +RESULT=-1 S NLINES=0 Q
S (ACTDT,NLINES)=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 NLINES=NLINES+1
. I NLINES=1 S TEXT(NLINES)=ENUM_U_CODE_U_ACTDT_U_INACTDT_U_DESC
. E S TEXT(NLINES)=U_U_ACTDT_U_INACTDT_U_DESC
Q
;
;=========================================
PEXIT ; Protocol exit code
S VALMSG="+ Next Screen - Prev Screen ?? More Actions"
;Reset after page up/down etc
D XQORM^PXRMTXLS
Q
;
;=========================================
RFD(ENUM) ;Remove UID from the selected entry.
N NDUP,START
S NDUP=0
F S NDUP=$O(^TMP("PXRMTXSC",$J,"SELECTED",ENUM,NDUP)) Q:NDUP="" D
. S $P(^TMP("PXRMTXSC",$J,"SELECTED",ENUM,NDUP),U,4)=0
S START=$P(^TMP("PXRMTXSC",$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.
N CODE,CODESYS,DEL,NDUP,TEMP,TERM
S NDUP=0
F S NDUP=$O(^TMP("PXRMTXSC",$J,"SELECTED",ENUM,NDUP)) Q:NDUP="" D
. S TEMP=^TMP("PXRMTXSC",$J,"SELECTED",ENUM,NDUP)
. S ^TMP("PXRMTXSC",$J,"SELECTED",ENUM,NDUP)=TEMP_U_"@"
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. This amounts to rebuilding
;^TMP("PXRMCODES",$J).
N CODE,CODESYS,DEL,ENUM,NDUP,TEMP,TERM,UID
S ENUM=0
F S ENUM=$O(^TMP("PXRMTXSC",$J,"SELECTED",ENUM)) Q:ENUM="" D
. S NDUP=0
. F S NDUP=$O(^TMP("PXRMTXSC",$J,"SELECTED",ENUM,NDUP)) Q:NDUP="" D
.. S TEMP=^TMP("PXRMTXSC",$J,"SELECTED",ENUM,NDUP)
.. S TERM=$P(TEMP,U,1),CODESYS=$P(TEMP,U,2)
.. S CODE=$P(TEMP,U,3),UID=$P(TEMP,U,4)
.. I TEMP["@" K ^TMP("PXRMCODES",$J,TERM,CODESYS,CODE)
.. E S ^TMP("PXRMCODES",$J,TERM,CODESYS,CODE)=UID
;Check for terms that should be deleted.
S TERM=""
F S TERM=$O(^TMP("PXRMCODES",$J,TERM)) Q:TERM="" D
. S DEL=$$TERMDEL(TERM)
. I DEL S ^TMP("PXRMCODES",$J,TERM)="@" Q
. S CODESYS=""
. F S CODESYS=$O(^TMP("PXRMCODES",$J,TERM,CODESYS)) Q:CODESYS="" D
..;(TERM,CODESYS) exists but has no codes if $D=1
.. I $D(^TMP("PXRMCODES",$J,TERM,CODESYS))=1 S ^TMP("PXRMCODES",$J,TERM,CODESYS)=""
S VALMBCK="R"
Q
;
;=========================================
TERMDEL(TERM) ;Determine how many codes this term contains. If there are none
;then ask the user if they want the term deleted.
N CODE,CODESYS,DEL,DIR,IENS,IND,KFDA,MSG,NCODES,TEXT,X,Y
S CODESYS="",NCODES=0
S CODESYS=""
F S CODESYS=$O(^TMP("PXRMCODES",$J,TERM,CODESYS)) Q:CODESYS="" D
. S CODE=""
. F S CODE=$O(^TMP("PXRMCODES",$J,TERM,CODESYS,CODE)) Q:CODE="" S NCODES=NCODES+1
;
I NCODES>0 Q 0
;Have the user verify the term deletion is OK.
S TEXT(1)=""
S TEXT(2)="All the codes in term "_TERM
S TEXT(3)="have been selected for removal from the taxonomy."
S TEXT(4)=""
D EN^DDIOL(.TEXT)
S DIR(0)="YAO"
S DIR("A")="Do you want this term deleted too? "
S DIR("B")="Y"
D ^DIR
;The user said not to delete the term.
I +Y=0 Q 0
K TEXT
S TEXT(1)="The term will be deleted when the editing session is saved."
S TEXT(2)=""
D EN^DDIOL(.TEXT) H 2
Q 1
;
;=========================================
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
;
;=========================================
XQORM ; Set range for selection.
N NCODES
S NCODES=+$G(^TMP("PXRMTXSC",$J,"NCODES"))
I NCODES=0 Q
S XQORM("#")=$O(^ORD(101,"B","PXRM TAXONOMY ALL SELECTED SELECT",0))_U_"1:"_NCODES
S XQORM("A")="Select Action: "
Q
;
;=========================================
XSEL ;Entry action for protocol PXRM TAXONOMY ALL SELECTED SELECT.
N ENUM,IND,LIST,NCODES,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
S NCODES=+$O(^TMP("PXRMTXSC",$J,"LINES",""),-1)
F IND=1:1:$L(LIST,",") D
. S ENUM=$P(LIST,",",IND)
. I (ENUM<1)!(ENUM>NCODES) D
.. W !,ENUM," is not a valid selection."
.. W !,"The range is 1 to ",NCODES,"."
.. 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;"
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^PXRMTXLS(.LIST,0)
I OPTION="RFD" D RFDX^PXRMTXLS(.LIST)
I OPTION="RFT" D RFTX^PXRMTXLS(.LIST)
I OPTION="UID" D INCX^PXRMTXLS(.LIST,1)
;
S VALMBCK="R"
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMTXLS 14277 printed Oct 16, 2024@17:50:28 Page 2
PXRMTXLS ;SLC/PKR - List Manager routines for taxonomy all selected codes. ;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 CODESYS,NDUP,UIDT
+2 SET CODESYS=$PIECE(^TMP("PXRMTXSC",$JOB,"CODE",ENUM,1),U,2)
+3 SET UIDT=$SELECT('UID:0,1:$$UIDOK^PXRMUID(CODESYS))
+4 DO HLITE(ENUM,1,UIDT)
+5 SET NDUP=0
+6 FOR
SET NDUP=$ORDER(^TMP("PXRMTXSC",$JOB,"CODE",ENUM,NDUP))
if NDUP=""
QUIT
Begin DoDot:1
+7 SET ^TMP("PXRMTXSC",$JOB,"SELECTED",ENUM,NDUP)=^TMP("PXRMTXSC",$JOB,"CODE",ENUM,NDUP)
+8 SET $PIECE(^TMP("PXRMTXSC",$JOB,"SELECTED",ENUM,NDUP),U,4)=UIDT
End DoDot:1
+9 QUIT
+10 ;
+11 ;=========================================
BLDLIST ;Build the list of all selected codes.
+1 NEW CODE,CODESYS,CODESYSP,ENUM,FMTSTR,IND,JND,NDUP,NL,NLINES
+2 NEW NSEL,NUID,NUM,OUTPUT,START,TERM,TEXT,UID,UIDOK,UIDMSG
+3 SET FMTSTR=$$LMFMTSTR^PXRMTEXT(.VALMDDF,"RLLLL")
+4 ;^TMP("PXRMTAX",$J) is set in VEALLSEL^PXRMTXSM which invokes the List
+5 ;Manager screen PXRM TAXONOMY ALL SELECTED MENU. It is also set in
+6 ;UIDE^PXRMTAXL which starts the UID edit.
+7 ;Clear the display.
+8 DO KILL^VALM10
+9 KILL ^TMP("PXRMTXSC",$JOB)
+10 IF '$DATA(^TMP("PXRMCODES",$JOB))
Begin DoDot:1
+11 SET VALMHDR(2)="No codes have been selected."
SET ^TMP("PXRMTXSC",$JOB,1,0)=""
+12 SET VALMCNT=1
SET VALMBCK="R"
End DoDot:1
QUIT
+13 ;Build the display list grouped by coding system.
+14 SET TERM=""
+15 FOR
SET TERM=$ORDER(^TMP("PXRMCODES",$JOB,TERM))
if TERM=""
QUIT
Begin DoDot:1
+16 SET CODESYS=""
+17 FOR
SET CODESYS=$ORDER(^TMP("PXRMCODES",$JOB,TERM,CODESYS))
if CODESYS=""
QUIT
Begin DoDot:2
+18 SET CODE=""
+19 FOR
SET CODE=$ORDER(^TMP("PXRMCODES",$JOB,TERM,CODESYS,CODE))
if CODE=""
QUIT
Begin DoDot:3
+20 SET ^TMP("PXRMTXSC",$JOB,"CODES",CODESYS,CODE)=^TMP("PXRMCODES",$JOB,TERM,CODESYS,CODE)
+21 SET ^TMP("PXRMTXSC",$JOB,"CODES",CODESYS,CODE,TERM)=^TMP("PXRMCODES",$JOB,TERM,CODESYS,CODE)
End DoDot:3
End DoDot:2
End DoDot:1
+22 ;
+23 SET (ENUM,NLINES,NUID,VALMCNT)=0
+24 SET CODESYS=""
+25 FOR
SET CODESYS=$ORDER(^TMP("PXRMTXSC",$JOB,"CODES",CODESYS))
if CODESYS=""
QUIT
Begin DoDot:1
+26 ;Get the Lexicon coding system information for building the display.
+27 ;DBIA #5679
+28 SET CODESYSP=$$CSYS^LEXU(CODESYS)
+29 SET UIDOK=$$UIDOK^PXRMUID(CODESYS)
+30 SET UIDMSG=" (This coding system "_$SELECT(UIDOK:"can",1:"cannot")_" be used in a dialog.)"
+31 SET VALMCNT=VALMCNT+1
SET ^TMP("PXRMTXSC",$JOB,VALMCNT,0)=""
+32 SET VALMCNT=VALMCNT+1
SET ^TMP("PXRMTXSC",$JOB,VALMCNT,0)=$PIECE(CODESYSP,U,4)_UIDMSG
+33 SET CODE=""
+34 FOR
SET CODE=$ORDER(^TMP("PXRMTXSC",$JOB,"CODES",CODESYS,CODE))
if CODE=""
QUIT
Begin DoDot:2
+35 SET ENUM=ENUM+1
SET START=VALMCNT+1
+36 DO LEXPER(ENUM,CODE,CODESYS,.NLINES,.TEXT)
+37 FOR IND=1:1:NLINES
Begin DoDot:3
+38 DO FORMAT(TEXT(IND),FMTSTR,.NL,.OUTPUT)
+39 FOR JND=1:1:NL
SET VALMCNT=VALMCNT+1
SET ^TMP("PXRMTXSC",$JOB,VALMCNT,0)=OUTPUT(JND)
End DoDot:3
+40 SET ^TMP("PXRMTXSC",$JOB,"IDX",START,ENUM)=""
+41 SET ^TMP("PXRMTXSC",$JOB,"LINES",ENUM)=START_U_VALMCNT
+42 SET UID=+^TMP("PXRMTXSC",$JOB,"CODES",CODESYS,CODE)
+43 IF UID
SET NUID=NUID+1
+44 DO HLITE(ENUM,1,UID)
+45 SET TERM=""
SET NDUP=0
+46 FOR
SET TERM=$ORDER(^TMP("PXRMTXSC",$JOB,"CODES",CODESYS,CODE,TERM))
if TERM=""
QUIT
Begin DoDot:3
+47 SET NDUP=NDUP+1
+48 SET TEMP=TERM_U_CODESYS_U_CODE_U_UID
+49 SET ^TMP("PXRMTXSC",$JOB,"SELECTED",ENUM,NDUP)=TEMP
+50 SET ^TMP("PXRMTXSC",$JOB,"CODE",ENUM,NDUP)=TEMP
End DoDot:3
End DoDot:2
End DoDot:1
+51 SET ^TMP("PXRMTXSC",$JOB,"NCODES")=ENUM
+52 SET ^TMP("PXRMTXSC",$JOB,"VALMCNT")=VALMCNT
+53 ;Set these so LM shows Page 1 of 1 when there are no codes.
+54 IF ENUM=0
SET VALMHDR(2)="No codes have been selected."
SET ^TMP("PXRMTXSC",$JOB,1,0)=""
SET VALMCNT=1
QUIT
+55 SET VALMHDR(2)=ENUM_" codes have been selected, "_NUID_" are marked UID."
+56 QUIT
+57 ;
+58 ;=========================================
ENTRY ;Entry code
+1 DO INITMPG^PXRMTXLS
+2 DO HDR^PXRMTXLS
+3 DO BLDLIST^PXRMTXLS
+4 DO XQORM^PXRMTXLS
+5 QUIT
+6 ;
+7 ;=========================================
EXIT ;Exit code
+1 DO INITMPG^PXRMTXLS
+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^PXRMTXLS
+2 SET VALMBCK="Q"
+3 QUIT
+4 ;
+5 ;=========================================
FORMAT(TEXT,FMTSTR,NL,OUTPUT) ;Format entry number, code,
+1 ;activation date, inactivation date, short text for LM display.
+2 NEW ACTDT,INACTDT
+3 SET ACTDT=$PIECE(TEXT,U,3)
SET INACTDT=$PIECE(TEXT,U,4)
+4 SET ACTDT=$$FMTE^XLFDT(ACTDT,5)
+5 SET INACTDT=$$FMTE^XLFDT(INACTDT,5)
+6 SET $PIECE(TEXT,U,3)=ACTDT
SET $PIECE(TEXT,U,4)=INACTDT
+7 DO COLFMT^PXRMTEXT(FMTSTR,TEXT," ",.NL,.OUTPUT)
+8 QUIT
+9 ;
+10 ;=========================================
GETLIST(LIST) ;Let the user input a list of items.
+1 NEW INUM,ITEM,LEND,LELEM,NCODES,LSTART,X,Y
+2 SET NCODES=+$GET(^TMP("PXRMTXSC",$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)="All selected codes in this 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("PXRMTXSC",$JOB,"LINES",ENUM),U,1)
+5 SET STOP=$PIECE(^TMP("PXRMTXSC",$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. PROBABLY CAN REMOVE AND USE ORIGINAL
+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 ;=========================================
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 CODESYS,ENUM,IND,NDUP
+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("PXRMTXSC",$JOB)
+2 QUIT
+3 ;
+4 ;=========================================
LEXPER(ENUM,CODE,CODESYS,NLINES,TEXT) ;Call PERIOD^LEXU to get the code
+1 ;information.
+2 NEW ACTDT,DESC,INACTDT,PDATA,RESULT
+3 ;DBIA #5679
+4 SET RESULT=$$PERIOD^LEXU(CODE,CODESYS,.PDATA)
+5 IF +RESULT=-1
SET NLINES=0
QUIT
+6 SET (ACTDT,NLINES)=0
+7 FOR
SET ACTDT=$ORDER(PDATA(ACTDT))
if ACTDT=""
QUIT
Begin DoDot:1
+8 SET INACTDT=$PIECE(PDATA(ACTDT),U,1)
+9 SET DESC=PDATA(ACTDT,0)
+10 IF CODESYS="SCT"
SET DESC=DESC_" "_$$SCTHIER^PXRMTXIN(CODE,ACTDT)
+11 SET NLINES=NLINES+1
+12 IF NLINES=1
SET TEXT(NLINES)=ENUM_U_CODE_U_ACTDT_U_INACTDT_U_DESC
+13 IF '$TEST
SET TEXT(NLINES)=U_U_ACTDT_U_INACTDT_U_DESC
End DoDot:1
+14 QUIT
+15 ;
+16 ;=========================================
PEXIT ; Protocol exit code
+1 SET VALMSG="+ Next Screen - Prev Screen ?? More Actions"
+2 ;Reset after page up/down etc
+3 DO XQORM^PXRMTXLS
+4 QUIT
+5 ;
+6 ;=========================================
RFD(ENUM) ;Remove UID from the selected entry.
+1 NEW NDUP,START
+2 SET NDUP=0
+3 FOR
SET NDUP=$ORDER(^TMP("PXRMTXSC",$JOB,"SELECTED",ENUM,NDUP))
if NDUP=""
QUIT
Begin DoDot:1
+4 SET $PIECE(^TMP("PXRMTXSC",$JOB,"SELECTED",ENUM,NDUP),U,4)=0
End DoDot:1
+5 SET START=$PIECE(^TMP("PXRMTXSC",$JOB,"LINES",ENUM),U,1)
+6 DO FLDCTRL^VALM10(START,"CODE",IORVOFF,IORVOFF,"")
+7 QUIT
+8 ;
+9 ;=========================================
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 NEW CODE,CODESYS,DEL,NDUP,TEMP,TERM
+2 SET NDUP=0
+3 FOR
SET NDUP=$ORDER(^TMP("PXRMTXSC",$JOB,"SELECTED",ENUM,NDUP))
if NDUP=""
QUIT
Begin DoDot:1
+4 SET TEMP=^TMP("PXRMTXSC",$JOB,"SELECTED",ENUM,NDUP)
+5 SET ^TMP("PXRMTXSC",$JOB,"SELECTED",ENUM,NDUP)=TEMP_U_"@"
End DoDot:1
+6 DO HLITE(ENUM,0,0)
+7 QUIT
+8 ;
+9 ;=========================================
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. This amounts to rebuilding
+1 ;^TMP("PXRMCODES",$J).
+2 NEW CODE,CODESYS,DEL,ENUM,NDUP,TEMP,TERM,UID
+3 SET ENUM=0
+4 FOR
SET ENUM=$ORDER(^TMP("PXRMTXSC",$JOB,"SELECTED",ENUM))
if ENUM=""
QUIT
Begin DoDot:1
+5 SET NDUP=0
+6 FOR
SET NDUP=$ORDER(^TMP("PXRMTXSC",$JOB,"SELECTED",ENUM,NDUP))
if NDUP=""
QUIT
Begin DoDot:2
+7 SET TEMP=^TMP("PXRMTXSC",$JOB,"SELECTED",ENUM,NDUP)
+8 SET TERM=$PIECE(TEMP,U,1)
SET CODESYS=$PIECE(TEMP,U,2)
+9 SET CODE=$PIECE(TEMP,U,3)
SET UID=$PIECE(TEMP,U,4)
+10 IF TEMP["@"
KILL ^TMP("PXRMCODES",$JOB,TERM,CODESYS,CODE)
+11 IF '$TEST
SET ^TMP("PXRMCODES",$JOB,TERM,CODESYS,CODE)=UID
End DoDot:2
End DoDot:1
+12 ;Check for terms that should be deleted.
+13 SET TERM=""
+14 FOR
SET TERM=$ORDER(^TMP("PXRMCODES",$JOB,TERM))
if TERM=""
QUIT
Begin DoDot:1
+15 SET DEL=$$TERMDEL(TERM)
+16 IF DEL
SET ^TMP("PXRMCODES",$JOB,TERM)="@"
QUIT
+17 SET CODESYS=""
+18 FOR
SET CODESYS=$ORDER(^TMP("PXRMCODES",$JOB,TERM,CODESYS))
if CODESYS=""
QUIT
Begin DoDot:2
+19 ;(TERM,CODESYS) exists but has no codes if $D=1
+20 IF $DATA(^TMP("PXRMCODES",$JOB,TERM,CODESYS))=1
SET ^TMP("PXRMCODES",$JOB,TERM,CODESYS)=""
End DoDot:2
End DoDot:1
+21 SET VALMBCK="R"
+22 QUIT
+23 ;
+24 ;=========================================
TERMDEL(TERM) ;Determine how many codes this term contains. If there are none
+1 ;then ask the user if they want the term deleted.
+2 NEW CODE,CODESYS,DEL,DIR,IENS,IND,KFDA,MSG,NCODES,TEXT,X,Y
+3 SET CODESYS=""
SET NCODES=0
+4 SET CODESYS=""
+5 FOR
SET CODESYS=$ORDER(^TMP("PXRMCODES",$JOB,TERM,CODESYS))
if CODESYS=""
QUIT
Begin DoDot:1
+6 SET CODE=""
+7 FOR
SET CODE=$ORDER(^TMP("PXRMCODES",$JOB,TERM,CODESYS,CODE))
if CODE=""
QUIT
SET NCODES=NCODES+1
End DoDot:1
+8 ;
+9 IF NCODES>0
QUIT 0
+10 ;Have the user verify the term deletion is OK.
+11 SET TEXT(1)=""
+12 SET TEXT(2)="All the codes in term "_TERM
+13 SET TEXT(3)="have been selected for removal from the taxonomy."
+14 SET TEXT(4)=""
+15 DO EN^DDIOL(.TEXT)
+16 SET DIR(0)="YAO"
+17 SET DIR("A")="Do you want this term deleted too? "
+18 SET DIR("B")="Y"
+19 DO ^DIR
+20 ;The user said not to delete the term.
+21 IF +Y=0
QUIT 0
+22 KILL TEXT
+23 SET TEXT(1)="The term will be deleted when the editing session is saved."
+24 SET TEXT(2)=""
+25 DO EN^DDIOL(.TEXT)
HANG 2
+26 QUIT 1
+27 ;
+28 ;=========================================
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 ;=========================================
XQORM ; Set range for selection.
+1 NEW NCODES
+2 SET NCODES=+$GET(^TMP("PXRMTXSC",$JOB,"NCODES"))
+3 IF NCODES=0
QUIT
+4 SET XQORM("#")=$ORDER(^ORD(101,"B","PXRM TAXONOMY ALL SELECTED SELECT",0))_U_"1:"_NCODES
+5 SET XQORM("A")="Select Action: "
+6 QUIT
+7 ;
+8 ;=========================================
XSEL ;Entry action for protocol PXRM TAXONOMY ALL SELECTED SELECT.
+1 NEW ENUM,IND,LIST,NCODES,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 SET NCODES=+$ORDER(^TMP("PXRMTXSC",$JOB,"LINES",""),-1)
+7 FOR IND=1:1:$LENGTH(LIST,",")
Begin DoDot:1
+8 SET ENUM=$PIECE(LIST,",",IND)
+9 IF (ENUM<1)!(ENUM>NCODES)
Begin DoDot:2
+10 WRITE !,ENUM," is not a valid selection."
+11 WRITE !,"The range is 1 to ",NCODES,"."
+12 HANG 2
+13 SET LVALID=0
End DoDot:2
End DoDot:1
+14 IF 'LVALID
SET VALMBCK="R"
QUIT
+15 ;
+16 ;Full screen mode
+17 DO FULL^VALM1
+18 ;
+19 ;Possible actions.
+20 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,OPTION,X,Y
+21 SET DIR(0)="SBM"_U_"ADD:Add to taxonomy;"
+22 SET DIR(0)=DIR(0)_"RFT:Remove from taxonomy;"
+23 SET DIR(0)=DIR(0)_"RFD:Remove from dialog;"
+24 SET DIR(0)=DIR(0)_"UID:Use in dialog;"
+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^PXRMTXLS(.LIST,0)
+35 IF OPTION="RFD"
DO RFDX^PXRMTXLS(.LIST)
+36 IF OPTION="RFT"
DO RFTX^PXRMTXLS(.LIST)
+37 IF OPTION="UID"
DO INCX^PXRMTXLS(.LIST,1)
+38 ;
+39 SET VALMBCK="R"
+40 QUIT
+41 ;
