BPXRMEXT ;IHS/MSC/MGH - Calls to big for other routines. ;13-Aug-2015 12:23;du
;;2.0;CLINICAL REMINDERS;**1005**;Feb 04, 2005;Build 23
;==========================================
LEXCHK(CODE,CODESYS,TERM,NCODES,NL,TEXTOUT) ;Use $$TAX^LEX10CS
;to determine if code is a partial code that expands to a list of
;codes. Add valid codes to the list.
N ACODE,CODEI,IND,NFOUND,RESULT,SRC,TEXT
K ^TMP("LEXTAX",$J)
;DBIA #5681
S RESULT=$$TAX^LEX10CS(CODE,CODESYS,DT,"LEXTAX",0)
S NFOUND=+RESULT
I NFOUND=-1 D Q
. S TEXT(1)="Invalid coding system code pair:"
. S TEXT(2)=" Coding system is "_CODESYS_", code is "_CODE
. D EN^DDIOL(.TEXT)
. S NL=NL+1,TEXTOUT(NL)=TEXT(1)
. S NL=NL+1,TEXTOUT(NL)=TEXT(2)
. K ^TMP("LEXTAX",$J)
S SRC=+$O(^TMP("LEXTAX",$J,0))
S CODEI=""
F S CODEI=$O(^TMP("LEXTAX",$J,SRC,CODEI)) Q:CODEI="" D
. S IND=0
. F S IND=$O(^TMP("LEXTAX",$J,SRC,CODEI,IND)) Q:IND="" D
.. S ACODE=$P(^TMP("LEXTAX",$J,SRC,CODEI,IND,0),U,1)
.. S NCODES=NCODES+1
.. S NL=NL+1,TEXTOUT(NL)=$J(NCODES,5)_". "_ACODE
.. S ^TMP($J,"CODES",TERM,CODESYS,ACODE)=""
.. I '$D(^TMP($J,"CC",ACODE,CODESYS,TERM)) D
... S ^TMP($J,"CC",ACODE,CODESYS,TERM)=""
... S ^TMP($J,"CC",ACODE)=$G(^TMP($J,"CC",ACODE))+1
... S NCODES(CODESYS)=NCODES(CODESYS)+1
K ^TMP("LEXTAX",$J)
Q
;
;==========================================
PASTECSV(NODE) ;Paste the CSV file.
N DONE,NL,TEMP
K ^TMP($J,NODE)
S DONE=0,NL=0
D EN^DDIOL("Paste the CSV file now, press <ENTER> to finish.")
D EN^DDIOL("","","!") H 1
F Q:DONE D
. R TEMP:10
. I '$T S DONE=1 Q
. I $L(TEMP)=0 S DONE=1 Q
. S NL=NL+1,^TMP($J,NODE,NL,1)=TEMP
Q
;=================================================
HELP ;Display help for taxonomy edits
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
;IHS/MSC/MGH Newed Variables
N IOSTBM,IORI
D BROWSE^DDBR("TEXT","NR","Lexicon Selection Help")
S VALMBCK="R"
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 i
;; SAVE - saves all selected codes. Even if codes have been selected,
;; not be stored until they are saved. Finally, a save must be
;; 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 R
;;actions cannot be selected. Actions that cannot be selected have thei
;;description surrounded by parentheses. For example, when a coding sys
;;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
;; UID (Use in dialog)
;;
;;You can select the action first and then be prompted for a list of co
;;you can input the list and then select the action. Because of the way
;;Manager works, you may be able to select a larger list by selecting t
;;first.
;;
;;**End Text**
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^PXRMLEXL 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
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
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)
.. 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
BPXRMEXT ;IHS/MSC/MGH - Calls to big for other routines. ;13-Aug-2015 12:23;du
+1 ;;2.0;CLINICAL REMINDERS;**1005**;Feb 04, 2005;Build 23
+2 ;==========================================
LEXCHK(CODE,CODESYS,TERM,NCODES,NL,TEXTOUT) ;Use $$TAX^LEX10CS
+1 ;to determine if code is a partial code that expands to a list of
+2 ;codes. Add valid codes to the list.
+3 NEW ACODE,CODEI,IND,NFOUND,RESULT,SRC,TEXT
+4 KILL ^TMP("LEXTAX",$JOB)
+5 ;DBIA #5681
+6 SET RESULT=$$TAX^LEX10CS(CODE,CODESYS,DT,"LEXTAX",0)
+7 SET NFOUND=+RESULT
+8 IF NFOUND=-1
Begin DoDot:1
+9 SET TEXT(1)="Invalid coding system code pair:"
+10 SET TEXT(2)=" Coding system is "_CODESYS_", code is "_CODE
+11 DO EN^DDIOL(.TEXT)
+12 SET NL=NL+1
SET TEXTOUT(NL)=TEXT(1)
+13 SET NL=NL+1
SET TEXTOUT(NL)=TEXT(2)
+14 KILL ^TMP("LEXTAX",$JOB)
End DoDot:1
QUIT
+15 SET SRC=+$ORDER(^TMP("LEXTAX",$JOB,0))
+16 SET CODEI=""
+17 FOR
SET CODEI=$ORDER(^TMP("LEXTAX",$JOB,SRC,CODEI))
IF CODEI=""
QUIT
Begin DoDot:1
+18 SET IND=0
+19 FOR
SET IND=$ORDER(^TMP("LEXTAX",$JOB,SRC,CODEI,IND))
IF IND=""
QUIT
Begin DoDot:2
+20 SET ACODE=$PIECE(^TMP("LEXTAX",$JOB,SRC,CODEI,IND,0),U,1)
+21 SET NCODES=NCODES+1
+22 SET NL=NL+1
SET TEXTOUT(NL)=$JUSTIFY(NCODES,5)_". "_ACODE
+23 SET ^TMP($JOB,"CODES",TERM,CODESYS,ACODE)=""
+24 IF '$DATA(^TMP($JOB,"CC",ACODE,CODESYS,TERM))
Begin DoDot:3
+25 SET ^TMP($JOB,"CC",ACODE,CODESYS,TERM)=""
+26 SET ^TMP($JOB,"CC",ACODE)=$GET(^TMP($JOB,"CC",ACODE))+1
+27 SET NCODES(CODESYS)=NCODES(CODESYS)+1
End DoDot:3
End DoDot:2
End DoDot:1
+28 KILL ^TMP("LEXTAX",$JOB)
+29 QUIT
+30 ;
+31 ;==========================================
PASTECSV(NODE) ;Paste the CSV file.
+1 NEW DONE,NL,TEMP
+2 KILL ^TMP($JOB,NODE)
+3 SET DONE=0
SET NL=0
+4 DO EN^DDIOL("Paste the CSV file now, press <ENTER> to finish.")
+5 DO EN^DDIOL("","","!")
HANG 1
+6 FOR
IF DONE
QUIT
Begin DoDot:1
+7 READ TEMP:10
+8 IF '$TEST
SET DONE=1
QUIT
+9 IF $LENGTH(TEMP)=0
SET DONE=1
QUIT
+10 SET NL=NL+1
SET ^TMP($JOB,NODE,NL,1)=TEMP
End DoDot:1
+11 QUIT
+12 ;=================================================
HELP ;Display help for taxonomy edits
+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 ;IHS/MSC/MGH Newed Variables
+9 NEW IOSTBM,IORI
+10 DO BROWSE^DDBR("TEXT","NR","Lexicon Selection Help")
+11 SET VALMBCK="R"
+12 QUIT
+13 ;=========================================
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 i
+7 ;; SAVE - saves all selected codes. Even if codes have been selected,
+8 ;; not be stored until they are saved. Finally, a save must be
+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 R
+13 ;;actions cannot be selected. Actions that cannot be selected have thei
+14 ;;description surrounded by parentheses. For example, when a coding sys
+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
+18 ;; UID (Use in dialog)
+19 ;;
+20 ;;You can select the action first and then be prompted for a list of co
+21 ;;you can input the list and then select the action. Because of the way
+22 ;;Manager works, you may be able to select a larger list by selecting t
+23 ;;first.
+24 ;;
+25 ;;**End Text**
+26 QUIT
+27 ;--------------------------------------------------------
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 ;Possible actions.
+18 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,OPTION,X,Y
+19 SET DIR(0)="SBM"_U_"ADD:Add to taxonomy;"
+20 SET DIR(0)=DIR(0)_"RFT:Remove from taxonomy;"
+21 IF $$UIDOK^PXRMLEXL
Begin DoDot:1
+22 SET DIR(0)=DIR(0)_"RFD:Remove from dialog;"
+23 SET DIR(0)=DIR(0)_"UID:Use in dialog;"
End DoDot:1
+24 SET DIR("A")="Select Action: "
+25 SET DIR("B")="ADD"
+26 SET DIR("?")="Select from the actions displayed."
+27 DO ^DIR
+28 IF $DATA(DIROUT)!$DATA(DIRUT)
SET VALMBCK="R"
QUIT
+29 IF $DATA(DTOUT)!$DATA(DUOUT)
SET VALMBCK="R"
QUIT
+30 SET OPTION=Y
+31 DO CLEAR^VALM1
+32 IF OPTION="ADD"
DO INCX^PXRMLEXL(.LIST,0)
+33 IF OPTION="RFD"
DO RFDX^PXRMLEXL(.LIST)
+34 IF OPTION="RFT"
DO RFTX^PXRMLEXL(.LIST)
+35 IF OPTION="UID"
DO INCX^PXRMLEXL(.LIST,1)
+36 ;
+37 SET VALMBCK="R"
+38 QUIT
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
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 SET NUM=NUM+1
+15 SET NLINES=NLINES+1
+16 IF NUM=1
SET TEXT(NLINES)=NCODES_U_CODE_U_ACTDT_U_INACTDT_U_DESC
+17 IF '$TEST
SET TEXT(NLINES)=U_U_ACTDT_U_INACTDT_U_DESC
End DoDot:2
End DoDot:1
+18 QUIT
