source: WorldVistAEHR/trunk/r/MASTER_PATIENT_INDEX_VISTA-MPIF/MPIFAG1.m@ 1780

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

initial load of WorldVistAEHR

File size: 2.8 KB
Line 
1MPIFAG1 ; EHR/DAOU/WCJ - ENTER HEALTH RECORD NUMBER ;1/27/07 21:26
2 ;;1.0; MASTER PATIENT INDEX VISTA ;**40**;30 Apr 99;Build 13
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 ;;;EHR PATIENT REGISTRATION;;
20 ;
21 ;This routine was originally from IHS routine AG1.
22 ;It was modified so that it could be called from anywhere as long as
23 ;DFN - patient
24 ;DUZ(2) - location
25 ;are defined.
26 ;
27 ;It was specifcally written so that it could be called within a DR string
28 ;It is used to modify file 9000001 while in file 2.
29 ;
30HRN ;
31 Q:'$G(DUZ(2))
32 Q:'$G(DFN)
33 N IENS,OUT,AG,SEQ,LIEN
34 N DTOUT,DFOUT,DLOUT,DUOUT,DQOUT,Y
35 N FDA,FDAIEN,XXX,PATID
36 ;
37 ; Find HRN for this DFN/location
38 S IENS=","_DFN_","
39 D FIND^DIC(9000001.41,IENS,"@;.01;.02;","X",DUZ(2),,,,,"OUT")
40 ;
41 ; Check if it's a new location
42 S SEQ=$O(OUT("DILIST","ID",0))
43 I SEQ S LIEN=$O(OUT("DILIST",2,SEQ)) ;(No point to this!)
44 ;
45 ; prompt user for HRN
46L1 ;
47 I SEQ S (AG("CH"),AG("OCH"))=OUT("DILIST","ID",SEQ,.02)
48 I 'SEQ S (AG("CH"),AG("OCH"))=$$GENHRN()
49 S DIR(0)="9000001.41,.02",DIR("B")=AG("CH")
50 D ^DIR
51 I 'SEQ,$D(DTOUT) S Y=$G(AG("CH")) K DTOUT
52 I $G(AG("CH"))]"",$D(DTOUT) Q
53 I $D(DUOUT) Q ;W !,"EXIT NOT ALLOWED ??"
54 ; See if anyone is using that one
55 S AG("CH")=+Y
56 G L3:'$D(^AUPNPAT("D",AG("CH")))
57 Q:$D(^AUPNPAT("D",AG("CH"),$G(DFN)))
58 S AG("D")=0
59 ;
60 ; someone is using this one already, see if it's the same location
61L2 ;
62 S AG("D")=$O(^AUPNPAT("D",AG("CH"),AG("D")))
63 G L3:AG("D")=""
64 S AG("DD")=0
65 S AG("DD")=$O(^AUPNPAT("D",AG("CH"),AG("D"),AG("DD")))
66 G L2:AG("DD")'=DUZ(2)
67 W !,*7,AG("CH")," is already assigned to ",$P(^DPT(AG("D"),0),U)
68 G L1
69 ;
70 ; let's do it. unique for this Location
71L3 ;
72 S IENS="?+1,"_DFN_","
73 S FDAIEN(1)=DUZ(2)
74 S XXX="FDA"
75 S FDA(9000001.41,IENS,.01)=DUZ(2)
76 S FDA(9000001.41,IENS,.02)=AG("CH")
77 D UPDATE^DIE("",XXX,"FDAIEN","RET")
78 Q
79 ;
80 ;
81CHECK(Y) ;
82 N X,DA S DA(1)=+$G(DFN),DA=DUZ(2),X=Y
83 X $P(^DD(9000001.41,.02,0),U,5,99) Q $D(X)>0
84 ;
85 ;
86GENHRN() ;
87 N HRN
88 S HRN=$O(^AUPNPAT("D",999999999),-1) I HRN'?.N S HRN="" G Q
89 S HRN=HRN+1
90 I '$$CHECK(HRN) S HRN="" G Q
91 F Q:'$D(^AUPNPAT("D",HRN)) S HRN=HRN+1 I '$$CHECK(HRN) S HRN="" G Q
92Q Q HRN
Note: See TracBrowser for help on using the repository browser.