source: BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXRPC.m@ 1187

Last change on this file since 1187 was 1147, checked in by Sam Habiel, 14 years ago

Mumps Routines 4 BMX4
File size: 6.2 KB
RevLine 
[1147]1BMXRPC ; IHS/OIT/HMW - BMX REMOTE PROCEDURE CALLS ; 4/7/11 2:06pm
2 ;;4.1000;BMX;;Apr 17, 2011
3 ;;Stolen from:* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
4 ;; GENERIC LOOKUP UTILITY FOR RETURNING MATCHING RECORDS
5 ;; OR TABLES TO RPC'S.
6 ;
7 ; *** NOTE: I have discovered a number of cases where these calls
8 ; produce errors (with error messages to IO) or simply
9 ; do not work correctly. ANY CALL to this utility
10 ; should be thoroughly tested in the M environment
11 ; before being used as an RPC.
12 ;
13 ; Change Log:
14 ; WV/SMH on Apr 7 2011 -- added RPC for determining UTF-8 support on GT.M
15 ; Tag: UTF-8
16 ;
17 ;----------
18LOOKUP(BMXGBL,BMXFL,BMXFLDS,BMXFLG,BMXIN,BMXMX,BMXIX,BMXSCR,BMXMC) ;EP
19 ;---> Places matching records from requested file into a
20 ;---> result global, ^BMXTEMP($J). The exact global name
21 ;---> is returned in the first parameter (BMXGBL).
22 ;---> Records are returned one per node in the result global.
23 ;---> Each record is terminated with a $C(30), for parsing out
24 ;---> on the VB side, since the Broker concatenates all nodes
25 ;---> into a single string when passing the data out of M.
26 ;---> Requested fields within records are delimited by "^".
27 ;---> NOTE: The first "^"-piece of every node is the IEN of
28 ;---> that entry in its file; the requested fields follow.
29 ;---> The final record (node) contains Error Delimiter,
30 ; $C(31)_$C(31), followed by error text, if any.
31 ;
32 ;---> Parameters:
33 ; 1 - BMXGBL (ret) Name of result global for Broker.
34 ; 2 - BMXFL (req) File for lookup.
35 ; 3 - BMXFLDS (opt) Fields to return w/each entry.
36 ; 4 - BMXFLG (opt) Flags in DIC(0); If null, "M" is sent.
37 ; 5 - BMXIN (opt) Input to match on (see Algorithm below).
38 ; 6 - BMXMX (opt) Maximum number of entries to return.
39 ; 7 - BMXIX (opt) Indexes to search.
40 ; 8 - BMXSCR (opt) Screen/filter (M code).
41 ; 9 - BMXMC (opt) Mixed Case: 1=mixed case, 0=no change.
42 ; (Converts data in uppercase to mixed case.)
43 ;
44 ;---> Set variables, kill temp globals.
45 N (BMXGBL,BMXFL,BMXFLDS,BMXFLG,BMXIN,BMXMX,BMXIX,BMXSCR,BMXMC) ;IHS/OIT/HMW SAC Exemption Applied For
46 S BMX31=$C(31)_$C(31)
47 S BMXGBL="^BMXTEMP("_$J_")",BMXERR="",U="^"
48 K ^BMXTMP($J),^BMXTEMP($J)
49 ;
50 ;---> If file number not provided, return error.
51 I '$G(BMXFL) D ERROUT("File number not provided.",1) Q
52 ;
53 ;---> If no fields provided, pass .01.
54 ;---> IEN will always be the first piece of data returned.
55 ;---> NOTE: If .01 is NOT included, but the Index to lookup on is
56 ;---> NOT on the .01, then the .01 will be returned
57 ;---> automatically as the second ^-piece of data in the
58 ;---> Result Global.
59 ;---> So it would be: IEN^.01^requested fields...
60 I $G(BMXFLDS)="" S BMXFLDS=".01"
61 ;
62 ;---> If no index or flag provided, set flag="M".
63 I $G(BMXFLG)="" D
64 .I $G(BMXIX)="" S BMXFLG="M" Q
65 .S BMXFLG=""
66 ;
67 ;---> If no Maximum Number provided, set it to 200.
68 I '$G(BMXMX) S BMXMX=200
69 ;
70 ;---> Define index and screen.
71 S:'$D(BMXIX) BMXIX=""
72 S:'$D(BMXSCR) BMXSCR=""
73 ;
74 ;---> Set Target Global for output and errors.
75 S BMXG="^BMXTMP($J)"
76 ;
77 ;---> If Mixed Case not set, set to No Change.
78 I '$D(BMXMC) S BMXMC=0
79 ;
80 ;---> Silent Fileman call.
81 D
82 .I $G(BMXIN)="" D Q
83 ..D LIST^DIC(BMXFL,,BMXFLDS,,BMXMX,0,,BMXIX,BMXSCR,,BMXG,BMXG)
84 .D FIND^DIC(BMXFL,,BMXFLDS,BMXFLG,BMXIN,BMXMX,BMXIX,BMXSCR,,BMXG,BMXG)
85 ;
86 D WRITE
87 Q
88 ;
89 ;
90 ;----------
91WRITE ;EP
92 ;---> Collect data for matching records and write in result global.
93 ;
94 ;---> First, check for errors.
95 ;---> If errors exist, write them and quit.
96 N I,N,X
97 I $D(^BMXTMP($J,"DIERR")) I $O(^("DIERR",0)) D Q
98 .S N=0,X=""
99 .F S N=$O(^BMXTMP($J,"DIERR",N)) Q:'N D
100 ..N M S M=0
101 ..F S M=$O(^BMXTMP($J,"DIERR",N,"TEXT",M)) Q:'M D
102 ...S X=X_^BMXTMP($J,"DIERR",N,"TEXT",M)_" "
103 .D ERROUT(X,1)
104 ;
105 ;
106 ;---> Write Field Names
107 S $P(ASDX,"^",1)="IEN"
108 F ASDC=1:1:$L(BMXFLDS,";") D
109 . S ASDXFNUM=$P(BMXFLDS,";",ASDC)
110 . S ASDXFNAM=$P(^DD(BMXFL,ASDXFNUM,0),"^")
111 . S:ASDXFNAM="" ASDXFNAM="UNKNOWN"_ASDC
112 . S $P(ASDX,"^",ASDC+1)=ASDXFNAM
113 S ^BMXTEMP($J,1)=ASDX_$C(30)
114 ;---> Write valid results.
115 ;---> Loop through the IEN node (...2,N) of the temp global.
116 N I,N,X S N=0
117 F I=2:1 S N=$O(^BMXTMP($J,"DILIST",2,N)) Q:'N D
118 .;---> Always set first piece of X=IEN of entry.
119 .S X=^BMXTMP($J,"DILIST",2,N)
120 .;
121 .;---> Collect other fields and concatenate to X.
122 .N M S M=0
123 .F S M=$O(^BMXTMP($J,"DILIST","ID",N,M)) Q:'M D
124 ..S X=X_U_^BMXTMP($J,"DILIST","ID",N,M)
125 .;
126 .;---> Convert data to mixed case if BMXMC=1.
127 .S:BMXMC X=$$T^BMXTRS(X)
128 .;
129 .;---> Set data in result global.
130 .S ^BMXTEMP($J,I)=X_$C(30)
131 ;
132 ;---> If no results, report it as an error.
133 D:'$O(^BMXTEMP($J,0))
134 .I BMXIN]"" S BMXERR="No entry matches """_BMXIN_"""." Q
135 .S BMXERR="Either the lookup file is empty"
136 .S BMXERR=BMXERR_" or all entries are screened (software error)."
137 ;
138 ;---> Tack on Error Delimiter and any error.
139 S ^BMXTEMP($J,I)=BMX31_BMXERR
140 Q
141 ;
142 ;
143 ;----------
144ERROUT(BMXERR,I) ;EP
145 ;---> Save next line for Error Code File if ever used.
146 ;---> If necessary, use I>1 to avoid overwriting valid data.
147 S:'$G(I) I=1
148 S ^BMXTEMP($J,I)=BMX31_BMXERR
149 Q
150 ;
151 ;
152PASSERR(BMXGBL,BMXERR) ;EP
153 ;---> If the RPC routine calling the BMX Generic Lookup above
154 ;---> detects a specific error prior to the call and wants to pass
155 ;---> that error in the result global rather than a generic error,
156 ;---> then a call to this function (PASSERR) can be made.
157 ;---> This call will store the error text passed in the result global.
158 ;---> The calling routine should then quit (abort its call to the
159 ;---> BMX Generic Lookup function above).
160 ;
161 ;---> Parameters:
162 ; 1 - BMXGBL (ret) Name of result global for Broker.
163 ; 2 - BMXERR (req) Text of error to be stored in result global.
164 ;
165 S:$G(BMXERR)="" BMXERR="Error not passed (software error)."
166 ;
167 N BMX31 S BMX31=$C(31)_$C(31)
168 K ^BMXTMP($J),^BMXTEMP($J)
169 S BMXGBL="^BMXTEMP("_$J_")"
170 S ^BMXTEMP($J,1)=BMX31_BMXERR
171 Q
172UTF8(BMXRET) ; PEP - Does this DB Support UTF-8 encoding?
173 ; RPC: BMX UTF-8
174 ; 0 for FALSE for 1 for TRUE.
175 I ^%ZOSF("OS")'["GT.M" S BMXRET=0 QUIT
176 I $ZCHSET="M" S BMXRET=0 QUIT
177 I $ZCHSET="UTF-8" S BMXRET=1 QUIT
178 S BMXRET=0 QUIT ;default
Note: See TracBrowser for help on using the repository browser.