source: WorldVistAEHR/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDF2A1.m@ 1361

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

initial load of WorldVistAEHR
File size: 6.0 KB
RevLine 
[613]1IBDF2A1 ;ALB/CJM - ENCOUNTER FORM (IBDF2A continued);NOV 16,1992
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
3 ;
4DEVSETUP(IBFORM,IBDEVICE) ;set up the device for the form
5 ;pass IBFORM, IBDEVICE by reference
6 ;sets device to no wrap
7 ;sets "ROW_HT" and "COL_WIDTH" in IBDEVICE
8 ;
9 S X=0 X $G(^%ZOSF("RM")) K X ;sets device to no wrapping
10 ;
11 I $G(IBDEVICE("PCL")) D
12 .S IOSL=IBFORM("PAGE_HT")
13 .W $C(27),"E"
14 .I $G(IBDEVICE("RESET"))'="" W @IBDEVICE("RESET")
15 .S IOINHI=$C(27)_"(s3B",IOINORM=$C(27)_"(s0B"
16 .S IBDEVICE("DUPLEX_SHORT")=$C(27)_"&l2S",IBDEVICE("SIMPLEX")=$C(27)_"&l0S",IBDEVICE("DUPLEX_LONG")=$C(27)_"&l1S"
17 .S IORVON=$C(27)_"*v0n1o1T",IORVOFF=$C(27)_"*v0T"
18 .S IOXY="W $C(27)_""&a""_DX_""c""_DY_""R"""
19 .;set to paper to letter size, portrait mode
20 .W $C(27),"&l2a0O"
21 .D
22 ..I IBFORM("WIDTH")>96 W $C(27)_"(s0p16.67h8.5v0s0b0T" S IBDEVICE("COL_WIDTH")=720/16.67,(IOINHI,IOINORM)="" Q
23 ..I IBFORM("WIDTH")>80 W $C(27)_"(s0p12h10v0s0b0T" S IBDEVICE("COL_WIDTH")=720/12 Q
24 ..W $C(27)_"(s0p10h12v0s0b0T" S IBDEVICE("COL_WIDTH")=720/10
25 .D
26 ..;!!!!!!!!!!Make the VMI a bit bigger? Seems to look good at VMI=6, and getting too cramped
27 ..;!!!!!!I IBFORM("PAGE_HT")>72 W $C(27),"&l5.6667C" S IBDEVICE("ROW_HT")=85.0005 Q ;sets the VMI=5.6667, to get 8 lines per inch Q
28 ..I IBFORM("PAGE_HT")>72 W $C(27),"&l6C" S IBDEVICE("ROW_HT")=90 Q ;sets the VMI=5.6667, to get 8 lines per inch Q
29 ..I IBFORM("PAGE_HT")>60 W $C(27),"&l6.6667C" S IBDEVICE("ROW_HT")=100.0005 Q ;sets the VMI=6.6667, to get 7.2 lines per inch
30 ..W $C(27),"&l8C" S IBDEVICE("ROW_HT")=120 ;sets the VMI=8, to get 6 lines per inch
31 ;
32 I '$G(IBDEVICE("PCL")) D
33 .S (DX,DY)=0 X $G(^%ZOSF("XY")) K DX,DY ;make sure $X,$Y=0
34 Q
35 ;
36DRWBLOCK(IBBLK,NOOFFSET) ;IBBLK should be passed by reference, is an array containing the block description
37 ;NOOFFSET=1 means don't offset the block on the form
38 ;
39 N IBFIELD,IBLIST,IBLINE,IBTEXT,IBWRTCNT,HDROS,BOX,OPTIONS,WIDTH,SUB,NODE,STRING,IBLINES,TYPE
40 ;
41 ;IBPRINT parameters may be altered durring this routine - make sure the original is restored after execution
42 D SAVE^IBDF2A2(.IBPRINT,.IBPRINT)
43 ;
44 Q:$$BLKDESCR^IBDFU1B(.IBBLK)
45 I $G(NOOFFSET) S (IBBLK("X"),IBBLK("Y"))=0
46 I (IBBLK("X")'=+IBBLK("X"))!(IBBLK("Y")'=+IBBLK("Y")) G EXIT ;location not known
47 ;
48 I 'IBPRINT("COMPILING_BLOCKS"),('$D(^IBE(357.1,IBBLK,"S"))!'$D(^IBE(357.1,IBBLK,"V"))!'$D(^IBE(357.1,IBBLK,"B"))!'$D(^IBE(357.1,IBBLK,"H"))) S IBPRINT("COMPILING_BLOCKS")=1,IBPRINT("WRITE_IF_COMPILING")=1
49 I IBPRINT("COMPILING_BLOCKS") S (IBWRTCNT("S"),IBWRTCNT("V"),IBWRTCNT("B"),IBWRTCNT("H"))=0 D UNCMPBLK^IBDF19(IBBLK)
50 I 'IBPRINT("COMPILING_BLOCKS") D WCMP^IBDF2A2
51 I IBPRINT("COMPILING_BLOCKS") D G:'IBPRINT("WRITE_IF_COMPILING") EXIT
52 .N TEMP S TEMP=IBPRINT("WITH_DATA"),IBPRINT("WITH_DATA")=0
53 .S IBLIST="" F S IBLIST=$O(^IBE(357.2,"C",IBBLK,IBLIST)) Q:'IBLIST D PRINTLST^IBDF2D(IBLIST)
54 .S IBFIELD="" F S IBFIELD=$O(^IBE(357.93,"C",IBBLK,IBFIELD)) Q:'IBFIELD D MFLD^IBDF2G(IBFIELD)
55 .S IBFIELD="" F S IBFIELD=$O(^IBE(359.94,"C",IBBLK,IBFIELD)) Q:'IBFIELD D HFLD^IBDF2H(IBFIELD)
56 .S ^IBE(357.1,IBBLK,"S",0)="^357.11A^"_IBWRTCNT("S")_"^"_IBWRTCNT("S")
57 .S ^IBE(357.1,IBBLK,"V",0)="^357.12A^"_IBWRTCNT("V")_"^"_IBWRTCNT("V")
58 .S ^IBE(357.1,IBBLK,"B",0)="^357.13A^"_IBWRTCNT("B")_"^"_IBWRTCNT("B")
59 .S ^IBE(357.1,IBBLK,"H",0)="^357.14A^"_IBWRTCNT("H")_"^"_IBWRTCNT("H")
60 .S IBPRINT("WITH_DATA")=TEMP
61 ;
62 ;now write the uncompiled part of the block
63 S IBPRINT("COMPILING_BLOCKS")=0
64 K IBWRTCNT
65 I IBDEVICE("LISTMAN") N IBWARN S IBWARN=0 ;flag set to 1 if a warning is already displayed - don't want to display multiple warnings, users find it aggravating
66 S BOX=$S(IBBLK("BOX")=1:1,1:0)
67 D:BOX DRWBOX^IBDFU(0,0,IBBLK("W"),IBBLK("H"))
68 I IBBLK("HDR")'="" D
69 .S HDROS=0
70 .S WIDTH=IBBLK("W")-(2*BOX)
71 .S OPTIONS=$TR(IBBLK("HDISP"),"C","")
72 .S OPTIONS=$TR(OPTIONS,"R","r")
73 .I IBBLK("HDISP")["C",$L(IBBLK("HDR"))<WIDTH S HDROS=(WIDTH-$L(IBBLK("HDR")))\2
74 .I BOX D DRWSTR^IBDFU(1,1,$J("",HDROS)_$E(IBBLK("HDR"),1,WIDTH),OPTIONS,WIDTH)
75 .I 'BOX D DRWSTR^IBDFU(0,0+HDROS,$E(IBBLK("HDR"),1,WIDTH),OPTIONS)
76 S IBLINE="" F S IBLINE=$O(^IBE(357.7,"C",IBBLK,IBLINE)) Q:'IBLINE D PRNTLINE^IBDF2E(IBLINE)
77 S IBTEXT="" F S IBTEXT=$O(^IBE(357.8,"C",IBBLK,IBTEXT)) Q:'IBTEXT D PRNTTEXT^IBDF2E(IBTEXT)
78 S IBFIELD="" F S IBFIELD=$O(^IBE(357.5,"C",IBBLK,IBFIELD)) Q:'IBFIELD D DATAFLD^IBDF2B(IBFIELD)
79 I IBPRINT("WITH_DATA") S IBPRINT("ENTIRE")=0,IBLIST="" F S IBLIST=$O(^IBE(357.2,"AD",IBBLK,IBLIST)) Q:'IBLIST D PRINTLST^IBDF2D(IBLIST)
80 ;
81 ;NOTE: bubbles & hand print fields have been written to file, but not to the array for list processor
82 ;
83 G:'IBDEVICE("LISTMAN") EXIT
84 S SUB=0 F S SUB=$O(^IBE(357.1,IBBLK,"B",SUB)) Q:'SUB S NODE=$G(^IBE(357.1,IBBLK,"B",SUB,0)) D DRWSTR^IBDFU(+$P(NODE,"^")\1,+$P(NODE,"^",2),"[ ]")
85 S SUB=0 F S SUB=$O(^IBE(357.1,IBBLK,"H",SUB)) Q:'SUB S NODE=$G(^IBE(357.1,IBBLK,"H",SUB,0)) S TYPE=$P(NODE,"^",14),WIDTH=+$P(NODE,"^",3) I TYPE,WIDTH D
86 .N UNIT,PRINT,REPLACE,A,I,TYPENODE
87 .S IBLINES=$P(NODE,"^",6) S:IBLINES'>0 IBLINES=1
88 .S STRING="",ROW=+NODE
89 .;
90 .;replace the hand print fields - overlay with print format and label for units
91 .;TYPE=2 means use ICR, may have a print format and datatype
92 .I TYPE=2 D
93 ..S TYPENODE=$P(NODE,"^",17) I TYPENODE S TYPENODE=$G(^IBE(359.1,TYPENODE,0))
94 ..S UNIT=$P(TYPENODE,"^",11),PRINT=$P(TYPENODE,"^",5)
95 ..F Q:IBLINES'>0 D S IBLINES=IBLINES-1,ROW=ROW+2
96 ...I IBFORM("WIDTH")>96 S $P(STRING,"___|",WIDTH+1)="",REPLACE("_")=" " F I=1:1:$L(PRINT) S A=$E(PRINT,I) S:A'="_" REPLACE(A)=" "_A_" "
97 ...I IBFORM("WIDTH")'>96 S $P(STRING,"__|",WIDTH+1)="",REPLACE("_")=" " F I=1:1:$L(PRINT) S A=$E(PRINT,I) S:A'="_" REPLACE(A)=" "_A_" "
98 ...S:$L(UNIT) STRING=STRING_" "_UNIT
99 ...I $L(PRINT) S PRINT=$$REPLACE^XLFSTR(PRINT,.REPLACE)
100 ...D DRWSTR^IBDFU(ROW,+$P(NODE,"^",2),PRINT,"R",$L(STRING))
101 ...D DRWSTR^IBDFU(ROW+1,+$P(NODE,"^",2),STRING,"R",$L(STRING))
102 .;
103 .I TYPE=1 D CNVRTLEN^IBDF2D1(WIDTH,.WIDTH),CNVRTHT^IBDF2D1(IBLINES,.IBLINES) F Q:IBLINES'>0 D S IBLINES=IBLINES-1,ROW=ROW+1
104 ..D DRWSTR^IBDFU(ROW,+$P(NODE,"^",2),"","R",WIDTH)
105 ;
106EXIT ;
107 D RESTORE^IBDF2A2(.IBPRINT,.IBPRINT)
108 Q
Note: See TracBrowser for help on using the repository browser.