source: IHS-VA_UTILITIES-XB/trunk/XBDIQ1.m@ 1319

Last change on this file since 1319 was 642, checked in by Sam Habiel, 15 years ago

Modified directory structure; moved routines.

File size: 4.2 KB
Line 
1XBDIQ1 ; IHS/ADC/GTH - SPECIAL EN^DIQ1 DATA PULLER ; [ 02/07/97 3:02 PM ]
2 ;;4.0;XB;;Jul 20, 2009;Build 2
3 ;
4 ; Thanks to Paul Wesley, DSD/OIRM, for the original routine.
5 ;
6 ; Documentation for the APIs in this routine can be found
7 ; in routine XBDIQ0.
8 ;
9DOC ;
10 Q
11 ;
12EN ;PEP - Returns single entries
13 NEW XB0,XBDIC,XBFN,XBGBL,XBNEWPAR,XBGL
14 S XBDIC=DIC
15 I DA'=+DA D PARSE(DA)
16 D DICFNGL(DIC),^XBSFGBL(XBFN,.XBGBL)
17 S XBDIC=$P(XBGBL,"DA,"),DIC=XBDIC
18 D ENDIQ1,EXIT
19 Q
20 ;
21ENP(DIC,DA,DR,DIQ,XBFMT) ;PEP - param pass into EN
22 S:'$D(DIQ(0)) DIQ(0)=$G(XBFMT)
23 D EN
24 Q
25 ;
26ENPM(DIC,DA,DR,DIQ,XBFMT) ;PEP - param pass into EN
27 S:'$D(DIQ(0)) DIQ(0)=$G(XBFMT)
28 D ENM
29 Q
30 ;
31ENM ;PEP - get multiple entries
32 NEW XB0,XBDIC,XBFN,XBGBL,XBNEWPAR,XBGL
33 S XBDIC=DIC
34 S:$G(DA)="" DA=0
35 I DA'=+DA D PARSE(DA)
36 S:(+$G(DIQ(0))'>0) DIQ(0)=1_$G(DIQ(0))
37 D DICFNGL(DIC)
38 S XBDIC=$P(XBGL,"DA,"),DIC=XBDIC,DA=0,DIC(0)=""
39 I $D(DIC("S")) S XBDICS=DIC("S")
40 F S DA=$O(@(XBDIC_"DA)")) Q:DA'>0 D
41 . S XB0=@(XBDIC_"DA,0)")
42 . I $L($G(XBDICS)) S DIC("S")=XBDICS
43 . I $D(DIC("S")) S X="`"_DA,DIC(0)="N" D ^DIC Q:Y'>0
44 . S DIC=XBDIC
45 . D ENDIQ1
46 .Q
47 KILL XBDICS
48 S DA=""
49 D EXIT
50 Q
51 ;
52ENDIQ1 ;EP - call EN^DIQ1
53 NEW XBDIQ,XBGBL0,XBGLS,XBLVL,XBUDA,XB,XB0
54 S XBDIQ=DIQ,XBDIQ(0)=$G(DIQ(0))
55 NEW DIQ,XBDTMP
56 D LEVELS
57 D
58 . NEW DIC,DR,DA
59 . D SETDIQ1
60 . D ENDIQ1X
61 .Q
62 D PULLDIQ1
63 Q:XBDIQ(0)'["I" ; Internal if XB["I"
64 KILL DIC
65 S DIC=XBDIC ;reset dic
66 S DIQ(0)="I"
67 D ENDIQ1X,PULLDIQ1
68 KILL ^UTILITY("DIQ1",$J)
69 Q
70 ;
71ENDIQ1X ;EP - to call DIQ1 with new
72 I $G(XBDIQ1(0))["N" S DIQ(0)=$G(DIQ(0))_"N"
73 I $G(XBFMT)["N",$G(DIQ(0))'["N" S DIQ(0)=$G(DIQ(0))_"N"
74 D EN^XBNEW("ENDIQ1XN^XBDIQ1","DR;DA;DIC;DIQ;XBDTMP;XBSRCFL")
75 Q
76 ;
77ENDIQ1XN ;EP
78 S DIQ="XBDTMP("
79 D EN^DIQ1
80 Q
81 ;
82EXIT ;EP
83 KILL XBI,XBDEST,XBNEWPAR
84 Q
85 ;
86PULLDIQ1 ;EP - PULL FROM ^UTILITY("DIQ1",$J)
87 D %XY
88 S XBGLS=XBDIQ_"""ID"")" S @XBGLS=DA_":"_DIC_":"_XBUDA_":"_+XBDIQ(0)
89 D %XY^%RCR
90 Q
91 ;
92%XY ;EP - set %X & %Y to format
93 KILL %X,%Y
94 S XBUDA=""
950 I +XBDIQ(0)=0 D Q
96 . S %X="XBDTMP("_XBFN_","_DA_",",%Y=XBDIQ
97 .Q
981 I +XBDIQ(0)=1 D Q
99 . S %X="XBDTMP("_XBFN_",",%Y=XBDIQ,XBUDA=DA_","
100 .Q
1012 I +XBDIQ(0)=2 D Q
102 . S %X="XBDTMP("_XBFN_","
103 . D ;build da(x),..,da subscripts
104 .. S %Y=""
105 .. F %=1:1 Q:'$G(DA(%)) S %Y=DA(%)_","_%Y
106 ..Q
107 . S XBUDA=%Y_DA_","
108 . S %Y=XBDIQ_%Y
109 .Q
110%XYE Q
111 ;--
112DICFNGL(X) ;EP - set XBFN & XBGL0 return 1 error
113 NEW Y
114 KILL XBGL,XBFN
115 I X S XBFN=X D ^XBSFGBL(XBFN,.XBGL) Q
116 I 'X S Y=X_"0)" S XBFN=+$P(@Y,U,2),Y=0 D ^XBSFGBL(XBFN,.XBGL)
117 Q
118 ;
119DICFNGLX ;
120 Q
121 ;
122VAL(DIC,DA,DR) ;PEP - extrinsic pull a value for a field
123 NEW DIQ,XBT
124 S DIQ="XBT("
125 D EN
126 Q $G(XBT(+DR))
127 ;
128VALI(DIC,DA,DR) ;PEP - extrinsic pull a value for a field
129 NEW DIQ,XBT
130 S DIQ="XBT(",DIQ(0)="I"
131 D EN
132 Q $G(XBT(+DR,"I"))
133 ;
134PARSE(XBDA) ;PEP - parse DA literal into da array
135 NEW D,I,J
136 F I=1:1 S D(I)=$P(XBDA,",",I) Q:D(I)=""
137 S I=I-1
138 F J=0:1:I-1 S DA(J)=D(I-J)
139 F J=0:1:I-1 F Q:(DA(J)=+DA(J)) S DA(J)=@(DA(J))
140 S DA=DA(0)
141 KILL DA(0)
142 Q
143 ;
144DIC(XBFN) ;PEP - Extrensic entry to return DIC from global
145 NEW XBDIC
146 D EN^XBSFGBL(XBFN,.XBDIC)
147 S XBDIC=$P(XBDIC,"DA,")
148 Q XBDIC
149 ;
150LEVELS ;EP - setup XB_FN_DA_DR_FLD arrays for upper levels it they exist
151 ;set bottom level
152 KILL XB
153 S XBLVL=0
154 S XB(0,"DR")=DR,XB(0,"DA")=DA,XB(0,"FN")=XBFN
155 S XB(0,"FLD")=""
156 S XB(0,"PAR")=$G(^DD(XB(0,"FN"),0,"UP"))
157 S:XB(0,"PAR")]"" XB(XBLVL,"FLD")=$O(^DD(XB(0,"PAR"),"SB",XB(0,"FN"),""))
158 D ^XBSFGBL(XB(0,"FN"),.XBGBL0)
159 S XB(0,"GBL")=$P(XBGBL0,"DA,")
160 I XB(0,"PAR")]"" S XB(0+1,"FN")=XB(0,"PAR"),XBLVL=XBLVL+1 D PARENT
161 Q
162 ;
163PARENT ; gather parent information
164 ; build elements from XBFN(XBLVL)
165 S XB(XBLVL,"DA")=DA(XBLVL)
166 S XB(XBLVL,"DR")=XB(XBLVL-1,"FLD")
167 S XB(XBLVL,"FLD")=""
168 S XB(XBLVL,"PAR")=$G(^DD(XB(XBLVL,"FN"),0,"UP"))
169 S:XB(XBLVL,"PAR")]"" XB(XBLVL,"FLD")=$O(^DD(XB(XBLVL,"PAR"),"SB",XB(XBLVL,"FN"),""))
170 D ^XBSFGBL(XB(XBLVL,"FN"),.XBGBL0)
171 S XB(XBLVL,"GBL")=$P(XBGBL0,"DA,")
172 I XB(XBLVL,"PAR")]"" S XB(XBLVL+1,"FN")=XB(XBLVL,"PAR"),XBLVL=XBLVL+1 D PARENT
173EPAR ;
174 Q
175 ;
176SETDIQ1 ;EP - set DR(fn and DA(fn arrays for DIQ1
177 F XBLVL=0:1 Q:'$D(XB(XBLVL)) D
178 . S DR(XB(XBLVL,"FN"))=XB(XBLVL,"DR")
179 . S DA(XB(XBLVL,"FN"))=XB(XBLVL,"DA")
180 . S DIC=XB(XBLVL,"GBL")
181 . S DR=XB(XBLVL,"DR")
182 . S DA=XB(XBLVL,"DA")
183 .Q
184 ; kill off redundant DR( and DA(
185 S XBLVL=XBLVL-1
186 KILL DR(XB(XBLVL,"FN")),DA(XB(XBLVL,"FN"))
187 Q
188 ;
Note: See TracBrowser for help on using the repository browser.