IBDF4.m

IBDF4 ;ALB/CJM - ENCOUNTER FORM - BUILD FORM(editing group's selections) ;NOV 16,1992

 ;;3.0;AUTOMATED INFO COLLECTION SYS;**19,38**;APR 24, 1997

 ;

SLCTNS ;

 N IBRTN

 Q:IBLIST'=$P($G(^IBE(357.4,IBGRP,0)),"^",3)

 S IBRTN=IBLIST("RTN")

 D RTNDSCR^IBDFU1B(.IBRTN)

 D KILL^IBDFUA

 D EN^VALM("IBDF EDIT GROUP'S SELECTIONS") ;call the list manager

 Q

ONENTRY ;entry code for list manager

 D IDXSLCTN

 Q

ONEXIT ;exit code for the list manager

 K @VALMAR

 Q

 ;

IDXSLCTN ;build an array of selections in print order for the list processor

 N SLCTN,ODR,NODE

 K @VALMAR

 S ODR="",VALMCNT=0

 F  S ODR=$O(^IBE(357.3,"APO",IBLIST,IBGRP,ODR)) Q:ODR=""  D

 .S SLCTN="" F  S SLCTN=$O(^IBE(357.3,"APO",IBLIST,IBGRP,ODR,SLCTN)) Q:'SLCTN  D

 ..;check for messed up index and take appropriate action

 ..S NODE=$G(^IBE(357.3,SLCTN,0))

 ..I ($P(NODE,"^",3)'=IBLIST)!($P(NODE,"^",4)'=IBGRP) D  Q

 ...K ^IBE(357.3,"APO",IBLIST,IBGRP,ODR,SLCTN)

 ...I $P(NODE,"^",3)'=IBLIST,$P(NODE,"^",4)=IBGRP D  Q

 ....K DIK,DA S DIK="^IBE(357.3,",DA=SLCTN D ^DIK K DIK,DA

 ...I $P(NODE,"^",3)=IBLIST,$P($G(^IBE(357.4,+IBGRP,0)),"^",3)'=IBLIST D  Q

 ....K DIK,DA S DIK="^IBE(357.3,",DA=SLCTN D ^DIK K DIK,DA

 ...K DIK,DA S DIK="^IBE(357.3,",DA=SLCTN D IX^DIK K DIK,DA

 ..;

 ..S VALMCNT=VALMCNT+1

 ..S @VALMAR@(VALMCNT,0)=$$DISPLAY(SLCTN,VALMCNT),@VALMAR@("IDX",VALMCNT,VALMCNT)=SLCTN

 ..D FLDCTRL^VALM10(VALMCNT,"ID") ;set video for ID column

 Q

LMGRPHDR ;header for the screen

 S VALMHDR(1)="SELECTIONS CURRENTLY DEFINED FOR '"_$$GRPNAME_"' PRINT GROUP"

 Q

 ;

GRPNAME() ;the name of the selection group

 Q $P($G(^IBE(357.4,IBGRP,0)),"^",1)

 ;

DISPLAY(SLCTN,COUNT) ;returns a line to display to the list containing a selection - SLCTN is a ptr to the selectin, COUNT is the number of the selection on the list

 N SC,SCDA,VAL,RET,W,NODE,ORDER

 ;W - an array cotaining the widths of the subcolumns that contain text

 S VAL=""

 S RET=$$PADRIGHT^IBDFU(COUNT,4)

 S NODE=$G(^IBE(357.3,SLCTN,0))

 S ORDER=$P(NODE,"^",5),RET=RET_$J(ORDER,6,2)

 I $P(NODE,"^",2) S RET=RET_$S($P(NODE,"^",7):" SH",1:" PH")_"| "_$P(NODE,"^",6)

 I '$P(NODE,"^",2) S RET=RET_"  ",SC="" F SC=1:1:8 S SCDA=$O(^IBE(357.3,SLCTN,1,"B",SC,"")) D

 .I $G(IBLIST("SCTYPE",SC))=1 S W(SC)=IBLIST("SCW",SC)*(1+IBLIST("BTWN"))

 .S:$G(W(SC)) VAL=$$PADRIGHT^IBDFU($S(SCDA:$P($G(^IBE(357.3,SLCTN,1,SCDA,0)),"^",2),1:""),W(SC))

 .S:VAL'="" RET=RET_" | "_VAL

 .S VAL=""

 I $D(^IBE(357.3,SLCTN,2)) S RET=RET_"  ",SC="" F SC=1:1:2 S SCDA=$P(^IBE(357.3,SLCTN,2),"^",SC) S:SC=2 SCDA=$S($D(^LEX)>1:$P($G(^LEX(757.01,+SCDA,0)),"^"),1:$P($G(^GMP(757.01,+SCDA,0)),"^")) D

 .S W(SC)=25

 .S VAL=$$PADRIGHT^IBDFU($S(SCDA]"":SCDA,1:""),W(SC))

 .S:VAL'="" RET=RET_" | "_VAL

 .S VAL=""

 Q RET

