Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBDF2B

IBDF2B.m

Go to the documentation of this file. 
  1. IBDF2B ;ALB/CJM - ENCOUNTER FORM - (prints data field);12/15/92
  1.  ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
  1. DATAFLD(FIELD) ;for printing data fields to the encounter form
  1.  ;IBPRINT("WITH_DATA") means to complete the form with data
  1.  ;RTNLIST is used to keep a list of package interface routines called - it should not be newed
  1.  ;IBPRINT("ENTIRE")=0 means just fill in the data
  1.  ;
  1.  N LASTITEM,RTN,MAXX,MAXY,LABEL,XLAB,YLAB,XIO,YIO,WIO,HIO,BLK,ITEM,PIECE,SPACING,DISPLAY,LAST,VALUE,FLDNAME
  1.  ;LAST - the last subfield read
  1.  Q:'$$FLDDESCR^IBDFU1A(FIELD)  ;get the 0 node of the field description
  1.  Q:BLK='IBBLK  ;check that the field really belongs to correct block
  1.  D RTNDSCR^IBDFU1B(.RTN) ;get the rtn used by the field
  1.  ;if this is not the first time this form is being printed, and the data does not change, quit
  1.  I 'IBPRINT("ENTIRE"),'RTN("CHANGES") Q
  1.  I $G(IBDEVICE("LISTMAN")) D RANGE
  1.  I IBPRINT("WITH_DATA")!('RTN("CHANGES")) D RTN
  1.  I RTN("DATATYPE")=5 D TXTPRINT^IBDF2B1 Q  ;wordprocessing fields treated differently
  1.  ;now do other than wordprocessing
  1.  ;process each subfield
  1.  S LAST=$$SFLDDSCR^IBDFU1A(FIELD,0) Q:'LAST
  1.  F  D  S LAST=$$SFLDDSCR^IBDFU1A(FIELD,LAST) Q:'LAST
  1.  .;print labels unless it's a batch job and the form has already been computed
  1.  .I IBPRINT("ENTIRE"),(LABEL'=""),DISPLAY'["I" D
  1.  ..D DRWSTR^IBDFU(YLAB,XLAB,LABEL,DISPLAY)
  1.  ..I IBDEVICE("LISTMAN"),((XLAB+($L(LABEL)-1))>MAXX)!(YLAB>MAXY) D WARNING
  1.  .D PRNTDATA
  1.  Q
  1. RANGE ;sets MAXX and MAXY to the maximum values allowed for the X,Y coordinates
  1.  N BOX
  1.  S BOX=$S(IBBLK("BOX")'=2:1,1:0)
  1.  S MAXY=IBBLK("H")-(1+BOX)
  1.  S MAXX=IBBLK("W")-(1+BOX)
  1.  Q
  1. PRNTDATA ;displays the correct data to the subfield
  1.  N PVALUE,NODE
  1.  I RTN("DATATYPE")=1!(RTN("DATATYPE")=3) S PIECE=1
  1.  Q:'PIECE
  1.  S NODE=$$DATANODE^IBDFU1B(RTN,PIECE)
  1.  S PVALUE=$P($S(NODE'="":$G(VALUE(NODE)),1:$G(VALUE)),"^",PIECE)
  1.  I WIO,PVALUE="" D
  1.  .;print the underscore only if the data is not variable
  1.  .I IBDEVICE("LISTMAN") S PVALUE=$S(IBPRINT("WITH_DATA")&RTN("CHANGES"):$J("",WIO),1:$$HLINE^IBDFU(WIO)) Q
  1.  .I 'RTN("CHANGES") S PVALUE=$$HLINE^IBDFU(WIO)
  1.  I PVALUE'="" D
  1.  .I ('IBDEVICE("LISTMAN")),($L(PVALUE)>WIO),RTN("FULL") D OVERFLOW("CURRENT")
  1.  .I 'IBDEVICE("LISTMAN"),((RTN("DATATYPE")=3)!(RTN("DATATYPE")=4)),LASTITEM,$O(@RTN("DATA_LOCATION")@(ITEM)),RTN("FULL") D OVERFLOW("NEXT")
  1.  .D DRWSTR^IBDFU(YIO,XIO,$$PADRIGHT^IBDFU(PVALUE,WIO))
  1.  .I IBDEVICE("LISTMAN"),((XIO+WIO-1)>MAXX)!(YIO>MAXY) D WARNING
  1.  Q
  1. RTN ;calls the rtn specified by the pkg interface if ok
  1.  Q:RTN("ACTION")'=2
  1.  Q:RTN("NAME")=""
  1.  ;quit if its not the first time this form has been printed and the data is not changeable
  1.  Q:(('IBPRINT("ENTIRE"))&('RTN("CHANGES")))
  1.  ;
  1.  N NODE S NODE=""
  1.  ;call the interface routine if it has not already been called
  1.  I '$D(RTNLIST(RTN("RTN"))) Q:'$$DORTN^IBDFU1B(.RTN)
  1.  ;
  1.  ;keep a list of rtns called because some routines return multiple data elements
  1.  S:'IBDEVICE("LISTMAN") RTNLIST(RTN("RTN"))=""
  1.  ;
  1.  ;now fetch the value, unless it's wordprocessing field
  1.  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
  1.  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))
  1.  Q
  1.  ;
  1. ADDLINES ;if there are unused lines writes blank lines to the form
  1.  ;LNSUSED is the number of lines used already,HIO is the total number of lines allowed
  1.  N I,LSPACING,NUMLEFT
  1.  Q:HIO'>0
  1.  I LNSUSED'<HIO Q
  1.  S LSPACING=1
  1.  I (SPACING=2)!(SPACING=3) S LSPACING=2
  1.  S NUMLEFT=HIO-LNSUSED
  1.  S NUMLEFT=NUMLEFT\LSPACING
  1.  I IBDEVICE("LISTMAN") D
  1.  .I ((XIO+WIO-1)>MAXX)!((YIO+(NUMLEFT*LSPACING)-1)>MAXY) D WARNING
  1.  F I=1:1:NUMLEFT D DRWSTR^IBDFU(YIO+LNSUSED+(I*LSPACING)-1,XIO,$$HLINE^IBDFU(WIO))
  1.  Q
  1. WARNING ; prints a warning that data field prints outside of block - meant only for display while editing a form description
  1.  Q:IBWARN
  1.  W !,"Data Field="_FLDNAME_" in Block="_IBBLK("NAME")_" is printing",!,"outside of the block!"
  1.  D PAUSE^IBDFU5
  1.  S IBWARN=1
  1.  Q
  1. OVERFLOW(TYPE) ;keeps track of data that does not fit on the form
  1.  ;TYPE=="CURRENT" if other than a WP field will not fit
  1.  ;    ="NEXT" if the data is from a list and the last item indicator is set
  1.  S @IBARRAY("OVERFLOW")@(IBBLK,FIELD,TYPE)=$G(ITEM)
  1.  Q