source: WorldVistAEHR/trunk/r/IHS_ROUTINES-AUP/AUPNLK2.m@ 1361

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

initial load of WorldVistAEHR
File size: 3.5 KB
RevLine 
[613]1AUPNLK2 ; IHS/CMI/LAB - IHS PATIENT LOOKUP ADD NEW PATIENT ;10/29/07 10:32
2 ;;1.0;PCE PATIENT CARE ENCOUNTER;**167**;Aug 12, 1996;Build 2
3 ;'Modified' MAS Patient Look-up Add New Patient, June 1987
4 ;
5 ; Upon exiting this routine AUPDFN will be set as follows:
6 ;
7 ; AUPDFN >0 means patient added and AUPDFN is the DFN
8 ; AUPDFN <0 means patient not added
9 ;
10 ; AUPQF2 values have the following meaning:
11 ;
12 ; 0 = Initial state
13 ; 1 = Primary error
14 ; 2 = Name edit error
15 ; 3 = Operator said no
16 ; 4 = Identifier failure
17 ; 5 = No add from dupe checker
18 ; 6 = Add failed
19 ;
20START ;
21 D INIT ; Initialization
22 I AUPQF2 D EOJ Q
23 D EDIT ; Edit the name
24 I AUPQF2 D EOJ Q
25 K AUPLID
26 I DIC(0)["E" D TALK ; Ask if add, get identifiers, check dupes
27 I AUPQF2 D EOJ Q
28 D ADDPAT ; Add patient
29 I AUPQF2 D EOJ Q
30 D EOJ
31 Q
32 ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
33 ;
34EDIT ; EXTERNAL ENTRY POINT - EDIT NAME
35 S X=AUPX
36 X $P(^DD(2,.01,0),U,5,99)
37 I '$D(X) S AUPQF2=2 W:DIC(0)["Q" *7," ??" Q
38 Q
39 ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
40 ;
41TALK ; EXTERNAL ENTERY POINT - TALK TO OPERATOR
42 D ^AUPNLK2B
43 Q
44 ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
45 ;
46ADDPAT ; ADD PATIENT
47 I $D(AUPLID),DIC(0)["E" W !!?3,"Please enter the following additional information:",!?3
48 K DD,DO S X=AUPX S:$D(AUP("DR")) DIC("DR")=AUP("DR") D FILE^DICN S DIC("W")=AUPDICW K:$D(AUP("DR")) DIC("DR") S AUPDFN=Y
49 I +AUPDFN>0 L +^DPT(+AUPDFN):10 D IHSPAT L -^DPT(+AUPDFN) Q:AUPQF2
50 Q:$T(GOTIDQ^DGLBPID)=""
51 N DFN S DFN=+AUPDFN
52 Q:$$GOTIDQ^DGLBPID(DFN)
53 I $$REQID^DGLBPID(DFN)="HRN" D
54 .D HRN^MPIFAG1
55 I $$REQID^DGLBPID(DFN)="SSN" D
56 .N DIE,DR,DA S DA=DFN,DIE=2,DR=.09 D ^DIE
57 I '$$GOTIDQ^DGLBPID(DFN) D S AUPQF2=6
58 .N DA,DIK,DIC S DIK="^DPT(",DA=DFN D ^DIK W !,"PATIENT DELETED BECAUSE YOU DIDN'T ENTER ",$$REQID^DGLBPID(DFN),!!
59 Q
60 ;
61 ;
62 ;
63 ;
64IHSPAT ; ADD PATIENT TO 9000001
65 K DD,D0
66 F AUPV="DINUM","DIC","DIC(""DR"")","DIC(0)","DLAYGO" S:$D(@AUPV) AUPRCR(AUPV)=@AUPV
67 S (Y,X)=+AUPDFN,DINUM=X,DIC="^AUPNPAT(",DIC(0)="L",DLAYGO=9000001,DIC("DR")=".02////"_DT_";.11////"_DUZ D:'$D(^AUPNPAT(X)) FILE^DICN L +^DPT(+AUPDFN):10 S DIC("W")=AUPDICW I Y<0 D IHSPATE
68 K DINUM,DIC("DR"),DIC(0),DLAYGO S AUPV="" F AUPL=0:0 S AUPV=$O(AUPRCR(AUPV)) Q:AUPV="" S @AUPV=AUPRCR(AUPV)
69 K AUPRCR,AUPV
70 Q
71 ;
72IHSPATE ; ERROR ADDING TO 9000001
73 W:AUPRCR("DIC(0)")["Q" !!?3,"Adding patient to ^AUPNPAT failed. Patient being removed from ^DPT also.",!
74 S DA=+AUPDFN,DIK="^DPT(" D ^DIK K DA,DIK
75 S AUPQF2=6
76 Q
77 ;
78 ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
79 ;
80INIT ; EXTERNAL ENTRY POINT - INITIALIZATION
81 S AUPQF2=0
82 I '$D(DUZ(0)) W:DIC(0)["Q" !?3,*7,"Unable to Add Patient. Your Fileman Access Code is undefined." S AUPQF2=1 Q
83 D ACCESS K I,X
84 Q:AUPQF2
85 S:'($D(DUZ)#2) DUZ=0 S:DUZ="" DUZ=0
86 ; Next line edited to remove reference to file #3; RED
87 I '$D(^VA(200,DUZ)) W:DIC(0)["Q" !?3,*7,"Unable to Add Patient. DUZ is not a valid user." S AUPQF2=1 Q
88 Q
89 ;
90ACCESS ; CHECK FILEMAN ACCESS
91 S X=$S(AUPDIC="^DPT(":2,1:9000001)
92 I $S($D(DLAYGO):X-DLAYGO,1:1),DUZ(0)'["@",$D(^DIC(X,0,"LAYGO")) S X=^("LAYGO") X "F I=1:1 I DUZ(0)[$E(X,I) Q" I I>$L(DUZ(0)) W:DIC(0)["Q" !?3,*7,"Unable to Add Patient. You do not have Add authority." S AUPQF2=1 Q
93 Q
94 ;
95 ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
96 ;
97EOJ ; EXTERNAL ENTRY POINT
98 S:AUPQF2 AUPDFN=-1
99 K AUPGID,AUPID,AUPID0,AUPIDS,AUPLID,AUP("DR"),AUPQF2,AUPRCR,AUPSET,AUPV
100 Q
Note: See TracBrowser for help on using the repository browser.