- 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 Mar 13, 2025@21:56:50 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
