Routine: BPXRMEXT

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)

 ;==========================================

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

 ;=================================================

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"

 ;=========================================

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**

 ;--------------------------------------------------------

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"

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")

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

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

BPXRMEXT.m