source: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDFRPC2.m@ 636

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

initial load of FOIAVistA 6/30/08 version
File size: 8.0 KB
Line 
1IBDFRPC2 ;ALB/AAS - Return list of selections, broker call ;29-JAN-96
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;**34,38**;APR 24, 1997
3 ;
4SEL(RESULT,IBDF) ; -- Procedure
5 ; -- called by ibdfrpc1, returns list for one selection list
6 ; see ibdfrpc1 for complete input/output lists
7 ; -- Input IBDF("IEN") := pointer to selection list (357.2)
8 ; IBDF("PI") := pointer to package interface (357.6) (optional)
9 ; IBDF("DFN") := pointer to patient (2) (optional)
10 ; IBDF("CLINIC") := pointer to clinic (44) (optional)
11 ;
12 N OTEXT,TEXT,SC,TERM,COUNT,DCODE,SECOND,THIRD
13 I $E($G(RESULT),1)="^" S ARRY=RESULT
14 E S ARRY="RESULT"
15 S COUNT=+$G(@ARRY@(0))
16 ;
17 S @ARRY@(0)="List not found"
18 G:'$G(IBDF("IEN")) SELQ
19 G:$G(^IBE(357.2,IBDF("IEN"),0))="" SELQ
20 ;K ^TMP("IBD-DUP",$J)
21 ;
22 ; -- copy list
23 I '$G(IBDF("RULE-ONLY")) D COPYLIST(.RESULT,IBDF("IEN"),.COUNT)
24 ;I COUNT D URH
25 ;
26 S @ARRY@(0)=COUNT_"^LIST^"
27 D GETQLF
28SELQ Q
29 ;
30GETQLF ; -- add selection rule and qualifiers from marking area
31 ; subcolumns to results(0) node, but only for bubbles
32 N SC,NODE,BUBB,BUBBCNT
33 S SC=0,BUBBCNT=0,BUBB=$O(^IBE(357.91,"B","BUBBLE (use for scanning)",0)) Q:'BUBB
34 F S SC=$O(^IBE(357.2,IBDF("IEN"),2,SC)) Q:'SC D
35 .S NODE=$G(^IBE(357.2,IBDF("IEN"),2,SC,0))
36 .I $P(NODE,"^",4)=2,$P(NODE,"^",6)=BUBB S BUBBCNT=BUBBCNT+1,@ARRY@(0)=@ARRY@(0)_$P($G(^IBD(357.98,+$P(NODE,"^",9),0)),"^")_";;"_+$P(NODE,"^",10)_"::"
37 ;
38 ; -- if no bubbles then kill off array, leave zero node for reports
39 I BUBBCNT<1 S SC=@ARRY@(0) K @ARRY S @ARRY@(0)="0^"_$P(SC,"^",2,3) S $P(@ARRY@(0),"^",4)=1
40 Q
41 ;
42COPYLIST(RESULT,LIST,COUNT) ;copies the entries from LIST to @ARY, starting subscript at COUNT+1
43 ;
44 N SLCTN,SUBCOL,TEXT,IEN,NODE,TSUBCOL,NOTREAL,GROUP,ORDER,HDR,CSUBCOL,DCODE,QUANTITY,SECOND,THIRD
45 ;
46 I $E($G(RESULT),1)="^" S ARRY=RESULT
47 E S ARRY="RESULT"
48 ;
49 S SUBCOL=$$SUBCOL(LIST),TSUBCOL=+SUBCOL,CSUBCOL=+$P(SUBCOL,"^",2)
50 ;
51 S PRNT=""
52 F S PRNT=$O(^IBE(357.4,"APO",LIST,PRNT)) Q:PRNT="" D
53 . S GROUP=""
54 . F S GROUP=$O(^IBE(357.4,"APO",LIST,PRNT,GROUP)) Q:GROUP="" D
55 .. S HDR=$P($G(^IBE(357.4,GROUP,0)),"^")
56 .. I $P($G(^IBE(357.4,GROUP,0)),"^",4)="I" S HDR=" "
57 .. I HDR="BLANK" S HDR=" "
58 .. S COUNT=COUNT+1,@ARRY@(COUNT)=HDR_"^^^^^^0"
59 .. S ORDER=""
60 .. F S ORDER=$O(^IBE(357.3,"APO",LIST,GROUP,ORDER)) Q:ORDER="" D
61 ... S SLCTN=0
62 ... F S SLCTN=$O(^IBE(357.3,"APO",LIST,GROUP,ORDER,SLCTN)) Q:'SLCTN D
63 .... S (TEXT,DCODE,OTEXT,TERM,NOTREAL,IEN,SECOND,THIRD)=""
64 .... S NODE=$G(^IBE(357.3,SLCTN,0)),IEN=$P(NODE,"^")
65 .... S QUANTITY=$P(NODE,"^",9)
66 .... ;
67 .... ; -- handle place holder as headers
68 .... S NOTREAL=$P(NODE,"^",2)
69 .... I NOTREAL,$P(NODE,"^",6)'="" D Q
70 ..... I $P(NODE,"^",7) S COUNT=COUNT+1,HDR=$P(NODE,"^",6),@ARRY@(COUNT)=HDR_"^^^^^^0" Q
71 ..... I $P(NODE,"^",8) S COUNT=COUNT+1,HDR=" ",@ARRY@(COUNT)=HDR_"^^^^^^0" Q
72 .....;
73 .... ; -- find text for entry
74 .... S SUBCOL=$O(^IBE(357.3,SLCTN,1,"B",+TSUBCOL,0))
75 .... S NODE=$G(^IBE(357.3,+SLCTN,1,+SUBCOL,0))
76 .... S:$P(NODE,"^")=TSUBCOL TEXT=$P(NODE,"^",2)
77 .... ;
78 .... ; -- find display code for entry
79 .... S SUBCOL=$O(^IBE(357.3,+SLCTN,1,"B",+CSUBCOL,0))
80 .... S NODE=$G(^IBE(357.3,+SLCTN,1,+SUBCOL,0))
81 .... S:$P(NODE,"^")=CSUBCOL DCODE=$P(NODE,"^",2)
82 .... ;
83 .... ; -- find optional caption and lexicon pointer
84 .... S NODE=$G(^IBE(357.3,SLCTN,2))
85 .... S OTEXT=$P(NODE,"^"),TERM=$P(NODE,"^",2)
86 .... ;
87 .... ; -- find optional second and third codes
88 .... S SECOND=$P(NODE,"^",3),THIRD=$P(NODE,"^",4)
89 .... ;
90 .... ; -- add to array. Is dup ien or ien+text???
91 .... I $L(TEXT) S COUNT=COUNT+1 D BLDA Q
92 .... ;I $L(TEXT),'$D(IBDUP(IEN_"^"_TEXT)) S COUNT=COUNT+1,IBDUP(IEN_"^"_TEXT)="" D BLDA Q ;this line checks ien+text for duplicates
93 ;
94 K ^TMP("IBD-DUP",$J)
95 Q
96 ;
97SUBCOL(LIST) ; -- function
98 ; -- returns the subcolumn containing the text
99 ; input LIST := selection list internal entry
100 ; -- Assumes data returned by the package interface, piece 2 is the description
101 ;
102 N SC,TSUBCOL,CSUBCOL
103 S (TSUBCOL,CSUBCOL)=""
104 S SC=0
105 F S SC=$O(^IBE(357.2,LIST,2,SC)) Q:'SC D
106 .Q:$P($G(^IBE(357.2,LIST,2,SC,0)),"^",4)=2 ;is a marking area
107 .I $P($G(^IBE(357.2,LIST,2,SC,0)),"^",5)=2 S TSUBCOL=$P(^(0),"^") Q ;data piece 2 is usually text subcol
108 .I $P($G(^IBE(357.2,LIST,2,SC,0)),"^",5)=1 S CSUBCOL=$P(^(0),"^") Q ; data piece 1 is always code
109 .I TSUBCOL="",$P($G(^IBE(357.2,LIST,2,SC,0)),"^",5)>2 S TSUBCOL=$P(^(0),"^") Q ; -- see if other than data piece two is text subcolumn
110 .I CSUBCOL="",$P($G(^IBE(357.2,LIST,2,SC,0)),"^",5)>2 S CSUBCOL=$P(^(0),"^") Q
111 Q TSUBCOL_"^"_CSUBCOL
112 ;
113BLDA ; -- build results array
114 S @ARRY@(COUNT)=TEXT ;B ;;
115 S $P(@ARRY@(COUNT),"^",2)=$G(DCODE)
116 S $P(@ARRY@(COUNT),"^",3)=$S($G(NOTREAL):"",1:$G(IEN))
117 S $P(@ARRY@(COUNT),"^",4)=""
118 S $P(@ARRY@(COUNT),"^",5)=$G(OTEXT)
119 S $P(@ARRY@(COUNT),"^",6)=$G(TERM)
120 S $P(@ARRY@(COUNT),"^",7)=$S($G(NOTREAL):0,1:1)
121 S $P(@ARRY@(COUNT),"^",9)=$G(QUANTITY)
122 S $P(@ARRY@(COUNT),"^",10)=$G(SECOND)
123 S $P(@ARRY@(COUNT),"^",11)=$G(THIRD)
124 ;--added for slctn to be passed also
125 S $P(@ARRY@(COUNT),"^",12)=$G(SLCTN)
126 Q
127 ;
128URH ; -- UnReferenced Headers removal
129 ; if a header doesn't have any data under it, then remove the header
130 N X,HDR
131 S X=0 F S X=$O(@ARRY@(X)) Q:'X D
132 .I '$D(HDR),$P(@ARRY@(X),"^",1)="" S HDR=X Q ;find a header
133 .I $P(@ARRY@(X),"^",1)="" K HDR Q ; is item under header
134 .I $D(HDR),$P(@ARRY@(X),"^",1)="" K @ARRY@(HDR) S COUNT=COUNT-1,HDR=X ;hdr doesn't have any items, kill hdr node and reset header to next header
135 I $D(HDR) S X=$O(@ARRY@(""),-1) I $P(@ARRY@(X),"^",1)="" K @ARRY@(X) S COUNT=COUNT-1,HDR=X ;last item in list is a header
136 Q
137 ;
138DYN(RESULT,IBDF) ; -- Procedure
139 ; -- called by ibdfrpc1 to return selection list for dynamic selections
140 ; see ibdfrpc1 for complete input/output lists
141 ; -- Input IBDF("PI") := pointer to package interface (357.6)
142 ; IBDF("IEN") := pointer to selection list (357.2)
143 ; IBDF("DFN") := pointer to patient (2) (optional for provider selections)
144 ; IBDF("CLINIC") := pointer to clinic (44) (optional for active problem selections)
145 ;
146 N PI,DFN,CNT,COUNT,NAME,RTN,IBARY,IBCLINIC
147 I $E($G(RESULT),1)="^" S ARRY=RESULT
148 E S ARRY="RESULT"
149 S COUNT=+$G(@ARRY@(0))
150 I '$G(IBDF("DFN")) S @ARRY@(0)="-1^Patient not defined" G DYNQ
151 I $G(^DPT(+IBDF("DFN"),0))="" S @ARRY@(0)="-1^Patient not Found" G DYNQ
152 S DFN=+$G(IBDF("DFN"))
153 I $G(IBDF("RULE-ONLY")) G RULE
154 ;
155 S @ARRY@(0)="List not found"
156 G:'$G(IBDF("IEN")) SELQ
157 G:$G(^IBE(357.2,IBDF("IEN"),0))="" DYNQ
158 ;
159 S @ARRY@(0)="-1^Package Interface Not found"
160 S PI=$G(^IBE(357.6,+$G(IBDF("PI")),0)) I PI="" G DYNQ
161 ;
162 S IBCLINIC=$G(IBDF("CLINIC"))
163 I +IBCLINIC'=IBCLINIC,IBCLINIC'="" S IBCLINIC=$O(^SC("B",IBCLINIC,0))
164 I +IBCLINIC=0 S @ARRY@(0)="Clinic Not Specified"
165 ;
166 S NAME=$P(PI,"^"),RTN=$P(PI,"^",2,3) I RTN=""!(RTN="^") G DYNQ
167 I NAME["ACTIVE PROBLEM" S NAME="GMP SELECT PATIENT ACTIVE PROBLEMS"
168 S IBARY="^TMP(""IB"",$J,""INTERFACES"","""_NAME_""")"
169 D @RTN
170 ;
171 S @ARRY@(0)=+$G(@IBARY@(0))_"^LIST^"
172RULE I $G(IBDF("RULE-ONLY")) S @ARRY@(0)="1^DYNLIST^"
173 ;G DYNQ:@ARRY@(0)<1
174 D GETQLF
175 G:$G(IBDF("RULE-ONLY")) DYNQ
176 ;
177 S CNT=0 F S CNT=$O(@IBARY@(CNT)) Q:'CNT D
178 .Q:$G(@IBARY@(CNT))=""
179 .;
180 .; -- Process provider lists
181 .I NAME["PROVIDER" D Q
182 ..I IBCLINIC<1 Q
183 ..S @ARRY@(CNT)=$P(@IBARY@(CNT),"^",2)_"^^"_$P(@IBARY@(CNT),"^",1)_"^^^^1" Q
184 .;
185 .; -- process patient active problem lists
186 .I NAME["ACTIVE PROBLEMS" D Q
187 ..S @ARRY@(CNT)=$P(@IBARY@(CNT),"^",2)_"^"_$P(@IBARY@(CNT),"^",3)_"^"_+@IBARY@(CNT)_"^^^^1"
188 .I '$D(@ARRY@(CNT)) S @ARRY@(CNT)=@IBARY@(CNT)
189 ;
190DYNQ Q
191 ;
192 ; -- here are some sample tests for different lists
193TEST K VAR,IBDF
194 S IBDF("IEN")=489
195 D SEL(.VAR,.IBDF)
196 X "ZW VAR"
197 Q
198 ;
199TEST1 K VAR,IBDF
200 S IBDF("IEN")=488
201 D SEL(.VAR,.IBDF)
202 X "ZW VAR"
203 Q
204 ;
205TESTD ; -- Test dynamic
206 K VAR,IBDF
207 ;S IBDF("PI")=71,IBDF("IEN")=103 ;provider, 1577 FEX
208 ;S IBDF("PI")=73 ;patient active problems
209 ;S IBDF("CLINIC")=300
210 S IBDF("PI")=7,IBDF("IEN")=14 ;provider, 1577 FEX
211 ;S IBDF("PI")=73 ;patient active problems
212 S IBDF("DFN")=7169761
213 S IBDF("CLINIC")=88
214 D DYN(.VAR,.IBDF)
215 X "ZW VAR"
Note: See TracBrowser for help on using the repository browser.