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
Q
EXIT ;
K @VALMAR
Q
HDR ;
S VALMHDR(1)=$$PADRIGHT^IBDFU("",4)
F I=1:1:16 S VALMHDR(1)=VALMHDR(1)_$J(I,10)
Q
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
Q
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
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDF9 1949 printed Nov 22, 2024@18:01:49 Page 2
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
