IBDF2D3 ;ALB/CJM - ENCOUNTER FORM - WRITE SELECTION LIST (cont'd) ;NOV 16,1992
;;3.0;AUTOMATED INFO COLLECTION SYS;**38**;APR 24, 1997
;
DISPLAY(SLCTN,COL,HEADER,SUBHDR) ;writes the selection to the list
N J,K,DA,ENTRY,VALUE,TYPE,UNDRLINE,OFFSET,LEN,FIRST,IBROW,IBCOL,BBBLS,ID,DISPLAY,NODE,SUB,WRAP,QTY,ND2
S UNDRLINE=$S(IBLIST("ULSLCTNS"):"U",1:"")
S FIRST=1,(ID,HEADER,DISPLAY,NODE)=""
;
;get the 0 node of the selection & the selection identifier
I SLCTN S:IBLIST("DYNAMIC") NODE=$G(@LOCATION@(SLCTN)) S:'IBLIST("DYNAMIC") NODE=$G(^IBE(357.3,SLCTN,0)),ND2=$G(^IBE(357.3,SLCTN,2)) S ID=$P(NODE,"^")
;
;if a place holder, determine its use as a subheader - dynamic lists don't have place holders
I 'IBLIST("DYNAMIC") D
.S QTY=$P(NODE,"^",9)
.I $P(NODE,"^",2) D
..;turn of the use of any prior subhdr if it was used
..I $P(NODE,"^",8) S SUBHDR=""
..;determine if this is to be used as a subheader
..S $P(NODE,"^",6)=$P(NODE,"^",6)
..I $P(NODE,"^",7),$P(NODE,"^",6)]"" S SUBHDR=SUBHDR_" "_$$STRIP^IBDFU($P(NODE,"^",6))
;
;if place holder with text,just print the text and quit
I 'IBLIST("DYNAMIC"),$P(NODE,"^",2),$P(NODE,"^",6)]"" D Q
.I IBLIST("ULSLCTNS") D
..D DRWSTR^IBDFU($$Y^IBDF2D,($$X^IBDF2D)+LINE,$P(IBLIST("SEP"),"|",2)_$P(NODE,"^",6),"U",CWIDTH-(2*LINE))
..I NEEDUPR D DRWSTR^IBDFU(($$Y^IBDF2D)-1,($$X^IBDF2D)+LINE,"","U",CWIDTH-(2*LINE)) S NEEDUPR=0
.E D DRWSTR^IBDFU($$Y^IBDF2D,($$X^IBDF2D)+$L(IBLIST("SEP2"))+LINE,$P(NODE,"^",6))
.D DECREASE^IBDF2D(.COL)
;
;don't draw bubbles for place holders
I 'IBLIST("DYNAMIC"),$P(NODE,"^",2) N DRWBBL S DRWBBL=0
;
I SLCTN,(IBLIST("DYNAMIC")!('$P(NODE,"^",2))) S CNT=CNT+1
;
I 'IBFORM("COMPILED") I 'SLCTN,IBLIST("DYNAMIC") D
.S CNT=CNT+1
.S DISPLAY="#"_CNT
.S ID=""
;
F K=1:1:(+IBLIST("BTWN")+1) D Q:COL("ROWSLEFT")<1
.S ENTRY=""
.S OFFSET=LINE
.F J=1-IBLIST("SC0"):1:8 S TYPE=IBLIST("SCTYPE",J) D:TYPE'=""
..;S VALUE=""
..S VALUE=$S(K=2:$G(WRAP(J)),1:"")
..I TYPE=1,K'>1,SLCTN D S:(ID]"")&IBLIST("SCPIECE",J) DISPLAY=DISPLAY_$S(DISPLAY="":"",1:" :: ")_$E(VALUE,1,IBLIST("SCW",J)*(1+$S(IBLIST("BTWN"):1,1:0))) I IBLIST("BTWN"),$L(VALUE)>IBLIST("SCW",J) D WRAP
...I IBLIST("SCPIECE",J)=0 S:SLCTN&(IBLIST("DYNAMIC")!('$P(NODE,"^",2))) VALUE="#"_CNT Q
...I 'IBLIST("DYNAMIC") S DA=$O(^IBE(357.3,SLCTN,1,"B",J,"")) S:DA VALUE=$P($G(^IBE(357.3,SLCTN,1,DA,0)),"^",2) Q
...;dynamic lists
...S SUB=$$DATANODE^IBDFU1B(IBLIST("RTN"),IBLIST("SCPIECE",J))
...I SUB]"" S VALUE=$P($G(@IBLIST("DATA_LOCATION")@(SUB,SLCTN)),"^",IBLIST("SCPIECE",J))
...E S VALUE=$P(NODE,"^",IBLIST("SCPIECE",J))
...;
..S:TYPE=2 VALUE=$S(K'>1:IBLIST("SCSYMBOL",J),1:$J("",IBLIST("SCW",J)))
..;I TYPE=1 I SLCTN,ID]"",K'>1,IBLIST("SCPIECE",J) S DISPLAY=DISPLAY_$S(DISPLAY="":"",1:" :: ")_$E(VALUE,1,(IBLIST("SCW",J))
..S:TYPE=1 VALUE=$$PADRIGHT^IBDFU(VALUE,IBLIST("SCW",J))
..I TYPE=2 I IBLIST("ROUTINE",J)]"",K'>1,DRWBBL S IBCOL=($$X^IBDF2D)+OFFSET+$L(IBLIST("SEP2"))+$L(ENTRY)+((IBLIST("SCW",J)-3)\2),IBROW=$$Y^IBDF2D+$S(IBLIST("BTWN"):.5,1:0),BBBLS(IBCOL)=J
..I (TYPE=1)!('IBLIST("NOUL",J))!(K'=(+IBLIST("BTWN")+1))!(UNDRLINE'="U") D
...S ENTRY=ENTRY_IBLIST("SEP2")_VALUE_IBLIST("SEP1")
...S FIRST=0
..E D
...S NEEDUPR=1
...S LEN=$S(FIRST:0,1:$L(ENTRY)-LINE)
...S ENTRY=ENTRY_IBLIST("SEP2")_VALUE_IBLIST("SEP1")
...I OFFSET+$L(ENTRY)=CWIDTH S ENTRY=$E(ENTRY,1,$L(ENTRY)-LINE)
...D DRWSTR^IBDFU($$Y^IBDF2D,($$X^IBDF2D)+OFFSET,ENTRY,"U",LEN)
...S OFFSET=OFFSET+$L(ENTRY),ENTRY="",FIRST=1
.I ENTRY'="" S ENTRY=$E(ENTRY,1,$L(ENTRY)-$L(IBLIST("SEP1"))) D DRWSTR^IBDFU($$Y^IBDF2D,($$X^IBDF2D)+OFFSET,ENTRY,$S(K'=(+IBLIST("BTWN")+1):"",1:UNDRLINE),$L(ENTRY)+$L(IBLIST("SEP2")))
.D DECREASE^IBDF2D(.COL)
;
;Writting bubbles to form tracking? Is the form NOT yet compiled? Otherwise, don't need to do anything with the bubbles
I (TRACKBBL)!('IBFORM("COMPILED")) S IBCOL="" F S IBCOL=$O(BBBLS(IBCOL)) Q:IBCOL="" S J=BBBLS(IBCOL) I IBLIST("ROUTINE",J)="BUBBLE" D
.;
.D:'TRACKBBL DRWBBL^IBDFM1(IBROW,IBCOL,IBLIST("INPUT_RTN"),ID,IBLIST("NAME"),"S"_IBLIST_"("_J,IBLIST("RULE",J),DISPLAY,HEADER,IBLIST("QLFR",J),IBLIST("DYNAMIC"),CNT,SUBHDR,$G(QTY),$G(ND2),$G(SLCTN))
.D:TRACKBBL TRACKBBL^IBDFM1("S"_IBLIST_"("_J,CNT,IBLIST("QLFR",J),IBLIST("INPUT_RTN"),DISPLAY,ID)
Q
;
WRAP ;
Q:IBLIST("SCW",J)<8
N FOUND,AT,I,CHAR S FOUND=0
S AT=IBLIST("SCW",J)+2
F I=0:1:IBLIST("SCW",J)\4 S AT=AT-1,CHAR=$E(VALUE,AT) I " /\-:;"[CHAR S FOUND=1 Q
I FOUND D
.S WRAP(J)=$E(VALUE,AT+$S(" -"[CHAR:1,1:0),AT+IBLIST("SCW",J))
.F I=1:1:IBLIST("SCW",J) I $E(WRAP(J),I)'=" " D Q
..I I>1 S WRAP(J)=$E(WRAP(J),I,$L(WRAP(J)))
.S VALUE=$E(VALUE,1,AT-1)
E S WRAP(J)=$E(VALUE,IBLIST("SCW",J),2*IBLIST("SCW",J)-1),VALUE=$E(VALUE,1,IBLIST("SCW",J)-1)_"-"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDF2D3 4816 printed Dec 13, 2024@02:51:19 Page 2
IBDF2D3 ;ALB/CJM - ENCOUNTER FORM - WRITE SELECTION LIST (cont'd) ;NOV 16,1992
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**38**;APR 24, 1997
+2 ;
DISPLAY(SLCTN,COL,HEADER,SUBHDR) ;writes the selection to the list
+1 NEW J,K,DA,ENTRY,VALUE,TYPE,UNDRLINE,OFFSET,LEN,FIRST,IBROW,IBCOL,BBBLS,ID,DISPLAY,NODE,SUB,WRAP,QTY,ND2
+2 SET UNDRLINE=$SELECT(IBLIST("ULSLCTNS"):"U",1:"")
+3 SET FIRST=1
SET (ID,HEADER,DISPLAY,NODE)=""
+4 ;
+5 ;get the 0 node of the selection & the selection identifier
+6 IF SLCTN
if IBLIST("DYNAMIC")
SET NODE=$GET(@LOCATION@(SLCTN))
if 'IBLIST("DYNAMIC")
SET NODE=$GET(^IBE(357.3,SLCTN,0))
SET ND2=$GET(^IBE(357.3,SLCTN,2))
SET ID=$PIECE(NODE,"^")
+7 ;
+8 ;if a place holder, determine its use as a subheader - dynamic lists don't have place holders
+9 IF 'IBLIST("DYNAMIC")
Begin DoDot:1
+10 SET QTY=$PIECE(NODE,"^",9)
+11 IF $PIECE(NODE,"^",2)
Begin DoDot:2
+12 ;turn of the use of any prior subhdr if it was used
+13 IF $PIECE(NODE,"^",8)
SET SUBHDR=""
+14 ;determine if this is to be used as a subheader
+15 SET $PIECE(NODE,"^",6)=$PIECE(NODE,"^",6)
+16 IF $PIECE(NODE,"^",7)
IF $PIECE(NODE,"^",6)]""
SET SUBHDR=SUBHDR_" "_$$STRIP^IBDFU($PIECE(NODE,"^",6))
End DoDot:2
End DoDot:1
+17 ;
+18 ;if place holder with text,just print the text and quit
+19 IF 'IBLIST("DYNAMIC")
IF $PIECE(NODE,"^",2)
IF $PIECE(NODE,"^",6)]""
Begin DoDot:1
+20 IF IBLIST("ULSLCTNS")
Begin DoDot:2
+21 DO DRWSTR^IBDFU($$Y^IBDF2D,($$X^IBDF2D)+LINE,$PIECE(IBLIST("SEP"),"|",2)_$PIECE(NODE,"^",6),"U",CWIDTH-(2*LINE))
+22 IF NEEDUPR
DO DRWSTR^IBDFU(($$Y^IBDF2D)-1,($$X^IBDF2D)+LINE,"","U",CWIDTH-(2*LINE))
SET NEEDUPR=0
End DoDot:2
+23 IF '$TEST
DO DRWSTR^IBDFU($$Y^IBDF2D,($$X^IBDF2D)+$L(IBLIST("SEP2"))+LINE,$PIECE(NODE,"^",6))
+24 DO DECREASE^IBDF2D(.COL)
End DoDot:1
QUIT
+25 ;
+26 ;don't draw bubbles for place holders
+27 IF 'IBLIST("DYNAMIC")
IF $PIECE(NODE,"^",2)
NEW DRWBBL
SET DRWBBL=0
+28 ;
+29 IF SLCTN
IF (IBLIST("DYNAMIC")!('$PIECE(NODE,"^",2)))
SET CNT=CNT+1
+30 ;
+31 IF 'IBFORM("COMPILED")
IF 'SLCTN
IF IBLIST("DYNAMIC")
Begin DoDot:1
+32 SET CNT=CNT+1
+33 SET DISPLAY="#"_CNT
+34 SET ID=""
End DoDot:1
+35 ;
+36 FOR K=1:1:(+IBLIST("BTWN")+1)
Begin DoDot:1
+37 SET ENTRY=""
+38 SET OFFSET=LINE
+39 FOR J=1-IBLIST("SC0"):1:8
SET TYPE=IBLIST("SCTYPE",J)
if TYPE'=""
Begin DoDot:2
+40 ;S VALUE=""
+41 SET VALUE=$SELECT(K=2:$GET(WRAP(J)),1:"")
+42 IF TYPE=1
IF K'>1
IF SLCTN
Begin DoDot:3
+43 IF IBLIST("SCPIECE",J)=0
if SLCTN&(IBLIST("DYNAMIC")!('$PIECE(NODE,"^",2)))
SET VALUE="#"_CNT
QUIT
+44 IF 'IBLIST("DYNAMIC")
SET DA=$ORDER(^IBE(357.3,SLCTN,1,"B",J,""))
if DA
SET VALUE=$PIECE($GET(^IBE(357.3,SLCTN,1,DA,0)),"^",2)
QUIT
+45 ;dynamic lists
+46 SET SUB=$$DATANODE^IBDFU1B(IBLIST("RTN"),IBLIST("SCPIECE",J))
+47 IF SUB]""
SET VALUE=$PIECE($GET(@IBLIST("DATA_LOCATION")@(SUB,SLCTN)),"^",IBLIST("SCPIECE",J))
+48 IF '$TEST
SET VALUE=$PIECE(NODE,"^",IBLIST("SCPIECE",J))
+49 ;
End DoDot:3
if (ID]"")&IBLIST("SCPIECE",J)
SET DISPLAY=DISPLAY_$SELECT(DISPLAY="":"",1:" :: ")_$EXTRACT(VALUE,1,IBLIST("SCW",J)*(1+$SELECT(IBLIST("BTWN"):1,1:0)))
IF IBLIST("BTWN")
IF $LENGTH(VALUE)>IBLIST("SCW",J)
DO WRAP
+50 if TYPE=2
SET VALUE=$SELECT(K'>1:IBLIST("SCSYMBOL",J),1:$JUSTIFY("",IBLIST("SCW",J)))
+51 ;I TYPE=1 I SLCTN,ID]"",K'>1,IBLIST("SCPIECE",J) S DISPLAY=DISPLAY_$S(DISPLAY="":"",1:" :: ")_$E(VALUE,1,(IBLIST("SCW",J))
+52 if TYPE=1
SET VALUE=$$PADRIGHT^IBDFU(VALUE,IBLIST("SCW",J))
+53 IF TYPE=2
IF IBLIST("ROUTINE",J)]""
IF K'>1
IF DRWBBL
SET IBCOL=($$X^IBDF2D)+OFFSET+$L(IBLIST("SEP2"))+$LENGTH(ENTRY)+((IBLIST("SCW",J)-3)\2)
SET IBROW=$$Y^IBDF2D+$S(IBLIST("BTWN"):.5,1:0)
SET BBBLS(IBCOL)=J
+54 IF (TYPE=1)!('IBLIST("NOUL",J))!(K'=(+IBLIST("BTWN")+1))!(UNDRLINE'="U")
Begin DoDot:3
+55 SET ENTRY=ENTRY_IBLIST("SEP2")_VALUE_IBLIST("SEP1")
+56 SET FIRST=0
End DoDot:3
+57 IF '$TEST
Begin DoDot:3
+58 SET NEEDUPR=1
+59 SET LEN=$SELECT(FIRST:0,1:$LENGTH(ENTRY)-LINE)
+60 SET ENTRY=ENTRY_IBLIST("SEP2")_VALUE_IBLIST("SEP1")
+61 IF OFFSET+$LENGTH(ENTRY)=CWIDTH
SET ENTRY=$EXTRACT(ENTRY,1,$LENGTH(ENTRY)-LINE)
+62 DO DRWSTR^IBDFU($$Y^IBDF2D,($$X^IBDF2D)+OFFSET,ENTRY,"U",LEN)
+63 SET OFFSET=OFFSET+$LENGTH(ENTRY)
SET ENTRY=""
SET FIRST=1
End DoDot:3
End DoDot:2
+64 IF ENTRY'=""
SET ENTRY=$EXTRACT(ENTRY,1,$LENGTH(ENTRY)-$LENGTH(IBLIST("SEP1")))
DO DRWSTR^IBDFU($$Y^IBDF2D,($$X^IBDF2D)+OFFSET,ENTRY,$SELECT(K'=(+IBLIST("BTWN")+1):"",1:UNDRLINE),$LENGTH(ENTRY)+$LENGTH(IBLIST("SEP2")))
+65 DO DECREASE^IBDF2D(.COL)
End DoDot:1
if COL("ROWSLEFT")<1
QUIT
+66 ;
+67 ;Writting bubbles to form tracking? Is the form NOT yet compiled? Otherwise, don't need to do anything with the bubbles
+68 IF (TRACKBBL)!('IBFORM("COMPILED"))
SET IBCOL=""
FOR
SET IBCOL=$ORDER(BBBLS(IBCOL))
if IBCOL=""
QUIT
SET J=BBBLS(IBCOL)
IF IBLIST("ROUTINE",J)="BUBBLE"
Begin DoDot:1
+69 ;
+70 if 'TRACKBBL
DO DRWBBL^IBDFM1(IBROW,IBCOL,IBLIST("INPUT_RTN"),ID,IBLIST("NAME"),"S"_IBLIST_"("_J,IBLIST("RULE",J),DISPLAY,HEADER,IBLIST("QLFR",J),IBLIST("DYNAMIC"),CNT,SUBHDR,$GET(QTY),$GET(ND2),$GET(SLCTN))
+71 if TRACKBBL
DO TRACKBBL^IBDFM1("S"_IBLIST_"("_J,CNT,IBLIST("QLFR",J),IBLIST("INPUT_RTN"),DISPLAY,ID)
End DoDot:1
+72 QUIT
+73 ;
WRAP ;
+1 if IBLIST("SCW",J)<8
QUIT
+2 NEW FOUND,AT,I,CHAR
SET FOUND=0
+3 SET AT=IBLIST("SCW",J)+2
+4 FOR I=0:1:IBLIST("SCW",J)\4
SET AT=AT-1
SET CHAR=$EXTRACT(VALUE,AT)
IF " /\-:;"[CHAR
SET FOUND=1
QUIT
+5 IF FOUND
Begin DoDot:1
+6 SET WRAP(J)=$EXTRACT(VALUE,AT+$SELECT(" -"[CHAR:1,1:0),AT+IBLIST("SCW",J))
+7 FOR I=1:1:IBLIST("SCW",J)
IF $EXTRACT(WRAP(J),I)'=" "
Begin DoDot:2
+8 IF I>1
SET WRAP(J)=$EXTRACT(WRAP(J),I,$LENGTH(WRAP(J)))
End DoDot:2
QUIT
+9 SET VALUE=$EXTRACT(VALUE,1,AT-1)
End DoDot:1
+10 IF '$TEST
SET WRAP(J)=$EXTRACT(VALUE,IBLIST("SCW",J),2*IBLIST("SCW",J)-1)
SET VALUE=$EXTRACT(VALUE,1,IBLIST("SCW",J)-1)_"-"
+11 QUIT
