- 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 Feb 19, 2025@00:20:05 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