- IBDF10C ;ALB/CJM - ENCOUNTER FORM - (shift block contents - continued) ;APRIL 22,1993
- ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
- ;
- MAX(TYPE,WAY,MAX,TOP,BOTTOM,LEFT,RIGHT) ;returns the maximum allowable shift
- ;
- N VERT,AREASIZE,IBY,IBX,SIZE,NODE
- S VERT=$S("UD"[WAY:1,1:0)
- S AREASIZE=$S(VERT:$S(TYPE="B":IBFORM("HT"),1:IBBLK("H")),1:$S(TYPE="B":IBFORM("WIDTH"),1:IBBLK("W")))
- D @TYPE
- I TYPE'="B",IBBLK("BOX")=1 S MAX=MAX-1
- S:MAX<0 MAX=0
- Q MAX
- E ;
- D D
- D S
- D T
- D L
- D M
- D H
- Q
- D ;
- N SUB,FLD
- S FLD="" F S FLD=$O(^IBE(357.5,"C",IBBLK,FLD)) Q:'FLD D
- .S NODE=$G(^IBE(357.5,FLD,0)) Q:NODE=""
- .S IBY=$P(NODE,"^",11),IBX=$P(NODE,"^",10) I $$INRANGE^IBDF10A(IBX,IBY,TOP,BOTTOM,LEFT,RIGHT) D
- ..S SIZE=$S(VERT:$P(NODE,"^",12),1:$S($L($P(NODE,"^",6))>$P(NODE,"^",14):$L($P(NODE,"^",6)),1:$P(NODE,"^",14)))
- ..D COMPARE
- .S SUB=0 F S SUB=$O(^IBE(357.5,FLD,2,SUB)) Q:'SUB D
- ..S NODE=$G(^IBE(357.5,FLD,2,SUB,0)) Q:NODE=""
- ..S IBX=$P(NODE,"^",4),IBY=$P(NODE,"^",5) I $$INRANGE^IBDF10A(IBX,IBY,TOP,BOTTOM,LEFT,RIGHT) D
- ...S SIZE=$S(VERT:1,1:$L($P(NODE,"^",1)))
- ...D COMPARE
- ..S IBX=$P(NODE,"^",7),IBY=$P(NODE,"^",6) I $$INRANGE^IBDF10A(IBX,IBY,TOP,BOTTOM,LEFT,RIGHT) D
- ...S SIZE=$S(VERT:1,1:$P(NODE,"^",8))
- ...D COMPARE
- Q
- ;
- M ;shift multiple choice field
- N SUB,FLD
- S FLD="" F S FLD=$O(^IBE(357.93,"C",IBBLK,FLD)) Q:'FLD D
- .S NODE=$G(^IBE(357.93,FLD,0)) Q:NODE=""
- .S IBY=$P(NODE,"^",4),IBX=$P(NODE,"^",3) I $$INRANGE^IBDF10A(IBX,IBY,TOP,BOTTOM,LEFT,RIGHT) D
- ..S SIZE=$S(VERT:1,1:$L($P(NODE,"^",2)))
- ..D COMPARE
- .S SUB=0 F S SUB=$O(^IBE(357.93,FLD,1,SUB)) Q:'SUB D
- ..S NODE=$G(^IBE(357.93,FLD,1,SUB,0)) Q:NODE=""
- ..S IBX=$P(NODE,"^",2),IBY=$P(NODE,"^",3) I $$INRANGE^IBDF10A(IBX,IBY,TOP,BOTTOM,LEFT,RIGHT) D
- ...S SIZE=$S(VERT:1,1:$L($P(NODE,"^",1)))
- ...D COMPARE
- ..S IBX=$P(NODE,"^",6),IBY=$P(NODE,"^",7) I $$INRANGE^IBDF10A(IBX,IBY,TOP,BOTTOM,LEFT,RIGHT) D
- ...S SIZE=$S(VERT:1,1:3)
- ...D COMPARE
- Q
- ;
- H ;shift hand print fields
- N SUB,FLD
- S FLD="" F S FLD=$O(^IBE(359.94,"C",IBBLK,FLD)) Q:'FLD D
- .S NODE=$G(^IBE(359.94,FLD,0)) Q:NODE=""
- .S IBY=$P(NODE,"^",4),IBX=$P(NODE,"^",3) I $$INRANGE^IBDF10A(IBX,IBY,TOP,BOTTOM,LEFT,RIGHT) D
- ..I VERT S SIZE=2
- ..I 'VERT S SIZE=$L($P(NODE,"^",2))+1 S NODE=$G(^IBE(359.1,$P(NODE,"^",10),0)) S SIZE=SIZE+($P(NODE,"^",6)*$S(IBFORM("WIDTH")>96:4,1:3)) I $L($P(NODE,"^",11)) S SIZE=SIZE+(2*$L($P(NODE,"^",11)))
- ..D COMPARE
- Q
- ;
- S ;
- ;just let the user do what he wants - lists automatically resize themselves to fit the block
- Q
- T ;
- N TXT
- S TXT="" F S TXT=$O(^IBE(357.8,"C",IBBLK,TXT)) Q:'TXT D
- .S NODE=$G(^IBE(357.8,TXT,0)) Q:NODE=""
- .S IBY=$P(NODE,"^",4),IBX=$P(NODE,"^",3) I $$INRANGE^IBDF10A(IBX,IBY,TOP,BOTTOM,LEFT,RIGHT) D
- ..S SIZE=$S(VERT:$P(NODE,"^",6),1:$P(NODE,"^",5))
- ..D COMPARE
- Q
- L ;
- N LINE
- S LINE="" F S LINE=$O(^IBE(357.7,"C",IBBLK,LINE)) Q:'LINE D
- .S NODE=$G(^IBE(357.7,LINE,0)) Q:NODE=""
- .S IBY=$P(NODE,"^",3),IBX=$P(NODE,"^",2) I $$INRANGE^IBDF10A(IBX,IBY,TOP,BOTTOM,LEFT,RIGHT) D
- ..S SIZE=$S(((($P(NODE,"^",4)="V")&VERT)!(($P(NODE,"^",4)="H")&'VERT)):$P(NODE,"^",5),1:1)
- ..D COMPARE
- Q
- B ;
- N BLOCK
- S BLOCK="" F S BLOCK=$O(^IBE(357.1,"C",IBFORM,BLOCK)) Q:'BLOCK D
- .S NODE=$G(^IBE(357.1,BLOCK,0)) Q:NODE=""
- .S SIZE=$S(VERT:$P(NODE,"^",7),1:$P(NODE,"^",6)),IBX=$P(NODE,"^",5),IBY=$P(NODE,"^",4)
- .I $$INRANGE^IBDF10A(IBX,IBY,TOP,BOTTOM,LEFT,RIGHT) D COMPARE
- ;..I WAY="R" S:(IBFORM("WIDTH")-(IBX+WIDTH))<MAX MAX=(IBFORM("WIDTH")-(IBX+WIDTH)) Q
- ;..I WAY="L" S:IBX<MAX MAX=IBX Q
- ;..I WAY="D" S:(IBFORM("HT")-(IBY+HT))<MAX MAX=(IBFORM("HT")-(IBY+HT)) Q
- ;..I WAY="U" S:IBY<MAX MAX=IBY Q
- Q
- COMPARE ;
- I WAY="R" S:(AREASIZE-(IBX+SIZE))<MAX MAX=(AREASIZE-(IBX+SIZE)) Q
- I WAY="L" S:IBX<MAX MAX=IBX Q
- I WAY="D" S:(AREASIZE-(IBY+SIZE))<MAX MAX=(AREASIZE-(IBY+SIZE)) Q
- I WAY="U" S:IBY<MAX MAX=IBY Q
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDF10C 3915 printed Mar 13, 2025@21:55:41 Page 2
- IBDF10C ;ALB/CJM - ENCOUNTER FORM - (shift block contents - continued) ;APRIL 22,1993
- +1 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
- +2 ;
- MAX(TYPE,WAY,MAX,TOP,BOTTOM,LEFT,RIGHT) ;returns the maximum allowable shift
- +1 ;
- +2 NEW VERT,AREASIZE,IBY,IBX,SIZE,NODE
- +3 SET VERT=$SELECT("UD"[WAY:1,1:0)
- +4 SET AREASIZE=$SELECT(VERT:$SELECT(TYPE="B":IBFORM("HT"),1:IBBLK("H")),1:$SELECT(TYPE="B":IBFORM("WIDTH"),1:IBBLK("W")))
- +5 DO @TYPE
- +6 IF TYPE'="B"
- IF IBBLK("BOX")=1
- SET MAX=MAX-1
- +7 if MAX<0
- SET MAX=0
- +8 QUIT MAX
- E ;
- +1 DO D
- +2 DO S
- +3 DO T
- +4 DO L
- +5 DO M
- +6 DO H
- +7 QUIT
- D ;
- +1 NEW SUB,FLD
- +2 SET FLD=""
- FOR
- SET FLD=$ORDER(^IBE(357.5,"C",IBBLK,FLD))
- if 'FLD
- QUIT
- Begin DoDot:1
- +3 SET NODE=$GET(^IBE(357.5,FLD,0))
- if NODE=""
- QUIT
- +4 SET IBY=$PIECE(NODE,"^",11)
- SET IBX=$PIECE(NODE,"^",10)
- IF $$INRANGE^IBDF10A(IBX,IBY,TOP,BOTTOM,LEFT,RIGHT)
- Begin DoDot:2
- +5 SET SIZE=$SELECT(VERT:$PIECE(NODE,"^",12),1:$SELECT($LENGTH($PIECE(NODE,"^",6))>$PIECE(NODE,"^",14):$LENGTH($PIECE(NODE,"^",6)),1:$PIECE(NODE,"^",14)))
- +6 DO COMPARE
- End DoDot:2
- +7 SET SUB=0
- FOR
- SET SUB=$ORDER(^IBE(357.5,FLD,2,SUB))
- if 'SUB
- QUIT
- Begin DoDot:2
- +8 SET NODE=$GET(^IBE(357.5,FLD,2,SUB,0))
- if NODE=""
- QUIT
- +9 SET IBX=$PIECE(NODE,"^",4)
- SET IBY=$PIECE(NODE,"^",5)
- IF $$INRANGE^IBDF10A(IBX,IBY,TOP,BOTTOM,LEFT,RIGHT)
- Begin DoDot:3
- +10 SET SIZE=$SELECT(VERT:1,1:$LENGTH($PIECE(NODE,"^",1)))
- +11 DO COMPARE
- End DoDot:3
- +12 SET IBX=$PIECE(NODE,"^",7)
- SET IBY=$PIECE(NODE,"^",6)
- IF $$INRANGE^IBDF10A(IBX,IBY,TOP,BOTTOM,LEFT,RIGHT)
- Begin DoDot:3
- +13 SET SIZE=$SELECT(VERT:1,1:$PIECE(NODE,"^",8))
- +14 DO COMPARE
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +15 QUIT
- +16 ;
- M ;shift multiple choice field
- +1 NEW SUB,FLD
- +2 SET FLD=""
- FOR
- SET FLD=$ORDER(^IBE(357.93,"C",IBBLK,FLD))
- if 'FLD
- QUIT
- Begin DoDot:1
- +3 SET NODE=$GET(^IBE(357.93,FLD,0))
- if NODE=""
- QUIT
- +4 SET IBY=$PIECE(NODE,"^",4)
- SET IBX=$PIECE(NODE,"^",3)
- IF $$INRANGE^IBDF10A(IBX,IBY,TOP,BOTTOM,LEFT,RIGHT)
- Begin DoDot:2
- +5 SET SIZE=$SELECT(VERT:1,1:$LENGTH($PIECE(NODE,"^",2)))
- +6 DO COMPARE
- End DoDot:2
- +7 SET SUB=0
- FOR
- SET SUB=$ORDER(^IBE(357.93,FLD,1,SUB))
- if 'SUB
- QUIT
- Begin DoDot:2
- +8 SET NODE=$GET(^IBE(357.93,FLD,1,SUB,0))
- if NODE=""
- QUIT
- +9 SET IBX=$PIECE(NODE,"^",2)
- SET IBY=$PIECE(NODE,"^",3)
- IF $$INRANGE^IBDF10A(IBX,IBY,TOP,BOTTOM,LEFT,RIGHT)
- Begin DoDot:3
- +10 SET SIZE=$SELECT(VERT:1,1:$LENGTH($PIECE(NODE,"^",1)))
- +11 DO COMPARE
- End DoDot:3
- +12 SET IBX=$PIECE(NODE,"^",6)
- SET IBY=$PIECE(NODE,"^",7)
- IF $$INRANGE^IBDF10A(IBX,IBY,TOP,BOTTOM,LEFT,RIGHT)
- Begin DoDot:3
- +13 SET SIZE=$SELECT(VERT:1,1:3)
- +14 DO COMPARE
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +15 QUIT
- +16 ;
- H ;shift hand print fields
- +1 NEW SUB,FLD
- +2 SET FLD=""
- FOR
- SET FLD=$ORDER(^IBE(359.94,"C",IBBLK,FLD))
- if 'FLD
- QUIT
- Begin DoDot:1
- +3 SET NODE=$GET(^IBE(359.94,FLD,0))
- if NODE=""
- QUIT
- +4 SET IBY=$PIECE(NODE,"^",4)
- SET IBX=$PIECE(NODE,"^",3)
- IF $$INRANGE^IBDF10A(IBX,IBY,TOP,BOTTOM,LEFT,RIGHT)
- Begin DoDot:2
- +5 IF VERT
- SET SIZE=2
- +6 IF 'VERT
- SET SIZE=$LENGTH($PIECE(NODE,"^",2))+1
- SET NODE=$GET(^IBE(359.1,$PIECE(NODE,"^",10),0))
- SET SIZE=SIZE+($PIECE(NODE,"^",6)*$SELECT(IBFORM("WIDTH")>96:4,1:3))
- IF $LENGTH($PIECE(NODE,"^",11))
- SET SIZE=SIZE+(2*$LENGTH($PIECE(NODE,"^",11)))
- +7 DO COMPARE
- End DoDot:2
- End DoDot:1
- +8 QUIT
- +9 ;
- S ;
- +1 ;just let the user do what he wants - lists automatically resize themselves to fit the block
- +2 QUIT
- T ;
- +1 NEW TXT
- +2 SET TXT=""
- FOR
- SET TXT=$ORDER(^IBE(357.8,"C",IBBLK,TXT))
- if 'TXT
- QUIT
- Begin DoDot:1
- +3 SET NODE=$GET(^IBE(357.8,TXT,0))
- if NODE=""
- QUIT
- +4 SET IBY=$PIECE(NODE,"^",4)
- SET IBX=$PIECE(NODE,"^",3)
- IF $$INRANGE^IBDF10A(IBX,IBY,TOP,BOTTOM,LEFT,RIGHT)
- Begin DoDot:2
- +5 SET SIZE=$SELECT(VERT:$PIECE(NODE,"^",6),1:$PIECE(NODE,"^",5))
- +6 DO COMPARE
- End DoDot:2
- End DoDot:1
- +7 QUIT
- L ;
- +1 NEW LINE
- +2 SET LINE=""
- FOR
- SET LINE=$ORDER(^IBE(357.7,"C",IBBLK,LINE))
- if 'LINE
- QUIT
- Begin DoDot:1
- +3 SET NODE=$GET(^IBE(357.7,LINE,0))
- if NODE=""
- QUIT
- +4 SET IBY=$PIECE(NODE,"^",3)
- SET IBX=$PIECE(NODE,"^",2)
- IF $$INRANGE^IBDF10A(IBX,IBY,TOP,BOTTOM,LEFT,RIGHT)
- Begin DoDot:2
- +5 SET SIZE=$SELECT(((($PIECE(NODE,"^",4)="V")&VERT)!(($PIECE(NODE,"^",4)="H")&'VERT)):$PIECE(NODE,"^",5),1:1)
- +6 DO COMPARE
- End DoDot:2
- End DoDot:1
- +7 QUIT
- B ;
- +1 NEW BLOCK
- +2 SET BLOCK=""
- FOR
- SET BLOCK=$ORDER(^IBE(357.1,"C",IBFORM,BLOCK))
- if 'BLOCK
- QUIT
- Begin DoDot:1
- +3 SET NODE=$GET(^IBE(357.1,BLOCK,0))
- if NODE=""
- QUIT
- +4 SET SIZE=$SELECT(VERT:$PIECE(NODE,"^",7),1:$PIECE(NODE,"^",6))
- SET IBX=$PIECE(NODE,"^",5)
- SET IBY=$PIECE(NODE,"^",4)
- +5 IF $$INRANGE^IBDF10A(IBX,IBY,TOP,BOTTOM,LEFT,RIGHT)
- DO COMPARE
- End DoDot:1
- +6 ;..I WAY="R" S:(IBFORM("WIDTH")-(IBX+WIDTH))<MAX MAX=(IBFORM("WIDTH")-(IBX+WIDTH)) Q
- +7 ;..I WAY="L" S:IBX<MAX MAX=IBX Q
- +8 ;..I WAY="D" S:(IBFORM("HT")-(IBY+HT))<MAX MAX=(IBFORM("HT")-(IBY+HT)) Q
- +9 ;..I WAY="U" S:IBY<MAX MAX=IBY Q
- +10 QUIT
- COMPARE ;
- +1 IF WAY="R"
- if (AREASIZE-(IBX+SIZE))<MAX
- SET MAX=(AREASIZE-(IBX+SIZE))
- QUIT
- +2 IF WAY="L"
- if IBX<MAX
- SET MAX=IBX
- QUIT
- +3 IF WAY="D"
- if (AREASIZE-(IBY+SIZE))<MAX
- SET MAX=(AREASIZE-(IBY+SIZE))
- QUIT
- +4 IF WAY="U"
- if IBY<MAX
- SET MAX=IBY
- QUIT
- +5 QUIT
