IBDF4A ;ALB/CJM - ENCOUNTER FORM - BUILD FORM(editing group's selections - continued from IBDF4) ;11/16/92
;;3.0;AUTOMATED INFO COLLECTION SYS;**38,63**;APR 24, 1997;Build 80
;
;
EDIT ;allows editing of an existing selection
N SEL,SUB,SLCTN,SC,NODE,OQTY,NQTY,IBDQUIT
D EN^VALM2($G(XQORNOD(0)),"S")
S SEL="" F S SEL=$O(VALMY(SEL)) Q:'SEL D
.W !,"Editing Entry #",SEL
.S SLCTN=$G(@VALMAR@("IDX",SEL,SEL)) Q:'SLCTN
.S NODE=$G(^IBE(357.3,SLCTN,0))
.;re-index the record, to insure it is good
.K DIK,DA S DIK="^IBE(357.3,",DA=SLCTN D IX^DIK K DIK
.;edit the order of the selection - also, for placeholders, the text, then quit
.D FULL^VALM1
.I $P(NODE,"^",2) D Q
..S DA=SLCTN,DIE=357.3,DR="[IBDF EDIT PLACE HOLDER]" D ^DIE K DIE,DA,DR
.S DA=SLCTN,DIE=357.3,DR=".05;I '$P($G(^IBE(357.6,$P($G(^IBE(357.2,+IBLIST,0)),""^"",11),16)),""^"",8) S Y=""@99"";S OQTY=$P(^IBE(357.3,DA,0),""^"",9);.09;S NQTY=X;@99;S CONT=1" S CONT=0 D ^DIE K DIE,DA,DR
.D CODES
.D ADD^IBDF4C
.;add any missing subcolumns
.S SC=0 F SC=1:1:8 I $G(IBLIST("SCTYPE",SC))=1 I '$D(^IBE(357.3,SLCTN,1,"B",SC)) D
..K DA,DO,DINUM,DIC
..N DLAYGO
..S DIC="^IBE(357.3,"_SLCTN_",1,",DA(1)=SLCTN,X=SC,DIC(0)="L",DLAYGO=357.3 D FILE^DICN
.;now allow the user to edit editable subcolumns - CONT=0 means the user up-arrowed out, so stop
.I CONT S SUB=0 F S SUB=$O(^IBE(357.3,SLCTN,1,SUB)) Q:'SUB D
..S SC=+$G(^IBE(357.3,SLCTN,1,SUB,0)) I $G(IBLIST("SCTYPE",SC))=1,$G(IBLIST("SCPIECE",SC)),$G(IBLIST("SCEDITABLE",SC)) D
...I $G(^IBE(357.3,SLCTN,1,0))="" S ^IBE(357.3,SLCTN,1,0)="^357.31AI^"
...S DIE="^IBE(357.3,"_SLCTN_",1,",DA(1)=SLCTN,DA=SUB,DR=".02;S CONT=1",CONT=0 W !!,"Editing Subcolumn "_SC_": Header="_IBLIST("SCHDR",SC)
...S IBVAL=$P($G(^IBE(357.3,SLCTN,1,SUB,0)),"^",2)
...I $G(OQTY)'=$G(NQTY) S IBVAL=$P(IBVAL," x "_OQTY)_$S(NQTY>1:" x "_NQTY,1:""),DR=".02////^S X=IBVAL;I;"_DR
...;--added for modifiers
...I $P($G(^IBE(357.3,SLCTN,3,0)),"^",4)>0 D
....S:IBVAL'["w/ mod" IBVAL=IBVAL_" w/ mod"
....S DR=".02////^S X=IBVAL;I;"_DR
...D ^DIE K DIE,DA,DR,IBVAL I 'CONT Q
.D NARR^IBDF4 W !
.D TERM^IBDF4 W !
D IDXSLCTN^IBDF4
S VALMBCK="R"
EDITEXIT ;
Q
CODES(IBDQUIT) ; -- allow editing of 2nd & 3rd codes that are associated w/ original
S IBDQUIT=$G(IBDQUIT)
N IBPI S IBPI=+$P($G(^IBE(357.2,+IBLIST,0)),U,11) Q:'IBPI
Q:'$P($G(^IBE(357.6,IBPI,16)),U,9)!('$D(^IBE(357.6,IBPI,17)))
N IBI,IBEXT,FLD,IBDICD,IBDSERCH
;IBDSERCH 1=ICD Lexicon Search; 2=ICD Wildcard search.
;If user chose Replace Code option, do ICD Lexicon search, else do Wildcard Search.
S IBDSERCH=$S($P($G(XQORNOD(0)),U,4)="RC":2,1:1)
F IBI=3,4 S FLD="2.0"_IBI D Q:IBDQUIT
.S IBEXT=$P($G(^IBE(357.3,SLCTN,2)),"^",IBI)
.I $G(IBEXT)]"" D
..W !,$S(IBI=3:"SECOND",1:"THIRD")," CODE: ",IBEXT
..S DIR(0)="Y",DIR("A")="Delete?",DIR("B")="NO" D ^DIR K DIR
..I Y=1 S IBEXT="",DIE="^IBE(357.3,",DA=SLCTN,DR=FLD_"////@" D ^DIE K DIE,DA,DR
.; Change for ICD-10 project
.S IBDICD=$S($G(IBRTN("NAME"))["ICD-9":"ICD-9",$G(IBRTN("NAME"))["ICD-10":"ICD-10",1:"")
.S DIC("A")="Select a "_$S(IBI=3:"SECOND "_IBDICD,1:"THIRD "_IBDICD)_" code to associate with the original: ",DIC("B")=$S($G(IBEXT)]"":IBEXT,1:"")
.I '$$DORTN^IBDFU1B(.IBRTN,IBDSERCH) K DIC Q
.K DIC
.I IBDQUIT'="",$D(DTOUT) S IBDQUIT=1 Q
.I IBDQUIT'="",$D(DUOUT) S IBDQUIT=1 Q
.S IBEXT=$S(+$G(Y)>0:$P($G(Y(0)),"^"),1:"")
.I $G(IBEXT)]"" D
..S DIE="^IBE(357.3,",DA=SLCTN,DR=FLD_"////^S X=IBEXT"
..D ^DIE K DIE,DA,DR
Q
DELETE ;allows the user to select selections to delete
N SEL
D EN^VALM2($G(XQORNOD(0)))
K DA
S SEL="" F S SEL=$O(VALMY(SEL)) Q:'SEL D
.S DIK="^IBE(357.3,",DA=$G(@VALMAR@("IDX",SEL,SEL))
.Q:'$$RUSURE^IBDFU5("Selection #"_SEL)
.D ^DIK
.D KILL^VALM10(SEL)
.I '$D(^TMP("IBDF ADDSLCTN",$J)) S ^TMP("IBDF DELETE SELECTION OPTION",$J)=1
K DIK,DA
D IDXSLCTN^IBDF4
S VALMBCK="R"
Q
;
ADDBLANK ;allows the user to add a dummy selection to the selection group
;i.e., a place holder that will not actually print a selection
;
D FULL^VALM1
D ADD
D IDXSLCTN^IBDF4
S VALMBCK="R"
Q
;
NEXT(IBLIST,IBGRP) ;returns the next print order to assign=last + 1
Q (1+$O(^IBE(357.3,"APO",IBLIST,IBGRP,""),-1))
;
ASKMORE() ;ask if the user wants to add another, returns 1 or 0
K DIR
S DIR(0)="Y",DIR("A")="Do you want to add another",DIR("B")="NO"
D ^DIR
K DIR
I $D(DIRUT)!'Y Q 0
Q 1
;
ADD ;allows the user to add a dummy selection to the selection group
;i.e., a place holder that will not actually print a selection
;
N QUIT,ORDER,SLCTN,NODE
S QUIT=0 F D Q:QUIT Q:'$$ASKMORE()
.S ORDER=$$NEXT(IBLIST,IBGRP)
.;we have all the data needed to add the selection - so add it
.S NODE=ORDER_"^"_1_"^"_IBLIST_"^"_IBGRP_"^"_ORDER
.K DIC,DD,DO,DINUM
.N DLAYGO
.S DIC="^IBE(357.3,",X=ORDER,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 the place holder!" D PAUSE^VALM1 S QUIT=1 Q
.S ^IBE(357.3,SLCTN,0)=NODE
.K DA S DA=SLCTN,DIK="^IBE(357.3," D IX^DIK K DIK,DA
.K DIE S DA=SLCTN,DIE=357.3,DR="[IBDF EDIT PLACE HOLDER]" D ^DIE K DIE,DA,DR
.K DA S DA=SLCTN,DIK="^IBE(357.3," D IX^DIK K DIK,DA
Q
EN ; -- Resequence selection lists not taking into account the
; the place holders. Will put the selection list into alphabetic
; or numeric order..... the place holders will be used as extra
; lines of description and not as separators or headers within
; the group.
N CNTR,COUNT,IBGROUP,IBORDER
S (CNTR,COUNT,IBGROUP)=0
K ^TMP("BLANK",$J),^TMP("IBDF",$J)
; -- 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 GROUP=+$P(NODE,"^",4)
.Q:$P($G(^IBE(357.4,GROUP,0)),"^",3)'=IBLIST
.S COUNT=COUNT+1
.I $P(NODE,"^",2) S ^TMP("BLANK",$J,GROUP,CNTR,COUNT,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))
.S CNTR=CNTR+1
.S ^TMP("IBDF",$J,"RESEQUENCE LIST",GROUP,$E(VALUE,1,40),ITEM)=CNTR
.S ^TMP("BLANK",$J,GROUP,CNTR,COUNT,ITEM)=""
;
;set the order
ORDER S (GROUP,CNTR)=0
F S GROUP=$O(^TMP("IBDF",$J,"RESEQUENCE LIST",GROUP)) Q:'GROUP D
.S VALUE="",CNT=0
.F S VALUE=$O(^TMP("IBDF",$J,"RESEQUENCE LIST",GROUP,VALUE)) Q:VALUE="" D
..S ITEM=0 F S ITEM=$O(^TMP("IBDF",$J,"RESEQUENCE LIST",GROUP,VALUE,ITEM)) Q:'ITEM S CNTR=^TMP("IBDF",$J,"RESEQUENCE LIST",GROUP,VALUE,ITEM) D:'$D(^TMP("BLANK",$J,GROUP,CNTR)) I $D(^TMP("BLANK",$J,GROUP,CNTR)) D BLANK
...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
BLANK ; -- Check to see if there is any place holders.
N IBDITEM,COUNT
F COUNT=0:0 S COUNT=$O(^TMP("BLANK",$J,GROUP,CNTR,COUNT)) Q:'COUNT F IBDITEM=0:0 S IBDITEM=$O(^TMP("BLANK",$J,GROUP,CNTR,COUNT,IBDITEM)) Q:'IBDITEM D
.S CNT=CNT+1
.K DIE,DA,DR S DIE="^IBE(357.3,",DR=".05///"_CNT,DA=IBDITEM D ^DIE K DIE,DA,DR
.Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDF4A 7567 printed Oct 16, 2024@18:52:13 Page 2
IBDF4A ;ALB/CJM - ENCOUNTER FORM - BUILD FORM(editing group's selections - continued from IBDF4) ;11/16/92
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**38,63**;APR 24, 1997;Build 80
+2 ;
+3 ;
EDIT ;allows editing of an existing selection
+1 NEW SEL,SUB,SLCTN,SC,NODE,OQTY,NQTY,IBDQUIT
+2 DO EN^VALM2($GET(XQORNOD(0)),"S")
+3 SET SEL=""
FOR
SET SEL=$ORDER(VALMY(SEL))
if 'SEL
QUIT
Begin DoDot:1
+4 WRITE !,"Editing Entry #",SEL
+5 SET SLCTN=$GET(@VALMAR@("IDX",SEL,SEL))
if 'SLCTN
QUIT
+6 SET NODE=$GET(^IBE(357.3,SLCTN,0))
+7 ;re-index the record, to insure it is good
+8 KILL DIK,DA
SET DIK="^IBE(357.3,"
SET DA=SLCTN
DO IX^DIK
KILL DIK
+9 ;edit the order of the selection - also, for placeholders, the text, then quit
+10 DO FULL^VALM1
+11 IF $PIECE(NODE,"^",2)
Begin DoDot:2
+12 SET DA=SLCTN
SET DIE=357.3
SET DR="[IBDF EDIT PLACE HOLDER]"
DO ^DIE
KILL DIE,DA,DR
End DoDot:2
QUIT
+13 SET DA=SLCTN
SET DIE=357.3
SET DR=".05;I '$P($G(^IBE(357.6,$P($G(^IBE(357.2,+IBLIST,0)),""^"",11),16)),""^"",8) S Y=""@99"";S OQTY=$P(^IBE(357.3,DA,0),""^"",9);.09;S NQTY=X;@99;S CONT=1"
SET CONT=0
DO ^DIE
KILL DIE,DA,DR
+14 DO CODES
+15 DO ADD^IBDF4C
+16 ;add any missing subcolumns
+17 SET SC=0
FOR SC=1:1:8
IF $GET(IBLIST("SCTYPE",SC))=1
IF '$DATA(^IBE(357.3,SLCTN,1,"B",SC))
Begin DoDot:2
+18 KILL DA,DO,DINUM,DIC
+19 NEW DLAYGO
+20 SET DIC="^IBE(357.3,"_SLCTN_",1,"
SET DA(1)=SLCTN
SET X=SC
SET DIC(0)="L"
SET DLAYGO=357.3
DO FILE^DICN
End DoDot:2
+21 ;now allow the user to edit editable subcolumns - CONT=0 means the user up-arrowed out, so stop
+22 IF CONT
SET SUB=0
FOR
SET SUB=$ORDER(^IBE(357.3,SLCTN,1,SUB))
if 'SUB
QUIT
Begin DoDot:2
+23 SET SC=+$GET(^IBE(357.3,SLCTN,1,SUB,0))
IF $GET(IBLIST("SCTYPE",SC))=1
IF $GET(IBLIST("SCPIECE",SC))
IF $GET(IBLIST("SCEDITABLE",SC))
Begin DoDot:3
+24 IF $GET(^IBE(357.3,SLCTN,1,0))=""
SET ^IBE(357.3,SLCTN,1,0)="^357.31AI^"
+25 SET DIE="^IBE(357.3,"_SLCTN_",1,"
SET DA(1)=SLCTN
SET DA=SUB
SET DR=".02;S CONT=1"
SET CONT=0
WRITE !!,"Editing Subcolumn "_SC_": Header="_IBLIST("SCHDR",SC)
+26 SET IBVAL=$PIECE($GET(^IBE(357.3,SLCTN,1,SUB,0)),"^",2)
+27 IF $GET(OQTY)'=$GET(NQTY)
SET IBVAL=$PIECE(IBVAL," x "_OQTY)_$SELECT(NQTY>1:" x "_NQTY,1:"")
SET DR=".02////^S X=IBVAL;I;"_DR
+28 ;--added for modifiers
+29 IF $PIECE($GET(^IBE(357.3,SLCTN,3,0)),"^",4)>0
Begin DoDot:4
+30 if IBVAL'["w/ mod"
SET IBVAL=IBVAL_" w/ mod"
+31 SET DR=".02////^S X=IBVAL;I;"_DR
End DoDot:4
+32 DO ^DIE
KILL DIE,DA,DR,IBVAL
IF 'CONT
QUIT
End DoDot:3
End DoDot:2
+33 DO NARR^IBDF4
WRITE !
+34 DO TERM^IBDF4
WRITE !
End DoDot:1
+35 DO IDXSLCTN^IBDF4
+36 SET VALMBCK="R"
EDITEXIT ;
+1 QUIT
CODES(IBDQUIT) ; -- allow editing of 2nd & 3rd codes that are associated w/ original
+1 SET IBDQUIT=$GET(IBDQUIT)
+2 NEW IBPI
SET IBPI=+$PIECE($GET(^IBE(357.2,+IBLIST,0)),U,11)
if 'IBPI
QUIT
+3 if '$PIECE($GET(^IBE(357.6,IBPI,16)),U,9)!('$DATA(^IBE(357.6,IBPI,17)))
QUIT
+4 NEW IBI,IBEXT,FLD,IBDICD,IBDSERCH
+5 ;IBDSERCH 1=ICD Lexicon Search; 2=ICD Wildcard search.
+6 ;If user chose Replace Code option, do ICD Lexicon search, else do Wildcard Search.
+7 SET IBDSERCH=$SELECT($PIECE($GET(XQORNOD(0)),U,4)="RC":2,1:1)
+8 FOR IBI=3,4
SET FLD="2.0"_IBI
Begin DoDot:1
+9 SET IBEXT=$PIECE($GET(^IBE(357.3,SLCTN,2)),"^",IBI)
+10 IF $GET(IBEXT)]""
Begin DoDot:2
+11 WRITE !,$SELECT(IBI=3:"SECOND",1:"THIRD")," CODE: ",IBEXT
+12 SET DIR(0)="Y"
SET DIR("A")="Delete?"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
+13 IF Y=1
SET IBEXT=""
SET DIE="^IBE(357.3,"
SET DA=SLCTN
SET DR=FLD_"////@"
DO ^DIE
KILL DIE,DA,DR
End DoDot:2
+14 ; Change for ICD-10 project
+15 SET IBDICD=$SELECT($GET(IBRTN("NAME"))["ICD-9":"ICD-9",$GET(IBRTN("NAME"))["ICD-10":"ICD-10",1:"")
+16 SET DIC("A")="Select a "_$SELECT(IBI=3:"SECOND "_IBDICD,1:"THIRD "_IBDICD)_" code to associate with the original: "
SET DIC("B")=$SELECT($GET(IBEXT)]"":IBEXT,1:"")
+17 IF '$$DORTN^IBDFU1B(.IBRTN,IBDSERCH)
KILL DIC
QUIT
+18 KILL DIC
+19 IF IBDQUIT'=""
IF $DATA(DTOUT)
SET IBDQUIT=1
QUIT
+20 IF IBDQUIT'=""
IF $DATA(DUOUT)
SET IBDQUIT=1
QUIT
+21 SET IBEXT=$SELECT(+$GET(Y)>0:$PIECE($GET(Y(0)),"^"),1:"")
+22 IF $GET(IBEXT)]""
Begin DoDot:2
+23 SET DIE="^IBE(357.3,"
SET DA=SLCTN
SET DR=FLD_"////^S X=IBEXT"
+24 DO ^DIE
KILL DIE,DA,DR
End DoDot:2
End DoDot:1
if IBDQUIT
QUIT
+25 QUIT
DELETE ;allows the user to select selections to delete
+1 NEW SEL
+2 DO EN^VALM2($GET(XQORNOD(0)))
+3 KILL DA
+4 SET SEL=""
FOR
SET SEL=$ORDER(VALMY(SEL))
if 'SEL
QUIT
Begin DoDot:1
+5 SET DIK="^IBE(357.3,"
SET DA=$GET(@VALMAR@("IDX",SEL,SEL))
+6 if '$$RUSURE^IBDFU5("Selection #"_SEL)
QUIT
+7 DO ^DIK
+8 DO KILL^VALM10(SEL)
+9 IF '$DATA(^TMP("IBDF ADDSLCTN",$JOB))
SET ^TMP("IBDF DELETE SELECTION OPTION",$JOB)=1
End DoDot:1
+10 KILL DIK,DA
+11 DO IDXSLCTN^IBDF4
+12 SET VALMBCK="R"
+13 QUIT
+14 ;
ADDBLANK ;allows the user to add a dummy selection to the selection group
+1 ;i.e., a place holder that will not actually print a selection
+2 ;
+3 DO FULL^VALM1
+4 DO ADD
+5 DO IDXSLCTN^IBDF4
+6 SET VALMBCK="R"
+7 QUIT
+8 ;
NEXT(IBLIST,IBGRP) ;returns the next print order to assign=last + 1
+1 QUIT (1+$ORDER(^IBE(357.3,"APO",IBLIST,IBGRP,""),-1))
+2 ;
ASKMORE() ;ask if the user wants to add another, returns 1 or 0
+1 KILL DIR
+2 SET DIR(0)="Y"
SET DIR("A")="Do you want to add another"
SET DIR("B")="NO"
+3 DO ^DIR
+4 KILL DIR
+5 IF $DATA(DIRUT)!'Y
QUIT 0
+6 QUIT 1
+7 ;
ADD ;allows the user to add a dummy selection to the selection group
+1 ;i.e., a place holder that will not actually print a selection
+2 ;
+3 NEW QUIT,ORDER,SLCTN,NODE
+4 SET QUIT=0
FOR
Begin DoDot:1
+5 SET ORDER=$$NEXT(IBLIST,IBGRP)
+6 ;we have all the data needed to add the selection - so add it
+7 SET NODE=ORDER_"^"_1_"^"_IBLIST_"^"_IBGRP_"^"_ORDER
+8 KILL DIC,DD,DO,DINUM
+9 NEW DLAYGO
+10 SET DIC="^IBE(357.3,"
SET X=ORDER
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 the place holder!"
DO PAUSE^VALM1
SET QUIT=1
QUIT
+14 SET ^IBE(357.3,SLCTN,0)=NODE
+15 KILL DA
SET DA=SLCTN
SET DIK="^IBE(357.3,"
DO IX^DIK
KILL DIK,DA
+16 KILL DIE
SET DA=SLCTN
SET DIE=357.3
SET DR="[IBDF EDIT PLACE HOLDER]"
DO ^DIE
KILL DIE,DA,DR
+17 KILL DA
SET DA=SLCTN
SET DIK="^IBE(357.3,"
DO IX^DIK
KILL DIK,DA
End DoDot:1
if QUIT
QUIT
if '$$ASKMORE()
QUIT
+18 QUIT
EN ; -- Resequence selection lists not taking into account the
+1 ; the place holders. Will put the selection list into alphabetic
+2 ; or numeric order..... the place holders will be used as extra
+3 ; lines of description and not as separators or headers within
+4 ; the group.
+5 NEW CNTR,COUNT,IBGROUP,IBORDER
+6 SET (CNTR,COUNT,IBGROUP)=0
+7 KILL ^TMP("BLANK",$JOB),^TMP("IBDF",$JOB)
+8 ; -- Resequence only specific groups in block.
+9 IF $DATA(IBGRUP)
FOR
SET IBGROUP=$ORDER(IBGRUP(IBGROUP))
if 'IBGROUP
QUIT
DO RESEQ
+10 IF $DATA(IBGRUP)
DO ORDER
QUIT
+11 ; -- Resequence all groups of the block.
+12 IF '$DATA(IBGRUP)
FOR
SET IBGROUP=$ORDER(^IBE(357.3,"APO",IBLIST,IBGROUP))
if 'IBGROUP
QUIT
DO RESEQ
+13 IF '$DATA(IBGRUP)
DO ORDER
QUIT
+14 QUIT
+15 ;
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 GROUP=+$PIECE(NODE,"^",4)
+4 if $PIECE($GET(^IBE(357.4,GROUP,0)),"^",3)'=IBLIST
QUIT
+5 SET COUNT=COUNT+1
+6 IF $PIECE(NODE,"^",2)
SET ^TMP("BLANK",$JOB,GROUP,CNTR,COUNT,ITEM)=""
+7 SET IEN=$ORDER(^IBE(357.3,ITEM,1,"B",SUBCOL,0))
if 'IEN
QUIT
+8 SET VALUE=$PIECE($GET(^IBE(357.3,ITEM,1,IEN,0)),"^",2)
+9 SET VALUE=$SELECT(SORT=1:VALUE=" "_VALUE,1:+$PIECE(NODE,"^",1))
+10 SET CNTR=CNTR+1
+11 SET ^TMP("IBDF",$JOB,"RESEQUENCE LIST",GROUP,$EXTRACT(VALUE,1,40),ITEM)=CNTR
+12 SET ^TMP("BLANK",$JOB,GROUP,CNTR,COUNT,ITEM)=""
End DoDot:1
+13 ;
+14 ;set the order
ORDER SET (GROUP,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 VALUE=$ORDER(^TMP("IBDF",$JOB,"RESEQUENCE LIST",GROUP,VALUE))
if VALUE=""
QUIT
Begin DoDot:2
+4 SET ITEM=0
FOR
SET ITEM=$ORDER(^TMP("IBDF",$JOB,"RESEQUENCE LIST",GROUP,VALUE,ITEM))
if 'ITEM
QUIT
SET CNTR=^TMP("IBDF",$JOB,"RESEQUENCE LIST",GROUP,VALUE,ITEM)
if '$DATA(^TMP("BLANK",$JOB,GROUP,CNTR))
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
IF $DATA(^TMP("BLANK",$JOB,GROUP,CNTR))
DO BLANK
End DoDot:2
End DoDot:1
+7 ;
+8 KILL Y,X,DIR,^TMP("IBDF",$JOB,"RESEQUENCE LIST")
+9 DO IDXGRP^IBDF3
+10 QUIT
BLANK ; -- Check to see if there is any place holders.
+1 NEW IBDITEM,COUNT
+2 FOR COUNT=0:0
SET COUNT=$ORDER(^TMP("BLANK",$JOB,GROUP,CNTR,COUNT))
if 'COUNT
QUIT
FOR IBDITEM=0:0
SET IBDITEM=$ORDER(^TMP("BLANK",$JOB,GROUP,CNTR,COUNT,IBDITEM))
if 'IBDITEM
QUIT
Begin DoDot:1
+3 SET CNT=CNT+1
+4 KILL DIE,DA,DR
SET DIE="^IBE(357.3,"
SET DR=".05///"_CNT
SET DA=IBDITEM
DO ^DIE
KILL DIE,DA,DR
+5 QUIT
End DoDot:1
+6 QUIT
