IBDF10B ;ALB/CJM - ENCOUNTER FORM - (shifting selection lists);3/29/93
;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
LSTS(WAY,AMOUNT,TOP,BOTTOM,LEFT,RIGHT) ;shifts all of the selection lists in IBBLK falling within the range START->END by AMOUNT - if END="" range extends all the way out
;WAY="D" for down, "U" for up, "L" for left, "R" for right
N SUB,NODE,POS,LIST,PIECE,VERT,IBX,IBY,COL
S VERT=$S("UD"[WAY:1,1:0)
;shifts to the left or up are negative
S:"UL"[WAY AMOUNT=AMOUNT*(-1)
;must make sure there is at least one column defined with the row and column specified
S LIST="" F S LIST=$O(^IBE(357.2,"C",IBBLK,LIST)) Q:'LIST D
.S COL=$O(^IBE(357.2,LIST,1,"B","")) I COL S SUB=$O(^IBE(357.2,LIST,1,"B",COL,0))
.S:'$G(SUB) SUB=$$ADDCOL(LIST) ;if there is no column then one must be added, otherwise positioning works through defaults
.Q:'SUB
.S NODE=$G(^IBE(357.2,LIST,1,SUB,0))
.I "DU"[WAY S POS=$P(NODE,"^",2) I POS="" S POS=$S(IBBLK("BOX")=1:1,1:0),POS=POS+$S(IBBLK("HDR")="":0,1:2) S $P(^IBE(357.2,LIST,1,SUB,0),"^",2)=POS
.I "RL"[WAY S POS=$P(NODE,"^",3) I POS="" S POS=0,$P(^IBE(357.2,LIST,1,SUB,0),"^",3)=POS
.;now loop through all of the columns, shifting the position of each
.S SUB=0 F S SUB=$O(^IBE(357.2,LIST,1,SUB)) Q:'SUB D
..S NODE=$G(^IBE(357.2,LIST,1,SUB,0)) Q:NODE=""
..S PIECE=$S(VERT:2,1:3),POS=$P(NODE,"^",PIECE),IBY=+$P(NODE,"^",2),IBX=+$P(NODE,"^",3) I POS=+POS,$$INRANGE^IBDF10A(IBX,IBY,TOP,BOTTOM,LEFT,RIGHT) S $P(^IBE(357.2,LIST,1,SUB,0),"^",PIECE)=$S(POS+AMOUNT<0:0,1:POS+AMOUNT)
Q
ADDCOL(LIST) ;adds a column to the selection list, which has none
S ^IBE(357.2,LIST,1,0)="^357.21I^1^1",^(1,0)="1^^^"
K DIK,DA S DIK="^IBE(357.2,"_LIST_",1,",DA(1)=LIST,DA=1 D IX1^DIK K DIK,DA
Q 1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDF10B 1764 printed Oct 16, 2024@18:51:23 Page 2
IBDF10B ;ALB/CJM - ENCOUNTER FORM - (shifting selection lists);3/29/93
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
LSTS(WAY,AMOUNT,TOP,BOTTOM,LEFT,RIGHT) ;shifts all of the selection lists in IBBLK falling within the range START->END by AMOUNT - if END="" range extends all the way out
+1 ;WAY="D" for down, "U" for up, "L" for left, "R" for right
+2 NEW SUB,NODE,POS,LIST,PIECE,VERT,IBX,IBY,COL
+3 SET VERT=$SELECT("UD"[WAY:1,1:0)
+4 ;shifts to the left or up are negative
+5 if "UL"[WAY
SET AMOUNT=AMOUNT*(-1)
+6 ;must make sure there is at least one column defined with the row and column specified
+7 SET LIST=""
FOR
SET LIST=$ORDER(^IBE(357.2,"C",IBBLK,LIST))
if 'LIST
QUIT
Begin DoDot:1
+8 SET COL=$ORDER(^IBE(357.2,LIST,1,"B",""))
IF COL
SET SUB=$ORDER(^IBE(357.2,LIST,1,"B",COL,0))
+9 ;if there is no column then one must be added, otherwise positioning works through defaults
if '$GET(SUB)
SET SUB=$$ADDCOL(LIST)
+10 if 'SUB
QUIT
+11 SET NODE=$GET(^IBE(357.2,LIST,1,SUB,0))
+12 IF "DU"[WAY
SET POS=$PIECE(NODE,"^",2)
IF POS=""
SET POS=$SELECT(IBBLK("BOX")=1:1,1:0)
SET POS=POS+$SELECT(IBBLK("HDR")="":0,1:2)
SET $PIECE(^IBE(357.2,LIST,1,SUB,0),"^",2)=POS
+13 IF "RL"[WAY
SET POS=$PIECE(NODE,"^",3)
IF POS=""
SET POS=0
SET $PIECE(^IBE(357.2,LIST,1,SUB,0),"^",3)=POS
+14 ;now loop through all of the columns, shifting the position of each
+15 SET SUB=0
FOR
SET SUB=$ORDER(^IBE(357.2,LIST,1,SUB))
if 'SUB
QUIT
Begin DoDot:2
+16 SET NODE=$GET(^IBE(357.2,LIST,1,SUB,0))
if NODE=""
QUIT
+17 SET PIECE=$SELECT(VERT:2,1:3)
SET POS=$PIECE(NODE,"^",PIECE)
SET IBY=+$PIECE(NODE,"^",2)
SET IBX=+$PIECE(NODE,"^",3)
IF POS=+POS
IF $$INRANGE^IBDF10A(IBX,IBY,TOP,BOTTOM,LEFT,RIGHT)
SET $PIECE(^IBE(357.2,LIST,1,SUB,0),"^",PIECE)=$SELECT(POS+AMOUNT<0:0,1:POS+AMOUNT)
End DoDot:2
End DoDot:1
+18 QUIT
ADDCOL(LIST) ;adds a column to the selection list, which has none
+1 SET ^IBE(357.2,LIST,1,0)="^357.21I^1^1"
SET ^(1,0)="1^^^"
+2 KILL DIK,DA
SET DIK="^IBE(357.2,"_LIST_",1,"
SET DA(1)=LIST
SET DA=1
DO IX1^DIK
KILL DIK,DA
+3 QUIT 1
