- IBDF4A ;ALB/CJM - ENCOUNTER FORM - BUILD FORM(editing group's selections - continued from IBDF4) ;NOV 16,1992
- ;;3.0;AUTOMATED INFO COLLECTION SYS;**38**;APR 24, 1997
- ;
- EDIT ;allows editing of an existing selection
- N SEL,SUB,SLCTN,SC,NODE,OQTY,NQTY
- 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 ; -- allow editing of 2nd & 3rd codes that are associated w/ original
- 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
- F IBI=3,4 S FLD="2.0"_IBI D
- .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
- .S DIC("A")="Select a "_$S(IBI=3:"SECOND",1:"THIRD")_" code to associate with the original:",DIC("B")=$S($G(IBEXT)]"":IBEXT,1:"")
- .I '$$DORTN^IBDFU1B(.IBRTN) 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)
- 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 exta
- ; 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
- IBDF4A ;ALB/CJM - ENCOUNTER FORM - BUILD FORM(editing group's selections - continued from IBDF4) ;NOV 16,1992
- +1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**38**;APR 24, 1997
- +2 ;
- EDIT ;allows editing of an existing selection
- +1 NEW SEL,SUB,SLCTN,SC,NODE,OQTY,NQTY
- +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 ; -- allow editing of 2nd & 3rd codes that are associated w/ original
- +1 NEW IBPI
- SET IBPI=+$PIECE($GET(^IBE(357.2,+IBLIST,0)),U,11)
- IF 'IBPI
- QUIT
- +2 IF '$PIECE($GET(^IBE(357.6,IBPI,16)),U,9)!('$DATA(^IBE(357.6,IBPI,17)))
- QUIT
- +3 NEW IBI,IBEXT,FLD
- +4 FOR IBI=3,4
- SET FLD="2.0"_IBI
- Begin DoDot:1
- +5 SET IBEXT=$PIECE($GET(^IBE(357.3,SLCTN,2)),"^",IBI)
- +6 IF $GET(IBEXT)]""
- Begin DoDot:2
- +7 WRITE !,$SELECT(IBI=3:"SECOND",1:"THIRD")," CODE: ",IBEXT
- +8 SET DIR(0)="Y"
- SET DIR("A")="Delete?"
- SET DIR("B")="NO"
- DO ^DIR
- KILL DIR
- +9 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
- +10 SET DIC("A")="Select a "_$SELECT(IBI=3:"SECOND",1:"THIRD")_" code to associate with the original:"
- SET DIC("B")=$SELECT($GET(IBEXT)]"":IBEXT,1:"")
- +11 IF '$$DORTN^IBDFU1B(.IBRTN)
- QUIT
- +12 SET IBEXT=$SELECT(+$GET(Y)>0:$PIECE($GET(Y(0)),"^"),1:"")
- +13 IF $GET(IBEXT)]""
- Begin DoDot:2
- +14 SET DIE="^IBE(357.3,"
- SET DA=SLCTN
- SET DR=FLD_"////^S X=IBEXT"
- +15 DO ^DIE
- KILL DIE,DA,DR
- End DoDot:2
- End DoDot:1
- +16 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)
- End DoDot:1
- +9 KILL DIK,DA
- +10 DO IDXSLCTN^IBDF4
- +11 SET VALMBCK="R"
- +12 QUIT
- +13 ;
- 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 exta
- +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