- 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 Feb 19, 2025@00:17:03 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
