IBDFU5 ;ALB/CJM - ENCOUNTER FORM (utilities) ;JAN 16,1993
;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
TOPNBOT(BLOCK,TOP,BOT) ;finds the top and bottom of the block - pass TOP and BOT by reference
N NODE
S NODE=$G(^IBE(357.1,BLOCK,0))
S TOP=+$P(NODE,"^",4),BOT=(TOP+(+$P(NODE,"^",7)))-1
Q
RUSURE(NAME) ;obtains verification from the user for deletion- returns 1 if answered YES, otherwise NO
;if NAME is defined it will be used in the prompt
N RET
S RET=1
K DIR S DIR(0)="Y",DIR("A")=$S(NAME="":"Are you sure",1:"Are you sure "_NAME_" should be deleted"),DIR("B")="NO"
D ^DIR K DIR I (Y<1)!$D(DIRUT) S RET=0
Q RET
PAUSE ;
N ANS
W !,$C(7),"Press RETURN to continue..." R ANS:DTIME
Q
;
NOGRPHCS ;sets graphics variables to "_" and "|"
S (IOVL,IOBLC,IOBRC)="|",(IOHL,IOTRC,IOTLC)="_"
Q
;
HELP1 ;displays a list of the record's fields from file 357.6, IB PACKAGE INTERFACE file - EXECUTABLE HELP FOR FIELDS IN THE DATA FIELD FILE
;
;INPUT - D0 is a pointer to a DATA FIELD (file 357.5)
;
N RTN
Q:'$G(D0)
W !,"WHAT DATA SHOULD BE PRINTED IN THE SUBFIELD? CHOOSE FROM:"
S RTN=$P($G(^IBE(357.5,D0,0)),"^",3) Q:'RTN
D SHOWDATA
Q
HELP2 ;displays a list of the record's fields from file 357.6, IB PACKAGE INTERFACE file - EXECUTABLE HELP FOR FIELDS IN THE SELECTION LIST FILE
;
;INPUT - D0 should be a pointer to a SELECTION LIST
;
N RTN
W !,"WHAT DATA SHOULD BE PRINTED IN THIS SUBCOLUMN? CHOOSE FROM:"
Q:'$G(D0)
S RTN=$P($G(^IBE(357.2,D0,0)),"^",11) Q:'RTN
D SHOWDATA
W !,"You can also enter 0 if you want the item number entered in the subcolumn.",!
Q
;
HELP3 ;displays a list of the record's fields from file 357.6, IB PACKAGE INTERFACE file - used to display available data to the user before he enters a data field label
;
;INPUT - D0 is a pointer to a DATA FIELD (file 357.5)
N RTN
W !,"Available Data:"
Q:'$G(D0)
S RTN=$P($G(^IBE(357.5,D0,0)),"^",3) Q:'RTN
D SHOWDATA
Q
;
HELP4 ;displays a list of the record's fields from file 357.6, IB PACKAGE INTERFACE file - used to display to the user the available data before a subcolumn to a selection list
;
;INPUT - D0 should be a pointer to a SELECTION LIST
;
N RTN
W !,"Available Data:"
Q:'$G(D0)
S RTN=$P($G(^IBE(357.2,D0,0)),"^",11) Q:'RTN
D SHOWDATA
Q
HELP5 ;for number of columns in list
I $G(IBDEVICE("LISTMAN")) D FULL^VALM1
W !!,"A selection list COLUMN contains items on the list. It may consist of several",!,"subcolumns. For example, a typical column may have three subcolumns, one"
W !,"containing a code, the second a description, and the third a marking area for",!,"the user to indicate his selections from the list. Besides going down the",!,"form, the list can can go across the form by having multiple columns."
W !!,"Entering the number of columns is optional. By default the entire block will",!,"be filled with the list.",!
I $G(IBDEVICE("LISTMAN")) D PAUSE^IBDFU5,RE^VALM4
Q
;
SHOWDATA ;displays a discription of the the record returned by the package interface
;
;INPUT - RTN - ptr to the package interface file
N NODE,SUB,ROW,COL,LINE,DESCR,CANSHOW,IEN
S NODE=$G(^IBE(357.6,RTN,2))
;
;piece 1 may not be displayable (an ien)
S CANSHOW=$S($P(NODE,"^",17)=0:0,1:1)
I 'CANSHOW S NODE=""
;
F ROW=0:1:3 S LINE="" D W:(LINE'="") !,LINE
.F COL=1:1:2 S SUB=COL+(2*ROW) D Q:LINE=""
..S DESCR=""
..I (SUB'=1) S NODE="",IEN=$O(^IBE(357.6,RTN,15,"C",SUB,0)) S:IEN NODE=$G(^IBE(357.6,RTN,15,IEN,0))
..I NODE="" I (COL=1&'$D(^IBE(357.6,RTN,15,"C",SUB+1)))!((COL'=1)&(DESCR="(not applicable)")) Q
..S DESCR=$P(NODE,"^") I DESCR'="" S DESCR=DESCR_" :"_$P(NODE,"^",2)_" char"
..I DESCR="" S DESCR="(N/A)"
..S LINE=LINE_$S(DESCR="":"",1:$$PADRIGHT^IBDFU(" "_SUB_"= "_DESCR,39))
Q
;
RESET ;resets the scrolling area of the screen to that defined by List Manager
;I $G(IOSTBM)'="" S IOTM=IOSL-4,IOBM=IOSL W IOSC,@IOSTBM,IORC
Q
VARIABLE(VAR) ;returns 0 if VAR is not syntactically a good local variable name, 1 otherwise
N I,LEN,CHAR,GOOD
S LEN=$L(VAR)
S CHAR=$E(VAR)
I '((CHAR?1A)!(CHAR="%")) Q 0
S GOOD=1
F I=2:1:LEN S CHAR=$E(VAR,I) I '((CHAR?1A)!(CHAR?1N)) S GOOD=0 Q
Q GOOD
ID1 ;writes identifier for subcolumn of selection list (file 357.2)
N NODE,TYPE,PIECE,IEN
S NODE=$G(^(0)) Q:NODE=""
W "HEADER=",$$PADRIGHT^IBDFU($P(NODE,U,2),27)_" CONTENT="
I $P(NODE,U,4)=1 D
.S TYPE=$P($G(^IBE(357.2,D0,0)),"^",11) Q:'TYPE
.S PIECE=+$P(NODE,U,5)
.W:'PIECE "#COUNT"
.W:PIECE $$DATANAME^IBDFU1B(TYPE,PIECE)
I $P(NODE,U,4)=2 D
.S TYPE=$P(NODE,U,6) Q:'TYPE
.W $P($G(^IBE(357.91,TYPE,0)),U)
Q
;
DFLTS() ;returns the default form if found, 0 otherwise
N FORM
S FORM=0 F S FORM=$O(^IBE(357,"B","DEFAULTS",FORM)) Q:'FORM Q:$P($G(^IBE(357,FORM,0)),"^",7)
Q FORM
;
OKPIECE(PI,PIECE) ;returns 1 if the piece=PIECE is selectable for the package interface=PI, 0 otherwise
;
I ('$G(PIECE))!('$G(PI)) Q 0
N QUIT S QUIT=0
I PIECE=1 S QUIT=$S($P($G(^IBE(357.6,PI,2)),"^",17)'=0:1,1:0)
I PIECE'=1 S QUIT=$D(^IBE(357.6,PI,15,"C",PIECE))
Q QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFU5 5123 printed Dec 13, 2024@02:53:40 Page 2
IBDFU5 ;ALB/CJM - ENCOUNTER FORM (utilities) ;JAN 16,1993
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
TOPNBOT(BLOCK,TOP,BOT) ;finds the top and bottom of the block - pass TOP and BOT by reference
+1 NEW NODE
+2 SET NODE=$GET(^IBE(357.1,BLOCK,0))
+3 SET TOP=+$PIECE(NODE,"^",4)
SET BOT=(TOP+(+$PIECE(NODE,"^",7)))-1
+4 QUIT
RUSURE(NAME) ;obtains verification from the user for deletion- returns 1 if answered YES, otherwise NO
+1 ;if NAME is defined it will be used in the prompt
+2 NEW RET
+3 SET RET=1
+4 KILL DIR
SET DIR(0)="Y"
SET DIR("A")=$SELECT(NAME="":"Are you sure",1:"Are you sure "_NAME_" should be deleted")
SET DIR("B")="NO"
+5 DO ^DIR
KILL DIR
IF (Y<1)!$DATA(DIRUT)
SET RET=0
+6 QUIT RET
PAUSE ;
+1 NEW ANS
+2 WRITE !,$CHAR(7),"Press RETURN to continue..."
READ ANS:DTIME
+3 QUIT
+4 ;
NOGRPHCS ;sets graphics variables to "_" and "|"
+1 SET (IOVL,IOBLC,IOBRC)="|"
SET (IOHL,IOTRC,IOTLC)="_"
+2 QUIT
+3 ;
HELP1 ;displays a list of the record's fields from file 357.6, IB PACKAGE INTERFACE file - EXECUTABLE HELP FOR FIELDS IN THE DATA FIELD FILE
+1 ;
+2 ;INPUT - D0 is a pointer to a DATA FIELD (file 357.5)
+3 ;
+4 NEW RTN
+5 if '$GET(D0)
QUIT
+6 WRITE !,"WHAT DATA SHOULD BE PRINTED IN THE SUBFIELD? CHOOSE FROM:"
+7 SET RTN=$PIECE($GET(^IBE(357.5,D0,0)),"^",3)
if 'RTN
QUIT
+8 DO SHOWDATA
+9 QUIT
HELP2 ;displays a list of the record's fields from file 357.6, IB PACKAGE INTERFACE file - EXECUTABLE HELP FOR FIELDS IN THE SELECTION LIST FILE
+1 ;
+2 ;INPUT - D0 should be a pointer to a SELECTION LIST
+3 ;
+4 NEW RTN
+5 WRITE !,"WHAT DATA SHOULD BE PRINTED IN THIS SUBCOLUMN? CHOOSE FROM:"
+6 if '$GET(D0)
QUIT
+7 SET RTN=$PIECE($GET(^IBE(357.2,D0,0)),"^",11)
if 'RTN
QUIT
+8 DO SHOWDATA
+9 WRITE !,"You can also enter 0 if you want the item number entered in the subcolumn.",!
+10 QUIT
+11 ;
HELP3 ;displays a list of the record's fields from file 357.6, IB PACKAGE INTERFACE file - used to display available data to the user before he enters a data field label
+1 ;
+2 ;INPUT - D0 is a pointer to a DATA FIELD (file 357.5)
+3 NEW RTN
+4 WRITE !,"Available Data:"
+5 if '$GET(D0)
QUIT
+6 SET RTN=$PIECE($GET(^IBE(357.5,D0,0)),"^",3)
if 'RTN
QUIT
+7 DO SHOWDATA
+8 QUIT
+9 ;
HELP4 ;displays a list of the record's fields from file 357.6, IB PACKAGE INTERFACE file - used to display to the user the available data before a subcolumn to a selection list
+1 ;
+2 ;INPUT - D0 should be a pointer to a SELECTION LIST
+3 ;
+4 NEW RTN
+5 WRITE !,"Available Data:"
+6 if '$GET(D0)
QUIT
+7 SET RTN=$PIECE($GET(^IBE(357.2,D0,0)),"^",11)
if 'RTN
QUIT
+8 DO SHOWDATA
+9 QUIT
HELP5 ;for number of columns in list
+1 IF $GET(IBDEVICE("LISTMAN"))
DO FULL^VALM1
+2 WRITE !!,"A selection list COLUMN contains items on the list. It may consist of several",!,"subcolumns. For example, a typical column may have three subcolumns, one"
+3 WRITE !,"containing a code, the second a description, and the third a marking area for",!,"the user to indicate his selections from the list. Besides going down the",!,"form, the list can can go across the form by having multiple columns."
+4 WRITE !!,"Entering the number of columns is optional. By default the entire block will",!,"be filled with the list.",!
+5 IF $GET(IBDEVICE("LISTMAN"))
DO PAUSE^IBDFU5
DO RE^VALM4
+6 QUIT
+7 ;
SHOWDATA ;displays a discription of the the record returned by the package interface
+1 ;
+2 ;INPUT - RTN - ptr to the package interface file
+3 NEW NODE,SUB,ROW,COL,LINE,DESCR,CANSHOW,IEN
+4 SET NODE=$GET(^IBE(357.6,RTN,2))
+5 ;
+6 ;piece 1 may not be displayable (an ien)
+7 SET CANSHOW=$SELECT($PIECE(NODE,"^",17)=0:0,1:1)
+8 IF 'CANSHOW
SET NODE=""
+9 ;
+10 FOR ROW=0:1:3
SET LINE=""
Begin DoDot:1
+11 FOR COL=1:1:2
SET SUB=COL+(2*ROW)
Begin DoDot:2
+12 SET DESCR=""
+13 IF (SUB'=1)
SET NODE=""
SET IEN=$ORDER(^IBE(357.6,RTN,15,"C",SUB,0))
if IEN
SET NODE=$GET(^IBE(357.6,RTN,15,IEN,0))
+14 IF NODE=""
IF (COL=1&'$DATA(^IBE(357.6,RTN,15,"C",SUB+1)))!((COL'=1)&(DESCR="(not applicable)"))
QUIT
+15 SET DESCR=$PIECE(NODE,"^")
IF DESCR'=""
SET DESCR=DESCR_" :"_$PIECE(NODE,"^",2)_" char"
+16 IF DESCR=""
SET DESCR="(N/A)"
+17 SET LINE=LINE_$SELECT(DESCR="":"",1:$$PADRIGHT^IBDFU(" "_SUB_"= "_DESCR,39))
End DoDot:2
if LINE=""
QUIT
End DoDot:1
if (LINE'="")
WRITE !,LINE
+18 QUIT
+19 ;
RESET ;resets the scrolling area of the screen to that defined by List Manager
+1 ;I $G(IOSTBM)'="" S IOTM=IOSL-4,IOBM=IOSL W IOSC,@IOSTBM,IORC
+2 QUIT
VARIABLE(VAR) ;returns 0 if VAR is not syntactically a good local variable name, 1 otherwise
+1 NEW I,LEN,CHAR,GOOD
+2 SET LEN=$LENGTH(VAR)
+3 SET CHAR=$EXTRACT(VAR)
+4 IF '((CHAR?1A)!(CHAR="%"))
QUIT 0
+5 SET GOOD=1
+6 FOR I=2:1:LEN
SET CHAR=$EXTRACT(VAR,I)
IF '((CHAR?1A)!(CHAR?1N))
SET GOOD=0
QUIT
+7 QUIT GOOD
ID1 ;writes identifier for subcolumn of selection list (file 357.2)
+1 NEW NODE,TYPE,PIECE,IEN
+2 SET NODE=$GET(^(0))
if NODE=""
QUIT
+3 WRITE "HEADER=",$$PADRIGHT^IBDFU($PIECE(NODE,U,2),27)_" CONTENT="
+4 IF $PIECE(NODE,U,4)=1
Begin DoDot:1
+5 SET TYPE=$PIECE($GET(^IBE(357.2,D0,0)),"^",11)
if 'TYPE
QUIT
+6 SET PIECE=+$PIECE(NODE,U,5)
+7 if 'PIECE
WRITE "#COUNT"
+8 if PIECE
WRITE $$DATANAME^IBDFU1B(TYPE,PIECE)
End DoDot:1
+9 IF $PIECE(NODE,U,4)=2
Begin DoDot:1
+10 SET TYPE=$PIECE(NODE,U,6)
if 'TYPE
QUIT
+11 WRITE $PIECE($GET(^IBE(357.91,TYPE,0)),U)
End DoDot:1
+12 QUIT
+13 ;
DFLTS() ;returns the default form if found, 0 otherwise
+1 NEW FORM
+2 SET FORM=0
FOR
SET FORM=$ORDER(^IBE(357,"B","DEFAULTS",FORM))
if 'FORM
QUIT
if $PIECE($GET(^IBE(357,FORM,0)),"^",7)
QUIT
+3 QUIT FORM
+4 ;
OKPIECE(PI,PIECE) ;returns 1 if the piece=PIECE is selectable for the package interface=PI, 0 otherwise
+1 ;
+2 IF ('$GET(PIECE))!('$GET(PI))
QUIT 0
+3 NEW QUIT
SET QUIT=0
+4 IF PIECE=1
SET QUIT=$SELECT($PIECE($GET(^IBE(357.6,PI,2)),"^",17)'=0:1,1:0)
+5 IF PIECE'=1
SET QUIT=$DATA(^IBE(357.6,PI,15,"C",PIECE))
+6 QUIT QUIT
