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

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

Mumps Routines 4 BMX4

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