IBDF5 ;ALB/CJM - ENCOUNTER FORM (edit a form) ;11/16/92
;;3.0;AUTOMATED INFO COLLECTION SYS;**63**;APR 24, 1997;Build 80
;
;
;displays the form for editing using the list processor
;
;these variables should always be defined while editing a form
;IBFORM - contains the form description
INIT ;
;
Q:'$$FORMDSCR^IBDFU1C(.IBFORM)
D IDXFORM^IBDF5A()
Q
EXIT ;
K @VALMAR
Q
HDR ;the screen header, a ruler
S VALMHDR(1)=$$PADRIGHT^IBDFU("",4) ;VALMHDR(2)=VALMHDR(2)_0
F I=1:1:16 S VALMHDR(1)=VALMHDR(1)_$J(I,10)
Q
DELETE ;allows user to select a block for deletion
N IBBLK,IBVALMBG,TOP,BOT,IBD9,IBD10,IBDN,IBDX
S VALMBCK="R",IBVALMBG=$G(VALMBG)
S VALMBG=IBVALMBG
D FULL^VALM1
S IBBLK=$$SLCTBLK^IBDFU8(IBFORM,IOSL)
Q:'IBBLK
Q:'$$RUSURE^IBDFU5($P($G(^IBE(357.1,IBBLK,0)),"^"))
D TOPNBOT^IBDFU5(IBBLK,.TOP,.BOT)
S (IBD9,IBD10)=0
;Check to see if block is an ICD-9 or ICD-10 code block.
S IBDN="" F S IBDN=$O(^IBE(357.2,"C",IBBLK,IBDN)) Q:IBDN="" S IBDX=$P($G(^IBE(357.2,IBDN,0)),U,11) I IBDX?1.N S IBDX=$E($P($G(^IBE(357.6,IBDX,0)),U,1),1,30) D
.I '$O(^IBE(357.3,"C",IBDN,"")) Q ;Only log history fields if ICD-9 or ICD-10 codes are contained in block.
.I IBDX="DG SELECT ICD-9 DIAGNOSIS CODE",$O(^IBE(357.3,"C",IBDN,"")) S IBD9=1
.I IBDX="DG SELECT ICD-10 DIAGNOSIS COD",$O(^IBE(357.3,"C",IBDN,"")) S IBD10=1
D DLTBLK^IBDFU3(IBBLK,IBFORM,357.1)
;Now update history if block was an ICD-9 or ICD-10 block before block was deleted.
N IBDX
I IBD9 S IBDX=$$CSUPD357^IBDUTICD(IBFORM,1,"",$$NOW^XLFDT(),DUZ)
I IBD10 S IBDX=$$CSUPD357^IBDUTICD(IBFORM,30,"",$$NOW^XLFDT(),DUZ)
S VALMBCK="R"
D IDXFORM^IBDF5A(TOP,BOT)
Q
;
MOVE ;allows the user to select a block and move it
N IBBLK,NODE0,BLKWIDTH,BLKHT,STARTCOL,STARTROW,TOP1,BOT1,TOP2,BOT2
S VALMBCK="R"
;D FULL^VALM1
S IBBLK=$$SLCTBLK^IBDFU8(IBFORM,5)
I IBBLK D
.S NODE0=$G(^IBE(357.1,IBBLK,0))
.S BLKWIDTH=+$P(NODE0,"^",6),BLKHT=+$P(NODE0,"^",7),STARTCOL=+$P(NODE0,"^",5),STARTROW=+$P(NODE0,"^",4)
.S TOP1=STARTROW,BOT1=(TOP1+BLKHT)-1
.I STARTROW!(IBFORM("HT")>BLKHT) K DIR S DIR(0)="NA^1:"_(IBFORM("HT")-BLKHT+1)_":0",DIR("A")="Move the TOP MARGIN of the block to which row?: ",DIR("B")=STARTROW+1 D ^DIR K DIR Q:$D(DIRUT) S STARTROW=X-1
.I STARTCOL!(IBFORM("WIDTH")>BLKWIDTH) K DIR S DIR(0)="NA^1:"_(IBFORM("WIDTH")-BLKWIDTH+1)_":0",DIR("A")="Move the LEFT MARGIN of the block to which column?: ",DIR("B")=STARTCOL+1 D ^DIR K DIR Q:$D(DIRUT) S STARTCOL=X-1
.K DIE,DA S DIE=357.1,DA=IBBLK,DR=".04////^S X=STARTROW;.05////^S X=STARTCOL" D ^DIE K DIE,DA,DR
.S VALMBCK="R"
.D TOPNBOT^IBDFU5(IBBLK,.TOP2,.BOT2) S TOP1=$S(TOP1<TOP2:TOP1,1:TOP2) S BOT1=$S(BOT1>BOT2:BOT1,1:BOT2)
.D IDXFORM^IBDF5A(TOP1,BOT1)
.S VALMBG=STARTROW-7 S:VALMBG<1 VALMBG=1
Q
RESIZE ;allows user to select a block & re-size it
N IBBLK,BLKWIDTH,BLKHT,STARTCOL,STARTROW,TOP1,TOP2,BOT1,BOT2
S IBBLK=$$SLCTBLK^IBDFU8(IBFORM,5)
I IBBLK D
.D NOWSIZE S TOP1=STARTROW,BOT1=(TOP1+BLKHT)-1
.D NEWSIZE
.D TOPNBOT^IBDFU5(IBBLK,.TOP2,.BOT2) S TOP1=$S(TOP1<TOP2:TOP1,1:TOP2) S BOT1=$S(BOT1>BOT2:BOT1,1:BOT2)
.D IDXFORM^IBDF5A(TOP1,BOT1)
S VALMBCK="R"
Q
NOWSIZE ;what size is the block, and where does it start? returns BLKWIDTH,BLKHT,STARTROW,STARTCOL
N NODE0
S NODE0=$G(^IBE(357.1,IBBLK,0))
S BLKWIDTH=+$P(NODE0,"^",6),BLKHT=+$P(NODE0,"^",7),STARTCOL=+$P(NODE0,"^",5),STARTROW=+$P(NODE0,"^",4)
Q
NEWSIZE ;allows user to change the size of a block
K DIR S DIR(0)="NA^"_(STARTROW+1)_":"_(IBFORM("HT"))_":0",DIR("A")="Move the BOTTOM MARGIN of the block to which row?: ",DIR("B")=(STARTROW+BLKHT) D ^DIR K DIR Q:$D(DIRUT) S BLKHT=(X-STARTROW)
K DIR S DIR(0)="NA^"_(STARTCOL+1)_":"_IBFORM("WIDTH")_":0",DIR("A")="Move the RIGHT MARGIN of the block to which column?: ",DIR("B")=(STARTCOL+BLKWIDTH) D ^DIR K DIR Q:$D(DIRUT) S BLKWIDTH=(X-STARTCOL)
K DIE,DA S DIE=357.1,DA=IBBLK,DR=".06////^S X=BLKWIDTH;.07////^S X=BLKHT" D ^DIE K DIE,DA,DR
D UNCMPBLK^IBDF19(IBBLK)
Q
SHIFT ;allows the user to shift a group of blocks within a rectangular region on the form
D SHIFT^IBDF10("B")
D IDXFORM^IBDF5A()
S VALMBCK="R"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDF5 4168 printed Apr 09, 2024@20:54:38 Page 2
IBDF5 ;ALB/CJM - ENCOUNTER FORM (edit a form) ;11/16/92
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**63**;APR 24, 1997;Build 80
+2 ;
+3 ;
+4 ;displays the form for editing using the list processor
+5 ;
+6 ;these variables should always be defined while editing a form
+7 ;IBFORM - contains the form description
INIT ;
+1 ;
+2 if '$$FORMDSCR^IBDFU1C(.IBFORM)
QUIT
+3 DO IDXFORM^IBDF5A()
+4 QUIT
EXIT ;
+1 KILL @VALMAR
+2 QUIT
HDR ;the screen header, a ruler
+1 ;VALMHDR(2)=VALMHDR(2)_0
SET VALMHDR(1)=$$PADRIGHT^IBDFU("",4)
+2 FOR I=1:1:16
SET VALMHDR(1)=VALMHDR(1)_$JUSTIFY(I,10)
+3 QUIT
DELETE ;allows user to select a block for deletion
+1 NEW IBBLK,IBVALMBG,TOP,BOT,IBD9,IBD10,IBDN,IBDX
+2 SET VALMBCK="R"
SET IBVALMBG=$GET(VALMBG)
+3 SET VALMBG=IBVALMBG
+4 DO FULL^VALM1
+5 SET IBBLK=$$SLCTBLK^IBDFU8(IBFORM,IOSL)
+6 if 'IBBLK
QUIT
+7 if '$$RUSURE^IBDFU5($PIECE($GET(^IBE(357.1,IBBLK,0)),"^"))
QUIT
+8 DO TOPNBOT^IBDFU5(IBBLK,.TOP,.BOT)
+9 SET (IBD9,IBD10)=0
+10 ;Check to see if block is an ICD-9 or ICD-10 code block.
+11 SET IBDN=""
FOR
SET IBDN=$ORDER(^IBE(357.2,"C",IBBLK,IBDN))
if IBDN=""
QUIT
SET IBDX=$PIECE($GET(^IBE(357.2,IBDN,0)),U,11)
IF IBDX?1.N
SET IBDX=$EXTRACT($PIECE($GET(^IBE(357.6,IBDX,0)),U,1),1,30)
Begin DoDot:1
+12 ;Only log history fields if ICD-9 or ICD-10 codes are contained in block.
IF '$ORDER(^IBE(357.3,"C",IBDN,""))
QUIT
+13 IF IBDX="DG SELECT ICD-9 DIAGNOSIS CODE"
IF $ORDER(^IBE(357.3,"C",IBDN,""))
SET IBD9=1
+14 IF IBDX="DG SELECT ICD-10 DIAGNOSIS COD"
IF $ORDER(^IBE(357.3,"C",IBDN,""))
SET IBD10=1
End DoDot:1
+15 DO DLTBLK^IBDFU3(IBBLK,IBFORM,357.1)
+16 ;Now update history if block was an ICD-9 or ICD-10 block before block was deleted.
+17 NEW IBDX
+18 IF IBD9
SET IBDX=$$CSUPD357^IBDUTICD(IBFORM,1,"",$$NOW^XLFDT(),DUZ)
+19 IF IBD10
SET IBDX=$$CSUPD357^IBDUTICD(IBFORM,30,"",$$NOW^XLFDT(),DUZ)
+20 SET VALMBCK="R"
+21 DO IDXFORM^IBDF5A(TOP,BOT)
+22 QUIT
+23 ;
MOVE ;allows the user to select a block and move it
+1 NEW IBBLK,NODE0,BLKWIDTH,BLKHT,STARTCOL,STARTROW,TOP1,BOT1,TOP2,BOT2
+2 SET VALMBCK="R"
+3 ;D FULL^VALM1
+4 SET IBBLK=$$SLCTBLK^IBDFU8(IBFORM,5)
+5 IF IBBLK
Begin DoDot:1
+6 SET NODE0=$GET(^IBE(357.1,IBBLK,0))
+7 SET BLKWIDTH=+$PIECE(NODE0,"^",6)
SET BLKHT=+$PIECE(NODE0,"^",7)
SET STARTCOL=+$PIECE(NODE0,"^",5)
SET STARTROW=+$PIECE(NODE0,"^",4)
+8 SET TOP1=STARTROW
SET BOT1=(TOP1+BLKHT)-1
+9 IF STARTROW!(IBFORM("HT")>BLKHT)
KILL DIR
SET DIR(0)="NA^1:"_(IBFORM("HT")-BLKHT+1)_":0"
SET DIR("A")="Move the TOP MARGIN of the block to which row?: "
SET DIR("B")=STARTROW+1
DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
SET STARTROW=X-1
+10 IF STARTCOL!(IBFORM("WIDTH")>BLKWIDTH)
KILL DIR
SET DIR(0)="NA^1:"_(IBFORM("WIDTH")-BLKWIDTH+1)_":0"
SET DIR("A")="Move the LEFT MARGIN of the block to which column?: "
SET DIR("B")=STARTCOL+1
DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
SET STARTCOL=X-1
+11 KILL DIE,DA
SET DIE=357.1
SET DA=IBBLK
SET DR=".04////^S X=STARTROW;.05////^S X=STARTCOL"
DO ^DIE
KILL DIE,DA,DR
+12 SET VALMBCK="R"
+13 DO TOPNBOT^IBDFU5(IBBLK,.TOP2,.BOT2)
SET TOP1=$SELECT(TOP1<TOP2:TOP1,1:TOP2)
SET BOT1=$SELECT(BOT1>BOT2:BOT1,1:BOT2)
+14 DO IDXFORM^IBDF5A(TOP1,BOT1)
+15 SET VALMBG=STARTROW-7
if VALMBG<1
SET VALMBG=1
End DoDot:1
+16 QUIT
RESIZE ;allows user to select a block & re-size it
+1 NEW IBBLK,BLKWIDTH,BLKHT,STARTCOL,STARTROW,TOP1,TOP2,BOT1,BOT2
+2 SET IBBLK=$$SLCTBLK^IBDFU8(IBFORM,5)
+3 IF IBBLK
Begin DoDot:1
+4 DO NOWSIZE
SET TOP1=STARTROW
SET BOT1=(TOP1+BLKHT)-1
+5 DO NEWSIZE
+6 DO TOPNBOT^IBDFU5(IBBLK,.TOP2,.BOT2)
SET TOP1=$SELECT(TOP1<TOP2:TOP1,1:TOP2)
SET BOT1=$SELECT(BOT1>BOT2:BOT1,1:BOT2)
+7 DO IDXFORM^IBDF5A(TOP1,BOT1)
End DoDot:1
+8 SET VALMBCK="R"
+9 QUIT
NOWSIZE ;what size is the block, and where does it start? returns BLKWIDTH,BLKHT,STARTROW,STARTCOL
+1 NEW NODE0
+2 SET NODE0=$GET(^IBE(357.1,IBBLK,0))
+3 SET BLKWIDTH=+$PIECE(NODE0,"^",6)
SET BLKHT=+$PIECE(NODE0,"^",7)
SET STARTCOL=+$PIECE(NODE0,"^",5)
SET STARTROW=+$PIECE(NODE0,"^",4)
+4 QUIT
NEWSIZE ;allows user to change the size of a block
+1 KILL DIR
SET DIR(0)="NA^"_(STARTROW+1)_":"_(IBFORM("HT"))_":0"
SET DIR("A")="Move the BOTTOM MARGIN of the block to which row?: "
SET DIR("B")=(STARTROW+BLKHT)
DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
SET BLKHT=(X-STARTROW)
+2 KILL DIR
SET DIR(0)="NA^"_(STARTCOL+1)_":"_IBFORM("WIDTH")_":0"
SET DIR("A")="Move the RIGHT MARGIN of the block to which column?: "
SET DIR("B")=(STARTCOL+BLKWIDTH)
DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
SET BLKWIDTH=(X-STARTCOL)
+3 KILL DIE,DA
SET DIE=357.1
SET DA=IBBLK
SET DR=".06////^S X=BLKWIDTH;.07////^S X=BLKHT"
DO ^DIE
KILL DIE,DA,DR
+4 DO UNCMPBLK^IBDF19(IBBLK)
+5 QUIT
SHIFT ;allows the user to shift a group of blocks within a rectangular region on the form
+1 DO SHIFT^IBDF10("B")
+2 DO IDXFORM^IBDF5A()
+3 SET VALMBCK="R"
+4 QUIT
