IBDF9D.m

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

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