IBDF9B4 ;ALB/CJM - ENCOUNTER FORM - (edit,delete,add Hand Print fields) ;JUL 20,1994
;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
;
HFIELD ;Create, Edit, or Delete a Hand Print field from the form
;
N IBVALMBG,QUIT
S IBVALMBG=VALMBG
S QUIT=0
S VALMBCK="R"
;
F D Q:QUIT
.D FULL^VALM1
.K DIR S DIR("?",1)="You can Create, Edit, or Delete an hand print field, or Shift all of the hand print fields",DIR("?")="within a definable range either up or down."
.W !!,DIR("?",1),!,DIR("?"),!
.S DIR("B")="C",DIR(0)="SB^C:Create;E:Edit;D:Delete;S:Shift;Q:Quit",DIR("A")="[C]reate, [D]elete, [E]dit, [S]hift, [Q]uit"
.D ^DIR K DIR I $D(DIRUT)!(Y<0) S QUIT=1 Q
.I Y="Q" S QUIT=1 Q
.D @$S(Y="C":"NEWFLD",Y="E":"EDITFLD",Y="D":"DLTFLD",Y="S":"SHIFT",1:"")
.D RE^VALM4
S VALMBCK="R",VALMBG=IBVALMBG
Q
SHIFT ;expects IBBLK to be defined - shifts all hand print fields within range supplied by user
D SHIFT^IBDF10("H")
D UNCMPBLK^IBDF19(IBBLK),IDXBLOCK^IBDFU4
Q
EDITFLD ;expects IBBLK to be defined
N IBFIELD,RTN,NODE
N IBOLD,IBDELETE,IBX,IBY,IBLEN,IBTYPE ;these are used in the input template
D SELECT
I IBFIELD D
.D RE^VALM4
.S (IBX,IBY,IBLEN)=0
.S IBOLD=1,IBTYPE=$P($G(^IBE(359.94,IBFIELD,0)),"^",5)
.K DR,DIE,DA S DIE=359.94,DA=IBFIELD,DR="[IBDF EDIT HAND PRINT FIELD]",DIE("NO^")="BACKOUTOK" D ^DIE K DIE,DR,DA
.D UNCMPBLK^IBDF19(IBBLK),IDXBLOCK^IBDFU4
Q
SELECT ;
S IBFIELD=0
Q:'$G(IBBLK)
I '$O(^IBE(359.94,"C",IBBLK,0)) W !,"There is no hand print field!" D PAUSE^IBDFU5 Q
AGAIN K DIC S DIC="^IBE(359.94,",DIC(0)="EFQ",DIC("B")="",D="C",X=IBBLK
S DIC("S")="I $P($G(^(0)),U,8)=IBBLK"
D IX^DIC K DIC
S:+Y>0 IBFIELD=+Y
I 'IBFIELD,'$D(DTOUT),'$D(DUOUT) K DIR S DIR(0)="Y",DIR("A")="No hand print field selected! Try again",DIR("B")="YES" D ^DIR K DIR I '$D(DIRUT),Y=1 G AGAIN
Q
DLTFLD ;expects IBBLK to be defined
N IBFIELD
D SELECT
I IBFIELD D
.Q:'$$RUSURE^IBDFU5($P($G(^IBE(359.94,IBFIELD,0)),"^"))
.D DLTHFLD^IBDFU3(359.94,IBBLK,IBFIELD)
.D UNCMPBLK^IBDF19(IBBLK),IDXBLOCK^IBDFU4
Q
NEWFLD ;adds a new field, expects IBBLK to be defined
N NAME,FIELD,NODE,IBRTN,DLAYGO
N IBX,IBY,IBLEN,IBDELETE,IBOLD,IBTYPE ;these are used in the input template
S NAME=$$NEWNAME^IBDF9B Q:NAME=-1
S IBOLD=0,(IBX,IBY,IBLEN)=""
K DIC,DIE,DD,DO,DINUM S DIC="^IBE(359.94,",DIC(0)="FL",X=NAME,DLAYGO=359.94
D FILE^DICN K DIC,DIE,DA
S FIELD=$S(+Y<0:"",1:+Y)
I 'FIELD D
.W !,"Unable to create a new hand print field!" D PAUSE^IBDFU5
I FIELD D
.S IBDELETE=1
.K DIE,DA,DR S DIE=359.94,DA=FIELD,DR="[IBDF EDIT HAND PRINT FIELD]",DIE("NO^")="BACKOUTOK" D ^DIE K DIE,DR,DA,DIC
.I IBDELETE K DA S DIK="^IBE(359.94,",DA=FIELD D ^DIK K DIK,DA Q
.D UNCMPBLK^IBDF19(IBBLK),IDXBLOCK^IBDFU4
Q
;
LENGTHDT(TYPE) ;
Q:'$G(TYPE) 0
N NODE,LEN
S NODE=$G(^IBE(359.1,TYPE,0))
S LEN=$L($P(NODE,"^",11))
S:LEN LEN=LEN+1
S LEN=LEN+(4*$P(NODE,"^",6))
Q LEN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDF9B4 2955 printed Dec 13, 2024@02:51:46 Page 2
IBDF9B4 ;ALB/CJM - ENCOUNTER FORM - (edit,delete,add Hand Print fields) ;JUL 20,1994
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
+2 ;
HFIELD ;Create, Edit, or Delete a Hand Print field from the form
+1 ;
+2 NEW IBVALMBG,QUIT
+3 SET IBVALMBG=VALMBG
+4 SET QUIT=0
+5 SET VALMBCK="R"
+6 ;
+7 FOR
Begin DoDot:1
+8 DO FULL^VALM1
+9 KILL DIR
SET DIR("?",1)="You can Create, Edit, or Delete an hand print field, or Shift all of the hand print fields"
SET DIR("?")="within a definable range either up or down."
+10 WRITE !!,DIR("?",1),!,DIR("?"),!
+11 SET DIR("B")="C"
SET DIR(0)="SB^C:Create;E:Edit;D:Delete;S:Shift;Q:Quit"
SET DIR("A")="[C]reate, [D]elete, [E]dit, [S]hift, [Q]uit"
+12 DO ^DIR
KILL DIR
IF $DATA(DIRUT)!(Y<0)
SET QUIT=1
QUIT
+13 IF Y="Q"
SET QUIT=1
QUIT
+14 DO @$SELECT(Y="C":"NEWFLD",Y="E":"EDITFLD",Y="D":"DLTFLD",Y="S":"SHIFT",1:"")
+15 DO RE^VALM4
End DoDot:1
if QUIT
QUIT
+16 SET VALMBCK="R"
SET VALMBG=IBVALMBG
+17 QUIT
SHIFT ;expects IBBLK to be defined - shifts all hand print fields within range supplied by user
+1 DO SHIFT^IBDF10("H")
+2 DO UNCMPBLK^IBDF19(IBBLK)
DO IDXBLOCK^IBDFU4
+3 QUIT
EDITFLD ;expects IBBLK to be defined
+1 NEW IBFIELD,RTN,NODE
+2 ;these are used in the input template
NEW IBOLD,IBDELETE,IBX,IBY,IBLEN,IBTYPE
+3 DO SELECT
+4 IF IBFIELD
Begin DoDot:1
+5 DO RE^VALM4
+6 SET (IBX,IBY,IBLEN)=0
+7 SET IBOLD=1
SET IBTYPE=$PIECE($GET(^IBE(359.94,IBFIELD,0)),"^",5)
+8 KILL DR,DIE,DA
SET DIE=359.94
SET DA=IBFIELD
SET DR="[IBDF EDIT HAND PRINT FIELD]"
SET DIE("NO^")="BACKOUTOK"
DO ^DIE
KILL DIE,DR,DA
+9 DO UNCMPBLK^IBDF19(IBBLK)
DO IDXBLOCK^IBDFU4
End DoDot:1
+10 QUIT
SELECT ;
+1 SET IBFIELD=0
+2 if '$GET(IBBLK)
QUIT
+3 IF '$ORDER(^IBE(359.94,"C",IBBLK,0))
WRITE !,"There is no hand print field!"
DO PAUSE^IBDFU5
QUIT
AGAIN KILL DIC
SET DIC="^IBE(359.94,"
SET DIC(0)="EFQ"
SET DIC("B")=""
SET D="C"
SET X=IBBLK
+1 SET DIC("S")="I $P($G(^(0)),U,8)=IBBLK"
+2 DO IX^DIC
KILL DIC
+3 if +Y>0
SET IBFIELD=+Y
+4 IF 'IBFIELD
IF '$DATA(DTOUT)
IF '$DATA(DUOUT)
KILL DIR
SET DIR(0)="Y"
SET DIR("A")="No hand print field selected! Try again"
SET DIR("B")="YES"
DO ^DIR
KILL DIR
IF '$DATA(DIRUT)
IF Y=1
GOTO AGAIN
+5 QUIT
DLTFLD ;expects IBBLK to be defined
+1 NEW IBFIELD
+2 DO SELECT
+3 IF IBFIELD
Begin DoDot:1
+4 if '$$RUSURE^IBDFU5($PIECE($GET(^IBE(359.94,IBFIELD,0)),"^"))
QUIT
+5 DO DLTHFLD^IBDFU3(359.94,IBBLK,IBFIELD)
+6 DO UNCMPBLK^IBDF19(IBBLK)
DO IDXBLOCK^IBDFU4
End DoDot:1
+7 QUIT
NEWFLD ;adds a new field, expects IBBLK to be defined
+1 NEW NAME,FIELD,NODE,IBRTN,DLAYGO
+2 ;these are used in the input template
NEW IBX,IBY,IBLEN,IBDELETE,IBOLD,IBTYPE
+3 SET NAME=$$NEWNAME^IBDF9B
if NAME=-1
QUIT
+4 SET IBOLD=0
SET (IBX,IBY,IBLEN)=""
+5 KILL DIC,DIE,DD,DO,DINUM
SET DIC="^IBE(359.94,"
SET DIC(0)="FL"
SET X=NAME
SET DLAYGO=359.94
+6 DO FILE^DICN
KILL DIC,DIE,DA
+7 SET FIELD=$SELECT(+Y<0:"",1:+Y)
+8 IF 'FIELD
Begin DoDot:1
+9 WRITE !,"Unable to create a new hand print field!"
DO PAUSE^IBDFU5
End DoDot:1
+10 IF FIELD
Begin DoDot:1
+11 SET IBDELETE=1
+12 KILL DIE,DA,DR
SET DIE=359.94
SET DA=FIELD
SET DR="[IBDF EDIT HAND PRINT FIELD]"
SET DIE("NO^")="BACKOUTOK"
DO ^DIE
KILL DIE,DR,DA,DIC
+13 IF IBDELETE
KILL DA
SET DIK="^IBE(359.94,"
SET DA=FIELD
DO ^DIK
KILL DIK,DA
QUIT
+14 DO UNCMPBLK^IBDF19(IBBLK)
DO IDXBLOCK^IBDFU4
End DoDot:1
+15 QUIT
+16 ;
LENGTHDT(TYPE) ;
+1 if '$GET(TYPE)
QUIT 0
+2 NEW NODE,LEN
+3 SET NODE=$GET(^IBE(359.1,TYPE,0))
+4 SET LEN=$LENGTH($PIECE(NODE,"^",11))
+5 if LEN
SET LEN=LEN+1
+6 SET LEN=LEN+(4*$PIECE(NODE,"^",6))
+7 QUIT LEN
