source: FOIAVistA/trunk/r/ENROLLMENT_APPLICATION_SYSTEM-EAS/EASEZF3.m@ 1757

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

initial load of FOIAVistA 6/30/08 version

File size: 4.9 KB
Line 
1EASEZF3 ;ALB/jap - Filing 1010EZ Data to Patient Database ;10/31/00 13:07
2 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**1,57**;Mar 15, 2001
3 ;
4SP ;file Spouse data
5 N C,MULTIPLE,FILE,SUBFILE,FLD,XDATA,ACCEPT,SUBIEN,SEX,EZDATA,EAS,ERR
6 N KEY,X,Y,XLINK,DIC
7 ;process sequence must be 408.13 - 408.12 - 408.21 - 408.22
8 ;set sex of spouse
9 S KEY=+$$KEY711^EASEZU1("APPLICANT SEX")
10 S X=$$DATA712^EASEZU1(EASAPP,KEY,1),APSEX=$P(X,U,1),SEX=$S(APSEX="M":"FEMALE",1:"MALE")
11 S XLINK=$G(FLINK("SP",1,408.13)),PTDATA="" I XLINK D
12 .S FFF="408.13^408.13^.02" S PTDATA=$$GET^EASEZC1(XLINK,FFF)
13 .S SP(1,408.13,408.13,.02)=SEX_U_2_U_U_PTDATA_U_XLINK
14 ;
15 F FILE=408.13,408.12,408.21,408.22 D
16 .S MULTIPLE=1,SUBFILE=FILE,FLD=""
17 .S XLINK=$G(FLINK("SP",MULTIPLE,FILE))
18 .;record in file #408.13 is needed for all further data filng
19 .Q:(FILE'=408.13)&('$G(FLINK("SP",MULTIPLE,408.13)))
20 .;for data elements with link to database,
21 .;only file 1010EZ data if accepted by user;
22 .;data in external format
23 .I XLINK D
24 ..;when #408.12 record exists, don't try to update subfile #408.1275
25 ..S FLD="" F S FLD=$O(SP(MULTIPLE,FILE,SUBFILE,FLD)) Q:FLD="" D
26 ...S XDATA=SP(MULTIPLE,FILE,SUBFILE,FLD),ACCEPT=$P(XDATA,U,2)
27 ...I FILE=408.13,FLD=.09 S XDATA=$TR(XDATA,"-","")
28 ...I ACCEPT D LINK^EASEZF2(XDATA,FILE,FLD,"SP",MULTIPLE)
29 .;for data elements with no link to database,
30 .;always create new record(s) to store 1010EZ data;
31 .;put data in internal format
32 .I 'XLINK D
33 ..K EAS,ERR
34 ..;supplement data and convert to internal format
35 ..S FLD="" F S FLD=$O(SP(MULTIPLE,FILE,SUBFILE,FLD)) Q:FLD="" D
36 ...S EZDATA=$P(SP(MULTIPLE,FILE,SUBFILE,FLD),U,1)
37 ...S EAS(EASAPP,FILE,"+1,",FLD)=EZDATA
38 ..I FILE=408.13 D
39 ...S X=$G(EAS(EASAPP,FILE,"+1,",".03")) I X'="" D ^%DT S EAS(EASAPP,FILE,"+1,",".03")=Y
40 ...S X=$G(EAS(EASAPP,FILE,"+1,",".09")) I X'="" D
41 ....S SSN=$TR(X,"-","") S EAS(EASAPP,FILE,"+1,",".09")=SSN
42 ....I $D(^DGPR(408.13,"SSN",SSN)) S EAS(EASAPP,FILE,"+1,",".09")=""
43 ...S KEY=+$$KEY711^EASEZU1("APPLICANT SEX")
44 ...S X=$P($$DATA712^EASEZU1(EASAPP,KEY,1),U,1),SEX=$S(X="M":"F",1:"M")
45 ...S EAS(EASAPP,FILE,"+1,",".02")=SEX
46 ...S X=$G(EAS(EASAPP,FILE,"+1,","1.6")) I X'="" D
47 ....S DIC=5,DIC(0)="X" D ^DIC
48 ....S EAS(EASAPP,FILE,"+1,","1.6")=$S(+Y:+Y,1:"")
49 ..I FILE=408.12,$G(FLINK("SP",MULTIPLE,408.13)) D F40812("SP",1)
50 ..I FILE=408.21,$G(FLINK("SP",MULTIPLE,408.12)) D
51 ...S EAS(EASAPP,FILE,"+1,",".01")=INCYR
52 ...S EAS(EASAPP,FILE,"+1,",".02")=FLINK("SP",MULTIPLE,408.12)
53 ...S EAS(EASAPP,FILE,"+1,","101")=DUZ
54 ...S EAS(EASAPP,FILE,"+1,","102")=DT
55 ...S EAS(EASAPP,FILE,"+1,","103")=DUZ
56 ...S EAS(EASAPP,FILE,"+1,","104")=DT
57 ..I FILE=408.22,$G(FLINK("SP",MULTIPLE,408.21)) D
58 ...S EAS(EASAPP,FILE,"+1,",".01")=EASDFN
59 ...S EAS(EASAPP,FILE,"+1,",".02")=FLINK("SP",MULTIPLE,408.21)
60 ..I FILE'=408.12 D
61 ...S FLINK("SP",MULTIPLE,FILE)=$$NOLINK^EASEZF2(.EAS,"SP",MULTIPLE)
62 ...S FLD="" F S FLD=$O(SP(MULTIPLE,FILE,SUBFILE,FLD)) Q:FLD="" D
63 ....S $P(SP(MULTIPLE,FILE,SUBFILE,FLD),U,5)=FLINK("SP",MULTIPLE,FILE)
64 Q
65 ;
66F40812(TYPE,MULT) ;create a new record in file #408.12
67 ;input TYPE = "SP" for Souse or "CN" for Child
68 ; MULT = always 1 for spouse; or
69 ; 1st subscript of CN array for child
70 ;can't use normal FileMan data entry
71 N C,ARR,FILE,SUBFILE,FLD,DGPRIEN,XDATE,SUBIEN,RELATE,XX,X,Y,DA,DIK,EAS,ERR
72 S DGPRIEN=""
73 S ARR=TYPE
74 S FILE=408.12,SUBFILE=408.12
75 I TYPE="SP" S RELATE=2
76 I TYPE="CN" D
77 .S X=$P($G(CN(MULT,FILE,SUBFILE,".02")),U,1)
78 .S RELATE=$S(X="SON":3,X="DAUGHTER":4,1:99)
79 ;verify that no record points to known file #408.13 record
80 S C=FLINK(TYPE,MULT,408.13)_";DGPR(408.13,"
81 I $D(^DGPR(408.12,"C",C)) S DGPRIEN=$O(^DGPR(408.12,"C",C,0))
82 ;if it does, quit w/o filing
83 Q:DGPRIEN
84 ;otherwise create a new entry
85 L +^DGPR(408.12,0):30
86 K DA,DIK
87 S DGPRIEN=$P(^DGPR(408.12,0),U,3)+1,$P(^DGPR(408.12,0),U,3)=DGPRIEN
88 S ^DGPR(408.12,DGPRIEN,0)=EASDFN_U_RELATE_U_C
89 S DA=DGPRIEN,DIK="^DGPR(408.12,",DIK(1)=".01^" D EN^DIK S DIK(1)=".03" D EN^DIK
90 S X=$P(^DGPR(408.12,0),U,4),$P(^DGPR(408.12,0),U,4)=X+1
91 L -^DGPR(408.12,0)
92 S FLINK(TYPE,MULT,408.12)=DGPRIEN
93 ;don't continue if file#408.12 record doesn't exist
94 Q:'$G(FLINK(TYPE,MULT,408.12))
95 ;store the link in subfile #712.01 record
96 S FLD="" F S FLD=$O(@ARR@(MULT,FILE,SUBFILE,FLD)) Q:FLD="" D
97 .S SUBIEN=$P(@ARR@(MULT,FILE,SUBFILE,FLD),U,3)
98 .S $P(@ARR@(MULT,FILE,SUBFILE,FLD),U,5)=FLINK(TYPE,MULT,FILE)
99 ;there's never more than one array node for subfile #408.1275; for field #.01;
100 S SUBFILE=408.1275,FLD=".01"
101 S XX=$G(@ARR@(MULT,FILE,SUBFILE,FLD))
102 K EAS
103 S XDATE=$P(XX,U,1)
104 S SUBIEN=$P(XX,U,3)
105 Q:XDATE=""
106 S X=XDATE D ^%DT S XDATE=Y
107 S EAS(EASAPP,SUBFILE,"+1,"_FLINK(TYPE,MULT,408.12)_",",".01")=XDATE
108 S EAS(EASAPP,SUBFILE,"+1,"_FLINK(TYPE,MULT,408.12)_",",".02")=1
109 S FLINK(TYPE,MULT,SUBFILE)=$$NOLINK^EASEZF2(.EAS,TYPE,MULT)
110 Q:FLINK(TYPE,MULT,SUBFILE)=""
111 ;store link to new subrecord in subfile #712.01
112 S $P(@ARR@(MULT,FILE,SUBFILE,FLD),U,5)=FLINK(TYPE,MULT,FILE)_";"_FLINK(TYPE,MULT,SUBFILE)
113 Q
Note: See TracBrowser for help on using the repository browser.