ADDSLCTN ;allows the user to add a selection to the selection group

 N QUIT,SUB

 ;

 S VALMBCK="R"

 D FULL^VALM1

 I IBRTN("ACTION")'=3 D NOGOOD G ADDEXIT

 K @IBRTN("DATA_LOCATION")

 S QUIT=0 F  D  Q:QUIT  W !!!,"Now for another SELECTION LIST entry!"

 .I '$$DORTN^IBDFU1B(.IBRTN) S QUIT=1 D NOGOOD Q

 .I '$D(@IBRTN("DATA_LOCATION")) S QUIT=1 Q

 .D ADDREC(.QUIT) ;edits and adds the selection

 .K @IBRTN("DATA_LOCATION")

ADDEXIT ;

 D IDXSLCTN

 Q

ADDREC(QUIT,ORDER,SLCTN) ;allows the user to number the selection, edit the editable subcolumns, then adds the record - sets QUIT=1 if user quits

 N SUB,COUNT,NODE,VAL,DLAYGO,QTY,DTOUT,DUOUT,DIRUT

 I $P($G(^IBE(357.6,$P($G(^IBE(357.2,+IBLIST,0)),"^",11),16)),"^",8) S DIR(0)="NO",DIR("A")="Quantity",DIR("B")=1,DIR("?")="Enter the number of occurrences" D ^DIR K DIR S:$D(DTOUT)!$D(DUOUT) QUIT=1 Q:QUIT  S QTY=$G(Y)

 I '$G(ORDER) D  Q:QUIT

 .K DIR S DIR(0)="357.3,.05",DIR("B")=$$NEXT^IBDF4A(IBLIST,IBGRP) D ^DIR K DIR I $D(DIRUT) S QUIT=1 Q

 .S ORDER=+Y

 S VAL=$G(@IBRTN("DATA_LOCATION"))

 Q:QUIT

 ;we have all the data needed to add the selection - so add it

 S NODE=$S($P(VAL,"^")'="":$P(VAL,"^"),1:ORDER)_"^^"_IBLIST_"^"_IBGRP_"^"_ORDER_$S($G(QTY):"^^^^"_QTY,1:"")

 K DIC,DD,DO,DINUM S DIC="^IBE(357.3,",X=$P(NODE,"^",1),DIC(0)="FL",DLAYGO=357.3

 D FILE^DICN K DIC,DIE,DA

 S SLCTN=$S(+Y<0:"",1:+Y)

 I 'SLCTN W !,"Unable to create a new selection record!" D PAUSE^VALM1 S QUIT=1 Q

 S ^IBE(357.3,SLCTN,0)=NODE

 ;--- move codes and add modifiers

 D CODES^IBDF4A,ADD^IBDF4C

 ;---move the subcolum set up

 F SUB=1:1:8 D  Q:QUIT

 .I $G(IBLIST("SCTYPE",SUB))=1 I IBLIST("SCPIECE",SUB),IBLIST("SCW",SUB) D

 ..S NODE=$$DATANODE^IBDFU1B(IBRTN,IBLIST("SCPIECE",SUB))

 ..I NODE]"" S VAL(SUB)=$P($G(@IBRTN("DATA_LOCATION")@(NODE)),"^",IBLIST("SCPIECE",SUB))

 ..E  S VAL(SUB)=$P(VAL,"^",IBLIST("SCPIECE",SUB))

 ..Q:('IBLIST("SCEDITABLE",SUB))!((IBRTN("WIDTH",1))&(IBLIST("SCPIECE",SUB)=1))

 ..W !!,"Subcolumn Header: "_IBLIST("SCHDR",SUB) K DIR S DIR(0)="FO^0:"_(IBLIST("SCW",SUB)*(1+IBLIST("BTWN"))),DIR("A")="Edit Subcolumn "_SUB,DIR("B")=VAL(SUB)_$S($G(QTY)>1:" x "_QTY,1:"")

 ..I $P($G(^IBE(357.3,SLCTN,3,0)),"^",4)>0 D

 ...S:DIR("B")'["w/ mod" DIR("B")=DIR("B")_"w/ mod"

 ..D ^DIR K DIR S:$D(DTOUT)!$D(DUOUT) QUIT=1 Q:QUIT  S VAL(SUB)=Y I IBLIST("SCPIECE",SUB)=1,X="" S QUIT=1

 ;

 ;add the subcolumn value multiple

 S COUNT=0 F SUB=1:1:8 I $G(VAL(SUB))'="" S COUNT=COUNT+1,^IBE(357.3,SLCTN,1,COUNT,0)=SUB_"^"_VAL(SUB)

 S ^IBE(357.3,SLCTN,1,0)="^357.31IA^"_COUNT_"^"_COUNT

 K DA S DA=SLCTN,DIK="^IBE(357.3," D IX^DIK K DIK,DA

 D NARR,TERM

 Q

 ;

NARR ; -- edit provider narrative, but only for selections where the

 ;    interface allows editing

 N DIE,DA,DR

 I $P($G(^IBE(357.6,+$P($G(^IBE(357.2,+IBLIST,0)),U,11),0)),U,17) D

 .S DIE="^IBE(357.3,",DA=SLCTN,DR=2.01 D ^DIE

 Q

 ;

TERM ; -- map selection to clinical lexicon, but only for selections where

 ;    the package interface allows editing

 N DIE,DA,DR,GMPTUN,GMPTSUB,GMPTSHOW,XTLKGLB,XTLKHLP,XTLKKSCH,XTLKSAY,IBDLEX

 I $P($G(^IBE(357.6,+$P($G(^IBE(357.2,+IBLIST,0)),U,11),0)),U,18) D

 .I $D(^LEX)>1 S X="LEXSET" X ^%ZOSF("TEST") I $T D CONFIG^LEXSET("GMPL","PL1") S IBDLEX=1

 .I '$D(IBDLEX) S X="GMPTSET" X ^%ZOSF("TEST") I $T D CONFIG^GMPTSET("GMPL","PL1") S IBDLEX=1

 .;D CONFIG^GMPTSET("ICD","ICD") (this is an alternate filter)

 .Q:'$D(IBDLEX)

 .S DIE="^IBE(357.3,",DA=SLCTN,DR="2.02//"_$P($G(^IBE(357.3,DA,0)),"^") D ^DIE

 Q

 ;

CODES ; -- allow selection of a second code to pass through for this entry

 ; -- only as if pi allows input of more than one code

 ;N PI S PI=+$P($G(^IBE(357.2,+IBLIST,0)),U,11)

 ;Q:'$P($G(^IBE(357.6,PI,16)),U,9)

 ;N IBI,QUIT,IBVAL S QUIT=0

 ;F IBI=1,2 D  Q:QUIT

 ;.W !,"****Select a ",$S(IBI=1:"second",1:"third")," code to pass along with original."

 ;.I '$$DORTN^IBDFU1B(.IBRTN) S QUIT=1 Q

 ;.I +Y'>0 S QUIT=1 Q

 ;.X $G(^IBE(357.6,PI,9)) S IBVAL=X

 ;.S DIE="^IBE(357.3,",DA=SLCTN,DR=$S(IBI=1:"2.03",1:"2.04")_"////^S X=IBVAL" D ^DIE K DIE,DA,DR

 ;Q

 ;

NOGOOD ;

 W !,"The package interface routine for selection is not properly defined" D PAUSE^VALM1

 Q

 ;

SEQUENCE ;allows the user to resequence all of the selections on the list

 ;

 N SUBCOL,CNT,P,SORT,GROUP,NODE,VALUE,ITEM,IEN,HDR,DTOUT,DUOUT,DIRUT,SORT1

 S VALMBCK="R"

 D FULL^VALM1

 ;

 ;sort by which subcolumn?

 K DIR S DIR("A")="Which subcolumn do you want to sort by?",DIR("?")=" "

 S SUBCOL=0 F  S SUBCOL=$O(IBLIST("SCTYPE",SUBCOL)) Q:'SUBCOL  I IBLIST("SCTYPE",SUBCOL)=1 S SUBCOL(SUBCOL)=""

 S (CNT,SUBCOL)=0,DIR(0)="SOX^"

 F CNT=1:1 S SUBCOL=$O(SUBCOL(SUBCOL)) Q:'SUBCOL  D

 .S P=IBLIST("SCPIECE",SUBCOL),P=$S(P=1:1,P=2:3,P=3:5,P=4:7,P=5:9,P=6:11,P=7:13,1:0),HDR=$P($G(^IBE(357.6,+IBLIST("RTN"),2)),"^",P),DIR("?",CNT)=SUBCOL_" = "_HDR

 .S HDR=$S($G(IBLIST("SCHDR",SUBCOL))="":HDR,1:IBLIST("SCHDR",SUBCOL))

 .S DIR(0)=DIR(0)_SUBCOL_":"_HDR_";"

 D ^DIR

 Q:$D(DIRUT)!(Y=-1)

 K SUBCOL S SUBCOL=+Y

 ;

 ;sort aphabetically or numerically?

 K DIR

 S DIR("A")="How should the list be sorted?",DIR(0)="SO^1:ALPHABETICALLY;2:NUMERICALLY;",DIR("B")="ALPHABETICALLY"

 D ^DIR

 Q:$D(DIRUT)!(Y=-1)

 S SORT=Y

 ;  -- Resequence by group or group and placeholders

 K DIR

 S DIR("A")="Resequence by Group or Group and Place Holders?",DIR(0)="SO^1:GROUP/PLACE HOLDERS;2:GROUP;",DIR("B")="GROUP/PLACE HOLDERS"

 D ^DIR

 Q:$D(DIRUT)!(Y=-1)

 S SORT1=Y

 ;

 ;sort

 I SORT1=2 D EN^IBDF4A Q

 N CNTR,GROUP1,IBGROUP,IBORDER

 K ^TMP("IBDF",$J)

 S (GROUP,GROUP1,CNTR,IBGROUP)=0

 ;  -- Resequence only specific groups in block.

 I $D(IBGRUP) F  S IBGROUP=$O(IBGRUP(IBGROUP)) Q:'IBGROUP  D RESEQ

 I $D(IBGRUP) D ORDER Q

 ;  -- Resequence all groups of the block.

 I '$D(IBGRUP) F  S IBGROUP=$O(^IBE(357.3,"APO",IBLIST,IBGROUP)) Q:'IBGROUP  D RESEQ

 I '$D(IBGRUP) D ORDER Q

 Q

RESEQ S IBORDER=0 F  S IBORDER=$O(^IBE(357.3,"APO",IBLIST,IBGROUP,IBORDER)) Q:'IBORDER  S ITEM=0 F  S ITEM=$O(^IBE(357.3,"APO",IBLIST,IBGROUP,IBORDER,ITEM)) Q:'ITEM  D

 .S NODE=$G(^IBE(357.3,ITEM,0))

 .I ($P(NODE,"^",3)'=IBLIST) Q

 .S GROUP1=GROUP,GROUP=+$P(NODE,"^",4)

 .Q:$P($G(^IBE(357.4,GROUP,0)),"^",3)'=IBLIST

 .I $P(NODE,"^",2)=1 D  Q

 ..S CNTR=CNTR+1

 ..S VALUE=$S(SORT=1:" ",1:+$P(NODE,"^",1))

 ..S ^TMP("IBDF",$J,"RESEQUENCE LIST",GROUP,CNTR,VALUE,ITEM)=""

 .S IEN=$O(^IBE(357.3,ITEM,1,"B",SUBCOL,0)) Q:'IEN

 .S VALUE=$P($G(^IBE(357.3,ITEM,1,IEN,0)),"^",2)

 .S VALUE=$S(SORT=1:VALUE=" "_VALUE,1:+$P(NODE,"^",1))

 .I GROUP'=GROUP1 S CNTR=CNTR+1

 .S ^TMP("IBDF",$J,"RESEQUENCE LIST",GROUP,CNTR,$E(VALUE,1,40),ITEM)=""

 ;set the order

ORDER S GROUP=0,CNTR=0

 F  S GROUP=$O(^TMP("IBDF",$J,"RESEQUENCE LIST",GROUP)) Q:'GROUP  D

 .S VALUE="",CNT=0

 .F  S CNTR=$O(^TMP("IBDF",$J,"RESEQUENCE LIST",GROUP,CNTR)) Q:'CNTR  F  S VALUE=$O(^TMP("IBDF",$J,"RESEQUENCE LIST",GROUP,CNTR,VALUE)) Q:VALUE=""  D

 ..S ITEM=0 F  S ITEM=$O(^TMP("IBDF",$J,"RESEQUENCE LIST",GROUP,CNTR,VALUE,ITEM)) Q:'ITEM  D

 ...S CNT=CNT+1

 ...K DIE,DA,DR S DIE="^IBE(357.3,",DR=".05///"_CNT,DA=ITEM D ^DIE K DIE,DA,DR

 ;

 K Y,X,DIR,^TMP("IBDF",$J,"RESEQUENCE LIST")

 D IDXGRP^IBDF3

 Q

IBDF4     ;ALB/CJM - ENCOUNTER FORM - BUILD FORM(editing group's selections) ;NOV 16,1992

 +1       ;;3.0;AUTOMATED INFO COLLECTION SYS;**19,38**;APR 24, 1997

 +2       ;

SLCTNS    ;

 +1        NEW IBRTN

 +2        IF IBLIST'=$PIECE($GET(^IBE(357.4,IBGRP,0)),"^",3)

               QUIT 

 +3        SET IBRTN=IBLIST("RTN")

 +4        DO RTNDSCR^IBDFU1B(.IBRTN)

 +5        DO KILL^IBDFUA

 +6       ;call the list manager

           DO EN^VALM("IBDF EDIT GROUP'S SELECTIONS")

 +7        QUIT 

ONENTRY   ;entry code for list manager

 +1        DO IDXSLCTN

 +2        QUIT 

ONEXIT    ;exit code for the list manager

 +1        KILL @VALMAR

 +2        QUIT 

 +3       ;

IDXSLCTN  ;build an array of selections in print order for the list processor

 +1        NEW SLCTN,ODR,NODE

 +2        KILL @VALMAR

 +3        SET ODR=""

           SET VALMCNT=0

 +4        FOR 

               SET ODR=$ORDER(^IBE(357.3,"APO",IBLIST,IBGRP,ODR))

               IF ODR=""

                   QUIT 

               Begin DoDot:1

 +5                SET SLCTN=""

                   FOR 

                       SET SLCTN=$ORDER(^IBE(357.3,"APO",IBLIST,IBGRP,ODR,SLCTN))

                       IF 'SLCTN

                           QUIT 

                       Begin DoDot:2

 +6       ;check for messed up index and take appropriate action

 +7                        SET NODE=$GET(^IBE(357.3,SLCTN,0))

 +8                        IF ($PIECE(NODE,"^",3)'=IBLIST)!($PIECE(NODE,"^",4)'=IBGRP)

                               Begin DoDot:3

 +9                                KILL ^IBE(357.3,"APO",IBLIST,IBGRP,ODR,SLCTN)

 +10                               IF $PIECE(NODE,"^",3)'=IBLIST

                                       IF $PIECE(NODE,"^",4)=IBGRP

                                           Begin DoDot:4

 +11                                           KILL DIK,DA

                                               SET DIK="^IBE(357.3,"

                                               SET DA=SLCTN

                                               DO ^DIK

                                               KILL DIK,DA

                                           End DoDot:4

                                           QUIT 

 +12                               IF $PIECE(NODE,"^",3)=IBLIST

                                       IF $PIECE($GET(^IBE(357.4,+IBGRP,0)),"^",3)'=IBLIST

                                           Begin DoDot:4

 +13                                           KILL DIK,DA

                                               SET DIK="^IBE(357.3,"

                                               SET DA=SLCTN

                                               DO ^DIK

                                               KILL DIK,DA

                                           End DoDot:4

                                           QUIT 

 +14                               KILL DIK,DA

                                   SET DIK="^IBE(357.3,"

                                   SET DA=SLCTN

                                   DO IX^DIK

                                   KILL DIK,DA

                               End DoDot:3

                               QUIT 

 +15      ;

 +16                       SET VALMCNT=VALMCNT+1

 +17                       SET @VALMAR@(VALMCNT,0)=$$DISPLAY(SLCTN,VALMCNT)

                           SET @VALMAR@("IDX",VALMCNT,VALMCNT)=SLCTN

 +18      ;set video for ID column

                           DO FLDCTRL^VALM10(VALMCNT,"ID")

                       End DoDot:2

               End DoDot:1

 +19       QUIT 

LMGRPHDR  ;header for the screen

 +1        SET VALMHDR(1)="SELECTIONS CURRENTLY DEFINED FOR '"_$$GRPNAME_"' PRINT GROUP"

 +2        QUIT 

 +3       ;

GRPNAME() ;the name of the selection group

 +1        QUIT $PIECE($GET(^IBE(357.4,IBGRP,0)),"^",1)

 +2       ;

DISPLAY(SLCTN,COUNT) ;returns a line to display to the list containing a selection - SLCTN is a ptr to the selectin, COUNT is the number of the selection on the list

 +1        NEW SC,SCDA,VAL,RET,W,NODE,ORDER

 +2       ;W - an array cotaining the widths of the subcolumns that contain text

 +3        SET VAL=""

 +4        SET RET=$$PADRIGHT^IBDFU(COUNT,4)

 +5        SET NODE=$GET(^IBE(357.3,SLCTN,0))

 +6        SET ORDER=$PIECE(NODE,"^",5)

           SET RET=RET_$JUSTIFY(ORDER,6,2)

 +7        IF $PIECE(NODE,"^",2)

               SET RET=RET_$SELECT($PIECE(NODE,"^",7):" SH",1:" PH")_"| "_$PIECE(NODE,"^",6)

 +8        IF '$PIECE(NODE,"^",2)

               SET RET=RET_"  "

               SET SC=""

               FOR SC=1:1:8

                   SET SCDA=$ORDER(^IBE(357.3,SLCTN,1,"B",SC,""))

                   Begin DoDot:1

 +9                    IF $GET(IBLIST("SCTYPE",SC))=1

                           SET W(SC)=IBLIST("SCW",SC)*(1+IBLIST("BTWN"))

 +10                   IF $GET(W(SC))

                           SET VAL=$$PADRIGHT^IBDFU($SELECT(SCDA:$PIECE($GET(^IBE(357.3,SLCTN,1,SCDA,0)),"^",2),1:""),W(SC))

 +11                   IF VAL'=""

                           SET RET=RET_" | "_VAL

 +12                   SET VAL=""

                   End DoDot:1

 +13       IF $DATA(^IBE(357.3,SLCTN,2))

               SET RET=RET_"  "

               SET SC=""

               FOR SC=1:1:2

                   SET SCDA=$PIECE(^IBE(357.3,SLCTN,2),"^",SC)

                   IF SC=2

                       SET SCDA=$SELECT($DATA(^LEX)>1:$PIECE($GET(^LEX(757.01,+SCDA,0)),"^"),1:$PIECE($GET(^GMP(757.01,+SCDA,0)),"^"))

                   Begin DoDot:1

 +14                   SET W(SC)=25

 +15                   SET VAL=$$PADRIGHT^IBDFU($SELECT(SCDA]"":SCDA,1:""),W(SC))

 +16                   IF VAL'=""

                           SET RET=RET_" | "_VAL

 +17                   SET VAL=""

                   End DoDot:1

 +18       QUIT RET

ADDSLCTN  ;allows the user to add a selection to the selection group

 +1        NEW QUIT,SUB

 +2       ;

 +3        SET VALMBCK="R"

 +4        DO FULL^VALM1

 +5        IF IBRTN("ACTION")'=3

               DO NOGOOD

               GOTO ADDEXIT

 +6        KILL @IBRTN("DATA_LOCATION")

 +7        SET QUIT=0

           FOR 

               Begin DoDot:1

 +8                IF '$$DORTN^IBDFU1B(.IBRTN)

                       SET QUIT=1

                       DO NOGOOD

                       QUIT 

 +9                IF '$DATA(@IBRTN("DATA_LOCATION"))

                       SET QUIT=1

                       QUIT 

 +10      ;edits and adds the selection

                   DO ADDREC(.QUIT)

 +11               KILL @IBRTN("DATA_LOCATION")

               End DoDot:1

               IF QUIT

                   QUIT 

               WRITE !!!,"Now for another SELECTION LIST entry!"

ADDEXIT   ;

 +1        DO IDXSLCTN

 +2        QUIT 

ADDREC(QUIT,ORDER,SLCTN) ;allows the user to number the selection, edit the editable subcolumns, then adds the record - sets QUIT=1 if user quits

 +1        NEW SUB,COUNT,NODE,VAL,DLAYGO,QTY,DTOUT,DUOUT,DIRUT

 +2        IF $PIECE($GET(^IBE(357.6,$PIECE($GET(^IBE(357.2,+IBLIST,0)),"^",11),16)),"^",8)

               SET DIR(0)="NO"

               SET DIR("A")="Quantity"

               SET DIR("B")=1

               SET DIR("?")="Enter the number of occurrences"

               DO ^DIR

               KILL DIR

               IF $DATA(DTOUT)!$DATA(DUOUT)

                   SET QUIT=1

               IF QUIT

                   QUIT 

               SET QTY=$GET(Y)

 +3        IF '$GET(ORDER)

               Begin DoDot:1

 +4                KILL DIR

                   SET DIR(0)="357.3,.05"

                   SET DIR("B")=$$NEXT^IBDF4A(IBLIST,IBGRP)

                   DO ^DIR

                   KILL DIR

                   IF $DATA(DIRUT)

                       SET QUIT=1

                       QUIT 

 +5                SET ORDER=+Y

               End DoDot:1

               IF QUIT

                   QUIT 

 +6        SET VAL=$GET(@IBRTN("DATA_LOCATION"))

 +7        IF QUIT

               QUIT 

 +8       ;we have all the data needed to add the selection - so add it

 +9        SET NODE=$SELECT($PIECE(VAL,"^")'="":$PIECE(VAL,"^"),1:ORDER)_"^^"_IBLIST_"^"_IBGRP_"^"_ORDER_$SELECT($GET(QTY):"^^^^"_QTY,1:"")

 +10       KILL DIC,DD,DO,DINUM

           SET DIC="^IBE(357.3,"

           SET X=$PIECE(NODE,"^",1)

           SET DIC(0)="FL"

           SET DLAYGO=357.3

 +11       DO FILE^DICN

           KILL DIC,DIE,DA

 +12       SET SLCTN=$SELECT(+Y<0:"",1:+Y)

 +13       IF 'SLCTN

               WRITE !,"Unable to create a new selection record!"

               DO PAUSE^VALM1

               SET QUIT=1

               QUIT 

 +14       SET ^IBE(357.3,SLCTN,0)=NODE

 +15      ;--- move codes and add modifiers

 +16       DO CODES^IBDF4A

           DO ADD^IBDF4C

 +17      ;---move the subcolum set up

 +18       FOR SUB=1:1:8

               Begin DoDot:1

 +19               IF $GET(IBLIST("SCTYPE",SUB))=1

                       IF IBLIST("SCPIECE",SUB)

                           IF IBLIST("SCW",SUB)

                               Begin DoDot:2

 +20                               SET NODE=$$DATANODE^IBDFU1B(IBRTN,IBLIST("SCPIECE",SUB))

 +21                               IF NODE]""

                                       SET VAL(SUB)=$PIECE($GET(@IBRTN("DATA_LOCATION")@(NODE)),"^",IBLIST("SCPIECE",SUB))

 +22                              IF '$TEST

                                       SET VAL(SUB)=$PIECE(VAL,"^",IBLIST("SCPIECE",SUB))

 +23                               IF ('IBLIST("SCEDITABLE",SUB))!((IBRTN("WIDTH",1))&(IBLIST("SCPIECE",SUB)=1))

                                       QUIT 

 +24                               WRITE !!,"Subcolumn Header: "_IBLIST("SCHDR",SUB)

                                   KILL DIR

                                   SET DIR(0)="FO^0:"_(IBLIST("SCW",SUB)*(1+IBLIST("BTWN")))

                                   SET DIR("A")="Edit Subcolumn "_SUB

                                   SET DIR("B")=VAL(SUB)_$SELECT($GET(QTY)>1:" x "_QTY,1:"")

 +25                               IF $PIECE($GET(^IBE(357.3,SLCTN,3,0)),"^",4)>0

                                       Begin DoDot:3

 +26                                       IF DIR("B")'["w/ mod"

                                               SET DIR("B")=DIR("B")_"w/ mod"

                                       End DoDot:3

 +27                               DO ^DIR

                                   KILL DIR

                                   IF $DATA(DTOUT)!$DATA(DUOUT)

                                       SET QUIT=1

                                   IF QUIT

                                       QUIT 

                                   SET VAL(SUB)=Y

                                   IF IBLIST("SCPIECE",SUB)=1

                                       IF X=""

                                           SET QUIT=1

                               End DoDot:2

               End DoDot:1

               IF QUIT

                   QUIT 

 +28      ;

 +29      ;add the subcolumn value multiple

 +30       SET COUNT=0

           FOR SUB=1:1:8

               IF $GET(VAL(SUB))'=""

                   SET COUNT=COUNT+1

                   SET ^IBE(357.3,SLCTN,1,COUNT,0)=SUB_"^"_VAL(SUB)

 +31       SET ^IBE(357.3,SLCTN,1,0)="^357.31IA^"_COUNT_"^"_COUNT

 +32       KILL DA

           SET DA=SLCTN

           SET DIK="^IBE(357.3,"

           DO IX^DIK

           KILL DIK,DA

 +33       DO NARR

           DO TERM

 +34       QUIT 

 +35      ;

NARR      ; -- edit provider narrative, but only for selections where the

 +1       ;    interface allows editing

 +2        NEW DIE,DA,DR

 +3        IF $PIECE($GET(^IBE(357.6,+$PIECE($GET(^IBE(357.2,+IBLIST,0)),U,11),0)),U,17)

               Begin DoDot:1

 +4                SET DIE="^IBE(357.3,"

                   SET DA=SLCTN

                   SET DR=2.01

                   DO ^DIE

               End DoDot:1

 +5        QUIT 

 +6       ;

TERM      ; -- map selection to clinical lexicon, but only for selections where

 +1       ;    the package interface allows editing

 +2        NEW DIE,DA,DR,GMPTUN,GMPTSUB,GMPTSHOW,XTLKGLB,XTLKHLP,XTLKKSCH,XTLKSAY,IBDLEX

 +3        IF $PIECE($GET(^IBE(357.6,+$PIECE($GET(^IBE(357.2,+IBLIST,0)),U,11),0)),U,18)

               Begin DoDot:1

 +4                IF $DATA(^LEX)>1

                       SET X="LEXSET"

                       XECUTE ^%ZOSF("TEST")

                       IF $TEST

                           DO CONFIG^LEXSET("GMPL","PL1")

                           SET IBDLEX=1

 +5                IF '$DATA(IBDLEX)

                       SET X="GMPTSET"

                       XECUTE ^%ZOSF("TEST")

                       IF $TEST

                           DO CONFIG^GMPTSET("GMPL","PL1")

                           SET IBDLEX=1

 +6       ;D CONFIG^GMPTSET("ICD","ICD") (this is an alternate filter)

 +7                IF '$DATA(IBDLEX)

                       QUIT 

 +8                SET DIE="^IBE(357.3,"

                   SET DA=SLCTN

                   SET DR="2.02//"_$PIECE($GET(^IBE(357.3,DA,0)),"^")

                   DO ^DIE

               End DoDot:1

 +9        QUIT 

 +10      ;

CODES     ; -- allow selection of a second code to pass through for this entry

 +1       ; -- only as if pi allows input of more than one code

 +2       ;N PI S PI=+$P($G(^IBE(357.2,+IBLIST,0)),U,11)

 +3       ;Q:'$P($G(^IBE(357.6,PI,16)),U,9)

 +4       ;N IBI,QUIT,IBVAL S QUIT=0

 +5       ;F IBI=1,2 D  Q:QUIT

 +6       ;.W !,"****Select a ",$S(IBI=1:"second",1:"third")," code to pass along with original."

 +7       ;.I '$$DORTN^IBDFU1B(.IBRTN) S QUIT=1 Q

 +8       ;.I +Y'>0 S QUIT=1 Q

 +9       ;.X $G(^IBE(357.6,PI,9)) S IBVAL=X

 +10      ;.S DIE="^IBE(357.3,",DA=SLCTN,DR=$S(IBI=1:"2.03",1:"2.04")_"////^S X=IBVAL" D ^DIE K DIE,DA,DR

 +11      ;Q

 +12      ;

NOGOOD    ;

 +1        WRITE !,"The package interface routine for selection is not properly defined"

           DO PAUSE^VALM1

 +2        QUIT 

 +3       ;

SEQUENCE  ;allows the user to resequence all of the selections on the list

 +1       ;

 +2        NEW SUBCOL,CNT,P,SORT,GROUP,NODE,VALUE,ITEM,IEN,HDR,DTOUT,DUOUT,DIRUT,SORT1

 +3        SET VALMBCK="R"

 +4        DO FULL^VALM1

 +5       ;

 +6       ;sort by which subcolumn?

 +7        KILL DIR

           SET DIR("A")="Which subcolumn do you want to sort by?"

           SET DIR("?")=" "

 +8        SET SUBCOL=0

           FOR 

               SET SUBCOL=$ORDER(IBLIST("SCTYPE",SUBCOL))

               IF 'SUBCOL

                   QUIT 

               IF IBLIST("SCTYPE",SUBCOL)=1

                   SET SUBCOL(SUBCOL)=""

 +9        SET (CNT,SUBCOL)=0

           SET DIR(0)="SOX^"

 +10       FOR CNT=1:1

               SET SUBCOL=$ORDER(SUBCOL(SUBCOL))

               IF 'SUBCOL

                   QUIT 

               Begin DoDot:1

 +11               SET P=IBLIST("SCPIECE",SUBCOL)

                   SET P=$SELECT(P=1:1,P=2:3,P=3:5,P=4:7,P=5:9,P=6:11,P=7:13,1:0)

                   SET HDR=$PIECE($GET(^IBE(357.6,+IBLIST("RTN"),2)),"^",P)

                   SET DIR("?",CNT)=SUBCOL_" = "_HDR

 +12               SET HDR=$SELECT($GET(IBLIST("SCHDR",SUBCOL))="":HDR,1:IBLIST("SCHDR",SUBCOL))

 +13               SET DIR(0)=DIR(0)_SUBCOL_":"_HDR_";"

               End DoDot:1

 +14       DO ^DIR

 +15       IF $DATA(DIRUT)!(Y=-1)

               QUIT 

 +16       KILL SUBCOL

           SET SUBCOL=+Y

 +17      ;

 +18      ;sort aphabetically or numerically?

 +19       KILL DIR

 +20       SET DIR("A")="How should the list be sorted?"

           SET DIR(0)="SO^1:ALPHABETICALLY;2:NUMERICALLY;"

           SET DIR("B")="ALPHABETICALLY"

 +21       DO ^DIR

 +22       IF $DATA(DIRUT)!(Y=-1)

               QUIT 

 +23       SET SORT=Y

 +24      ;  -- Resequence by group or group and placeholders

 +25       KILL DIR

 +26       SET DIR("A")="Resequence by Group or Group and Place Holders?"

           SET DIR(0)="SO^1:GROUP/PLACE HOLDERS;2:GROUP;"

           SET DIR("B")="GROUP/PLACE HOLDERS"

 +27       DO ^DIR

 +28       IF $DATA(DIRUT)!(Y=-1)

               QUIT 

 +29       SET SORT1=Y

 +30      ;

 +31      ;sort

 +32       IF SORT1=2

               DO EN^IBDF4A

               QUIT 

 +33       NEW CNTR,GROUP1,IBGROUP,IBORDER

 +34       KILL ^TMP("IBDF",$JOB)

 +35       SET (GROUP,GROUP1,CNTR,IBGROUP)=0