source: BMXNET_RPMS_dotNET_UTILITIES-BMX/branch/routines/BMXRPC10.m@ 1181

Last change on this file since 1181 was 1181, checked in by Sam Habiel, 13 years ago

Fixes and enhancements to BMX4
File size: 10.2 KB
Line 
1BMXRPC10 ; IHS/OIT/GIS - RPC CALL FOR EXTENDED BROKER FUNCTIONALITY ; 5/11/11 4:35pm
2 ;;4.1000;BMX;;Apr 17, 2011
3 ;; LOGIN RPCS TO RETURN PATIENTS, VISITS AND FACILITIES. SUPPORTS MULTI-INDEX PATIENT LOOKUP (DOB, NAME, CHART#, ETC)
4 ;
5 ; Changes in v 4.1000 to support GT.M
6 ; - In BMXCCXT, there are several lines that rely on the
7 ; settings in BMX MONITOR file. We don't use that on GT.M
8 ; as xinetd handles all connection issues.
9 ; Also, at this point, we don't have integrated windows authentication
10 ; See below for the specific details.
11 ;
12GETFCRS(BMXFACS,BMXDUZ) ; EP - Gets all facilities for a user - returns RECORDSET
13 ;
14 ;S BMXFACS="T00030FACILITY_NAME^T00030FACILITY_IEN^T00002MOST_RECENT_LOOKUP"_$C(30)
15 N BMXI
16 S BMXI=0,BMXFACS=$NA(^TMP("BMX FIND",$J)) K @BMXFACS
17 S ^TMP("BMX FIND",$J,0)="T00030FACILITY_NAME^T00030FACILITY_IEN^T00002MOST_RECENT_LOOKUP"_$C(30)
18 I $G(BMXDUZ)="" G XFRCS
19 N BMXFN,BMXN,BMXSUB,BMXRCNT,CREF,OREF,SITE,LAST,DFLT
20 S BMXDUZ=$TR(BMXDUZ,$C(13),"")
21 S BMXDUZ=$TR(BMXDUZ,$C(10),"")
22 S BMXDUZ=$TR(BMXDUZ,$C(9),"")
23 S BMXFN=0
24 S CREF=$NA(^VA(200,BMXDUZ,2))
25 I '$O(@CREF@(0)) D G XFRCS ; GIS/OIT JAN 22, 2010 ; Ensure at least one site returned
26 . S BMXFN=$P(^AUTTSITE(1,0),U,1)
27 . S SITE=$P($G(^DIC(4,BMXFN,0)),U,1)
28 . S DFLT=0
29 . S BMXI=BMXI+1
30 . S ^TMP("BMX FIND",$J,BMXI)=SITE_U_BMXFN_U_DFLT_$C(30)
31 . Q
32 S OREF="^VA(200,"_BMXDUZ_",2,"
33 S LAST=$G(^DISV(BMXDUZ,OREF))
34 I LAST="" D
35 . S BMXFN=0
36 . F Q:LAST S BMXFN=$O(VA(200,BMXDUZ,2,BMXFN)) Q:'BMXFN D I LAST Q
37 .. I $P($G(^VA(200,BMXDUZ,2,BMXFN,0)),U,2) S LAST=BMXFN
38 .. Q
39 . Q
40 I LAST="" S LAST=$O(^VA(200,BMXDUZ,2,0)) ; IF LAST UNDEFINED, DEFAULT TO 1 ENTRY FOR THAT USER IN THE DIVISION SUBFILE
41 I LAST="" S LAST=$P($G(^XTV(8989.3,1,"XUS")),U,17) ; IF LAST UNDEFINED, GET VALUE FROM KERNEL SYSTEM PARAMETERS FILE
42 S BMXFN=0,STG=""
43 F S BMXFN=$O(@CREF@(BMXFN)) Q:'BMXFN D
44 . S SITE=$P($G(^DIC(4,BMXFN,0)),U,1) I SITE="" Q
45 . S DFLT=(LAST=BMXFN)
46 . S BMXI=BMXI+1
47 . S ^TMP("BMX FIND",$J,BMXI)=SITE_U_BMXFN_U_DFLT_$C(30)
48 . Q
49XFRCS S BMXI=BMXI+1
50 S ^TMP("BMX FIND",$J,BMXI)=$C(31)
51 Q
52 ;
53GETVIS(OUT,STG) ; EP - RETURN SPECIFIED # OF VALID VISITS FOR THE PATIENT
54 S OUT="T00010VISIT_IEN^T00030PATIENT_IEN^T00021TIMESTAMP^T00030VISIT_TYPE^T00030LOCATION^T00010SERVICE CATEGORY^T00030CLINIC^T00030PRIMARY_PROVIDER^T00030PRIMARY_POV"_$C(30)
55 I $L($G(STG))
56 E G VOUT
57 N X,Y,Z,%,HDR,LINE,DFN,MAX,IDT,VIEN,CNT,STOP,TS,VIEN,TYPE,LOC,SCAT,CLIN,PPRV,PPOV,BDT,VDT,DATA
58 S DFN=+STG I '$D(^DPT(DFN,0)) G VOUT
59 S MAX=$P(STG,"|",2) I 'MAX S MAX=9
60 I '$O(^AUPNVSIT("AA",+$G(DFN),0)) G VOUT
61 S IDT=0,CNT=0,STOP=0,DATA=""
62 S BDT=$$FMADD^XLFDT(DT,-2)
63 F Q:STOP S IDT=$O(^AUPNVSIT("AA",DFN,IDT)) Q:'IDT S VIEN=999999999999 F Q:STOP S VIEN=$O(^AUPNVSIT("AA",DFN,IDT,VIEN),-1) Q:'VIEN D Q
64 . S X=$G(^AUPNVSIT(VIEN,0)) I '$L(X) Q ; VISIT DATA MUST EXIST
65 . S VDT=+X I 'VDT Q
66 . I $P(X,U,11) Q ; MUST BE AN 'ACTIVE' VISIT - NOT 'DELETED'
67 . I $P(X,U,5)'=DFN Q ; INVALID PATIENT IEN
68 . I $P(X,U,3)="" Q ; VISIT MUST HAVE A TYPE
69 . I '$P(X,U,6) Q ; MUST HAVE A VALID ENCOUNTER LOCATION
70 . I $P(X,U,7)="" Q ; VISIT MUST HAVE A CATEGORY
71 . I $P(X,U,8)="" Q ; VISIT MUST HAVE A VALID CLINIC STOP
72 . I VDT<BDT,'$D(^AUPNVPOV("AD",VIEN)) Q ; MUST HAVE A POV ; PATCHED BY GIS 4/27/2009
73 . I VDT<BDT,'$D(^AUPNVPRV("AD",VIEN)) Q ; MUST HAVE A PROVIDER
74 . D VIS(VIEN,DFN,.DATA)
75 . S CNT=CNT+1
76 . I CNT=MAX S STOP=1
77 . Q
78VOUT S OUT=OUT_$G(DATA)_$C(31)
79 Q
80 ;
81VIS(VIEN,DFN,DATA) ; EP - APPEND VISIT DATA STRING
82 I $G(VIEN),$G(DFN)
83 E Q
84 N TYPE,LOC,SCAT,CLIN,PPRV,PPOV,VDT,FIEN,IENS,FLD,TYPE
85 S FIEN=9000010,IENS=VIEN_","
86 S TS=$$GET1^DIQ(FIEN,IENS,.01) I TS="" Q
87 S TYPE=$$GET1^DIQ(FIEN,IENS,.03)
88 S LOC=$$GET1^DIQ(FIEN,IENS,.06)
89 S SCAT=$$GET1^DIQ(FIEN,IENS,.07)
90 S CLIN=$$GET1^DIQ(FIEN,IENS,.08)
91 S PPRV=$$PPRV(VIEN)
92 S PPOV=$$PPOV(VIEN)
93 S DATA=DATA_VIEN_U_DFN_U_TS_U_LOC_U_SCAT_U_CLIN_U_PPRV_U_PPOV_$C(30)
94 Q
95 ;
96PPRV(VIEN) ; EP - GIVEN A VISIT IEN, RETURN THE PRIMARY PROVIDER NAME
97 ; CALLED BY THE BMX SCHEMA
98 I '$D(^AUPNVPRV("AD",+$G(VIEN))) Q ""
99 N NAME,PIEN,VPIEN,X,Y,Z,%
100 S VPIEN=0,PIEN=""
101 F S VPIEN=$O(^AUPNVPRV("AD",VIEN,VPIEN)) Q:'VPIEN D I PIEN Q
102 . S X=$G(^AUPNVPRV(VPIEN,0)) I X="" Q
103 . S TYPE=$P(X,U,4)
104 . I TYPE="P" S PIEN=+X
105 . Q
106 I 'PIEN S VPIEN=$O(^AUPNVPRV("AD",VIEN,0)) I VPIEN S PIEN=+$G(^AUPNVPRV(VPIEN,0))
107 I 'PIEN Q ""
108 S PIEN=$$PRV^VENPCCU(PIEN)
109 S NAME=$P($G(^VA(200,PIEN,0)),U)
110 Q NAME
111 ;
112PPOV(VIEN) ; EP - GIVEN A VISIT IEN, RETURN THE PRIMARY PURPOSE OF VISIT ICD CODE (NARRATIVE)
113 ; CALLED BY BMX SCHEMA
114 I '$D(^AUPNVPOV("AD",+$G(VIEN))) Q ""
115 N TXT,IIEN,VPIEN,X,Y,Z,%,ICD,NIEN,DX
116 S VPIEN=0,IIEN=""
117 F S VPIEN=$O(^AUPNVPOV("AD",VIEN,VPIEN)) Q:'VPIEN D I IIEN Q
118 . S X=$G(^AUPNVPOV(VPIEN,0)) I X="" Q
119 . S TYPE=$P(X,U,12)
120 . I TYPE="P" S IIEN=+X
121 . Q
122 I 'IIEN S VPIEN=$O(^AUPNVPOV("AD",VIEN,0)) I VPIEN S IIEN=+$G(^AUPNVPOV(VPIEN,0))
123 I IIEN,VPIEN
124 E Q ""
125 I $L($T(ICDDX^ICDCODE)) S ICD=$P($$ICDDX^ICDCODE(IIEN),U,2) I 1
126 E S ICD=$P($G(^ICD9(IIEN,0)),U)
127 I '$L(ICD) Q ""
128 S NIEN=$P($G(^AUPNVPOV(VPIEN,0)),U,4) I 'NIEN Q ""
129 S TXT=$P($G(^AUTNPOV(NIEN,0)),U) I TXT="" Q ""
130 I $L(TXT)>20 S TXT=$E(TXT,1,17)_"..."
131 S DX=ICD_" ("_TXT_")"
132 Q DX
133 ;
134GETPAT(BMXRET,BMXSTR) ; EP - -- return patient in ADO table
135 ; S X="MERR^BMXGU",@^%ZOSF("TRAP") ; m error trap
136 N BMXI,BMXERR,BMXUIEN,P,X,Y,Z,%,%DT
137 S P="|"
138 K ^BMXTMP($J)
139 S BMXI=0
140 S BMXERR=""
141 S BMXRET="T00010IEN^T00030PATIENTNAME^T00015DOB^T00001SEX^T00007CHART^T00009SSN^T00010REG^T00030LASTUPDATE^T00030CLASSBEN^T00010AGE"_$C(30)
142 S BMXPAT=$P(BMXSTR,P,1)
143 S BMXMT=$P(BMXSTR,P,2)
144 ; S BMXNPAT=$P(BMXSTR,P,4)
145 I BMXMT="ALL"!(BMXMT="") S BMXMT=9999999
146 S BMXMT=(BMXMT-1)
147 S BMXPIEN=""
148 S X=BMXPAT D ^%DT
149 S Y=Y\1
150 I $E(Y,4,5)="00" G GETADO
151 I $E(Y,6,7)="00" G GETADO
152 I Y?7N D G GETADO
153 . S BMXPAT=Y
154 . S BMXPATE=$$PATDOB(.BMXPIEN,BMXPAT)
155 S X=$TR($P(BMXPAT," "),",","")
156 I X?1.30U S BMXPATE=$$PATNAM(.BMXPIEN,BMXPAT,"") G GETADO
157 I BMXPAT?9N D G GETADO
158 . S BMXPIEN=$$PATSSN(BMXPAT)
159 I BMXPAT?1.6N D G GETADO
160 . S BMXPIEN=$$PATCHT(.BMXPIEN,BMXPAT)
161GETADO I $G(BMXPIEN),'$G(BMXPATS) D PATADO(.BMXPIEN)
162 S BMXRET=BMXRET_$C(31)_$G(BMXERR)
163 K BMXPAT,BMXPIEN,BMXCNT,BMXDA,BMXIEN,BMXPATE,BMXNM,BMXDB,BMXSX,BMXCT,BMXSSN
164 K BMXPATS
165 Q
166 ;
167PATSSN(PAT) ;-- look up by ssn
168 S BMXPIEN=$O(^DPT("SSN",PAT,0))
169 S BMXPIEN(1)=BMXPIEN
170 Q $G(BMXPIEN)
171 ;
172PATCHT(BMXPIEN,HRN) ;-- lookup by chart
173 N BMXCNT
174 S BMXCNT=0,BMXPATE=0,BMXMCNT=0,BMXPIEN=""
175 S BMXIEN=0 F S BMXIEN=$O(^AUPNPAT("D",HRN,BMXIEN)) Q:'BMXIEN D I BMXPIEN Q
176 . I '$D(^AUPNPAT("D",HRN,BMXIEN,DUZ(2))) Q
177 . S %=$O(^AUPNPAT("D",HRN,BMXIEN)) I %,$D(^AUPNPAT("D",HRN,%,DUZ(2))) S BMXIEN=999999999 Q ; MORE THAN ONE PAT WITH THIS CHART NUMBER!
178 . S BMXPIEN=BMXIEN
179 . S BMXCNT=BMXCNT+1
180 . S:'$D(BMXPIEN(BMXCNT)) BMXPIEN(BMXCNT)=0
181 . S BMXPIEN(BMXCNT)=BMXPIEN
182 . Q
183 Q BMXPIEN
184 ;
185PATDOB(BMXPATE,PAT) ;-- lookup by DOB
186 N BMXCNT
187 S BMXCNT=0,BMXPATE=0
188 S BMXIEN=0
189 F S BMXIEN=$O(^DPT("ADOB",PAT,BMXIEN)) Q:'BMXIEN D
190 . S:'$D(BMXPATE(BMXCNT)) BMXPATE(BMXCNT)=0
191 . S BMXCNT=BMXCNT+1,BMXPATE=1
192 . S BMXPATE(BMXCNT)=BMXIEN
193 . Q
194 S BMXPATE=BMXCNT
195 Q $G(BMXPATE)
196 ;
197PATNAM(BMXPATE,PAT,NPAT) ;lookup by name
198 S BMXCNT=0,BMXPATE=0
199 N BMXLEN
200 S BMXLEN=$L(PAT)
201 S BMXNAM=PAT
202 S BMXNAM=$$BEGIN(PAT)
203 I $G(NPAT)]"" S BMXNAM=NPAT
204 F S BMXNAM=$O(^DPT("B",BMXNAM)) Q:BMXNAM=""!($E(BMXNAM,1,BMXLEN)'=PAT)!(BMXCNT>BMXMT) D
205 . S BMXIEN=0 F S BMXIEN=$O(^DPT("B",BMXNAM,BMXIEN)) Q:'BMXIEN D
206 .. Q:$O(^DPT("B",BMXNAM,BMXIEN,0)) ;cmi/maw 4/25/2005 don't get aliases
207 .. S BMXCNT=BMXCNT+1
208 .. S:'$D(BMXPATE(BMXCNT)) BMXPATE(BMXCNT)=0
209 .. S BMXPATE(BMXCNT)=BMXIEN
210 S BMXPATE=BMXCNT
211 Q $G(BMXPATE)
212 ;
213BEGIN(PT) ;-- get begin point
214 N BMXPDA,BMXPIEN,BMXPCNT
215 S BMXPCNT=0
216 S BMXPDA=PT
217 I $O(^DPT("B",BMXPDA,0)) D
218 . S BMXPDA=$O(^DPT("B",BMXPDA),-1)
219 F S BMXPDA=$O(^DPT("B",BMXPDA)) Q
220 I $G(BMXPDA)="" Q ""
221 Q $O(^DPT("B",BMXPDA),-1)
222 ;
223PATADO(PIEN) ;-- ado return
224 I '$G(DUZ(2)) Q ; DIVISION
225 S BMXCNTR=0
226 S BMXDA=0 F S BMXDA=$O(PIEN(BMXDA)) Q:'BMXDA D
227 . S BMXCNTR=BMXCNTR+1
228 . S BMXPI=$G(PIEN(BMXDA))
229 . I '$D(^AUPNPAT(BMXPI,41,DUZ(2),0)) Q ; PATIENT NOT REGISTERED IN THE CURRENT DIVISION
230 . S BMXNM=$P($G(^DPT(BMXPI,0)),U)
231 . S BMXDB=$$FMTE^XLFDT($P($G(^DPT(BMXPI,0)),U,3))
232 . S BMXSX=$P($G(^DPT(BMXPI,0)),U,2)
233 . S BMXCT=$$HRN^AUPNPAT(BMXPI,DUZ(2))
234 . S BMXSSN=$P($G(^DPT(BMXPI,0)),U,9)
235 . S BMXUPD=$P($G(^AUPNPAT(BMXPI,0)),U,3)
236 . S BMXELG=$$GET1^DIQ(9000001,BMXPI,1111) ;cmi/maw 5/17/2007 added class/ben for status bar
237 . S BMXAGE=$$AGE^AUPNPAT(BMXPI,DT)
238 . S BMXI=BMXI+1
239 . S BMXRET=BMXRET_BMXPI_U_BMXNM_U_BMXDB_U_BMXSX_U_BMXCT_U_BMXSSN_U_$G(BMXHD)_U_BMXUPD_U_BMXELG_U_BMXAGE_$C(30)
240 Q
241 ;
242BMXCCXT(RESULT,XOPTION) ;creates context for the passed in option
243 N XWB1,%,IEN,SIEN,OK,OPTION
244 S RESULT=0
245 S OPTION=$$DECRYP^XUSRB1(XOPTION) ;S:OPTION="" OPTION="\"
246 I $E(OPTION,1,3)="BMX" S RESULT=1 Q ; NO RESTRICTIONS FOR BMX CONTEXT FOR THIS PORT
247 K XQY0,XQY
248 I OPTION="" S XQY=0,XQY0="" Q ;delete context if "" passed in N PORT
249 ;
250 ; Following lines are addition for 4.1000; GT.M does not use BMXMON
251 D:^%ZOSF("OS")["OpenM" ; Doesn't apply to GT.M; Only Cache
252 . S PORT=+$P($P,"|",3) I 'PORT Q
253 . S IEN=$O(^BMXMON("B",PORT,0)) I 'IEN Q
254 . I '$O(^BMXMON(IEN,1,0)) G BC1 ; NO RESTRICTIONS ON CONTEXT FOR THIS PORT
255 . S OK=0,CIEN=0
256 . F S CIEN=$O(^BMXMON(IEN,1,CIEN)) Q:'CIEN D I OK Q
257 . . S %=$P($G(^BMXMON(IEN,1,CIEN,0)),U) I '% Q
258 . . S %=$P($G(^DIC(19,%,0)),U) I %="" Q
259 . . I %=OPTION S OK=1
260 . . Q
261 . I 'OK S (XWBSEC,RESULT)="The context '"_OPTION_"' is not registered with port "_PORT_"." Q
262BC1 S XWB1=$$OPTLK^XQCS(OPTION)
263 I XWB1="" S (XWBSEC,RESULT)="The context '"_OPTION_"' does not exist on server." Q ;P10
264 S RESULT=$$CHK^XQCS(DUZ,XWB1)
265 ;Access or programmer
266BC2 I RESULT!$$KCHK^XUSRB("XUPROGMODE") S XQY0=OPTION,XQY=XWB1,RESULT=1 Q
267 S XWBSEC=RESULT
268 Q
269 ;
270CVC(OUT,IN) ; EP - RPC: BMX CVC ; CHECK VERIFY CODE (SEE CVC^XUSRB)
271 S OUT(0)=99,OUT(1)="INVALID PARAMETERS"
272 I $L(IN)
273 E Q
274 N AV,EAC,EOVC,ENVC,USER,AC,OVC,NVC,EVC,NVC,X,Y,Z,%,RET,U
275 S U="^",RET(0)="",RET(1)=""
276 S AV=$$DECRYP^XUSRB1(IN) I AV="" Q
277 S AC=$P(AV,";")
278 S X=$$EN^XUSHSH(AC)
279 S USER=$O(^VA(200,"A",X,0)) I 'USER Q
280 S @$C(68,85,90)=USER
281 S OVC=$P(AV,";",2) I OVC="" Q
282 S NVC=$P(AV,";",3) I NVC="" Q
283 S EOVC=$$ENCRYP^XUSRB1(OVC)
284 S ENVC=$$ENCRYP^XUSRB1(NVC)
285 D CVC^XUSRB(.RET,(ENVC_U_EOVC))
286 M OUT=RET
287 Q
288 ;
289TEST ; TEST CVC
290 N DUZ,IN
291 S IN=$$ENCRYP^XUSRB1("GREG4330;IRA-1727;IRA-1727")
292 D CVC^BMXRPC10(.OUT,IN) W !,$G(OUT(0))," - ",$G(OUT(1))
293 Q
294 ;
Note: See TracBrowser for help on using the repository browser.