IBDFU1 ;ALB/CJM - AICS get list descriptions ;NOV 16,1992
;;3.0;AUTOMATED INFO COLLECTION SYS;**15**;APR 24, 1997
;
LSTDESCR(IBLIST) ;parses the IBLIST record pointed to by IBBLK and puts the
;descripition in IBLIST - should be called by reference
;returns 1 if list description not found
N NODE,J,C
S NODE=$G(^IBE(357.2,IBLIST,0))
Q:NODE="" 1
S IBLIST("NAME")=$P(NODE,"^",1)
S IBLIST("BLK")=$P(NODE,"^",2)
S IBLIST("DSCHDR")=$P(NODE,"^",4)
S IBLIST("HDR")=$P(NODE,"^",5)
S IBLIST("DHDR")=$P(NODE,"^",6)
S IBLIST("SEP")=$P(NODE,"^",7) D
.;how to separate subcolumns
.I IBLIST("SEP")=1 S IBLIST("SEP")=" ",IBLIST("SEP1")=" ",IBLIST("SEP2")="" Q
.I IBLIST("SEP")=2 S IBLIST("SEP")=" ",IBLIST("SEP1")=" ",IBLIST("SEP2")="" Q
.I IBLIST("SEP")=3 S IBLIST("SEP")="|",IBLIST("SEP1")="|",IBLIST("SEP2")="" Q
.I IBLIST("SEP")=4 S IBLIST("SEP")=" | ",IBLIST("SEP1")=" |",IBLIST("SEP2")=" " Q
;
S IBLIST("BTWN")=$P(NODE,"^",8)
S IBLIST("DGHDR")=$P(NODE,"^",9)
S IBLIST("RTN")=$P(NODE,"^",11)
S IBLIST("INPUT_RTN")=$S(IBLIST("RTN"):$P($G(^IBE(357.6,IBLIST("RTN"),0)),"^",13),1:"")
S IBLIST("ULSLCTNS")=$P(NODE,"^",12)
S IBLIST("NUMCOL")=$P(NODE,"^",13)
S IBLIST("DYNAMIC")=+$P(NODE,"^",14)
S IBLIST("OVERFLOW")=+$P(NODE,"^",15)
S IBLIST("OTHER")=$P(NODE,"^",16)
S IBLIST("CLRMLIST")=$P(NODE,"^",19)
S IBLIST("CLRM")=+$P($G(^IBE(357.6,+$P(NODE,"^",11),0)),"^",20)
S (IBLIST("NAR_READ"),IBLIST("NAR_PRINT"),IBLIST("CODE_READ"),IBLIST("CODE_PRINT"))=0
I $P(NODE,"^",17)=1 S IBLIST("NAR_PRINT")=1,IBLIST("CODE_PRINT")=0
I $P(NODE,"^",17)=2 S IBLIST("NAR_PRINT")=0,IBLIST("CODE_PRINT")=1
I $P(NODE,"^",17)=3 S IBLIST("NAR_PRINT")=1,IBLIST("CODE_PRINT")=1
I $P(NODE,"^",18)=1 S IBLIST("NAR_READ")=1,IBLIST("CODE_READ")=0
I $P(NODE,"^",18)=2 S IBLIST("NAR_READ")=0,IBLIST("CODE_READ")=1
I $P(NODE,"^",18)=3 S IBLIST("NAR_READ")=1,IBLIST("CODE_READ")=1
;
;go to the package interface
S NODE="" S:IBLIST("RTN") NODE=$G(^IBE(357.6,IBLIST("RTN"),16))
S IBLIST("NAR_DATATYPE")=$P(NODE,"^",2),IBLIST("NAR_HDR")=$P(NODE,"^",3),IBLIST("CODE_DATATYPE")=$P(NODE,"^",6),IBLIST("CODE_HDR")=$P(NODE,"^",7)
;
S IBLIST("SC0")=IBLIST("DYNAMIC")&IBLIST("INPUT_RTN")
;get column information
F J=1:1:4 S C=$O(^IBE(357.2,IBLIST,1,"B",J,"")) S NODE=$S('C:"",1:$G(^IBE(357.2,IBLIST,1,C,0))) S IBLIST("Y",J)=$P(NODE,"^",2),IBLIST("X",J)=$P(NODE,"^",3),IBLIST("H",J)=$P(NODE,"^",4)
;get subcolumn information
I IBLIST("SC0") S IBLIST("SCHDR",0)="",IBLIST("SCW",0)=4,IBLIST("SCTYPE",0)=1,IBLIST("SCPIECE",0)=0,IBLIST("SCEDITABLE",0)=0,IBLIST("NOUL",0)=0
F J=1:1:8 S C=$O(^IBE(357.2,IBLIST,2,"B",J,"")) S NODE=$S('C:"",1:$G(^IBE(357.2,IBLIST,2,C,0))) D
.S IBLIST("SCTYPE",J)=$P(NODE,"^",4) Q:'IBLIST("SCTYPE",J)
.S IBLIST("SCHDR",J)=$P(NODE,"^",2) S:IBLIST("SCHDR",J)=" " IBLIST("SCHDR",J)="" S IBLIST("SCW",J)=$P(NODE,"^",3)
.I IBLIST("SCTYPE",J)=1 S IBLIST("SCPIECE",J)=$P(NODE,"^",5),IBLIST("SCEDITABLE",J)=$P(NODE,"^",7),IBLIST("NOUL",J)=$P(NODE,"^",8) D
..I IBLIST("SCPIECE",J)=1,IBLIST("RTN") S IBLIST("SCEDITABLE",J)=$S($P($G(^IBE(357.6,IBLIST("RTN"),2)),"^",2)="":1,1:0)
.I IBLIST("SCTYPE",J)=2 D
..S IBLIST("SCSYMBOL",J)=$P(NODE,"^",6)
..S IBLIST("NOUL",J)=$P(NODE,"^",8),IBLIST("ROUTINE",J)=""
..S IBLIST("QLFR",J)=$P(NODE,"^",9),IBLIST("RULE",J)=+$P(NODE,"^",10)
..I 'IBLIST("SCSYMBOL",J) S IBLIST("SCSYMBOL",I)="",IBLIST("SCW",J)=0 Q
..S NODE=$G(^IBE(357.91,IBLIST("SCSYMBOL",J),0))
..I '$P(NODE,"^",4) S IBLIST("SCSYMBOL",J)=$P(NODE,"^",2),IBLIST("SCW",J)=$L(IBLIST("SCSYMBOL",J)) D Q
...I $L($G(IBLIST("SCHDR",J)))>IBLIST("SCW",J) S IBLIST("SCW",J)=$L(IBLIST("SCHDR",J)),IBLIST("SCSYMBOL",J)=$J($$CJ^XLFSTR(IBLIST("SCSYMBOL",J),IBLIST("SCW",J)),IBLIST("SCW",J))
..;may need to call a special procedure if printing to a PCL printer
..I $E($P(NODE,"^"),1,6)="BUBBLE" D
...S IBLIST("ROUTINE",J)="BUBBLE",IBLIST("SCW",J)=3,IBLIST("SCSYMBOL",J)=" "
...I $L(IBLIST("SCHDR",J))>IBLIST("SCW",J) S IBLIST("SCW",J)=$L(IBLIST("SCHDR",J)),IBLIST("SCSYMBOL",J)=$J(" ",IBLIST("SCW",J))
Q 0
;
LSTDSCR2(IBLIST) ;parses the IBLIST record pointed to by IBBLK and puts the
;descripition in IBLIST(just what's needed while editing the selection
;list, not for printing it) in- should be called by reference
;returns 1 if list description not found
N NODE,J,C
S NODE=$G(^IBE(357.2,IBLIST,0))
Q:NODE="" 1
S IBLIST("RTN")=$P(NODE,"^",11)
S IBLIST("DYNAMIC")=+$P(NODE,"^",14)
S IBLIST("BTWN")=$P(NODE,"^",8)
S IBLIST("CLRMLIST")=$P(NODE,"^",19)
S IBLIST("CLRM")=+$P($G(^IBE(357.6,+$P(NODE,"^",11),0)),"^",20)
;get subcolumn information
F J=1:1:8 S C=$O(^IBE(357.2,IBLIST,2,"B",J,"")) S NODE=$S('C:"",1:$G(^IBE(357.2,IBLIST,2,C,0))) D
.Q:NODE="" S IBLIST("SCTYPE",J)=$P(NODE,"^",4) Q:'IBLIST("SCTYPE",J)
.S IBLIST("SCHDR",J)=$P(NODE,"^",2),IBLIST("SCW",J)=$P(NODE,"^",3)
.I IBLIST("SCTYPE",J)=1 S IBLIST("SCPIECE",J)=$P(NODE,"^",5),IBLIST("SCEDITABLE",J)=$P(NODE,"^",7) I IBLIST("SCPIECE",J)=1,IBLIST("RTN") S IBLIST("SCEDITABLE",J)=$S($P($G(^IBE(357.6,IBLIST("RTN"),2)),"^",2)="":1,1:0)
Q 0
;
SCDESCR(LIST,CWIDTH) ;computes the offsets for each subcolumn and
;computes the column width (CWIDTH)
N I,SCHDR,CHDR,W,FLAG
;CHDR will be the line with all the subcolumn headers
S CWIDTH=LINE+$L($P(LIST("SEP"),"|",2))
S CHDR="",FLAG=0
F I=1-LIST("SC0"):1:8 D
.I (LIST("SCTYPE",I)'=1)&(LIST("SCTYPE",I)'=2) S LIST("SCTYPE",I)="" Q
.I 'LIST("SCW",I) S LIST("SCTYPE",I)="" Q
.I LIST("SCHDR",I)'="" S FLAG=1,LIST("SCHDR",I)=$E(LIST("SCHDR",I),1,LIST("SCW",I))
.S LIST("SCOS",I)=CWIDTH+((LIST("SCW",I)-$L(LIST("SCHDR",I)))\2)
.S CWIDTH=CWIDTH+LIST("SCW",I)+$L(LIST("SEP"))
.S SCHDR=LIST("SCHDR",I)
.S W=$L(SCHDR)
.S SCHDR=$$PADRIGHT^IBDFU($J(SCHDR,W+((LIST("SCW",I)-W)\2)),LIST("SCW",I))
.S:CHDR'="" CHDR=CHDR_$J("",$L(LIST("SEP")))
.S CHDR=CHDR_SCHDR
;
;calculate the column width
S CWIDTH=CWIDTH-$L($P(LIST("SEP"),"|"))
;
;if there were no subcolumn headers then that line is empty, don't print
I 'FLAG S LIST("CHDR")="" Q
S LIST("CHDR")=LIST("SEP2")_CHDR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDFU1 6119 printed Dec 13, 2024@02:53:29 Page 2
IBDFU1 ;ALB/CJM - AICS get list descriptions ;NOV 16,1992
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**15**;APR 24, 1997
+2 ;
LSTDESCR(IBLIST) ;parses the IBLIST record pointed to by IBBLK and puts the
+1 ;descripition in IBLIST - should be called by reference
+2 ;returns 1 if list description not found
+3 NEW NODE,J,C
+4 SET NODE=$GET(^IBE(357.2,IBLIST,0))
+5 if NODE=""
QUIT 1
+6 SET IBLIST("NAME")=$PIECE(NODE,"^",1)
+7 SET IBLIST("BLK")=$PIECE(NODE,"^",2)
+8 SET IBLIST("DSCHDR")=$PIECE(NODE,"^",4)
+9 SET IBLIST("HDR")=$PIECE(NODE,"^",5)
+10 SET IBLIST("DHDR")=$PIECE(NODE,"^",6)
+11 SET IBLIST("SEP")=$PIECE(NODE,"^",7)
Begin DoDot:1
+12 ;how to separate subcolumns
+13 IF IBLIST("SEP")=1
SET IBLIST("SEP")=" "
SET IBLIST("SEP1")=" "
SET IBLIST("SEP2")=""
QUIT
+14 IF IBLIST("SEP")=2
SET IBLIST("SEP")=" "
SET IBLIST("SEP1")=" "
SET IBLIST("SEP2")=""
QUIT
+15 IF IBLIST("SEP")=3
SET IBLIST("SEP")="|"
SET IBLIST("SEP1")="|"
SET IBLIST("SEP2")=""
QUIT
+16 IF IBLIST("SEP")=4
SET IBLIST("SEP")=" | "
SET IBLIST("SEP1")=" |"
SET IBLIST("SEP2")=" "
QUIT
End DoDot:1
+17 ;
+18 SET IBLIST("BTWN")=$PIECE(NODE,"^",8)
+19 SET IBLIST("DGHDR")=$PIECE(NODE,"^",9)
+20 SET IBLIST("RTN")=$PIECE(NODE,"^",11)
+21 SET IBLIST("INPUT_RTN")=$SELECT(IBLIST("RTN"):$PIECE($GET(^IBE(357.6,IBLIST("RTN"),0)),"^",13),1:"")
+22 SET IBLIST("ULSLCTNS")=$PIECE(NODE,"^",12)
+23 SET IBLIST("NUMCOL")=$PIECE(NODE,"^",13)
+24 SET IBLIST("DYNAMIC")=+$PIECE(NODE,"^",14)
+25 SET IBLIST("OVERFLOW")=+$PIECE(NODE,"^",15)
+26 SET IBLIST("OTHER")=$PIECE(NODE,"^",16)
+27 SET IBLIST("CLRMLIST")=$PIECE(NODE,"^",19)
+28 SET IBLIST("CLRM")=+$PIECE($GET(^IBE(357.6,+$PIECE(NODE,"^",11),0)),"^",20)
+29 SET (IBLIST("NAR_READ"),IBLIST("NAR_PRINT"),IBLIST("CODE_READ"),IBLIST("CODE_PRINT"))=0
+30 IF $PIECE(NODE,"^",17)=1
SET IBLIST("NAR_PRINT")=1
SET IBLIST("CODE_PRINT")=0
+31 IF $PIECE(NODE,"^",17)=2
SET IBLIST("NAR_PRINT")=0
SET IBLIST("CODE_PRINT")=1
+32 IF $PIECE(NODE,"^",17)=3
SET IBLIST("NAR_PRINT")=1
SET IBLIST("CODE_PRINT")=1
+33 IF $PIECE(NODE,"^",18)=1
SET IBLIST("NAR_READ")=1
SET IBLIST("CODE_READ")=0
+34 IF $PIECE(NODE,"^",18)=2
SET IBLIST("NAR_READ")=0
SET IBLIST("CODE_READ")=1
+35 IF $PIECE(NODE,"^",18)=3
SET IBLIST("NAR_READ")=1
SET IBLIST("CODE_READ")=1
+36 ;
+37 ;go to the package interface
+38 SET NODE=""
if IBLIST("RTN")
SET NODE=$GET(^IBE(357.6,IBLIST("RTN"),16))
+39 SET IBLIST("NAR_DATATYPE")=$PIECE(NODE,"^",2)
SET IBLIST("NAR_HDR")=$PIECE(NODE,"^",3)
SET IBLIST("CODE_DATATYPE")=$PIECE(NODE,"^",6)
SET IBLIST("CODE_HDR")=$PIECE(NODE,"^",7)
+40 ;
+41 SET IBLIST("SC0")=IBLIST("DYNAMIC")&IBLIST("INPUT_RTN")
+42 ;get column information
+43 FOR J=1:1:4
SET C=$ORDER(^IBE(357.2,IBLIST,1,"B",J,""))
SET NODE=$SELECT('C:"",1:$GET(^IBE(357.2,IBLIST,1,C,0)))
SET IBLIST("Y",J)=$PIECE(NODE,"^",2)
SET IBLIST("X",J)=$PIECE(NODE,"^",3)
SET IBLIST("H",J)=$PIECE(NODE,"^",4)
+44 ;get subcolumn information
+45 IF IBLIST("SC0")
SET IBLIST("SCHDR",0)=""
SET IBLIST("SCW",0)=4
SET IBLIST("SCTYPE",0)=1
SET IBLIST("SCPIECE",0)=0
SET IBLIST("SCEDITABLE",0)=0
SET IBLIST("NOUL",0)=0
+46 FOR J=1:1:8
SET C=$ORDER(^IBE(357.2,IBLIST,2,"B",J,""))
SET NODE=$SELECT('C:"",1:$GET(^IBE(357.2,IBLIST,2,C,0)))
Begin DoDot:1
+47 SET IBLIST("SCTYPE",J)=$PIECE(NODE,"^",4)
if 'IBLIST("SCTYPE",J)
QUIT
+48 SET IBLIST("SCHDR",J)=$PIECE(NODE,"^",2)
if IBLIST("SCHDR",J)=" "
SET IBLIST("SCHDR",J)=""
SET IBLIST("SCW",J)=$PIECE(NODE,"^",3)
+49 IF IBLIST("SCTYPE",J)=1
SET IBLIST("SCPIECE",J)=$PIECE(NODE,"^",5)
SET IBLIST("SCEDITABLE",J)=$PIECE(NODE,"^",7)
SET IBLIST("NOUL",J)=$PIECE(NODE,"^",8)
Begin DoDot:2
+50 IF IBLIST("SCPIECE",J)=1
IF IBLIST("RTN")
SET IBLIST("SCEDITABLE",J)=$SELECT($PIECE($GET(^IBE(357.6,IBLIST("RTN"),2)),"^",2)="":1,1:0)
End DoDot:2
+51 IF IBLIST("SCTYPE",J)=2
Begin DoDot:2
+52 SET IBLIST("SCSYMBOL",J)=$PIECE(NODE,"^",6)
+53 SET IBLIST("NOUL",J)=$PIECE(NODE,"^",8)
SET IBLIST("ROUTINE",J)=""
+54 SET IBLIST("QLFR",J)=$PIECE(NODE,"^",9)
SET IBLIST("RULE",J)=+$PIECE(NODE,"^",10)
+55 IF 'IBLIST("SCSYMBOL",J)
SET IBLIST("SCSYMBOL",I)=""
SET IBLIST("SCW",J)=0
QUIT
+56 SET NODE=$GET(^IBE(357.91,IBLIST("SCSYMBOL",J),0))
+57 IF '$PIECE(NODE,"^",4)
SET IBLIST("SCSYMBOL",J)=$PIECE(NODE,"^",2)
SET IBLIST("SCW",J)=$LENGTH(IBLIST("SCSYMBOL",J))
Begin DoDot:3
+58 IF $LENGTH($GET(IBLIST("SCHDR",J)))>IBLIST("SCW",J)
SET IBLIST("SCW",J)=$LENGTH(IBLIST("SCHDR",J))
SET IBLIST("SCSYMBOL",J)=$JUSTIFY($$CJ^XLFSTR(IBLIST("SCSYMBOL",J),IBLIST("SCW",J)),IBLIST("SCW",J))
End DoDot:3
QUIT
+59 ;may need to call a special procedure if printing to a PCL printer
+60 IF $EXTRACT($PIECE(NODE,"^"),1,6)="BUBBLE"
Begin DoDot:3
+61 SET IBLIST("ROUTINE",J)="BUBBLE"
SET IBLIST("SCW",J)=3
SET IBLIST("SCSYMBOL",J)=" "
+62 IF $LENGTH(IBLIST("SCHDR",J))>IBLIST("SCW",J)
SET IBLIST("SCW",J)=$LENGTH(IBLIST("SCHDR",J))
SET IBLIST("SCSYMBOL",J)=$JUSTIFY(" ",IBLIST("SCW",J))
End DoDot:3
End DoDot:2
End DoDot:1
+63 QUIT 0
+64 ;
LSTDSCR2(IBLIST) ;parses the IBLIST record pointed to by IBBLK and puts the
+1 ;descripition in IBLIST(just what's needed while editing the selection
+2 ;list, not for printing it) in- should be called by reference
+3 ;returns 1 if list description not found
+4 NEW NODE,J,C
+5 SET NODE=$GET(^IBE(357.2,IBLIST,0))
+6 if NODE=""
QUIT 1
+7 SET IBLIST("RTN")=$PIECE(NODE,"^",11)
+8 SET IBLIST("DYNAMIC")=+$PIECE(NODE,"^",14)
+9 SET IBLIST("BTWN")=$PIECE(NODE,"^",8)
+10 SET IBLIST("CLRMLIST")=$PIECE(NODE,"^",19)
+11 SET IBLIST("CLRM")=+$PIECE($GET(^IBE(357.6,+$PIECE(NODE,"^",11),0)),"^",20)
+12 ;get subcolumn information
+13 FOR J=1:1:8
SET C=$ORDER(^IBE(357.2,IBLIST,2,"B",J,""))
SET NODE=$SELECT('C:"",1:$GET(^IBE(357.2,IBLIST,2,C,0)))
Begin DoDot:1
+14 if NODE=""
QUIT
SET IBLIST("SCTYPE",J)=$PIECE(NODE,"^",4)
if 'IBLIST("SCTYPE",J)
QUIT
+15 SET IBLIST("SCHDR",J)=$PIECE(NODE,"^",2)
SET IBLIST("SCW",J)=$PIECE(NODE,"^",3)
+16 IF IBLIST("SCTYPE",J)=1
SET IBLIST("SCPIECE",J)=$PIECE(NODE,"^",5)
SET IBLIST("SCEDITABLE",J)=$PIECE(NODE,"^",7)
IF IBLIST("SCPIECE",J)=1
IF IBLIST("RTN")
SET IBLIST("SCEDITABLE",J)=$SELECT($PIECE($GET(^IBE(357.6,IBLIST("RTN"),2)),"^",2)="":1,1:0)
End DoDot:1
+17 QUIT 0
+18 ;
SCDESCR(LIST,CWIDTH) ;computes the offsets for each subcolumn and
+1 ;computes the column width (CWIDTH)
+2 NEW I,SCHDR,CHDR,W,FLAG
+3 ;CHDR will be the line with all the subcolumn headers
+4 SET CWIDTH=LINE+$LENGTH($PIECE(LIST("SEP"),"|",2))
+5 SET CHDR=""
SET FLAG=0
+6 FOR I=1-LIST("SC0"):1:8
Begin DoDot:1
+7 IF (LIST("SCTYPE",I)'=1)&(LIST("SCTYPE",I)'=2)
SET LIST("SCTYPE",I)=""
QUIT
+8 IF 'LIST("SCW",I)
SET LIST("SCTYPE",I)=""
QUIT
+9 IF LIST("SCHDR",I)'=""
SET FLAG=1
SET LIST("SCHDR",I)=$EXTRACT(LIST("SCHDR",I),1,LIST("SCW",I))
+10 SET LIST("SCOS",I)=CWIDTH+((LIST("SCW",I)-$LENGTH(LIST("SCHDR",I)))\2)
+11 SET CWIDTH=CWIDTH+LIST("SCW",I)+$LENGTH(LIST("SEP"))
+12 SET SCHDR=LIST("SCHDR",I)
+13 SET W=$LENGTH(SCHDR)
+14 SET SCHDR=$$PADRIGHT^IBDFU($JUSTIFY(SCHDR,W+((LIST("SCW",I)-W)\2)),LIST("SCW",I))
+15 if CHDR'=""
SET CHDR=CHDR_$JUSTIFY("",$LENGTH(LIST("SEP")))
+16 SET CHDR=CHDR_SCHDR
End DoDot:1
+17 ;
+18 ;calculate the column width
+19 SET CWIDTH=CWIDTH-$LENGTH($PIECE(LIST("SEP"),"|"))
+20 ;
+21 ;if there were no subcolumn headers then that line is empty, don't print
+22 IF 'FLAG
SET LIST("CHDR")=""
QUIT
+23 SET LIST("CHDR")=LIST("SEP2")_CHDR
+24 QUIT
