IBDF9C ;ALB/CJM - ENCOUNTER FORM - (edit header block) ;FEB 1,1993
;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
;
EDITHDR ;edit the header block
N HDRBLK,HDRFLD,TOP1,BOT1,TOP2,BOT2,HDRLINES,MAXLEN,QUIT,NEWBLOCK
S VALMBCK="R",(TOP1,TOP2,BOT1,BOT2,QUIT,NEWBLOCK)=0
D FULL^VALM1
S HDRBLK=$$FINDBLK I 'HDRBLK S HDRBLK=$$MAKEBLK I 'HDRBLK Q
D TOPNBOT^IBDFU5(HDRBLK,.TOP1,.BOT1)
S HDRFLD=$$FINDFLD I 'HDRFLD S HDRFLD=$$MAKEFLD I 'HDRFLD Q
D EDITFLD
D:'QUIT EDITBLK,MOVEFLD
I HDRBLK D TOPNBOT^IBDFU5(HDRBLK,.TOP2,.BOT2),UNCMPBLK^IBDF19(HDRBLK)
D IDXFORM^IBDF5A($S(TOP1<TOP2:TOP1,1:TOP2),$S(BOT1>BOT2:BOT1,1:BOT2))
S VALMBCK="R"
Q
FINDBLK() ;
S HDRBLK="" F S HDRBLK=$O(^IBE(357.1,"C",IBFORM,HDRBLK)) Q:'HDRBLK Q:$P($G(^IBE(357.1,HDRBLK,0)),"^")="HEADER"
Q HDRBLK
MAKEBLK() ;
S NEWBLOCK=1
K DIC,DD,DO,DINUM S DIC="^IBE(357.1,",X="HEADER",DIC(0)="",DIC("DR")=".02////"_IBFORM
D FILE^DICN K DIC,DIE
Q $S(+Y<0:"",1:+Y)
FINDFLD() ;
S HDRFLD="" F S HDRFLD=$O(^IBE(357.5,"C",HDRBLK,HDRFLD)) Q:'HDRFLD Q:$P($G(^IBE(357.5,HDRFLD,0)),"^")="HEADER"
Q HDRFLD
MAKEFLD() ;
K DIC,DD,DO,DINUM S DIC="^IBE(357.5,",X="HEADER",DIC(0)="",DIC("DR")=".02////"_HDRBLK
D FILE^DICN K DIC,DIE
Q $S(+Y<0:"",1:+Y)
EDITFLD ;allows the user to edit the header lines
N NODE,SUBFLD
K DIE,DA S DIE=357.5,DA=HDRFLD,DR="[IBDF EDIT FORM HEADER]",DIE("NO^")="BACKOUTOK" D ^DIE K DIE,DR,DA
;find the number of lines and the maximum length
S (HDRLINES,MAXLEN)=0
S SUBFLD=0 F S SUBFLD=$O(^IBE(357.5,HDRFLD,2,SUBFLD)) Q:'SUBFLD S NODE=$G(^(SUBFLD,0)) I NODE'="" S HDRLINES=HDRLINES+1 S MAXLEN=$S(MAXLEN>$L($P(NODE,"^",1)):MAXLEN,1:$L($P(NODE,"^",1)))
I 'MAXLEN D DLTBLK^IBDFU3(HDRBLK,IBFORM,357.1) S QUIT=1,HDRBLK=""
Q
EDITBLK ;allows the user to position the header block & draw a box around it
N IBBOX,IBDELETE
S IBBOX=0,IBDELETE=1
D RE^VALM4
K DIE,DA S DIE=357.1,DA=HDRBLK,DR="[IBDF EDIT HEADER BLOCK]",DIE("NO^")="BACKOUTOK" D ^DIE K DIE,DR,DA
I IBDELETE,NEWBLOCK D DLTBLK^IBDFU3(HDRBLK,IBFORM,357.1)
Q
DFLTCOL() ;finds the column that would center the header block
Q ((IBFORM("WIDTH")-(+$G(MAXLEN)+(+$G(IBBOX))))\2)+1
MOVEFLD ;centers each header line in the block
N START,SUBFLD,HDR,LINES
S LINES=0
S START=$S($P($G(^IBE(357.1,HDRBLK,0)),"^",10)=1:1,1:0)
S SUBFLD=0
F S SUBFLD=$O(^IBE(357.5,HDRFLD,2,SUBFLD)) Q:'SUBFLD S NODE=$G(^IBE(357.5,HDRFLD,2,SUBFLD,0)),HDR=$P(NODE,"^",1) D
.I HDR'="" S $P(NODE,"^",4)=((MAXLEN-$L(HDR))\2)+START,$P(NODE,"^",5)=LINES+START,LINES=LINES+1 S ^IBE(357.5,HDRFLD,2,SUBFLD,0)=NODE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDF9C 2588 printed Nov 22, 2024@18:01:57 Page 2
IBDF9C ;ALB/CJM - ENCOUNTER FORM - (edit header block) ;FEB 1,1993
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
+2 ;
EDITHDR ;edit the header block
+1 NEW HDRBLK,HDRFLD,TOP1,BOT1,TOP2,BOT2,HDRLINES,MAXLEN,QUIT,NEWBLOCK
+2 SET VALMBCK="R"
SET (TOP1,TOP2,BOT1,BOT2,QUIT,NEWBLOCK)=0
+3 DO FULL^VALM1
+4 SET HDRBLK=$$FINDBLK
IF 'HDRBLK
SET HDRBLK=$$MAKEBLK
IF 'HDRBLK
QUIT
+5 DO TOPNBOT^IBDFU5(HDRBLK,.TOP1,.BOT1)
+6 SET HDRFLD=$$FINDFLD
IF 'HDRFLD
SET HDRFLD=$$MAKEFLD
IF 'HDRFLD
QUIT
+7 DO EDITFLD
+8 if 'QUIT
DO EDITBLK
DO MOVEFLD
+9 IF HDRBLK
DO TOPNBOT^IBDFU5(HDRBLK,.TOP2,.BOT2)
DO UNCMPBLK^IBDF19(HDRBLK)
+10 DO IDXFORM^IBDF5A($SELECT(TOP1<TOP2:TOP1,1:TOP2),$SELECT(BOT1>BOT2:BOT1,1:BOT2))
+11 SET VALMBCK="R"
+12 QUIT
FINDBLK() ;
+1 SET HDRBLK=""
FOR
SET HDRBLK=$ORDER(^IBE(357.1,"C",IBFORM,HDRBLK))
if 'HDRBLK
QUIT
if $PIECE($GET(^IBE(357.1,HDRBLK,0)),"^")="HEADER"
QUIT
+2 QUIT HDRBLK
MAKEBLK() ;
+1 SET NEWBLOCK=1
+2 KILL DIC,DD,DO,DINUM
SET DIC="^IBE(357.1,"
SET X="HEADER"
SET DIC(0)=""
SET DIC("DR")=".02////"_IBFORM
+3 DO FILE^DICN
KILL DIC,DIE
+4 QUIT $SELECT(+Y<0:"",1:+Y)
FINDFLD() ;
+1 SET HDRFLD=""
FOR
SET HDRFLD=$ORDER(^IBE(357.5,"C",HDRBLK,HDRFLD))
if 'HDRFLD
QUIT
if $PIECE($GET(^IBE(357.5,HDRFLD,0)),"^")="HEADER"
QUIT
+2 QUIT HDRFLD
MAKEFLD() ;
+1 KILL DIC,DD,DO,DINUM
SET DIC="^IBE(357.5,"
SET X="HEADER"
SET DIC(0)=""
SET DIC("DR")=".02////"_HDRBLK
+2 DO FILE^DICN
KILL DIC,DIE
+3 QUIT $SELECT(+Y<0:"",1:+Y)
EDITFLD ;allows the user to edit the header lines
+1 NEW NODE,SUBFLD
+2 KILL DIE,DA
SET DIE=357.5
SET DA=HDRFLD
SET DR="[IBDF EDIT FORM HEADER]"
SET DIE("NO^")="BACKOUTOK"
DO ^DIE
KILL DIE,DR,DA
+3 ;find the number of lines and the maximum length
+4 SET (HDRLINES,MAXLEN)=0
+5 SET SUBFLD=0
FOR
SET SUBFLD=$ORDER(^IBE(357.5,HDRFLD,2,SUBFLD))
if 'SUBFLD
QUIT
SET NODE=$GET(^(SUBFLD,0))
IF NODE'=""
SET HDRLINES=HDRLINES+1
SET MAXLEN=$SELECT(MAXLEN>$LENGTH($PIECE(NODE,"^",1)):MAXLEN,1:$LENGTH($PIECE(NODE,"^",1)))
+6 IF 'MAXLEN
DO DLTBLK^IBDFU3(HDRBLK,IBFORM,357.1)
SET QUIT=1
SET HDRBLK=""
+7 QUIT
EDITBLK ;allows the user to position the header block & draw a box around it
+1 NEW IBBOX,IBDELETE
+2 SET IBBOX=0
SET IBDELETE=1
+3 DO RE^VALM4
+4 KILL DIE,DA
SET DIE=357.1
SET DA=HDRBLK
SET DR="[IBDF EDIT HEADER BLOCK]"
SET DIE("NO^")="BACKOUTOK"
DO ^DIE
KILL DIE,DR,DA
+5 IF IBDELETE
IF NEWBLOCK
DO DLTBLK^IBDFU3(HDRBLK,IBFORM,357.1)
+6 QUIT
DFLTCOL() ;finds the column that would center the header block
+1 QUIT ((IBFORM("WIDTH")-(+$GET(MAXLEN)+(+$GET(IBBOX))))\2)+1
MOVEFLD ;centers each header line in the block
+1 NEW START,SUBFLD,HDR,LINES
+2 SET LINES=0
+3 SET START=$SELECT($PIECE($GET(^IBE(357.1,HDRBLK,0)),"^",10)=1:1,1:0)
+4 SET SUBFLD=0
+5 FOR
SET SUBFLD=$ORDER(^IBE(357.5,HDRFLD,2,SUBFLD))
if 'SUBFLD
QUIT
SET NODE=$GET(^IBE(357.5,HDRFLD,2,SUBFLD,0))
SET HDR=$PIECE(NODE,"^",1)
Begin DoDot:1
+6 IF HDR'=""
SET $PIECE(NODE,"^",4)=((MAXLEN-$LENGTH(HDR))\2)+START
SET $PIECE(NODE,"^",5)=LINES+START
SET LINES=LINES+1
SET ^IBE(357.5,HDRFLD,2,SUBFLD,0)=NODE
End DoDot:1
+7 QUIT
