- 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 Jan 18, 2025@03:54:40 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