source: FOIAVistA/trunk/r/PATIENT_REPRESENTATIVE-QAC/QACI2B.m@ 1076

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

initial load of FOIAVistA 6/30/08 version
File size: 6.6 KB
Line 
1QACI2B ; OAKOIFO/TKW - DATA MIGRATION - BUILD SUPPORTING TABLE DATA ;4/10/06 12:06
2 ;;2.0;Patient Representative;**19**;07/25/1995;Build 55
3 ;
4PTDATA(STATION,DFN,QACI0,PATSERR,PATSCNT) ; Put patient data into ^XTMP global for migration
5 S PATSERR=0
6 Q:$D(^XTMP("QACMIGR","PT","D",DFN))
7 Q:$D(^XTMP("QACMIGR","PT","U",DFN))
8 I $D(^XTMP("QACMIGR","PT","E",DFN)) S PATSERR=1 Q
9 N PATX,I,X,Y,VAN,VAX,VAV,VADM,VAEL,DSPNAME,PTICN,PTNAME,PATSDATA,PATSDAT2,PATSENRL,GENDER,DOB,RACE,ETH
10 S (PATSDATA,PATSDAT2)=""
11 ; Get Patient Demographics, load name into variable. (IA #10061)
12 D DEM^VADPT
13 S DSPNAME=$G(VADM(1)) I $L(DSPNAME)>30 S DSPNAME=$E(DSPNAME,1,30)_"..."
14 ; Get Patient's Integration Control Number (ICN) (IA #2701)
15 S PTICN=$P($$GETICN^MPIF001(DFN),"^")
16 I PTICN]"",PTICN'=-1,PTICN'?1.12N1"V"1.6N S PATSERR=1 D ERREF^QACI2C("PT",DFN,DSPNAME_" - ICN invalid")
17 ; Load Parent Station number, Patients IEN (DFN) and ICN into output (node 1)
18 I 'QACI0 S PATSDATA="1^"_STATION_"^"_DFN_"^"_PTICN_"^"
19 ; Get enrollment priority for current enrollment from file 27.11 (IA #2918)
20 S PATSENRL=$$GETENRL^QACVDEM(DFN)
21 ; Get Patient Name Components and load into output. (IA #3065)
22 S PTNAME("FILE")=2,PTNAME("FIELD")=.01,PTNAME("IENS")=DFN
23 S PTNAME=$$HLNAME^XLFNAME(.PTNAME)
24 D
25 . N NMERR S NMERR=0
26 . I PTNAME'?.ANP S NMERR=1
27 . S X=$P(PTNAME,"^") I $$TXTERR^QACI2C(X,35,0,1) S NMERR=1
28 . S X=$P(PTNAME,"^",2) I $$TXTERR^QACI2C(X,25,0,1) S NMERR=1
29 . S X=$P(PTNAME,"^",3) I $$TXTERR^QACI2C(X,25) S NMERR=1
30 . F I=4:1:6 I $$TXTERR^QACI2C($P(PTNAME,"^",I),10) S NMERR=1 Q
31 . I NMERR=1 S PATSERR=1 D ERREF^QACI2C("PT",DFN,DSPNAME_" - Name invalid")
32 . Q
33 I 'QACI0 S PATSDATA=PATSDATA_PTNAME
34 ; Load Gender, date of birth and SSN into output
35 S GENDER=$P(VADM(5),"^") I GENDER'="M",GENDER'="F" D
36 . S PATSERR=1 D ERREF^QACI2C("PT",DFN,DSPNAME_" - Gender invalid") Q
37 S DOB=$$CONVDATE($P(VADM(3),"^")) D:'DOB
38 . S PATSERR=1 D ERREF^QACI2C("PT",DFN,DSPNAME_" - Date of Birth invalid") Q
39 S X=$E(VADM(2),1,9) I X]"",X'?9N D
40 . S PATSERR=1 D ERREF^QACI2C("PT",DFN,DSPNAME_" - SSN invalid") Q
41 I 'QACI0 S $P(PATSDATA,"^",11,14)=GENDER_"^"_DOB_"^"_X_"^0"
42 S PATX=$E(VADM(2),10) I PATX="P",'QACI0 S $P(PATSDATA,"^",14)=1
43 ; Get eligibility data, load eligibility code and enrollment priority
44 ; period of service, is service connected, svc.connected %
45 ; and category into output (IA #10061)
46 D ELIG^VADPT
47 S X=$P(VAEL(1),"^",2)
48 I $P(VAEL(1),"^"),X="" D
49 . S PATSERR=1 D ERREF^QACI2C("PT",DFN,DSPNAME_" - Primary Eligibility Code pointer invalid") Q
50 I $$TXTERR^QACI2C(X,30) D
51 . S PATSERR=1 D ERREF^QACI2C("PT",DFN,DSPNAME_" - Primary Eligibility Code invalid") Q
52 I 'QACI0 S $P(PATSDATA,"^",15,16)=X_"^"_PATSENRL
53 ; Load period of service, is service connected, svc.connected %
54 ; and category into output node 2.
55 S X=$P(VAEL(2),"^",2)
56 I $P(VAEL(2),"^"),X="" D
57 . S PATSERR=1 D ERREF^QACI2C("PT",DFN,DSPNAME_" - Period of Service pointer invalid") Q
58 I $$TXTERR^QACI2C(X,25) D
59 . S PATSERR=1 D ERREF^QACI2C("PT",DFN,DSPNAME_" - Period of Service invalid") Q
60 I 'QACI0 S PATSDAT2="2^"_X
61 S X=$P(VAEL(3),"^") I X'=1,X'=0 D
62 . S PATSERR=1 D ERREF^QACI2C("PT",DFN,DSPNAME_" - Is Service Connected Flag invalid") Q
63 I 'QACI0 S $P(PATSDAT2,"^",3)=X
64 S X=$P(VAEL(3),"^",2) D:X]""
65 . I X'?1.3N!(X<0)!(X>100) S PATSERR=1 D ERREF^QACI2C("PT",DFN,DSPNAME_" - Service Connected % invalid")
66 . Q
67 I 'QACI0 S $P(PATSDAT2,"^",4)=X
68 ; Add CATEGORY (Current Means Test Status)
69 S X=$P($G(^DPT(DFN,0)),"^",14) I X,'$D(^DG(408.32,X,0)) D
70 . S PATSERR=1 D ERREF^QACI2C("PT",DFN,DSPNAME_" - Current Means Test Status pointer invalid") Q
71 S X=$P(VAEL(9),"^",2)
72 I X]"",$L(X)>30!(X?.N)!($L(X)<3)!'(X'?1P.E)!(X'?.ANP) D
73 . S PATSERR=1 D ERREF^QACI2C("PT",DFN,DSPNAME_" - Current Means Test Status invalid") Q
74 I 'QACI0 S $P(PATSDAT2,"^",5)=X
75 ; Add Ethnicity and Race information to output (IA #3799)
76 D RACETH^QACVDEM(.VADM,.RACE,.ETH)
77 I ETH]"" S $P(PATSDAT2,"^",6)=ETH
78 S X=6
79 F I=0:0 S I=$O(RACE(I)) Q:'I D
80 . S X=X+1
81 . S $P(PATSDAT2,"^",X)=RACE(I)
82 . Q
83 ; Quit if any errors occurred
84 I PATSERR=1 Q
85 ; Put data into table for output.
86 S ^XTMP("QACMIGR","PT","U",DFN)=PATSDATA
87 S ^XTMP("QACMIGR","PT","U",DFN,"cont")=PATSDAT2
88 S PATSCNT("PT")=PATSCNT("PT")+1
89 Q
90 ;
91ELIGCAT(ELIGSTAT,CATEGORY,ROC0) ; Get Patient Eligibility Status and Category from ROC
92 S ELIGSTAT=$P(ROC0,"^",4) D:ELIGSTAT]""
93 . I $$TXTERR^QACI2C(ELIGSTAT,30) D ERROC^QACI2A(OLDROC,"ELIGIBILITY STATUS is invalid")
94 . Q
95 S CATEGORY=$P(ROC0,"^",5) D:CATEGORY]""
96 . I $$TXTERR^QACI2C(CATEGORY,30) D ERROC^QACI2A(OLDROC,"CATEGORY (current means test) is invalid")
97 . Q
98 Q
99 ;
100USERDATA(STATION,IEN,USERTYPE,QACI0,PATSERR,PATSCNT) ; Load pats_user data for migration
101 S PATSERR=0
102 N UTYPE S UTYPE=$S(USERTYPE="U":"USER",1:"EMPINV")
103 Q:$D(^XTMP("QACMIGR",UTYPE,"D",IEN))
104 Q:$D(^XTMP("QACMIGR",UTYPE,"U",IEN))
105 I $D(^XTMP("QACMIGR",UTYPE,"E",IEN)) S PATSERR=1 Q
106 N IENS,EMPDATA,DSPNAME,NAMECOMP,NAMEJ,TITLE,MAILCODE,NMERR
107 S IENS=IEN_",",EMPDATA=""
108 S DSPNAME=$P($G(^VA(200,+$G(IEN),0)),"^")
109 I $L(DSPNAME)>30 S DSPNAME=$E(DSPNAME,1,30)_"..."
110 ; Get user name, pointer to name componentents, title and mail code (IA #10060)
111 I USERTYPE="E" D
112 . D GETS^DIQ(200,IENS,"8;28","IE","EMPDATA")
113 . S X=$P($G(^VA(200,IEN,0)),"^",9) I X,'$D(^DIC(3.1,X,0)) D
114 .. S PATSERR=1 D ERREF^QACI2C("EMPINV",IEN,DSPNAME_" - Title pointer invalid")
115 . S TITLE=$E($G(EMPDATA(200,IENS,8,"E")),1,30)
116 . S MAILCODE=$E($G(EMPDATA(200,IENS,28,"E")),1,10)
117 . I $$TXTERR^QACI2C(TITLE) S PATSERR=1 D ERREF^QACI2C("EMPINV",IEN,DSPNAME_" - Title invalid")
118 . I $$TXTERR^QACI2C(MAILCODE) S PATSERR=1 D ERREF^QACI2C("EMPINV",IEN,DSPNAME_" - Mail Code invalid")
119 . Q
120 ; Load User IEN and station number into output
121 I 'QACI0 S EMPDATA=IEN_"^"_STATION_"^"
122 ; Get name components (IA #3065)
123 S NAMECOMP("FILE")=200,NAMECOMP("FIELD")=.01,NAMECOMP("IENS")=IENS
124 S NAMECOMP=$$HLNAME^XLFNAME(.NAMECOMP)
125 S NMERR=0
126 F NAMEJ=1:1:6 D
127 . S X=$P(NAMECOMP,"^",NAMEJ) I NAMEJ>2,X="" Q
128 . I X'?.ANP S NMERR=1 Q
129 . I NAMEJ=1,$$TXTERR^QACI2C(X,35,0,1) S NMERR=1 Q
130 . I NAMEJ=2,$$TXTERR^QACI2C(X,25,0,1) S NMERR=1 Q
131 . I NAMEJ=3,$$TXTERR^QACI2C(X,25) S NMERR=1 Q
132 . I NAMEJ>3,$$TXTERR^QACI2C(X,10) S NMERR=1 Q
133 . I 'QACI0 S $P(EMPDATA,"^",NAMEJ+2)=X
134 . Q
135 I NMERR=1 D NAMERR
136 Q:PATSERR=1
137 I 'QACI0,USERTYPE="E" S $P(EMPDATA,"^",9)=TITLE,$P(EMPDATA,"^",10)=MAILCODE
138 S ^XTMP("QACMIGR",UTYPE,"U",IEN)=EMPDATA
139 S PATSCNT(UTYPE)=PATSCNT(UTYPE)+1
140 Q
141 ;
142CONVDATE(OLDDATE) ; Convert data to MM/DD/YYYY format
143 N MM,DD S MM=$E(OLDDATE,4,5),DD=$E(OLDDATE,6,7)
144 S:MM="00" MM="01"
145 S:DD="00" DD="01"
146 S OLDDATE=$E(OLDDATE,1,3)_MM_DD
147 Q $$FMTE^XLFDT(OLDDATE,5)
148 ;
149NAMERR ;
150 N X S X="Name invalid"
151 I $G(DSPNAME)]"" S X=DSPNAME_" - "_X
152 S PATSERR=1 D ERREF^QACI2C(UTYPE,IEN,X)
153 Q
154 ;
Note: See TracBrowser for help on using the repository browser.