- 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)
- 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)
