source: WorldVistAEHR/trunk/r/IHS_ROUTINES-AUP/AUPNLKB.m@ 1432

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

initial load of WorldVistAEHR

File size: 3.6 KB
Line 
1AUPNLKB ; IHS/CMI/LAB - Broke up AUPNLK because of size ;8DEC2006
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 ;
20LOOKUPS ; EXTERNAL ENTRY POINT
21 S AUPBEG=1,(AUPDFN,AUPNUM)=0
22 D QUICK ; Try quick lookups first
23 I AUPQF Q ;HERE IS WHERE WE WOULD GO FARTHER IN OUR SEARCH IF MATCHING HRN WASN'T GOOD ENOUGH --GFT
24 D XREFS ; Try lookup on xrefs
25 Q:AUPQF
26 I DIC(0)["N" D DFN ; Try by DFN
27 Q:AUPQF
28 Q
29 ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
30 ;
31QUICK ; QUICK LOOKUPS
32 I $D(AUPNLK("ICN")) D ICN Q
33 D IHSCHRT I AUPDFN>0 S AUPQF=4 Q ;**GFT/VW
34 I AUPX["^" S AUPQF=3 Q
35 S AUPDFN=0
36 I AUPX=" " S Y=$S('($D(DUZ)#2):-1,$D(^DISV(DUZ,"^DPT(")):^("^DPT("),1:-1) D SETAUP^AUPNLKUT:Y>0 S AUPDFN=$S($D(AUPS(Y)):Y,1:-1) D CHKDFN K AUPSP Q
37 I $E(AUPX)="`" S Y=$S($D(^DPT(+$P(AUPX,"`",2),0)):+$P(AUPX,"`",2),1:-1) D SETAUP^AUPNLKUT:Y>0 S AUPDFN=$S($D(AUPS(Y)):Y,1:-1) D CHKDFN Q
38 Q
39 ;
40ICN ; LOOKUP BY ICN (for MFI)
41 S AUPDFN=-1
42 S X=$P(AUPNLK("ICN"),":",2),AUPNLK("ICN")=$P(AUPNLK("ICN"),":",1)
43 Q:X'?1N.N
44 Q:AUPNLK("ICN")'?1N.N
45 Q:'$D(^AUTTLOC(AUPNLK("ICN"),0))
46 Q:'$D(^AUPNPAT("AICN",AUPNLK("ICN"),X))
47 S (AUPDFN,Y)=$O(^(X,0))
48 S:$D(DIC("S")) AUPNLK("DICS")=DIC("S") K DIC("S") D SETAUP^AUPNLKUT S:$D(AUPNLK("DICS")) DIC("S")=AUPNLK("DICS") K AUPNLK("DICS")
49 S AUPQF=4
50 Q
51 ;
52IHSCHRT ; LOOKUP CHART #
53 Q:'$D(^AUPNPAT("D",AUPX))
54ALLQ D IHSCHRT1:'$G(AUPNLK("ALL")),IHSCHRT2:$G(AUPNLK("ALL"))
55 Q
56 ;
57IHSCHRT1 ; LOOKUP CHART # WHEN ONLY 1 DUZ(2) SHOULD BE USED
58 F Y=0:0 S Y=$O(^AUPNPAT("D",AUPX,Y)) Q:Y="" Q:$D(^(Y,DUZ(2)))
59 Q:Y=""
60 D SETAUP^AUPNLKUT
61 S AUPDFN=$S($D(AUPS(Y)):Y,1:-1)
62 Q
63 ;
64IHSCHRT2 ; LOOKUP CHART # WHEN ALL INSTITUTIONS SHOULD BE SCANNED
65 F AUPIFN=0:0 S AUPIFN=$O(^AUPNPAT("D",AUPX,AUPIFN)) Q:AUPIFN="" S Y=AUPIFN D SETAUP^AUPNLKUT
66 S:AUPCNT=1&($D(AUPIFNS(AUPCNT))) AUPDFN=+AUPIFNS(AUPCNT) D PRTAUP^AUPNLKUT:'AUPDFN&(AUPCNT>AUPNUM)&(DIC(0)["E") I 'AUPDFN,$D(AUPSEL),AUPSEL="" S AUPDFN=-1
67 Q
68 ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
69 ;
70XREFS ; LOOKUP BY XREFS
71 ; Upon returning from ^AUPNLK1 AUPDFN values/meanings are:
72 ; 0 = No hits
73 ; <0 = Hits but no selection
74 ; >0 = Selection made
75 D ^AUPNLK1
76 I $D(DTOUT) S AUPQF=2 Q
77 I AUPDFN>0 S AUPQF=4 Q
78 I AUPDFN<0 S AUPQF=3 Q
79 Q
80 ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
81 ;
82DFN ; LOOKUP BY DFN
83 Q:AUPX'?1N.N
84 S AUPDFN=-1,AUPBEG=1,AUPNUM=0
85 I $D(^DPT(AUPX,0)) S Y=X D SETAUP^AUPNLKUT S AUPDFN=$S($D(AUPS(Y)):Y,1:-1) D CHKDFN Q
86 Q
87 ;
88CHKDFN ;
89 S:'$D(AUPDFN) AUPDFN=-1
90 I +AUPDFN'>0!('$D(AUPS(+AUPDFN))) D:DIC(0)["Q" EN^DDIOL($C(7)_" ??") S AUPQF=3 Q
91 S AUPQF=4
92 Q
93 ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
94 ;
95ADDPAT ; EXTERNAL ENTRY POINT - ADD PATIENT
96 I AUPX?1"""".E1"""" S AUPX=$E(AUPX,2,$L(AUPX)-1)
97 D ^AUPNLK2
98 S Y=AUPDFN
99 I Y<0 S AUPQF=3 Q
100 S AUPQF=5
101 Q
Note: See TracBrowser for help on using the repository browser.