source: WorldVistAEHR/trunk/r/ENROLLMENT_APPLICATION_SYSTEM-EAS/EASEZI1.m@ 1406

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

initial load of WorldVistAEHR
File size: 3.9 KB
Line 
1EASEZI1 ;ALB/jap - Database Inquiry & Record Finder for 1010EZ Processing ;10/12/00 13:08
2 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**57**;Mar 15, 2001
3 ;continuation of EASEZI, split by patch 57 due to Max size limit
4 ;
5RESET ;
6 ;set link in file #712 record
7 N FDA,ERR
8 S FDA(712,EASAPP_",",3.4)=DFN
9 I NEW D
10 . S FDA(712,EASAPP_",",3.5)=NEW
11 D FILE^DIE("","FDA","ERR")
12 ;
13 W !,"One moment please...",!
14 S EASDFN=DFN
15 ;setup tmp array for data mapping
16 D LOCAL711^EASEZU2
17 I '$G(EASVRSN) S EASVRSN=$$VERSION^EASEZU4(EASAPP)
18 ;if applicant is new to database, user accept/not accept of data elements is constrained;
19 ;if applicant is new to VistA, mark all data elements 'accepted';
20 I NEW S N=0 F S N=$O(^EAS(712,EASAPP,10,N)) Q:'N I $G(^EAS(712,EASAPP,10,N,1))'="" D
21 .S ACCEPT="",FLD="",SUBFILE="",FILE=""
22 .S KEYIEN=$P(^EAS(712,EASAPP,10,N,0),U,1)
23 .I KEYIEN S X=$G(^TMP("EZDATA",$J,KEYIEN)),FILE=$P(X,U,1),SUBFILE=$P(X,U,2),FLD=$P(X,U,3),DATAKEY=$P(X,U,4),SECT=$P(DATAKEY,";",1)
24 .I FLD S ACCEPT=1
25 .I 'FLD S ACCEPT=-1
26 .I (FILE=355.33)!(FILE>408) S ACCEPT=2
27 .I FILE=2,SUBFILE=2,((FLD=.01)!(FLD=.03)!(FLD=.09)!(FLD=.531)) S ACCEPT=-1
28 .I ((SUBFILE=2.01)!(SUBFILE=2.101)) S ACCEPT=-1
29 .I (EASVRSN>5.99),((SECT="IIC")!(SECT="IIE")) D
30 ..S QUES=$P(DATAKEY,";",2)
31 ..I SECT="IIC","1.6;2.3;3.3"[QUES S ACCEPT=-1 Q
32 ..I SECT="IIE","1.3;2.3;3.3"[QUES S ACCEPT=-1
33 .S $P(^EAS(712,EASAPP,10,N,0),U,3)=ACCEPT
34 ;for applicants matched to existing patients check for
35 ; verified eligibility and appt request on 1010 app
36 I 'NEW D
37 .K ARRAY
38 .S DA=EASDFN,DIC="^DPT(",DR=".3611;.3613;1010.159;1010.1511"
39 .S DIQ(0)="I",DIQ="ARRAY"
40 .D EN^DIQ1
41 .I ARRAY(2,EASDFN,.3611,"I")="V",ARRAY(2,EASDFN,.3613,"I")="H" S ELIGVER=1
42 .I ARRAY(2,EASDFN,1010.159,"I")'="",ARRAY(2,EASDFN,1010.1511,"I")'="" S APPTVER=1
43 ;correlate #712 data with mapping array
44 S N=0 F S N=$O(^EAS(712,EASAPP,10,N)) Q:'N S X=^(N,0) D
45 .;don't set array node if no 1010EZ data
46 .S EZDATA=$P($G(^EAS(712,EASAPP,10,N,1)),U,1)
47 .Q:EZDATA=""
48 .S IEN=$P(X,U,1),MULTIPLE=$P(X,U,2),ACCEPT=$P(X,U,3)
49 .S ^TMP("EZDATA",$J,IEN,MULTIPLE,1)=EZDATA_U_ACCEPT_U_N
50 ;
51 ;if applicant new to VistA, stop here;
52 I NEW S EASEZNEW=1
53 Q:$G(EASEZNEW)
54 ;if matched to existing patient, get all iens needed
55 W !,"Preparing for data comparison to VistA Patient database...",!
56 K ALIAS,DISPOS,ENROLL,INCREL,RACE,ETHNC
57 D I201^EASEZI(EASDFN,.ALIAS) W "."
58 I $D(ALIAS)>1 D C201^EASEZC1
59 D I2101^EASEZI(EASDFN,.DISPOS) W "."
60 I $D(DISPOS)>1 D C2101^EASEZC1
61 ;finish getting the rest of file #2 data needed for comparison
62 D C2^EASEZC1
63 D I2711^EASEZI(EASDFN,.ENROLL) W "."
64 I $D(ENROLL)>1 D C2711^EASEZC1
65 D I408^EASEZI(EASDFN,EASAPP,.INCREL) W "."
66 I $D(INCREL)>1 D C408^EASEZC1
67 D I202^EASEZI(EASDFN,.RACE) W "."
68 I $D(RACE)>1 D C202^EASEZC3
69 D I206^EASEZI(EASDFN,.ETHNC) W "."
70 I $D(ETHNC)>1 D C206^EASEZC3
71 ;set file #355.33 data to 'always accept';
72 ;set unmatched data for files #408.12, #408.13, #408.21, #408.22 to 'always accept';
73 S N=0 F S N=$O(^EAS(712,EASAPP,10,N)) Q:'N S X=^(N,0) D
74 .S KEYIEN=$P(X,U,1),MULTIPLE=$P(X,U,2)
75 .I KEYIEN S X=$G(^TMP("EZDATA",$J,KEYIEN)),FILE=$P(X,U,1),SUBFILE=$P(X,U,2),FLD=$P(X,U,3),DATAKEY=$P(X,U,4),SECT=$P(DATAKEY,";",1)
76 .S ACCEPT=""
77 .I 'FLD S ACCEPT=-1
78 .I FILE=2,SUBFILE=2,((FLD=.01)!(FLD=.03)!(FLD=.09)!(FLD=.531)) S ACCEPT=-1
79 .;set certain eligibility related data elements to 'never accept' if eligibility verified
80 .I FILE=2,FLD=.313,$G(ARRAY(2,EASDFN,.3611,"I"))="V" S ACCEPT=-1
81 .I FILE=2,$G(ELIGVER),((FLD=.301)!(FLD=.302)!(FLD=.36235)) S ACCEPT=-1
82 .;set appt requested element to 'never accept' if already exist
83 .I FILE=2,$G(APPTVER),FLD=1010.159 S ACCEPT=-1
84 .I FILE=355.33 S ACCEPT=2
85 .I FILE>408 S ACCEPT=2
86 .I (EASVRSN>5.99),((SECT="IIC")!(SECT="IIE")) D
87 ..S QUES=$P(DATAKEY,";",2)
88 ..I SECT="IIC","1.6;2.3;3.3"[QUES S ACCEPT=-1 Q
89 ..I SECT="IIE","1.3;2.3;3.3"[QUES S ACCEPT=-1
90 .S $P(^EAS(712,EASAPP,10,N,0),U,3)=ACCEPT
91 .S $P(^TMP("EZDATA",$J,KEYIEN,MULTIPLE,1),U,2)=ACCEPT
92 K ALIAS,DISPOS,ENROLL,INCREL
93 Q
94 ;
Note: See TracBrowser for help on using the repository browser.