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
+36 ; -- Resequence only specific groups in block.
+37 IF $DATA(IBGRUP)
FOR
SET IBGROUP=$ORDER(IBGRUP(IBGROUP))
IF 'IBGROUP
QUIT
DO RESEQ
+38 IF $DATA(IBGRUP)
DO ORDER
QUIT
+39 ; -- Resequence all groups of the block.
+40 IF '$DATA(IBGRUP)
FOR
SET IBGROUP=$ORDER(^IBE(357.3,"APO",IBLIST,IBGROUP))
IF 'IBGROUP
QUIT
DO RESEQ
+41 IF '$DATA(IBGRUP)
DO ORDER
QUIT
+42 QUIT
RESEQ SET IBORDER=0
FOR
SET IBORDER=$ORDER(^IBE(357.3,"APO",IBLIST,IBGROUP,IBORDER))
IF 'IBORDER
QUIT
SET ITEM=0
FOR
SET ITEM=$ORDER(^IBE(357.3,"APO",IBLIST,IBGROUP,IBORDER,ITEM))
IF 'ITEM
QUIT
Begin DoDot:1
+1 SET NODE=$GET(^IBE(357.3,ITEM,0))
+2 IF ($PIECE(NODE,"^",3)'=IBLIST)
QUIT
+3 SET GROUP1=GROUP
SET GROUP=+$PIECE(NODE,"^",4)
+4 IF $PIECE($GET(^IBE(357.4,GROUP,0)),"^",3)'=IBLIST
QUIT
+5 IF $PIECE(NODE,"^",2)=1
Begin DoDot:2
+6 SET CNTR=CNTR+1
+7 SET VALUE=$SELECT(SORT=1:" ",1:+$PIECE(NODE,"^",1))
+8 SET ^TMP("IBDF",$JOB,"RESEQUENCE LIST",GROUP,CNTR,VALUE,ITEM)=""
End DoDot:2
QUIT
+9 SET IEN=$ORDER(^IBE(357.3,ITEM,1,"B",SUBCOL,0))
IF 'IEN
QUIT
+10 SET VALUE=$PIECE($GET(^IBE(357.3,ITEM,1,IEN,0)),"^",2)
+11 SET VALUE=$SELECT(SORT=1:VALUE=" "_VALUE,1:+$PIECE(NODE,"^",1))
+12 IF GROUP'=GROUP1
SET CNTR=CNTR+1
+13 SET ^TMP("IBDF",$JOB,"RESEQUENCE LIST",GROUP,CNTR,$EXTRACT(VALUE,1,40),ITEM)=""
End DoDot:1
+14 ;set the order
ORDER SET GROUP=0
SET CNTR=0
+1 FOR
SET GROUP=$ORDER(^TMP("IBDF",$JOB,"RESEQUENCE LIST",GROUP))
IF 'GROUP
QUIT
Begin DoDot:1
+2 SET VALUE=""
SET CNT=0
+3 FOR
SET CNTR=$ORDER(^TMP("IBDF",$JOB,"RESEQUENCE LIST",GROUP,CNTR))
IF 'CNTR
QUIT
FOR
SET VALUE=$ORDER(^TMP("IBDF",$JOB,"RESEQUENCE LIST",GROUP,CNTR,VALUE))
IF VALUE=""
QUIT
Begin DoDot:2
+4 SET ITEM=0
FOR
SET ITEM=$ORDER(^TMP("IBDF",$JOB,"RESEQUENCE LIST",GROUP,CNTR,VALUE,ITEM))
IF 'ITEM
QUIT
Begin DoDot:3
+5 SET CNT=CNT+1
+6 KILL DIE,DA,DR
SET DIE="^IBE(357.3,"
SET DR=".05///"_CNT
SET DA=ITEM
DO ^DIE
KILL DIE,DA,DR
End DoDot:3
End DoDot:2
End DoDot:1
+7 ;
+8 KILL Y,X,DIR,^TMP("IBDF",$JOB,"RESEQUENCE LIST")
+9 DO IDXGRP^IBDF3
+10 QUIT
