IBDF9D ;ALB/CJM - ENCOUNTER FORM (create/edit/delete lines);MARCH 20, 1993
;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
LINE ;Create, Edit, or Delete a line on the block
S VALMBCK="R"
K DIR S DIR("?",1)="You can add vertical or horizontal lines to the block, or edit or delete",DIR("?")="a line already there IF it was created through this action."
S DIR("B")="C",DIR(0)="SB^C:Create;E:Edit;D:Delete",DIR("A")="[C]reate , [D]elete, or [E]dit a line"
D ^DIR K DIR I $D(DIRUT)!(Y<0) Q
D @$S(Y="C":"NEWLINE",Y="E":"EDITLINE",Y="D":"DLTLINE",1:"")
S VALMBCK="R"
Q
EDITLINE ;expects IBBLK to be defined - edits an already existing line
N IBLINE,IBDFDONE
;IBDFDONE is used in the imput template
D FULL^VALM1
D SELECT
I IBLINE D
.D RE^VALM4
.K DIE,DA S DIE=357.7,DA=IBLINE,DR="[IBDF FORM LINE]",DIE("NO^")="BACKOUTOK" D ^DIE K DIE,DR,DA
.D UNCMPBLK^IBDF19(IBBLK),IDXBLOCK^IBDFU4
Q
SELECT ;select a line on the block
S IBLINE=0
Q:'$G(IBBLK)
I '$O(^IBE(357.7,"C",IBBLK,0)) W !,"There is no line!" D PAUSE^IBDFU5 Q
AGAIN K DIC S DIC="^IBE(357.7,",DIC(0)="EFQ",DIC("B")="",D="C",X=IBBLK
S DIC("S")="I $P($G(^(0)),U,6)=IBBLK"
D IX^DIC K DIC
S:+Y>0 IBLINE=+Y
I 'IBLINE,'$D(DTOUT),'$D(DUOUT) K DIR S DIR(0)="Y",DIR("A")="No data line selected! Try again",DIR("B")="YES" D ^DIR K DIR I '$D(DIRUT),Y=1 G AGAIN
Q
DLTLINE ;expects IBBLK to be defined - deletes one of the blocks lines
N IBLINE
D FULL^VALM1
D SELECT
I IBLINE D
.Q:'$$RUSURE^IBDFU5($P($G(^IBE(357.7,IBLINE,0)),"^"))
.D DLTLINE^IBDFU3(357.7,IBBLK,IBLINE)
.D UNCMPBLK^IBDF19(IBBLK),IDXBLOCK^IBDFU4
Q
NEWLINE ;adds a new line, expects IBBLK to be defined
N IBLINE,NODE,IBDFDONE,DLAYGO
;IBDONE - a flag used in the input template to indicate if the input template was completed - delete the line if not completed
;S NAME=$$NEWNAME Q:NAME=-1
K DIC,DIE,DD,DO,DINUM S DIC="^IBE(357.7,",DIC(0)="FL",X="NAME",DLAYGO=357.7
D FILE^DICN K DIC,DIE,DA,DO
S IBLINE=+Y
I 'IBLINE D
.W !,"Unable to create a new line!" D PAUSE^IBDFU5
I IBLINE D
.K DIE,DA S DIE=357.7,DA=IBLINE,DR="[IBDF FORM LINE]",DIE("NO^")="BACKOUTOK" D ^DIE K DIE,DR,DA
.I 'IBDFDONE K DA S DIK="^IBE(357.7,",DA=IBLINE D ^DIK K DIK Q
.D UNCMPBLK^IBDF19(IBBLK),IDXBLOCK^IBDFU4
Q
NEWNAME(IBLINE) ;
N NODE,NAME S NODE=$G(^IBE(357.7,IBLINE,0))
Q:NODE="" "LINE"
S NAME=$P(NODE,"^",4)_"("_(+$P(NODE,"^",3)+1)_","_(+$P(NODE,"^",2)+1)_")"
Q NAME
MAXLEN() ;returns the maximum length of the line=IBLINE that will fit in the block=IBBLK
N LEN,TYPE,NODE,POS
S NODE=$G(^IBE(357.7,IBLINE,0))
S TYPE=$P(NODE,"^",4)
S POS=$S(TYPE="H":$P(NODE,"^",2),1:$P(NODE,"^",3))
Q ((1+$S(TYPE="H":$$MAXX^IBDFU1B,1:$$MAXY^IBDFU1B))-POS)
;
TOOMANY() ;are there too many lines in the box? returns 0 or 1
;IBBLK is assumed to be defined=the block
N SPACING,NODE,START,NUMBER
Q:'$G(IBLINE) 0
Q:'$G(IBBLK) 0
S NODE=$G(^IBE(357.7,IBLINE,0))
S START=$P(NODE,"^",3),SPACING=$P(NODE,"^",8),NUMBER=$P(NODE,"^",7)
S SPACING=$S(SPACING="d":2,SPACING="t":3,1:1)
I (START+(SPACING*NUMBER)-(SPACING-1))>$$MAXY^IBDFU1B
Q $T
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDF9D 3124 printed Oct 16, 2024@18:52:34 Page 2
IBDF9D ;ALB/CJM - ENCOUNTER FORM (create/edit/delete lines);MARCH 20, 1993
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
LINE ;Create, Edit, or Delete a line on the block
+1 SET VALMBCK="R"
+2 KILL DIR
SET DIR("?",1)="You can add vertical or horizontal lines to the block, or edit or delete"
SET DIR("?")="a line already there IF it was created through this action."
+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 line"
+4 DO ^DIR
KILL DIR
IF $DATA(DIRUT)!(Y<0)
QUIT
+5 DO @$SELECT(Y="C":"NEWLINE",Y="E":"EDITLINE",Y="D":"DLTLINE",1:"")
+6 SET VALMBCK="R"
+7 QUIT
EDITLINE ;expects IBBLK to be defined - edits an already existing line
+1 NEW IBLINE,IBDFDONE
+2 ;IBDFDONE is used in the imput template
+3 DO FULL^VALM1
+4 DO SELECT
+5 IF IBLINE
Begin DoDot:1
+6 DO RE^VALM4
+7 KILL DIE,DA
SET DIE=357.7
SET DA=IBLINE
SET DR="[IBDF FORM LINE]"
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 line on the block
+1 SET IBLINE=0
+2 if '$GET(IBBLK)
QUIT
+3 IF '$ORDER(^IBE(357.7,"C",IBBLK,0))
WRITE !,"There is no line!"
DO PAUSE^IBDFU5
QUIT
AGAIN KILL DIC
SET DIC="^IBE(357.7,"
SET DIC(0)="EFQ"
SET DIC("B")=""
SET D="C"
SET X=IBBLK
+1 SET DIC("S")="I $P($G(^(0)),U,6)=IBBLK"
+2 DO IX^DIC
KILL DIC
+3 if +Y>0
SET IBLINE=+Y
+4 IF 'IBLINE
IF '$DATA(DTOUT)
IF '$DATA(DUOUT)
KILL DIR
SET DIR(0)="Y"
SET DIR("A")="No data line selected! Try again"
SET DIR("B")="YES"
DO ^DIR
KILL DIR
IF '$DATA(DIRUT)
IF Y=1
GOTO AGAIN
+5 QUIT
DLTLINE ;expects IBBLK to be defined - deletes one of the blocks lines
+1 NEW IBLINE
+2 DO FULL^VALM1
+3 DO SELECT
+4 IF IBLINE
Begin DoDot:1
+5 if '$$RUSURE^IBDFU5($PIECE($GET(^IBE(357.7,IBLINE,0)),"^"))
QUIT
+6 DO DLTLINE^IBDFU3(357.7,IBBLK,IBLINE)
+7 DO UNCMPBLK^IBDF19(IBBLK)
DO IDXBLOCK^IBDFU4
End DoDot:1
+8 QUIT
NEWLINE ;adds a new line, expects IBBLK to be defined
+1 NEW IBLINE,NODE,IBDFDONE,DLAYGO
+2 ;IBDONE - a flag used in the input template to indicate if the input template was completed - delete the line if not completed
+3 ;S NAME=$$NEWNAME Q:NAME=-1
+4 KILL DIC,DIE,DD,DO,DINUM
SET DIC="^IBE(357.7,"
SET DIC(0)="FL"
SET X="NAME"
SET DLAYGO=357.7
+5 DO FILE^DICN
KILL DIC,DIE,DA,DO
+6 SET IBLINE=+Y
+7 IF 'IBLINE
Begin DoDot:1
+8 WRITE !,"Unable to create a new line!"
DO PAUSE^IBDFU5
End DoDot:1
+9 IF IBLINE
Begin DoDot:1
+10 KILL DIE,DA
SET DIE=357.7
SET DA=IBLINE
SET DR="[IBDF FORM LINE]"
SET DIE("NO^")="BACKOUTOK"
DO ^DIE
KILL DIE,DR,DA
+11 IF 'IBDFDONE
KILL DA
SET DIK="^IBE(357.7,"
SET DA=IBLINE
DO ^DIK
KILL DIK
QUIT
+12 DO UNCMPBLK^IBDF19(IBBLK)
DO IDXBLOCK^IBDFU4
End DoDot:1
+13 QUIT
NEWNAME(IBLINE) ;
+1 NEW NODE,NAME
SET NODE=$GET(^IBE(357.7,IBLINE,0))
+2 if NODE=""
QUIT "LINE"
+3 SET NAME=$PIECE(NODE,"^",4)_"("_(+$PIECE(NODE,"^",3)+1)_","_(+$PIECE(NODE,"^",2)+1)_")"
+4 QUIT NAME
MAXLEN() ;returns the maximum length of the line=IBLINE that will fit in the block=IBBLK
+1 NEW LEN,TYPE,NODE,POS
+2 SET NODE=$GET(^IBE(357.7,IBLINE,0))
+3 SET TYPE=$PIECE(NODE,"^",4)
+4 SET POS=$SELECT(TYPE="H":$PIECE(NODE,"^",2),1:$PIECE(NODE,"^",3))
+5 QUIT ((1+$SELECT(TYPE="H":$$MAXX^IBDFU1B,1:$$MAXY^IBDFU1B))-POS)
+6 ;
TOOMANY() ;are there too many lines in the box? returns 0 or 1
+1 ;IBBLK is assumed to be defined=the block
+2 NEW SPACING,NODE,START,NUMBER
+3 if '$GET(IBLINE)
QUIT 0
+4 if '$GET(IBBLK)
QUIT 0
+5 SET NODE=$GET(^IBE(357.7,IBLINE,0))
+6 SET START=$PIECE(NODE,"^",3)
SET SPACING=$PIECE(NODE,"^",8)
SET NUMBER=$PIECE(NODE,"^",7)
+7 SET SPACING=$SELECT(SPACING="d":2,SPACING="t":3,1:1)
+8 IF (START+(SPACING*NUMBER)-(SPACING-1))>$$MAXY^IBDFU1B
+9 QUIT $TEST
