source: WorldVistAEHR/trunk/r/IHS_ROUTINES-AUP/AUPNLK1.m@ 1766

Last change on this file since 1766 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 5.6 KB
Line 
1AUPNLK1 ; IHS/CMI/LAB - IHS PATIENT LOOKUP CHECK XREFS ;12/26/06 10:52
2 ;;1.0;PCE PATIENT CARE ENCOUNTER;**167**;Aug 12, 1996;Build 22
3 ; Copyright (C) 2007 WorldVistA
4 ;
5 ; This program is free software; you can redistribute it and/or modify
6 ; it under the terms of the GNU General Public License as published by
7 ; the Free Software Foundation; either version 2 of the License, or
8 ; (at your option) any later version.
9 ;
10 ; This program is distributed in the hope that it will be useful,
11 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 ; GNU General Public License for more details.
14 ;
15 ; You should have received a copy of the GNU General Public License
16 ; along with this program; if not, write to the Free Software
17 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
18 ;'Modified' MAS Patient Look-up Check Cross-References June 1987
19 ;
20 ; Upon exiting this routine AUPDFN will exist as follows:
21 ; AUPDFN = 0 means no hits
22 ; AUPDFN < 0 means hits but no selection
23 ; AUPDFN > 0 means selection made
24 ;
25START ;
26 D INIT ; Fix up AUPX & set up xrefs
27 D SEARCH ; Search xrefs
28 D EOJ ; Cleanup
29 Q
30 ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
31 ;
32SEARCH ; SEARCH XREFS
33 F AUPLP=1:1 S AUPREF=$P(AUPREFS,",",AUPLP) Q:AUPREF=""!(AUPDFN) D
34 .I AUPREF="ADOB" S AUPVAL=AUPDT
35 .E I AUPREF="AZVWVOE" S AUPVAL=$E($TR(AUPX,"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!@#$%^&*()-_=+[]{}<>,./?:;'\|"),1,30)
36 .E S AUPVAL=AUPX
37 .D IHSVAL I 'AUPDFN,AUPREF="B" D IHSB I 'AUPDFN D IHSCHK
38 I 'AUPDFN S:AUPCNT=1&($D(AUPIFNS(AUPCNT))) AUPDFN=+AUPIFNS(AUPCNT) S AUP("NOPRT^")="" D PRTAUP^AUPNLKUT:'AUPDFN&(AUPCNT>AUPNUM)&(DIC(0)["E") K AUP("NOPRT^") I 'AUPDFN,$D(AUPSEL),AUPSEL="" S AUPX="",AUPDFN=-1
39 Q
40 ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
41 ;
42IHSB ; CHECK TRANSPOSED OR MISSING FIRST/MIDDLE
43 Q:AUPX'?1A.E1",".E
44 S AUPNML=$P(AUPX,",",1),AUPNMF=$P($P(AUPX,",",2)," ",1),AUPNMM=$P($P(AUPX,",",2)," ",2)
45 Q:AUPNMF=""
46 I AUPNMF?.E1P.E S X=AUPNMF D PUNC S AUPNMF=X
47 I AUPNMM?.E1P.E S X=AUPNMM D PUNC S AUPNMM=X
48 S AUPBX=AUPNML
49 F AUPBI=0:0 Q:AUPDFN S AUPBX=$O(^DPT("B",AUPBX)) Q:$P($P(AUPBX,",",1)," ",1)'=AUPNML S AUPBY=$P(AUPBX,",",2) D IHSB2 I Y F Y=0:0 S Y=$O(^DPT("B",AUPBX,Y)) Q:'Y I '$D(AUPS(Y)) S AUPVAL=AUPBX,AUPNICK(Y)="" D SETAUP^AUPNLKUT Q:AUPDFN
50 K AUPBI,AUPBX,AUPBY
51 Q
52 ;
53PUNC ;
54 F I=1:1:$L(X) I $E(X,I)?1P S X=$E(X,1,I-1)_$E(X,I+1,99)
55 Q
56 ;
57IHSB2 ;
58 S Y=0
59 I " "_$P(AUPBY," ",2)[(" "_AUPNMF)," "_$P(AUPBY," ",1)[(" "_AUPNMM) S Y=1 Q
60 I " "_$P(AUPBY," ",1)[(" "_AUPNMF)," "_$P(AUPBY," ",2)[(" "_AUPNMM) S Y=1 Q
61 Q
62 ;
63IHSCHK ; CHECK NICKNAMES AND LAST NAME FOR MISPELLING
64 Q:AUPX'?1A.E1",".E
65 S AUPNMCVN=3
66 D IHSCHK4
67 Q:AUPDFN
68 S AUPNMCHK("AUPX")=AUPX
69 S AUPNMCHK("LAST")=$P(AUPX,",",1)
70 I $D(^APMM(98,"B",AUPNMCHK("LAST"))) F AUPNMCHK("EN")=0:0 S AUPNMCHK("EN")=$O(^APMM(98,"B",AUPNMCHK("LAST"),AUPNMCHK("EN"))) Q:AUPNMCHK("EN")="" D IHSCHK2 Q:AUPDFN
71 S AUPX=AUPNMCHK("AUPX")
72 K AUPNMCHK,AUPNMCVN
73 Q
74 ;
75IHSCHK2 ;
76 K AUPNMCHK("TBL")
77 S AUPNMCHK("TBL",$P(^APMM(98,AUPNMCHK("EN"),0),U,1))=""
78 F AUPL=0:0 S AUPL=$O(^APMM(98,AUPNMCHK("EN"),"F",AUPL)) Q:AUPL'=+AUPL S AUPNMCHK("TBL",$P(^APMM(98,AUPNMCHK("EN"),"F",AUPL,0),U,1))=""
79 K AUPNMCHK("TBL",$P(AUPNMCHK("AUPX"),U,1))
80 S AUPNMCHK("NLAST")="" F AUPL=0:0 S AUPNMCHK("NLAST")=$O(AUPNMCHK("TBL",AUPNMCHK("NLAST"))) Q:AUPNMCHK("NLAST")="" D IHSCHK3 Q:AUPDFN
81 Q
82 ;
83IHSCHK3 ;
84 S $P(AUPX,",",1)=AUPNMCHK("NLAST"),AUPVAL=AUPX
85 S AUPNMCVN=3
86 D IHSVAL
87 Q:AUPDFN
88 D IHSCHK4
89 Q
90 ;
91IHSCHK4 ; CHECK FIRST & MIDDLE NAMES FOR NICK NAMES
92 S AUPNML=$P(AUPX,",",1),AUPNMF=$P($P(AUPX,",",2)," ",1),AUPNMM=$P($P(AUPX,",",2)," ",2)
93 Q:AUPNMF=""
94 I $D(^APMM(99,"B",AUPNMF)) S AUPNMCVN=1 F AUPNMCV=0:0 S AUPNMCV=$O(^APMM(99,"B",AUPNMF,AUPNMCV)) Q:AUPNMCV="" D IHSNMCV Q:AUPDFN
95 K AUPNMCV,AUPNMCVT
96 Q:AUPDFN
97 I AUPNMM'="",$D(^APMM(99,"B",AUPNMM)) S AUPNMCVN=2 F AUPNMCV=0:0 S AUPNMCV=$O(^APMM(99,"B",AUPNMM,AUPNMCV)) Q:AUPNMCV="" D IHSNMCV Q:AUPDFN
98 K AUPNMCV,AUPNMCVN,AUPNMCVT
99 Q:AUPDFN
100 K AUPNML,AUPNMF,AUPNMM
101 Q
102 ;
103IHSNMCV ; CHECK NICK NAMES
104 K AUPNMCVT
105 S AUPNMCVT($P(^APMM(99,AUPNMCV,0),U,1))=""
106 F AUPL=0:0 S AUPL=$O(^APMM(99,AUPNMCV,"F",AUPL)) Q:AUPL'=+AUPL S AUPNMCVT($P(^APMM(99,AUPNMCV,"F",AUPL,0),U,1))=""
107 K AUPNMCVT($S(AUPNMCVN=1:AUPNMF,1:AUPNMM))
108 S AUPNMCVI="" F AUPL=0:0 S AUPNMCVI=$O(AUPNMCVT(AUPNMCVI)) Q:AUPNMCVI=""!(AUPDFN) S AUPVAL=AUPNML_","_$S(AUPNMCVN=1:AUPNMCVI,1:AUPNMF)_$S(AUPNMCVN=1&(AUPNMM'=""):" "_AUPNMM,AUPNMCVN=2:" "_AUPNMCVI,1:"") D IHSNMCV2
109 K AUPNMCVI
110 Q
111 ;
112IHSNMCV2 ;
113 S AUPNMCVX=AUPX,AUPX=AUPVAL
114 D IHSVAL
115 S AUPX=AUPNMCVX
116 K AUPNMCVX
117 Q
118 ;
119IHSVAL ;
120 I $D(^DPT(AUPREF,AUPVAL))&(DIC(0)["X") D CHKIFN Q
121 D:$D(^DPT(AUPREF,AUPVAL)) CHKIFN
122 D:DIC(0)'["X" CHKVAL
123 Q
124 ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
125 ;
126CHKVAL ;
127 S AUPVAL=$S($D(AUPNMCVN):AUPVAL,AUPREF="ADOB":AUPDT,AUPX?.N:AUPX_" ",1:AUPX) S:$E(AUPVAL,$L(AUPVAL))="." AUPVAL=$E(AUPVAL,1,$L(AUPVAL)-1)
128 F AUPLP1=0:0 S AUPVAL=$O(^DPT(AUPREF,AUPVAL)) Q:AUPVAL=""!(AUPDFN)!($P(AUPVAL,$S($E(AUPX,$L(AUPX))=".":$E(AUPX,1,$L(AUPX)-1),1:AUPX))'="") D CHKIFN
129 Q
130 ;
131CHKIFN ;
132 F AUPIFN=0:0 S AUPIFN=$O(^DPT(AUPREF,AUPVAL,AUPIFN)) Q:'AUPIFN!(AUPDFN) S Y=AUPIFN D SETAUP^AUPNLKUT I $S<1000 F AUPI=1:1:AUPNUM-5 Q:'$D(AUPIFNS(AUPI)) K AUPIFNS(AUPI) S AUPBEG=AUPI
133 Q
134 ;
135 ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
136 ;
137INIT ; INITIALIZATION - FIX UP AUPX AND SET UP XREFS
138 D ^AUPNLK1I
139 Q
140 ;
141 ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
142 ;
143EOJ ;
144 K AUPBEG,AUPDT,AUPI,AUPIFN,AUPIFNS,AUPLP,AUPLK1,AUPNMCHK,AUPNMCV,AUPNMCVN,AUPNMCVT,AUPNMF,AUPNML,AUPNMM,AUPNUM,AUPREF,AUPREFS,AUPVAL
145 Q
Note: See TracBrowser for help on using the repository browser.