source: WorldVistAEHR/trunk/r/IHS_ROUTINES-AUP/AUPNLKI.m@ 1604

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

initial load of WorldVistAEHR

File size: 3.3 KB
Line 
1AUPNLKI ; IHS/CMI/LAB - IHS PATIENT LOOKUP, MAIN ROUTINE INITIALIZATION ;12/26/06 10:45
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 ;patch 5 fm v22
20 ;
21START ; INITIALIZATION
22 S AUPQF=0,AUPDIC=DIC
23 K AUPX,AUPDFN
24 ;
25 I '$D(DIC(0)) S AUPQF=1 Q
26 I DIC(0)'["A"&('$D(X)) S AUPQF=1 Q
27 I '$D(^DD("VERSION")) D:DIC(0)["E" EN^DDIOL("Unable to proceed. Fileman version node ^DD(""VERSION"") is undefined.","","!!?3") S AUPQF=1 Q
28 I ^DD("VERSION")<17.2 D:DIC(0)["E" EN^DDIOL("Unable to proceed. Fileman version must be at least 17.2.","","!!?3") S AUPQF=1 Q
29 I '$D(^DPT(0)) D:DIC(0)["E" EN^DDIOL("Unable to proceed. 0th node of ^DPT missing.","","!!?3") S AUPQF=1 Q
30 I '$D(^AUPNPAT(0)) D:DIC(0)["E" EN^DDIOL("Unable to proceed. 0th node of ^AUPNPAT missing.","","!!?3") S AUPQF=1 Q
31 I '$D(DUZ(2)) D:DIC(0)["E" EN^DDIOL("Unable to proceed. DUZ(2) is undefined.","","!!?3") S AUPQF=1 Q
32 I '$G(DUZ(2)) D:DIC(0)["E" EN^DDIOL("Unable to proceed. DUZ(2) is NULL.","","!!?3") S AUPQF=1 Q
33 I DUZ(2),'$D(^DIC(4,DUZ(2))) D:DIC(0)["E" EN^DDIOL("Unable to proceed. DUZ(2) is not a valid Location.","","!!?3") S AUPQF=1 Q
34 ;D:$D(AUPNLK("ALL")) SET^AUPNLKZ ; Undocumented feature (UGH!)
35 ;
36 ; - - - - - CHART # SCREEN - - - - -
37 S:$D(DIC("S"))#2 AUPDICS=DIC("S")
38NOTALL I '$G(AUPNLK("ALL")) D SETDICS ;**GFT/VW
39 ; - - - - - SETUP DIC("W") - - - - -
40 ; ** AUPNLKW overrides identifiers. Must be set & killed by caller **
41 K DUOUT,DTOUT S DIC="^DPT(" D DO^DIC1 S DIC("W")=$S($D(DIC("W")):DIC("W"),1:"") S:DIC("W")="W "" "" D ^AUPNLKID"!(DIC("W")="") DIC("W")=$S($D(AUPNLKW):AUPNLKW,1:"D ^AUPNLKID")
42 K AUPNLK("DICW")
43 S:$L(DIC("W"))>110 AUPNLK("DICW")=DIC("W")
44 S DIC("W")="D IHSDUPE^AUPNLKID "_$S($D(AUPNLK("DICW")):"X AUPNLK(""DICW"")",1:DIC("W"))
45 S DIC("W")=DIC("W")_" N DA,X S DA=Y X $P(^DD(2,.081,0),U,5,99) D:$G(X) EN^DDIOL(""<Unresolved potential duplicate>"","""",""!?10"") W @(""$E(""_DIC_""Y,0),0)"")" ;**GFT/VW
46 S DIC("W")=DIC("W")_" I $D(AUPMAPY) S Y=AUPMAPY K AUPMAPY"
47 S AUPDICW=DIC("W")
48 Q
49 ;
50SETDICS ;SET DIC("S") NODES
51 ;S DIC("S","IHSORIG")=$S($D(DIC("S")):DIC("S"),1:"I 1")
52 S AUPNORIG=$S($D(DIC("S")):DIC("S"),1:"I 1") ;IHS/ANMC/CLS 09/13/2000 fm v22
53 ;S DIC("S","IHSLOOK")="I $D(^AUPNPAT(Y,41,DUZ(2),0))"_$S('$D(AUPNLK("INAC")):","_"$P(^(0),U,3)=""""",1:""),DIC("S")="X DIC(""S"",""IHSORIG"") I $T X DIC(""S"",""IHSLOOK"")"
54 S AUPNLOOK="I $D(^AUPNPAT(Y,41,DUZ(2),0))"_$S('$D(AUPNLK("INAC")):","_"$P(^(0),U,3)=""""",1:""),DIC("S")="X AUPNORIG I $T X AUPNLOOK" ;IHS/ANMC/CLS 09/13/2000 fm v22
55 Q
Note: See TracBrowser for help on using the repository browser.