source: WorldVistAEHR/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDF2B.m@ 846

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

initial load of WorldVistAEHR
File size: 4.3 KB
Line 
1IBDF2B ;ALB/CJM - ENCOUNTER FORM - (prints data field);12/15/92
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
3DATAFLD(FIELD) ;for printing data fields to the encounter form
4 ;IBPRINT("WITH_DATA") means to complete the form with data
5 ;RTNLIST is used to keep a list of package interface routines called - it should not be newed
6 ;IBPRINT("ENTIRE")=0 means just fill in the data
7 ;
8 N LASTITEM,RTN,MAXX,MAXY,LABEL,XLAB,YLAB,XIO,YIO,WIO,HIO,BLK,ITEM,PIECE,SPACING,DISPLAY,LAST,VALUE,FLDNAME
9 ;LAST - the last subfield read
10 Q:'$$FLDDESCR^IBDFU1A(FIELD) ;get the 0 node of the field description
11 Q:BLK='IBBLK ;check that the field really belongs to correct block
12 D RTNDSCR^IBDFU1B(.RTN) ;get the rtn used by the field
13 ;if this is not the first time this form is being printed, and the data does not change, quit
14 I 'IBPRINT("ENTIRE"),'RTN("CHANGES") Q
15 I $G(IBDEVICE("LISTMAN")) D RANGE
16 I IBPRINT("WITH_DATA")!('RTN("CHANGES")) D RTN
17 I RTN("DATATYPE")=5 D TXTPRINT^IBDF2B1 Q ;wordprocessing fields treated differently
18 ;now do other than wordprocessing
19 ;process each subfield
20 S LAST=$$SFLDDSCR^IBDFU1A(FIELD,0) Q:'LAST
21 F D S LAST=$$SFLDDSCR^IBDFU1A(FIELD,LAST) Q:'LAST
22 .;print labels unless it's a batch job and the form has already been computed
23 .I IBPRINT("ENTIRE"),(LABEL'=""),DISPLAY'["I" D
24 ..D DRWSTR^IBDFU(YLAB,XLAB,LABEL,DISPLAY)
25 ..I IBDEVICE("LISTMAN"),((XLAB+($L(LABEL)-1))>MAXX)!(YLAB>MAXY) D WARNING
26 .D PRNTDATA
27 Q
28RANGE ;sets MAXX and MAXY to the maximum values allowed for the X,Y coordinates
29 N BOX
30 S BOX=$S(IBBLK("BOX")'=2:1,1:0)
31 S MAXY=IBBLK("H")-(1+BOX)
32 S MAXX=IBBLK("W")-(1+BOX)
33 Q
34PRNTDATA ;displays the correct data to the subfield
35 N PVALUE,NODE
36 I RTN("DATATYPE")=1!(RTN("DATATYPE")=3) S PIECE=1
37 Q:'PIECE
38 S NODE=$$DATANODE^IBDFU1B(RTN,PIECE)
39 S PVALUE=$P($S(NODE'="":$G(VALUE(NODE)),1:$G(VALUE)),"^",PIECE)
40 I WIO,PVALUE="" D
41 .;print the underscore only if the data is not variable
42 .I IBDEVICE("LISTMAN") S PVALUE=$S(IBPRINT("WITH_DATA")&RTN("CHANGES"):$J("",WIO),1:$$HLINE^IBDFU(WIO)) Q
43 .I 'RTN("CHANGES") S PVALUE=$$HLINE^IBDFU(WIO)
44 I PVALUE'="" D
45 .I ('IBDEVICE("LISTMAN")),($L(PVALUE)>WIO),RTN("FULL") D OVERFLOW("CURRENT")
46 .I 'IBDEVICE("LISTMAN"),((RTN("DATATYPE")=3)!(RTN("DATATYPE")=4)),LASTITEM,$O(@RTN("DATA_LOCATION")@(ITEM)),RTN("FULL") D OVERFLOW("NEXT")
47 .D DRWSTR^IBDFU(YIO,XIO,$$PADRIGHT^IBDFU(PVALUE,WIO))
48 .I IBDEVICE("LISTMAN"),((XIO+WIO-1)>MAXX)!(YIO>MAXY) D WARNING
49 Q
50RTN ;calls the rtn specified by the pkg interface if ok
51 Q:RTN("ACTION")'=2
52 Q:RTN("NAME")=""
53 ;quit if its not the first time this form has been printed and the data is not changeable
54 Q:(('IBPRINT("ENTIRE"))&('RTN("CHANGES")))
55 ;
56 N NODE S NODE=""
57 ;call the interface routine if it has not already been called
58 I '$D(RTNLIST(RTN("RTN"))) Q:'$$DORTN^IBDFU1B(.RTN)
59 ;
60 ;keep a list of rtns called because some routines return multiple data elements
61 S:'IBDEVICE("LISTMAN") RTNLIST(RTN("RTN"))=""
62 ;
63 ;now fetch the value, unless it's wordprocessing field
64 I (RTN("DATATYPE")=1)!(RTN("DATATYPE")=2) S VALUE=$G(@RTN("DATA_LOCATION")) F S NODE=$O(@RTN("DATA_LOCATION")@(NODE)) Q:NODE="" S VALUE(NODE)=$G(@RTN("DATA_LOCATION")@(NODE)) Q
65 I (RTN("DATATYPE")=3)!(RTN("DATATYPE")=4),ITEM S VALUE=$G(@RTN("DATA_LOCATION")@(ITEM)) F S NODE=$O(@RTN("DATA_LOCATION")@(ITEM,NODE)) Q:NODE="" S VALUE(NODE)=$G(@RTN("DATA_LOCATION")@(ITEM,NODE))
66 Q
67 ;
68ADDLINES ;if there are unused lines writes blank lines to the form
69 ;LNSUSED is the number of lines used already,HIO is the total number of lines allowed
70 N I,LSPACING,NUMLEFT
71 Q:HIO'>0
72 I LNSUSED'<HIO Q
73 S LSPACING=1
74 I (SPACING=2)!(SPACING=3) S LSPACING=2
75 S NUMLEFT=HIO-LNSUSED
76 S NUMLEFT=NUMLEFT\LSPACING
77 I IBDEVICE("LISTMAN") D
78 .I ((XIO+WIO-1)>MAXX)!((YIO+(NUMLEFT*LSPACING)-1)>MAXY) D WARNING
79 F I=1:1:NUMLEFT D DRWSTR^IBDFU(YIO+LNSUSED+(I*LSPACING)-1,XIO,$$HLINE^IBDFU(WIO))
80 Q
81WARNING ; prints a warning that data field prints outside of block - meant only for display while editing a form description
82 Q:IBWARN
83 W !,"Data Field="_FLDNAME_" in Block="_IBBLK("NAME")_" is printing",!,"outside of the block!"
84 D PAUSE^IBDFU5
85 S IBWARN=1
86 Q
87OVERFLOW(TYPE) ;keeps track of data that does not fit on the form
88 ;TYPE=="CURRENT" if other than a WP field will not fit
89 ; ="NEXT" if the data is from a list and the last item indicator is set
90 S @IBARRAY("OVERFLOW")@(IBBLK,FIELD,TYPE)=$G(ITEM)
91 Q
Note: See TracBrowser for help on using the repository browser.