- 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
- 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
