Routine: IBDF9

IBDF9 ;ALB/CJM - ENCOUNTER FORM - BUILD FORM(display single form block for edit) ; 08-JAN-1993

 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997

INIT ;

 D IDXBLOCK^IBDFU4

EXIT ;

 K @VALMAR

HDR ;

 S VALMHDR(1)=$$PADRIGHT^IBDFU("",4)

 F I=1:1:16 S VALMHDR(1)=VALMHDR(1)_$J(I,10)

RESIZE ;resize the block

 N IBW,IBH

 S VALMBCK="R"

 K DIR S DIR(0)="NA^1:"_IBFORM("WIDTH")_":0",DIR("A")="Move the RIGHT MARGIN of the block to which column?: ",DIR("B")=IBBLK("W") D ^DIR K DIR Q:$D(DIRUT)  S IBW=X

 S DIR(0)="NA^1:"_IBFORM("HT")_":0",DIR("A")="Move the BOTTOM MARGIN of the block to which row?: ",DIR("B")=IBBLK("H") D ^DIR K DIR Q:$D(DIRUT)  S IBH=X

 K DR,DIE,DA S DIE=357.1,DA=IBBLK,DR=".06////^S X=IBW;.07////^S X=IBH" D ^DIE K DIE,DR,DA

 S VALMBCK="R"

 D UNCMPBLK^IBDF19(IBBLK),IDXBLOCK^IBDFU4

EDITBLK ;edit the name,brief description, header and outline

 ;automatically shifts contents and changes size of block if changes in header or outline call for that

 N HDR1,HDR2 ;flags set to indicate existance of hdr before and after editing

 N NODE,IBNAME,QUIT

 S QUIT=0,VALMBCK="R"

 D FULL^VALM1

 S NODE=$G(^IBE(357.1,IBBLK,0))

 S HDR1=$P(NODE,"^",11) S:HDR1'="" HDR1=1

 K DIR S DIR(0)="357.1,.01",DIR("B")=$P($G(^IBE(357.1,IBBLK,0)),"^") D ^DIR K DIR D  Q:QUIT

 .I (Y=-1)!$D(DIRUT) S QUIT=1 Q

 .S IBNAME=Y

 .K DA,DR,DIE S DIE=357.1,DA=IBBLK,DR="[IBDF EDIT HEADER&OUTLINE]" D ^DIE K DIE,DR,DA

 S NODE=$G(^IBE(357.1,IBBLK,0))

 S HDR2=$P(NODE,"^",11) S HDR2=$S(HDR2="":0,1:1)

 ;shift contents and resize if there has been a change to existance of the header

 I HDR1'=HDR2 D

 .N TOP,BOTTOM,LEFT,RIGHT,WAY,AMOUNT

 .S TOP=0,BOTTOM=IBBLK("H"),LEFT=0,RIGHT=IBBLK("W"),AMOUNT=1

 .I HDR2 S WAY="D" D E^IBDF10 S $P(NODE,"^",7)=$P(NODE,"^",7)+1,^IBE(357.1,IBBLK,0)=NODE

 .I HDR1 S WAY="U" D E^IBDF10 S $P(NODE,"^",7)=$P(NODE,"^",7)-1,^IBE(357.1,IBBLK,0)=NODE

 D UNCMPBLK^IBDF19(IBBLK),IDXBLOCK^IBDFU4

IBDF9     ;ALB/CJM - ENCOUNTER FORM - BUILD FORM(display single form block for edit) ; 08-JAN-1993

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

 +2       ;

INIT      ;

 +1        DO IDXBLOCK^IBDFU4

 +2        QUIT

EXIT      ;

 +1        KILL @VALMAR

 +2        QUIT

HDR       ;

 +1        SET VALMHDR(1)=$$PADRIGHT^IBDFU("",4)

 +2        FOR I=1:1:16

               SET VALMHDR(1)=VALMHDR(1)_$JUSTIFY(I,10)

 +3        QUIT

RESIZE    ;resize the block

 +1        NEW IBW,IBH

 +2        SET VALMBCK="R"

 +3        KILL DIR

           SET DIR(0)="NA^1:"_IBFORM("WIDTH")_":0"

           SET DIR("A")="Move the RIGHT MARGIN of the block to which column?: "

           SET DIR("B")=IBBLK("W")

           DO ^DIR

           KILL DIR

           IF $DATA(DIRUT)

               QUIT

           SET IBW=X

 +4        SET DIR(0)="NA^1:"_IBFORM("HT")_":0"

           SET DIR("A")="Move the BOTTOM MARGIN of the block to which row?: "

           SET DIR("B")=IBBLK("H")

           DO ^DIR

           KILL DIR

           IF $DATA(DIRUT)

               QUIT

           SET IBH=X

 +5        KILL DR,DIE,DA

           SET DIE=357.1

           SET DA=IBBLK

           SET DR=".06////^S X=IBW;.07////^S X=IBH"

           DO ^DIE

           KILL DIE,DR,DA

 +6        SET VALMBCK="R"

 +7        DO UNCMPBLK^IBDF19(IBBLK)

           DO IDXBLOCK^IBDFU4

 +8        QUIT

EDITBLK   ;edit the name,brief description, header and outline

 +1       ;automatically shifts contents and changes size of block if changes in header or outline call for that

 +2       ;flags set to indicate existance of hdr before and after editing

           NEW HDR1,HDR2

 +3        NEW NODE,IBNAME,QUIT

 +4        SET QUIT=0

           SET VALMBCK="R"

 +5        DO FULL^VALM1

 +6        SET NODE=$GET(^IBE(357.1,IBBLK,0))

 +7        SET HDR1=$PIECE(NODE,"^",11)

           IF HDR1'=""

               SET HDR1=1

 +8        KILL DIR

           SET DIR(0)="357.1,.01"

           SET DIR("B")=$PIECE($GET(^IBE(357.1,IBBLK,0)),"^")

           DO ^DIR

           KILL DIR

           Begin DoDot:1

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

                   SET QUIT=1

                   QUIT

 +10           SET IBNAME=Y

 +11           KILL DA,DR,DIE

               SET DIE=357.1

               SET DA=IBBLK

               SET DR="[IBDF EDIT HEADER&OUTLINE]"

               DO ^DIE

               KILL DIE,DR,DA

           End DoDot:1

           IF QUIT

               QUIT

 +12       SET NODE=$GET(^IBE(357.1,IBBLK,0))

 +13       SET HDR2=$PIECE(NODE,"^",11)

           SET HDR2=$SELECT(HDR2="":0,1:1)

 +14      ;shift contents and resize if there has been a change to existance of the header

 +15       IF HDR1'=HDR2

               Begin DoDot:1

 +16               NEW TOP,BOTTOM,LEFT,RIGHT,WAY,AMOUNT

 +17               SET TOP=0

                   SET BOTTOM=IBBLK("H")

                   SET LEFT=0

                   SET RIGHT=IBBLK("W")

                   SET AMOUNT=1

 +18               IF HDR2

                       SET WAY="D"

                       DO E^IBDF10

                       SET $PIECE(NODE,"^",7)=$PIECE(NODE,"^",7)+1

                       SET ^IBE(357.1,IBBLK,0)=NODE

 +19               IF HDR1

                       SET WAY="U"

                       DO E^IBDF10

                       SET $PIECE(NODE,"^",7)=$PIECE(NODE,"^",7)-1

                       SET ^IBE(357.1,IBBLK,0)=NODE

               End DoDot:1

 +20       DO UNCMPBLK^IBDF19(IBBLK)

           DO IDXBLOCK^IBDFU4

 +21       QUIT

IBDF9.m