IBDF9E ;ALB/CJM - ENCOUNTER FORM (create/edit/delete text areas);MARCH 20, 1993
;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
TEXT ;Create, Edit, or Delete a text area on a block
S VALMBCK="R"
K DIR S DIR("?")="You can add text areas to the block, or edit or delete a text area already there."
S DIR("B")="C",DIR(0)="SB^C:Create;E:Edit;D:Delete",DIR("A")="[C]reate , [D]elete, or [E]dit a text area"
D ^DIR K DIR I $D(DIRUT)!(Y<0) Q
D @$S(Y="C":"NEWTEXT",Y="E":"EDITTEXT",Y="D":"DLTTEXT",1:"")
S VALMBCK="R"
Q
EDITTEXT ;expects IBBLK to be defined
N IBTEXT,IBDELETE
;IBDELETE is used in the imput template
D FULL^VALM1
D SELECT
I IBTEXT D
.D RE^VALM4
.K DIE,DA S DIE=357.8,DA=IBTEXT,DR="[IBDF EDIT TEXT AREA]",DIE("NO^")="BACKOUTOK" D ^DIE K DIE,DR,DA
.D UNCMPBLK^IBDF19(IBBLK),IDXBLOCK^IBDFU4
Q
SELECT ;select a text area on the block
S IBTEXT=0
Q:'$G(IBBLK)
I '$O(^IBE(357.8,"C",IBBLK,0)) W !,"There is no text area!" D PAUSE^IBDFU5 Q
AGAIN S DIC="^IBE(357.8,",DIC(0)="EFQ",DIC("B")="",D="C",X=IBBLK
D IX^DIC K DIC
S:+Y>0 IBTEXT=+Y
I 'IBTEXT,'$D(DTOUT),'$D(DUOUT) K DIR S DIR(0)="Y",DIR("A")="No text area selected! Try again",DIR("B")="YES" D ^DIR K DIR I '$D(DIRUT),Y=1 G AGAIN
Q
DLTTEXT ;delete a text area - expects IBBLK to be defined
N IBTEXT
D FULL^VALM1
D SELECT
I IBTEXT D
.Q:'$$RUSURE^IBDFU5($P($G(^IBE(357.8,IBTEXT,0)),"^"))
.D DLTTEXT^IBDFU3(357.8,IBBLK,IBTEXT)
.D UNCMPBLK^IBDF19(IBBLK),IDXBLOCK^IBDFU4
Q
NEWTEXT ;adds a new text area, expects IBBLK to be defined
N NAME,IBTEXT,NODE,IBDELETE,DLAYGO
;IBDELETE - a flag used in the input template to indicate if the input template was completed - if returns 1 delete the record
S NAME=$$NEWNAME Q:NAME=-1
K DIC,DIE,DD,D0,DINUM S DIC="^IBE(357.8,",DIC(0)="FL",X=NAME,DLAYGO=357.8
D FILE^DICN K DIC,DIE,DA
S IBTEXT=$S(+Y<0:"",1:+Y)
I 'IBTEXT D
.W !,"Unable to create a text area!" D PAUSE^IBDFU5
I IBTEXT D
.K DIE,DA S DIE=357.8,DA=IBTEXT,DR="[IBDF EDIT TEXT AREA]",DIE("NO^")="BACKOUTOK" D ^DIE K DIE,DR,DA
.I IBDELETE K DA S DIK="^IBE(357.8,",DA=IBTEXT D ^DIK K DIK Q
.D UNCMPBLK^IBDF19(IBBLK),IDXBLOCK^IBDFU4
Q
NEWNAME() ;
K DIR S DIR(0)="357.8,.01A",DIR("A")="New Text Area Name: ",DIR("B")=""
D ^DIR K DIR I $D(DIRUT) Q -1
Q Y
FORMAT ;formats the word-processing field of IBTEXT
N W,HT,NODE,COUNT,LINE
S NODE=$G(^IBE(357.8,IBTEXT,0))
S W=$P(NODE,"^",5),HT=$P(NODE,"^",6)
D FORMAT^IBDFU6("^IBE(357.8,IBTEXT,1)",W) ;creates formated version at ^UTILITY($J,"W",1)
K ^IBE(357.8,IBTEXT,1)
I $G(^UTILITY($J,"W",1))>HT W !,"WARNING! The text area is too small to display all of the text." D PAUSE^IBDFU5
S (COUNT,NUM)=0 F S NUM=$O(^UTILITY($J,"W",1,NUM)) Q:'NUM S LINE=$G(^(NUM,0)) D
.;I $L(LINE)>W W !,"WARNING! The word "_LINE_" is being truncated",!,"because it is too long." D PAUSE^IBDFU5
.S ^IBE(357.8,IBTEXT,1,NUM,0)=$E(LINE,1,W)
.S COUNT=COUNT+1
S ^IBE(357.8,IBTEXT,1,0)="^^"_COUNT_"^"_COUNT_"^"_DT_"^^^^"
K ^UTILITY($J,"W")
Q
MAXHT() ;returns the maximum ht. of IBTEXT text area fits in the block IBBLK
N NODE,Y
S NODE=$G(^IBE(357.8,IBTEXT,0)) S Y=$P(NODE,"^",4)
Q ((1+$$MAXY^IBDFU1B)-Y)
Q
MAXW() ;returns the maximum width of IBTEXT text area fits in the block IBBLK
N NODE,X
S NODE=$G(^IBE(357.8,IBTEXT,0)) S X=$P(NODE,"^",3)
Q ((1+$$MAXX^IBDFU1B)-X)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDF9E 3376 printed Nov 22, 2024@18:01:59 Page 2
IBDF9E ;ALB/CJM - ENCOUNTER FORM (create/edit/delete text areas);MARCH 20, 1993
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
TEXT ;Create, Edit, or Delete a text area on a block
+1 SET VALMBCK="R"
+2 KILL DIR
SET DIR("?")="You can add text areas to the block, or edit or delete a text area already there."
+3 SET DIR("B")="C"
SET DIR(0)="SB^C:Create;E:Edit;D:Delete"
SET DIR("A")="[C]reate , [D]elete, or [E]dit a text area"
+4 DO ^DIR
KILL DIR
IF $DATA(DIRUT)!(Y<0)
QUIT
+5 DO @$SELECT(Y="C":"NEWTEXT",Y="E":"EDITTEXT",Y="D":"DLTTEXT",1:"")
+6 SET VALMBCK="R"
+7 QUIT
EDITTEXT ;expects IBBLK to be defined
+1 NEW IBTEXT,IBDELETE
+2 ;IBDELETE is used in the imput template
+3 DO FULL^VALM1
+4 DO SELECT
+5 IF IBTEXT
Begin DoDot:1
+6 DO RE^VALM4
+7 KILL DIE,DA
SET DIE=357.8
SET DA=IBTEXT
SET DR="[IBDF EDIT TEXT AREA]"
SET DIE("NO^")="BACKOUTOK"
DO ^DIE
KILL DIE,DR,DA
+8 DO UNCMPBLK^IBDF19(IBBLK)
DO IDXBLOCK^IBDFU4
End DoDot:1
+9 QUIT
SELECT ;select a text area on the block
+1 SET IBTEXT=0
+2 if '$GET(IBBLK)
QUIT
+3 IF '$ORDER(^IBE(357.8,"C",IBBLK,0))
WRITE !,"There is no text area!"
DO PAUSE^IBDFU5
QUIT
AGAIN SET DIC="^IBE(357.8,"
SET DIC(0)="EFQ"
SET DIC("B")=""
SET D="C"
SET X=IBBLK
+1 DO IX^DIC
KILL DIC
+2 if +Y>0
SET IBTEXT=+Y
+3 IF 'IBTEXT
IF '$DATA(DTOUT)
IF '$DATA(DUOUT)
KILL DIR
SET DIR(0)="Y"
SET DIR("A")="No text area selected! Try again"
SET DIR("B")="YES"
DO ^DIR
KILL DIR
IF '$DATA(DIRUT)
IF Y=1
GOTO AGAIN
+4 QUIT
DLTTEXT ;delete a text area - expects IBBLK to be defined
+1 NEW IBTEXT
+2 DO FULL^VALM1
+3 DO SELECT
+4 IF IBTEXT
Begin DoDot:1
+5 if '$$RUSURE^IBDFU5($PIECE($GET(^IBE(357.8,IBTEXT,0)),"^"))
QUIT
+6 DO DLTTEXT^IBDFU3(357.8,IBBLK,IBTEXT)
+7 DO UNCMPBLK^IBDF19(IBBLK)
DO IDXBLOCK^IBDFU4
End DoDot:1
+8 QUIT
NEWTEXT ;adds a new text area, expects IBBLK to be defined
+1 NEW NAME,IBTEXT,NODE,IBDELETE,DLAYGO
+2 ;IBDELETE - a flag used in the input template to indicate if the input template was completed - if returns 1 delete the record
+3 SET NAME=$$NEWNAME
if NAME=-1
QUIT
+4 KILL DIC,DIE,DD,D0,DINUM
SET DIC="^IBE(357.8,"
SET DIC(0)="FL"
SET X=NAME
SET DLAYGO=357.8
+5 DO FILE^DICN
KILL DIC,DIE,DA
+6 SET IBTEXT=$SELECT(+Y<0:"",1:+Y)
+7 IF 'IBTEXT
Begin DoDot:1
+8 WRITE !,"Unable to create a text area!"
DO PAUSE^IBDFU5
End DoDot:1
+9 IF IBTEXT
Begin DoDot:1
+10 KILL DIE,DA
SET DIE=357.8
SET DA=IBTEXT
SET DR="[IBDF EDIT TEXT AREA]"
SET DIE("NO^")="BACKOUTOK"
DO ^DIE
KILL DIE,DR,DA
+11 IF IBDELETE
KILL DA
SET DIK="^IBE(357.8,"
SET DA=IBTEXT
DO ^DIK
KILL DIK
QUIT
+12 DO UNCMPBLK^IBDF19(IBBLK)
DO IDXBLOCK^IBDFU4
End DoDot:1
+13 QUIT
NEWNAME() ;
+1 KILL DIR
SET DIR(0)="357.8,.01A"
SET DIR("A")="New Text Area Name: "
SET DIR("B")=""
+2 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
QUIT -1
+3 QUIT Y
FORMAT ;formats the word-processing field of IBTEXT
+1 NEW W,HT,NODE,COUNT,LINE
+2 SET NODE=$GET(^IBE(357.8,IBTEXT,0))
+3 SET W=$PIECE(NODE,"^",5)
SET HT=$PIECE(NODE,"^",6)
+4 ;creates formated version at ^UTILITY($J,"W",1)
DO FORMAT^IBDFU6("^IBE(357.8,IBTEXT,1)",W)
+5 KILL ^IBE(357.8,IBTEXT,1)
+6 IF $GET(^UTILITY($JOB,"W",1))>HT
WRITE !,"WARNING! The text area is too small to display all of the text."
DO PAUSE^IBDFU5
+7 SET (COUNT,NUM)=0
FOR
SET NUM=$ORDER(^UTILITY($JOB,"W",1,NUM))
if 'NUM
QUIT
SET LINE=$GET(^(NUM,0))
Begin DoDot:1
+8 ;I $L(LINE)>W W !,"WARNING! The word "_LINE_" is being truncated",!,"because it is too long." D PAUSE^IBDFU5
+9 SET ^IBE(357.8,IBTEXT,1,NUM,0)=$EXTRACT(LINE,1,W)
+10 SET COUNT=COUNT+1
End DoDot:1
+11 SET ^IBE(357.8,IBTEXT,1,0)="^^"_COUNT_"^"_COUNT_"^"_DT_"^^^^"
+12 KILL ^UTILITY($JOB,"W")
+13 QUIT
MAXHT() ;returns the maximum ht. of IBTEXT text area fits in the block IBBLK
+1 NEW NODE,Y
+2 SET NODE=$GET(^IBE(357.8,IBTEXT,0))
SET Y=$PIECE(NODE,"^",4)
+3 QUIT ((1+$$MAXY^IBDFU1B)-Y)
+4 QUIT
MAXW() ;returns the maximum width of IBTEXT text area fits in the block IBBLK
+1 NEW NODE,X
+2 SET NODE=$GET(^IBE(357.8,IBTEXT,0))
SET X=$PIECE(NODE,"^",3)
+3 QUIT ((1+$$MAXX^IBDFU1B)-X)
