source: FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDFU1.m@ 1499

Last change on this file since 1499 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 5.9 KB
Line 
1IBDFU1 ;ALB/CJM - AICS get list descriptions ;NOV 16,1992
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;**15**;APR 24, 1997
3 ;
4LSTDESCR(IBLIST) ;parses the IBLIST record pointed to by IBBLK and puts the
5 ;descripition in IBLIST - should be called by reference
6 ;returns 1 if list description not found
7 N NODE,J,C
8 S NODE=$G(^IBE(357.2,IBLIST,0))
9 Q:NODE="" 1
10 S IBLIST("NAME")=$P(NODE,"^",1)
11 S IBLIST("BLK")=$P(NODE,"^",2)
12 S IBLIST("DSCHDR")=$P(NODE,"^",4)
13 S IBLIST("HDR")=$P(NODE,"^",5)
14 S IBLIST("DHDR")=$P(NODE,"^",6)
15 S IBLIST("SEP")=$P(NODE,"^",7) D
16 .;how to separate subcolumns
17 .I IBLIST("SEP")=1 S IBLIST("SEP")=" ",IBLIST("SEP1")=" ",IBLIST("SEP2")="" Q
18 .I IBLIST("SEP")=2 S IBLIST("SEP")=" ",IBLIST("SEP1")=" ",IBLIST("SEP2")="" Q
19 .I IBLIST("SEP")=3 S IBLIST("SEP")="|",IBLIST("SEP1")="|",IBLIST("SEP2")="" Q
20 .I IBLIST("SEP")=4 S IBLIST("SEP")=" | ",IBLIST("SEP1")=" |",IBLIST("SEP2")=" " Q
21 ;
22 S IBLIST("BTWN")=$P(NODE,"^",8)
23 S IBLIST("DGHDR")=$P(NODE,"^",9)
24 S IBLIST("RTN")=$P(NODE,"^",11)
25 S IBLIST("INPUT_RTN")=$S(IBLIST("RTN"):$P($G(^IBE(357.6,IBLIST("RTN"),0)),"^",13),1:"")
26 S IBLIST("ULSLCTNS")=$P(NODE,"^",12)
27 S IBLIST("NUMCOL")=$P(NODE,"^",13)
28 S IBLIST("DYNAMIC")=+$P(NODE,"^",14)
29 S IBLIST("OVERFLOW")=+$P(NODE,"^",15)
30 S IBLIST("OTHER")=$P(NODE,"^",16)
31 S IBLIST("CLRMLIST")=$P(NODE,"^",19)
32 S IBLIST("CLRM")=+$P($G(^IBE(357.6,+$P(NODE,"^",11),0)),"^",20)
33 S (IBLIST("NAR_READ"),IBLIST("NAR_PRINT"),IBLIST("CODE_READ"),IBLIST("CODE_PRINT"))=0
34 I $P(NODE,"^",17)=1 S IBLIST("NAR_PRINT")=1,IBLIST("CODE_PRINT")=0
35 I $P(NODE,"^",17)=2 S IBLIST("NAR_PRINT")=0,IBLIST("CODE_PRINT")=1
36 I $P(NODE,"^",17)=3 S IBLIST("NAR_PRINT")=1,IBLIST("CODE_PRINT")=1
37 I $P(NODE,"^",18)=1 S IBLIST("NAR_READ")=1,IBLIST("CODE_READ")=0
38 I $P(NODE,"^",18)=2 S IBLIST("NAR_READ")=0,IBLIST("CODE_READ")=1
39 I $P(NODE,"^",18)=3 S IBLIST("NAR_READ")=1,IBLIST("CODE_READ")=1
40 ;
41 ;go to the package interface
42 S NODE="" S:IBLIST("RTN") NODE=$G(^IBE(357.6,IBLIST("RTN"),16))
43 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)
44 ;
45 S IBLIST("SC0")=IBLIST("DYNAMIC")&IBLIST("INPUT_RTN")
46 ;get column information
47 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)
48 ;get subcolumn information
49 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
50 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
51 .S IBLIST("SCTYPE",J)=$P(NODE,"^",4) Q:'IBLIST("SCTYPE",J)
52 .S IBLIST("SCHDR",J)=$P(NODE,"^",2) S:IBLIST("SCHDR",J)=" " IBLIST("SCHDR",J)="" S IBLIST("SCW",J)=$P(NODE,"^",3)
53 .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
54 ..I IBLIST("SCPIECE",J)=1,IBLIST("RTN") S IBLIST("SCEDITABLE",J)=$S($P($G(^IBE(357.6,IBLIST("RTN"),2)),"^",2)="":1,1:0)
55 .I IBLIST("SCTYPE",J)=2 D
56 ..S IBLIST("SCSYMBOL",J)=$P(NODE,"^",6)
57 ..S IBLIST("NOUL",J)=$P(NODE,"^",8),IBLIST("ROUTINE",J)=""
58 ..S IBLIST("QLFR",J)=$P(NODE,"^",9),IBLIST("RULE",J)=+$P(NODE,"^",10)
59 ..I 'IBLIST("SCSYMBOL",J) S IBLIST("SCSYMBOL",I)="",IBLIST("SCW",J)=0 Q
60 ..S NODE=$G(^IBE(357.91,IBLIST("SCSYMBOL",J),0))
61 ..I '$P(NODE,"^",4) S IBLIST("SCSYMBOL",J)=$P(NODE,"^",2),IBLIST("SCW",J)=$L(IBLIST("SCSYMBOL",J)) D Q
62 ...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))
63 ..;may need to call a special procedure if printing to a PCL printer
64 ..I $E($P(NODE,"^"),1,6)="BUBBLE" D
65 ...S IBLIST("ROUTINE",J)="BUBBLE",IBLIST("SCW",J)=3,IBLIST("SCSYMBOL",J)=" "
66 ...I $L(IBLIST("SCHDR",J))>IBLIST("SCW",J) S IBLIST("SCW",J)=$L(IBLIST("SCHDR",J)),IBLIST("SCSYMBOL",J)=$J(" ",IBLIST("SCW",J))
67 Q 0
68 ;
69LSTDSCR2(IBLIST) ;parses the IBLIST record pointed to by IBBLK and puts the
70 ;descripition in IBLIST(just what's needed while editing the selection
71 ;list, not for printing it) in- should be called by reference
72 ;returns 1 if list description not found
73 N NODE,J,C
74 S NODE=$G(^IBE(357.2,IBLIST,0))
75 Q:NODE="" 1
76 S IBLIST("RTN")=$P(NODE,"^",11)
77 S IBLIST("DYNAMIC")=+$P(NODE,"^",14)
78 S IBLIST("BTWN")=$P(NODE,"^",8)
79 S IBLIST("CLRMLIST")=$P(NODE,"^",19)
80 S IBLIST("CLRM")=+$P($G(^IBE(357.6,+$P(NODE,"^",11),0)),"^",20)
81 ;get subcolumn information
82 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
83 .Q:NODE="" S IBLIST("SCTYPE",J)=$P(NODE,"^",4) Q:'IBLIST("SCTYPE",J)
84 .S IBLIST("SCHDR",J)=$P(NODE,"^",2),IBLIST("SCW",J)=$P(NODE,"^",3)
85 .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)
86 Q 0
87 ;
88SCDESCR(LIST,CWIDTH) ;computes the offsets for each subcolumn and
89 ;computes the column width (CWIDTH)
90 N I,SCHDR,CHDR,W,FLAG
91 ;CHDR will be the line with all the subcolumn headers
92 S CWIDTH=LINE+$L($P(LIST("SEP"),"|",2))
93 S CHDR="",FLAG=0
94 F I=1-LIST("SC0"):1:8 D
95 .I (LIST("SCTYPE",I)'=1)&(LIST("SCTYPE",I)'=2) S LIST("SCTYPE",I)="" Q
96 .I 'LIST("SCW",I) S LIST("SCTYPE",I)="" Q
97 .I LIST("SCHDR",I)'="" S FLAG=1,LIST("SCHDR",I)=$E(LIST("SCHDR",I),1,LIST("SCW",I))
98 .S LIST("SCOS",I)=CWIDTH+((LIST("SCW",I)-$L(LIST("SCHDR",I)))\2)
99 .S CWIDTH=CWIDTH+LIST("SCW",I)+$L(LIST("SEP"))
100 .S SCHDR=LIST("SCHDR",I)
101 .S W=$L(SCHDR)
102 .S SCHDR=$$PADRIGHT^IBDFU($J(SCHDR,W+((LIST("SCW",I)-W)\2)),LIST("SCW",I))
103 .S:CHDR'="" CHDR=CHDR_$J("",$L(LIST("SEP")))
104 .S CHDR=CHDR_SCHDR
105 ;
106 ;calculate the column width
107 S CWIDTH=CWIDTH-$L($P(LIST("SEP"),"|"))
108 ;
109 ;if there were no subcolumn headers then that line is empty, don't print
110 I 'FLAG S LIST("CHDR")="" Q
111 S LIST("CHDR")=LIST("SEP2")_CHDR
112 Q
Note: See TracBrowser for help on using the repository browser.