source: WorldVistAEHR/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDF2A.m@ 1450

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

initial load of WorldVistAEHR
File size: 4.7 KB
RevLine 
[613]1IBDF2A ;ALB/CJM - ENCOUNTER FORM (builds form and prints it) ;NOV 16,1992
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;**1,46**;APR 24, 1997
3FORM(IBFORM,WITHDATA) ;prints FORM - defines IBDEVICE array
4 ;input variables - IBFORM=ien of the form, WITHDATA=1 if the form should be completed with data
5 ;
6 N IBDEVICE
7 ;
8 D DEVICE^IBDFUA(0,.IBDEVICE)
9 D DRWFORM(IBFORM,WITHDATA,.IBDEVICE)
10EXIT ;
11 ;
12 D KPRNTVAR^IBDFUA ;kills the screen and graphics parameters
13 K X,Y,I
14 Q
15DRWFORM(IBFORM,WITHDATA,IBDEVICE) ;prints IBFORM - IBDEVICE array already defined, must be passed by reference
16 N RTNLIST,NODE,IBPFID,IBARRAY,LINES,HAND,IBPRINT,TYPE,UNIT,PRINT,REPRINT
17 ;
18 Q:'$$FORMDSCR^IBDFU1C(.IBFORM)
19 D PRNTPRMS^IBDFU1C(.IBPRINT,WITHDATA,1,0,1)
20 ;
21 D DEVSETUP^IBDF2A1(.IBFORM,.IBDEVICE)
22 K ^TMP("IB",$J,"INTERFACES"),^TMP("IBDF",$J,"FORM"),^("OVERFLOW")
23 S IBPFID=""
24 ;
25 ;for forms other than toolkit, always use compiled version
26 I 'IBFORM("TOOLKIT"),'IBFORM("COMPILED") D COMPILE^IBDF19 Q:'IBFORM("COMPILED")
27 ;
28 S REPRINT=0
29 ;if printing a form with patient data to paper get id for form tracking
30 I '$G(IBDSAMP),IBFORM("COMPILED"),IBPRINT("WITH_DATA"),'IBDEVICE("CRT") S IBPFID=+$$FID^IBDF18C(DFN,IBAPPT,1,IBFORM("TYPE"),IBCLINIC) I $P($G(^IBD(357.96,+IBPFID,1,0)),"^",4) S REPRINT=1
31 ;
32 D ARRAYS^IBDFU1C(.IBFORM,.IBARRAY)
33 I 'IBFORM("TOOLKIT"),WITHDATA D JUSTDATA(WITHDATA)
34 I IBFORM("TOOLKIT") D DRWBLKS
35 ;
36 ;if no graphics and not PCL replace graphics with something printable
37 I 'IBDEVICE("PCL") D REPLACE
38 ;
39 ;can not do underlining on a CRT
40 I IBDEVICE("CRT") S IBARRAY("UNDERLINES")="IBARRAY(""UNDERLINES"")"
41 ;
42 ;print the form
43 D LNPRINT^IBDF2F($G(IBPFID))
44 ;
45 ;print the overflow report
46 D OVERFLOW^IBDF1B3
47 ;
48 K ^TMP("IB",$J,"INTERFACES"),^TMP("IBDF",$J,"FORM")
49 ;
50 ;reset printer defaults if PCL5
51 I $G(IBDEVICE("PCL")) D
52 . X $G(^%ZIS(2,$G(IOST(0)),2))
53 Q
54 ;
55DRWBLKS ;draws all the form's blocks
56 N IBBLK,RTNLIST
57 S IBBLK="" F S IBBLK=$O(^IBE(357.1,"C",IBFORM,IBBLK)) Q:'IBBLK D DRWBLOCK^IBDF2A1(IBBLK,0)
58 Q
59 ;
60JUSTDATA(WITHDATA) ;draws the form's data fields and dynamic selection lists, just the portion that may change with data
61 ;WITHDATA means to fill in with data
62 ;
63 N IBBLK,RTNLIST,IBFLD,IBLIST,SUB,NODE,IBPRINT
64 ;
65 D PRNTPRMS^IBDFU1C(.IBPRINT,WITHDATA,0,0,1)
66 ;
67 I IBDEVICE("LISTMAN") N IBWARN S IBWARN=0
68 S IBBLK="" F S IBBLK=$O(^IBE(357.1,"C",IBFORM,IBBLK)) Q:'IBBLK D
69 .Q:$$BLKDESCR^IBDFU1B(.IBBLK)
70 .S IBFLD="" F S IBFLD=$O(^IBE(357.5,"C",IBBLK,IBFLD)) Q:'IBFLD D DATAFLD^IBDF2B(IBFLD)
71 .S:'IBPRINT("WITH_DATA") IBPRINT("ENTIRE")=1 S IBLIST="" F S IBLIST=$O(^IBE(357.2,"AD",IBBLK,IBLIST)) Q:'IBLIST D PRINTLST^IBDF2D(IBLIST)
72 .I IBDEVICE("LISTMAN") 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),"[ ]")
73 Q
74 ;
75REPLACE ;replace objects requiring PCL with plain text
76 N IBROW,IBCOL,IBBLK
77 D PRNTPRMS^IBDFU1C(.IBPRINT,0,1,0,1)
78 S IBBLK("X")=0,IBBLK("Y")=0
79 I 'IBDEVICE("GRAPHICS") D
80 .S IBROW="" F S IBROW=$O(@IBARRAY("GRAPHICS")@(IBROW)) Q:IBROW="" S IBCOL="" F S IBCOL=$O(@IBARRAY("GRAPHICS")@(IBROW,IBCOL)) Q:IBCOL="" D DRWSTR^IBDFU(IBROW,IBCOL,$G(@IBARRAY("GRAPHICS")@(IBROW,IBCOL)),"G")
81 .S IBARRAY("GRAPHICS")="IBARRAY(""GRAPHICS"")"
82 ;
83 ;replace bubbles with "[ ]"
84 S IBROW="" F S IBROW=$O(@IBARRAY("BUBBLES")@(IBROW)) Q:IBROW="" S IBCOL="" F S IBCOL=$O(@IBARRAY("BUBBLES")@(IBROW,IBCOL)) Q:IBCOL="" D DRWSTR^IBDFU(IBROW\1,IBCOL,"[ ]")
85 S IBARRAY("BUBBLES")="IBARRAY(""BUBBLES"")"
86 ;
87 ;now replace hand print fields
88 S IBROW="" F S IBROW=$O(@IBARRAY("HAND_PRINT")@(IBROW)) Q:IBROW="" S IBCOL="" F S IBCOL=$O(@IBARRAY("HAND_PRINT")@(IBROW,IBCOL)) Q:IBCOL="" S HAND=0 F S HAND=$O(@IBARRAY("HAND_PRINT")@(IBROW,IBCOL,HAND)) Q:'HAND D
89 .N ROW
90 .S NODE=$G(@IBARRAY("HAND_PRINT")@(IBROW,IBCOL,HAND)),WIDTH=$P(NODE,"^",3),LINES=$P(NODE,"^",6),TYPE=$P(NODE,"^",14),(UNIT,PRINT)="" I $P(NODE,"^",17) S NODE=$G(^IBE(359.1,$P(NODE,"^",17),0)),UNIT=$P(NODE,"^",11),PRINT=$P(NODE,"^",5)
91 .Q:('WIDTH)!('TYPE)
92 .S STRING=""
93 .S:LINES'>0 LINES=1
94 .S ROW=IBROW
95 .I TYPE=1 D CNVRTLEN^IBDF2D1(WIDTH,.WIDTH),CNVRTHT^IBDF2D1(LINES,.LINES)
96 .I TYPE=2 F Q:LINES'>0 D S LINES=LINES-1,ROW=IBROW+2
97 ..N REPLACE,A,I
98 ..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_" "
99 ..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_" "
100 ..S:$L(UNIT) STRING=STRING_" "_UNIT
101 ..I $L(PRINT) S PRINT=$$REPLACE^XLFSTR(PRINT,.REPLACE)
102 ..D:$L(PRINT) DRWSTR^IBDFU(ROW,IBCOL,PRINT,"",$L(STRING))
103 ..D DRWSTR^IBDFU(ROW+1,IBCOL,STRING,"",$L(STRING))
104 .I TYPE=1 S $P(STRING,"_",WIDTH+1)="_" D DRWSTR^IBDFU(ROW+LINES-1,IBCOL,STRING,"")
105 S IBARRAY("HAND_PRINT")="IBARRAY(""HAND_PRINT"")"
106 Q
Note: See TracBrowser for help on using the repository browser.