IBDFC2A ;ALB/CJM - ENCOUNTER FORM - converts a form for scanning (cont'd);MAR 3, 1995
;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
;
BUBBLES(LIST) ;changes the marking areas to bubbles
;no conversion if there is no input interface for the data
;pass LIST array by reference
Q:'LIST("INPUT_RTN")
;
N SC,SCORDER,LARGEST,SZCHANGE,NODE,CNT,BUBBLE
S (SZCHANGE,LARGEST)=0
;
;find the marking area used for bubbles
S BUBBLE=$O(^IBE(357.91,"B","BUBBLE (use for scanning)",0)) Q:'BUBBLE
;
;make two lists of the subcolumns, one indexed by ien and the other by the order - also, keep track of the largest subcolumn - adjustments may have to be made to it
S SC=0 F S SC=$O(^IBE(357.2,LIST,2,SC)) Q:'SC S SC(SC)=$G(^IBE(357.2,LIST,2,SC,0)),SCORDER(+SC(SC))=SC I $P(SC(SC),"^",4)=1,$P(SC(SC),"^",3)>+LARGEST S LARGEST=$P(SC(SC),"^",3)_"^"_SC
;
;look for the marking area subcolumns
S SC=0 F S SC=$O(SC(SC)) Q:'SC I $P(SC(SC),"^",4)=2,$P(SC(SC),"^",6)'=BUBBLE,$P(SC(SC),"^",6) D
.;
.;don't underline the marking area
.S $P(SC(SC),"^",8)=1
.;
.N MARK
.S MARK=$P($G(^IBE(357.91,$P(SC(SC),"^",6),0)),"^",2)
.Q:MARK=""
.I (MARK="(A) (I)")!(MARK="(A) (I) (H)")!(MARK="(P) (S)") D
..;break this subcolumn in two
..N QUAL1,QUAL2,HDR1,HDR2
..I MARK["A" D
...S QUAL1=$O(^IBD(357.98,"B","ACTIVE",0)),QUAL2=$O(^IBD(357.98,"B","INACTIVE",0)),HDR1="A",HDR2="I"
..E D
...S QUAL1=$O(^IBD(357.98,"B","PRIMARY",0)),QUAL2=$O(^IBD(357.98,"B","SECONDARY",0)),HDR1="P",HDR2="S"
..F CNT=1:1 I '$D(^IBE(357.2,LIST,2,CNT)) Q
..;create a new subcolumn
..S NODE=SC(SC),$P(NODE,"^")=+SC(SC)+.5,$P(NODE,"^",2)=HDR2,$P(NODE,"^",9)=QUAL2,$P(NODE,"^",6)=BUBBLE,^IBE(357.2,LIST,2,CNT,0)=NODE,$P(^IBE(357.2,LIST,2,0),"^",4)=$P(^IBE(357.2,LIST,2,0),"^",4)+1,SC(CNT)=NODE,SCORDER(+NODE)=CNT
..;change the original subcolumn
..S NODE=SC(SC),$P(NODE,"^",2)=HDR1,$P(NODE,"^",9)=QUAL1,$P(NODE,"^",6)=BUBBLE,^IBE(357.2,LIST,2,SC,0)=NODE
..;
..;may have to make an adjustment
..S SZCHANGE=SZCHANGE+($L(LIST("SEP"))-1)
.;
.;just change the marking area to bubble
.E D
..S $P(^IBE(357.2,LIST,2,SC,0),"^",6)=BUBBLE
..S SZCHANGE=SZCHANGE+(3-$L(MARK))
..;
;
;adjust subcolumn size to make up for extra space required by bubbles - may truncate text
I SZCHANGE D
.N SLCTN,SUBCOL,ORDER,IEN,NEWSIZE,TEXT
.S SUBCOL=$P(LARGEST,"^",2)
.S NEWSIZE=$P(SC(SUBCOL),"^",3)-SZCHANGE
.S $P(SC(SUBCOL),"^",3)=NEWSIZE,^IBE(357.2,LIST,2,SUBCOL,0)=SC(SUBCOL)
.S ORDER=+SC(SUBCOL)
.S SLCTN=0 F S SLCTN=$O(^IBE(357.3,"C",LIST,SLCTN)) Q:'SLCTN S IEN=$O(^IBE(357.3,SLCTN,1,"B",ORDER,0)) Q:'IEN D
..S TEXT=$P($G(^IBE(357.3,SLCTN,1,IEN,0)),"^",2)
..I $L(TEXT)>NEWSIZE D WARNING^IBDFC2("IN THE LIST '"_LIST("NAME")_"' THE TEXT '"_TEXT_"' WILL BE TRUNCATED BY "_($L(TEXT)-NEWSIZE)_" CHARACTERS - MANUAL EDITING MAY BE REQUIRED")
;
;reorder the subcolumns
N IBSWT
S (CNT,SCORDER)=0
F S SCORDER=$O(SCORDER(SCORDER)) Q:'SCORDER S CNT=CNT+1 I SCORDER'=CNT D I $P(SC(SCORDER(SCORDER)),"^",4)=1 S IBSWT(SCORDER)=CNT
.K ^IBE(357.2,LIST,2,"B",SCORDER,SCORDER(SCORDER))
.S $P(^IBE(357.2,LIST,2,SCORDER(SCORDER),0),"^")=CNT,^IBE(357.2,LIST,2,"B",CNT,SCORDER(SCORDER))=""
.;make the change in the selection due to the reordering of the subcolumns
.;I $P(SC(SCORDER(SCORDER)),"^",4)=1 D SWITCH^IBDF9A(LIST,SCORDER,CNT)
D SWITCH^IBDF9A(LIST,.IBSWT)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFC2A 3404 printed Oct 16, 2024@18:52:47 Page 2
IBDFC2A ;ALB/CJM - ENCOUNTER FORM - converts a form for scanning (cont'd);MAR 3, 1995
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;;APR 24, 1997
+2 ;
BUBBLES(LIST) ;changes the marking areas to bubbles
+1 ;no conversion if there is no input interface for the data
+2 ;pass LIST array by reference
+3 if 'LIST("INPUT_RTN")
QUIT
+4 ;
+5 NEW SC,SCORDER,LARGEST,SZCHANGE,NODE,CNT,BUBBLE
+6 SET (SZCHANGE,LARGEST)=0
+7 ;
+8 ;find the marking area used for bubbles
+9 SET BUBBLE=$ORDER(^IBE(357.91,"B","BUBBLE (use for scanning)",0))
if 'BUBBLE
QUIT
+10 ;
+11 ;make two lists of the subcolumns, one indexed by ien and the other by the order - also, keep track of the largest subcolumn - adjustments may have to be made to it
+12 SET SC=0
FOR
SET SC=$ORDER(^IBE(357.2,LIST,2,SC))
if 'SC
QUIT
SET SC(SC)=$GET(^IBE(357.2,LIST,2,SC,0))
SET SCORDER(+SC(SC))=SC
IF $PIECE(SC(SC),"^",4)=1
IF $PIECE(SC(SC),"^",3)>+LARGEST
SET LARGEST=$PIECE(SC(SC),"^",3)_"^"_SC
+13 ;
+14 ;look for the marking area subcolumns
+15 SET SC=0
FOR
SET SC=$ORDER(SC(SC))
if 'SC
QUIT
IF $PIECE(SC(SC),"^",4)=2
IF $PIECE(SC(SC),"^",6)'=BUBBLE
IF $PIECE(SC(SC),"^",6)
Begin DoDot:1
+16 ;
+17 ;don't underline the marking area
+18 SET $PIECE(SC(SC),"^",8)=1
+19 ;
+20 NEW MARK
+21 SET MARK=$PIECE($GET(^IBE(357.91,$PIECE(SC(SC),"^",6),0)),"^",2)
+22 if MARK=""
QUIT
+23 IF (MARK="(A) (I)")!(MARK="(A) (I) (H)")!(MARK="(P) (S)")
Begin DoDot:2
+24 ;break this subcolumn in two
+25 NEW QUAL1,QUAL2,HDR1,HDR2
+26 IF MARK["A"
Begin DoDot:3
+27 SET QUAL1=$ORDER(^IBD(357.98,"B","ACTIVE",0))
SET QUAL2=$ORDER(^IBD(357.98,"B","INACTIVE",0))
SET HDR1="A"
SET HDR2="I"
End DoDot:3
+28 IF '$TEST
Begin DoDot:3
+29 SET QUAL1=$ORDER(^IBD(357.98,"B","PRIMARY",0))
SET QUAL2=$ORDER(^IBD(357.98,"B","SECONDARY",0))
SET HDR1="P"
SET HDR2="S"
End DoDot:3
+30 FOR CNT=1:1
IF '$DATA(^IBE(357.2,LIST,2,CNT))
QUIT
+31 ;create a new subcolumn
+32 SET NODE=SC(SC)
SET $PIECE(NODE,"^")=+SC(SC)+.5
SET $PIECE(NODE,"^",2)=HDR2
SET $PIECE(NODE,"^",9)=QUAL2
SET $PIECE(NODE,"^",6)=BUBBLE
SET ^IBE(357.2,LIST,2,CNT,0)=NODE
SET $PIECE(^IBE(357.2,LIST,2,0),"^",4)=$PIECE(^IBE(357.2,LIST,2,0),"^",4)+1
SET SC(CNT)=NODE
SET SCORDER(+NODE)=CNT
+33 ;change the original subcolumn
+34 SET NODE=SC(SC)
SET $PIECE(NODE,"^",2)=HDR1
SET $PIECE(NODE,"^",9)=QUAL1
SET $PIECE(NODE,"^",6)=BUBBLE
SET ^IBE(357.2,LIST,2,SC,0)=NODE
+35 ;
+36 ;may have to make an adjustment
+37 SET SZCHANGE=SZCHANGE+($LENGTH(LIST("SEP"))-1)
End DoDot:2
+38 ;
+39 ;just change the marking area to bubble
+40 IF '$TEST
Begin DoDot:2
+41 SET $PIECE(^IBE(357.2,LIST,2,SC,0),"^",6)=BUBBLE
+42 SET SZCHANGE=SZCHANGE+(3-$LENGTH(MARK))
+43 ;
End DoDot:2
End DoDot:1
+44 ;
+45 ;adjust subcolumn size to make up for extra space required by bubbles - may truncate text
+46 IF SZCHANGE
Begin DoDot:1
+47 NEW SLCTN,SUBCOL,ORDER,IEN,NEWSIZE,TEXT
+48 SET SUBCOL=$PIECE(LARGEST,"^",2)
+49 SET NEWSIZE=$PIECE(SC(SUBCOL),"^",3)-SZCHANGE
+50 SET $PIECE(SC(SUBCOL),"^",3)=NEWSIZE
SET ^IBE(357.2,LIST,2,SUBCOL,0)=SC(SUBCOL)
+51 SET ORDER=+SC(SUBCOL)
+52 SET SLCTN=0
FOR
SET SLCTN=$ORDER(^IBE(357.3,"C",LIST,SLCTN))
if 'SLCTN
QUIT
SET IEN=$ORDER(^IBE(357.3,SLCTN,1,"B",ORDER,0))
if 'IEN
QUIT
Begin DoDot:2
+53 SET TEXT=$PIECE($GET(^IBE(357.3,SLCTN,1,IEN,0)),"^",2)
+54 IF $LENGTH(TEXT)>NEWSIZE
DO WARNING^IBDFC2("IN THE LIST '"_LIST("NAME")_"' THE TEXT '"_TEXT_"' WILL BE TRUNCATED BY "_($LENGTH(TEXT)-NEWSIZE)_" CHARACTERS - MANUAL EDITING MAY BE REQUIRED")
End DoDot:2
End DoDot:1
+55 ;
+56 ;reorder the subcolumns
+57 NEW IBSWT
+58 SET (CNT,SCORDER)=0
+59 FOR
SET SCORDER=$ORDER(SCORDER(SCORDER))
if 'SCORDER
QUIT
SET CNT=CNT+1
IF SCORDER'=CNT
Begin DoDot:1
+60 KILL ^IBE(357.2,LIST,2,"B",SCORDER,SCORDER(SCORDER))
+61 SET $PIECE(^IBE(357.2,LIST,2,SCORDER(SCORDER),0),"^")=CNT
SET ^IBE(357.2,LIST,2,"B",CNT,SCORDER(SCORDER))=""
+62 ;make the change in the selection due to the reordering of the subcolumns
+63 ;I $P(SC(SCORDER(SCORDER)),"^",4)=1 D SWITCH^IBDF9A(LIST,SCORDER,CNT)
End DoDot:1
IF $PIECE(SC(SCORDER(SCORDER)),"^",4)=1
SET IBSWT(SCORDER)=CNT
+64 DO SWITCH^IBDF9A(LIST,.IBSWT)
+65 QUIT
