source: WorldVistAEHR/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDF9C.m@ 1578

Last change on this file since 1578 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.5 KB
Line 
1IBDF9C ;ALB/CJM - ENCOUNTER FORM - (edit header block) ;FEB 1,1993
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
3 ;
4EDITHDR ;edit the header block
5 N HDRBLK,HDRFLD,TOP1,BOT1,TOP2,BOT2,HDRLINES,MAXLEN,QUIT,NEWBLOCK
6 S VALMBCK="R",(TOP1,TOP2,BOT1,BOT2,QUIT,NEWBLOCK)=0
7 D FULL^VALM1
8 S HDRBLK=$$FINDBLK I 'HDRBLK S HDRBLK=$$MAKEBLK I 'HDRBLK Q
9 D TOPNBOT^IBDFU5(HDRBLK,.TOP1,.BOT1)
10 S HDRFLD=$$FINDFLD I 'HDRFLD S HDRFLD=$$MAKEFLD I 'HDRFLD Q
11 D EDITFLD
12 D:'QUIT EDITBLK,MOVEFLD
13 I HDRBLK D TOPNBOT^IBDFU5(HDRBLK,.TOP2,.BOT2),UNCMPBLK^IBDF19(HDRBLK)
14 D IDXFORM^IBDF5A($S(TOP1<TOP2:TOP1,1:TOP2),$S(BOT1>BOT2:BOT1,1:BOT2))
15 S VALMBCK="R"
16 Q
17FINDBLK() ;
18 S HDRBLK="" F S HDRBLK=$O(^IBE(357.1,"C",IBFORM,HDRBLK)) Q:'HDRBLK Q:$P($G(^IBE(357.1,HDRBLK,0)),"^")="HEADER"
19 Q HDRBLK
20MAKEBLK() ;
21 S NEWBLOCK=1
22 K DIC,DD,DO,DINUM S DIC="^IBE(357.1,",X="HEADER",DIC(0)="",DIC("DR")=".02////"_IBFORM
23 D FILE^DICN K DIC,DIE
24 Q $S(+Y<0:"",1:+Y)
25FINDFLD() ;
26 S HDRFLD="" F S HDRFLD=$O(^IBE(357.5,"C",HDRBLK,HDRFLD)) Q:'HDRFLD Q:$P($G(^IBE(357.5,HDRFLD,0)),"^")="HEADER"
27 Q HDRFLD
28MAKEFLD() ;
29 K DIC,DD,DO,DINUM S DIC="^IBE(357.5,",X="HEADER",DIC(0)="",DIC("DR")=".02////"_HDRBLK
30 D FILE^DICN K DIC,DIE
31 Q $S(+Y<0:"",1:+Y)
32EDITFLD ;allows the user to edit the header lines
33 N NODE,SUBFLD
34 K DIE,DA S DIE=357.5,DA=HDRFLD,DR="[IBDF EDIT FORM HEADER]",DIE("NO^")="BACKOUTOK" D ^DIE K DIE,DR,DA
35 ;find the number of lines and the maximum length
36 S (HDRLINES,MAXLEN)=0
37 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)))
38 I 'MAXLEN D DLTBLK^IBDFU3(HDRBLK,IBFORM,357.1) S QUIT=1,HDRBLK=""
39 Q
40EDITBLK ;allows the user to position the header block & draw a box around it
41 N IBBOX,IBDELETE
42 S IBBOX=0,IBDELETE=1
43 D RE^VALM4
44 K DIE,DA S DIE=357.1,DA=HDRBLK,DR="[IBDF EDIT HEADER BLOCK]",DIE("NO^")="BACKOUTOK" D ^DIE K DIE,DR,DA
45 I IBDELETE,NEWBLOCK D DLTBLK^IBDFU3(HDRBLK,IBFORM,357.1)
46 Q
47DFLTCOL() ;finds the column that would center the header block
48 Q ((IBFORM("WIDTH")-(+$G(MAXLEN)+(+$G(IBBOX))))\2)+1
49MOVEFLD ;centers each header line in the block
50 N START,SUBFLD,HDR,LINES
51 S LINES=0
52 S START=$S($P($G(^IBE(357.1,HDRBLK,0)),"^",10)=1:1,1:0)
53 S SUBFLD=0
54 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
55 .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
56 Q
Note: See TracBrowser for help on using the repository browser.