source: WorldVistAEHR/trunk/r/IHS_ROUTINES-AUP/AUPNLK1I.m@ 724

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

initial load of WorldVistAEHR

File size: 2.1 KB
Line 
1AUPNLK1I ; IHS/CMI/LAB - INITIALIZATION FOR ^AUPNLK1 ;16DEC2006
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 ;
20INIT ; INITIALIZATION - FIX UP AUPX AND SET UP XREFS
21 I AUPX?.E1L.E F AUPI=1:1:$L(AUPX) S:$E(AUPX,AUPI)?1L AUPX=$E(AUPX,0,AUPI-1)_$C($A(AUPX,AUPI)-32)_$E(AUPX,AUPI+1,$L(AUPX))
22 I AUPX[", " F AUPL=0:0 Q:'$F(AUPX,", ") S AUPX=$E(AUPX,1,($F(AUPX,", ")-2))_$E(AUPX,$F(AUPX,", "),$L(AUPX))
23 K AUPREFS S AUPREFS=$S(DIC(0)'["M":"B",AUPX?1A1N.N:"CN,RM,BS5",AUPX?4N.1A:"CN,RM,BS",AUPX?9N.E:"SSN,CN,RM",1:"")
24 S:AUPREFS="" AUPREFS=$S(AUPX?1N.N:$S($L(AUPX)<5:"CN,RM,BS,SSN",1:"CN,RM,SSN"),AUPX?1N.E:"CN,RM",1:"B,CN,RM,BS5") S:$D(AUPIX) AUPREFS=AUPIX_","_AUPREFS
25 ; - - - - - IHS DOB - - - - -
26 ;beginning Y2K IHS/CMI/LAB
27 ;change "X" to %DT="PX", change allowable input from 6N to 8N
28 ;I DIC(0)["M",AUPX'?1N.N S %DT="X",X=$S(AUPX?1"B"6N:$E(AUPX,2,7),1:AUPX) D ^%DT S:Y'=-1 AUPDT=Y,AUPREFS=AUPREFS_",ADOB" K %DT,Y ;Y2000 IHS/CMI/LAB
29 I DIC(0)["M",AUPX'?1N.N S %DT="PX",X=$S(AUPX?1"B"8N:$E(AUPX,2,9),1:AUPX) D ^%DT S:Y'=-1 AUPDT=Y,AUPREFS=AUPREFS_",ADOB" K %DT,Y ;Y2000 IHS/CMI/LAB
30 ;end Y2K fix
31 ; - - - - - IHS TEMPORARY CHART # - - - - -
32 I AUPX?1"T"5N,$D(^AUPNPAT("D",AUPX)) S (AUPIFN,Y)=$O(^AUPNPAT("D",AUPX,0)) D SETAUP^AUPNLKUT
33 ; - - - - - - - - - - - - - - - - - - - - -
34PHONE I DIC(0)["M",AUPX?.NP S AUPREFS=AUPREFS_",AZVWVOE" ;**GFT/VW
35 Q
Note: See TracBrowser for help on using the repository browser.