source: FOIAVistA/trunk/r/PATIENT_REPRESENTATIVE-QAC/QACI2D.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 8.7 KB
Line 
1QACI2D ; OAKOIFO/TKW - DATA MIGRATION - BUILD LEGACY DATA TO BE MIGRATED (CONT.) ;11/30/06 12:06
2 ;;2.0;Patient Representative;**19**;07/25/1995;Build 55
3ENISS(ROCIEN,ROCNO,OLDROC,QACI0,ROCCNT,RESERR,HL,PARENT,STATION,PATSCNT) ; Move Issue Code and related data to output global
4 N I,J,X,ROCISS,ISSIEN,ISSLIST,ISSCODE,ISSNAME,FSOSIEN,FSOS,FSOSCNT,ERR,HLID,HLNAME,EMPID,EMP,EMPNAME,EMPCNT,NEWITXT,ISACTIVE,ITXT,HLINST,ROCDT
5 S ERR=0
6 ; Read through Issue Codes, build lists of active/inactive codes
7 F ROCISS=0:0 S ROCISS=$O(^QA(745.1,ROCIEN,3,ROCISS)) Q:'ROCISS!(ERR) S ISSIEN=$P($G(^(ROCISS,0)),"^") D:ISSIEN]""
8 . S X=""
9 . I ISSIEN S X=$G(^QA(745.2,ISSIEN,0))
10 . I X="" D ERROC^QACI2A(OLDROC,"Issue Code Pointer "_+X_" is invalid") Q
11 . S ISSCODE=$P(X,"^"),ISSNAME=$P(X,"^",3)
12 . I ISSCODE=""!(ISSNAME="") S ERR=1 D ERROC^QACI2A(OLDROC,"Issue Code or Issue Code Name NULL") Q
13 . ; Set a flag based on whether this is an active (migrated) issue code.
14 . S ISACTIVE=$S($D(^XTMP("QACMIGR","ISS","D",ISSCODE)):1,1:0)
15 . S ISSLIST(ISACTIVE,ROCISS)=ISSIEN_"^"_ISSCODE_"^"_ISSNAME
16 . Q
17 ;
18 ; If there are no issue codes, and date of contact after FY2003, generate an error
19 I '$D(ISSLIST) D Q:ERR ERR
20 . N ROCDT S ROCDT=$P(^QA(745.1,ROCIEN,0),"^",2)
21 . I ROCDT<3031001 S ISSLIST(0,1)=0 Q
22 . S ERR=1 D ERROC^QACI2A(OLDROC,"ROC Has no valid Issue Codes")
23 . Q
24 ;
25 ; Build hospital location ref table data if there's at least one active issue code to migrate
26 S (HLNAME,HLINST)=""
27 I HL]"" D
28 . S HLNAME=$P($G(^SC(+HL,0)),"^")
29 . Q:'$O(ISSLIST(1,0))
30 . ; First check for errors on Hospital Location
31 . I HLNAME="",'$D(^SC(+HL,0)) S ERR=1 D Q
32 .. D ERROC^QACI2A(OLDROC,"LOCATION OF EVENT pointer "_+HL_" is invalid") Q
33 . I HLNAME="" S ERR=1 D
34 .. D ERROC^QACI2A(OLDROC,"LOCATION OF EVENT Name field is NULL") Q
35 . I $D(^XTMP("QACMIGR","HL","E",HL)) D Q
36 .. D ERROC^QACI2A(OLDROC,"LOCATION OF EVENT has invalid data -- see ref data report") Q
37 . S HLINST=$P($G(^XTMP("QACMIGR","HL","U",HL)),"^",3) Q:HLINST]""
38 . ; Build Reference Table data for Hospital Location
39 . D HLDATA(STATION,HL,QACI0,.ERR,.HLINST,.PATSCNT)
40 . I ERR D ERROC^QACI2A(OLDROC,"LOCATION OF EVENT has invalid data -- see ref data report")
41 . Q
42 ;
43 ; Build list of employees.
44 S EMPCNT=0
45 F I=0:0 S I=$O(^QA(745.1,ROCIEN,8,I)) Q:'I S EMP=$P($G(^(I,0)),"^") D:EMP]""
46 . S EMPNAME=""
47 . ; Check for errors on Employee data
48 . I '$D(^VA(200,+EMP,0)) D Q
49 .. D ERROC^QACI2A(OLDROC,"EMPLOYEE pointer "_+EMP_" is invalid")
50 .. S ERR=1 Q
51 . S EMPNAME=$P(^VA(200,+EMP,0),"^")
52 . S EMP(EMP)=EMPNAME,EMPCNT=EMPCNT+1
53 . ; Quit if there are no active issue codes to migrate.
54 . Q:'$O(ISSLIST(1,0))
55 . I EMPNAME="" D Q
56 .. S ERR=1
57 .. D ERREF^QACI2C("EMPINV",EMP,"Name missing")
58 .. D ERROC^QACI2A(OLDROC,"EMPLOYEE Name is NULL -- see EMP.INVOLVED on ref data report") Q
59 . ; Build reference table data for Employee Involved.
60 . D USERDATA^QACI2B(PARENT,EMP,"E",QACI0,.ERR,.PATSCNT)
61 . I ERR D ERROC^QACI2A(OLDROC,"EMPLOYEE has invalid data -- see EMP.INVOLVED on ref data report")
62 . Q
63 Q:ERR ERR
64 ;
65 ;
66 ; For inactive issue codes, issue multiple data goes in resolution text.
67 I $O(ISSLIST(0,0)) D
68 . N RTXTCNT,RESERR1,RESERR2
69 . S RESERR2=" char.(8000 maximum)"
70 . ; Set current resolution text number of characters and error code
71 . I 'RESERR D
72 .. S RTXTCNT=0
73 .. S RESERR1="Resolution Text" Q
74 . E D
75 .. S RTXTCNT=$P(RESERR,"^")
76 .. S RESERR1=$P(RESERR,"^",2)_" + Issue Code Data" Q
77 . ; Add header to resolution text.
78 . S RTXTCNT=RTXTCNT+34
79 . I 'QACI0,RTXTCNT'>8000 D
80 .. I RTXTCNT>0 S ^XTMP("QACMIGR","ROC","U",ROCNO_" ",ROCCNT+1)=ROCNO_"^RTXT^ ",^(ROCCNT+2)=ROCNO_"^RTXT^ ",ROCCNT=ROCCNT+2
81 .. I $P($G(ISSLIST(0,1)),"^")=0 S X="** No Issue Code Assigned **"
82 .. E S X="** Inactive Issue Code Data **"
83 .. S ROCCNT=ROCCNT+1,^XTMP("QACMIGR","ROC","U",ROCNO_" ",ROCCNT)=ROCNO_"^RTXT^"_X
84 .. Q
85 . ; Add Hospital Location data to Resolution Text
86 . I HL]"" D
87 .. I 'HL S HLNAME=HL
88 .. S:HLNAME="" HLNAME="*Unknown*"
89 .. S RTXTCNT=RTXTCNT+$L(HLNAME)+12
90 .. I 'QACI0,RTXTCNT'>8000 D
91 ... S ^XTMP("QACMIGR","ROC","U",ROCNO_" ",ROCCNT+1)=ROCNO_"^RTXT^ "
92 ... S ^XTMP("QACMIGR","ROC","U",ROCNO_" ",ROCCNT+2)=ROCNO_"^RTXT^Hosp.Loc.: "_HLNAME
93 ... S ROCCNT=ROCCNT+2 Q
94 .. Q
95 . ; Add Employee Involved data to Resolution Text
96 . F EMP=0:0 S EMP=$O(EMP(EMP)) Q:'EMP D
97 .. S EMPNAME=EMP(EMP)
98 .. S:EMPNAME="" EMPNAME="*Unknown*"
99 .. S RTXTCNT=RTXTCNT+$L(EMPNAME)+11
100 .. I 'QACI0,RTXTCNT'>8000 D
101 ... S ^XTMP("QACMIGR","ROC","U",ROCNO_" ",ROCCNT+1)=ROCNO_"^RTXT^ "
102 ... S ^XTMP("QACMIGR","ROC","U",ROCNO_" ",ROCCNT+2)=ROCNO_"^RTXT^Emp.Inv.: "_EMPNAME
103 ... S ROCCNT=ROCCNT+2 Q
104 .. Q
105 . ; Add Issue Code and Service/Discipline data to Resolution Text
106 . F I=0:0 S I=$O(ISSLIST(0,I)) Q:'I S X=ISSLIST(0,I) D:X
107 .. S ISSCODE=$P(X,"^",2),ISSNAME=$P(X,"^",3) S:ISSCODE="" ISSCODE="*Unknown*"
108 .. S RTXTCNT=RTXTCNT+$L(ISSNAME)+19
109 .. I 'QACI0,RTXTCNT'>8000 D
110 ... S ^XTMP("QACMIGR","ROC","U",ROCNO_" ",ROCCNT+1)=ROCNO_"^RTXT^ "
111 ... S ^XTMP("QACMIGR","ROC","U",ROCNO_" ",ROCCNT+2)=ROCNO_"^RTXT^Issue Code: "_ISSCODE_" "_ISSNAME
112 ... S ROCCNT=ROCCNT+2 Q
113 .. ; Read through Service/Discipline multiples
114 .. F J=0:0 S J=$O(^QA(745.1,ROCIEN,3,I,3,J)) Q:'J S FSOSIEN=$P($G(^(J,0)),"^") D:FSOSIEN
115 ... S X=$P($G(^QA(745.55,FSOSIEN,0)),"^")
116 ... S:X="" X="*Unknown*"
117 ... S RTXTCNT=RTXTCNT+$L(X)+14
118 ... I 'QACI0,RTXTCNT'>8000 D
119 .... S ^XTMP("QACMIGR","ROC","U",ROCNO_" ",ROCCNT+1)=ROCNO_"^RTXT^ "
120 .... S ^XTMP("QACMIGR","ROC","U",ROCNO_" ",ROCCNT+2)=ROCNO_"^RTXT^ Serv/Disc: "_X
121 .... S ROCCNT=ROCCNT+2 Q
122 ... Q
123 .. Q
124 . I RTXTCNT>8000 D
125 .. D ERROC^QACI2A(OLDROC,RESERR1_"="_RTXTCNT_RESERR2)
126 .. S ERR=1 Q
127 . Q
128 ;
129 ;
130 ; For active issue codes, build issue code multiple data for the ROC.
131 F I=0:0 S I=$O(ISSLIST(1,I)) Q:'I S X=ISSLIST(1,I) D
132 . S ISSCODE=$P(X,"^",2)
133 . ;
134 . ; Read through Service/Discipline multiple
135 . S FSOSCNT=0,FSOSNAME=""
136 . F J=0:0 S J=$O(^QA(745.1,ROCIEN,3,I,3,J)) Q:'J!(ERR) S FSOSIEN=$P($G(^(J,0)),"^") D:FSOSIEN]""
137 .. ; Check for errors
138 .. I '$D(^QA(745.55,+FSOSIEN,0)) D Q
139 ... D ERROC^QACI2A(OLDROC,"SERVICE/DISCIPLINE pointer "_+FSOSIEN_" is invalid")
140 ... S ERR=1 Q
141 .. S FSOSNAME=$P(^QA(745.55,+FSOSIEN,0),"^")
142 .. I $$TXTERR^QACI2C(FSOSNAME,50,0,1) D
143 ... S ERR=1
144 ... D ERROC^QACI2A(OLDROC,"SERVICE/DISCIPLINE on issue "_ISSCODE_" invalid -- see ref data report")
145 ... Q
146 .. ; Build reference table data for FSOS
147 .. D BLDFSOS^QACI2A(FSOSIEN,FSOSNAME,QACI0,.PATSCNT)
148 .. ; Quit if errors were encountered in FSOS data
149 .. I $D(^XTMP("QACMIGR","FSOS","E",FSOSIEN)) S ERR=1 Q
150 .. S FSOSCNT=FSOSCNT+1
151 .. ;
152 .. ; Set ROC Issue data for Issue Multiples with both FSOS and Employees
153 .. I EMPCNT D Q
154 ... F EMP=0:0 S EMP=$O(EMP(EMP)) Q:'EMP D:'QACI0 SETDATA
155 ... Q
156 .. ; If no employees notified, set Issue Multiples with FSOS
157 .. S EMP="" D:'QACI0 SETDATA
158 .. Q
159 . I FSOSCNT=0 S FSOSNAME="" D
160 .. ; If no FSOS, but there are employees, set Issue Multiples
161 .. I EMPCNT D Q
162 ... F EMP=0:0 S EMP=$O(EMP(EMP)) Q:'EMP D:'QACI0 SETDATA
163 ... Q
164 .. ; If there are no FSOS and no employees, set Issue Multiples
165 .. S EMP="" D:'QACI0 SETDATA Q
166 . Q
167 ; If errors were encountered, quit with the error code
168 I ERR K ^XTMP("QACMIGR","ROC","U",ROCNO) Q ERR
169 Q 0
170 ;
171 ;
172SETDATA ; Set data for Issue Code multiple on a ROC
173 ; We don't call this routine if just building error report (i.e., from ^QACI0).
174 S ROCCNT=ROCCNT+1
175 S ^XTMP("QACMIGR","ROC","U",ROCNO_" ",ROCCNT)=ROCNO_"^ISS^"_ISSCODE_"^"_FSOSNAME_"^"_EMP_"^"_HLNAME_"^"_HLINST_"^"
176 Q
177 ;
178HLDATA(STATION,HL,QACI0,ERR,HLINST,PATSCNT) ; Load Hospital Location Data for migration
179 ; IA #10040, #10112
180 N Y,HLNAME S ERR=0
181 S Y=$G(^SC(HL,0)) I Y="" S ERR=1 Q
182 S HLNAME=$P(Y,"^"),HLINST=""
183 D
184 . ; Get DIVISION station number for Hospital Location
185 . S HLINST=$P(Y,"^",15)
186 . I HLINST S HLINST=$P($$SITE^VASITE(,HLINST),"^",3) Q:HLINST'=-1
187 . ; If not found, get Institution station
188 . S HLINST=$P(Y,"^",4) Q:'HLINST
189 . S HLINST=$$STA^XUAF4(HLINST) Q:HLINST]""
190 . ; If no station number for either one, generate an error
191 . S Y=$L(HLNAME)
192 . S HLNAME=$E(HLNAME,1,30)_$S(Y>30:"...",1:"")
193 . S ERR=1 D ERREF^QACI2C("HL",HL,HLNAME_" - has no STATION NUMBER") Q
194 I HLINST="" S HLINST=STATION
195 Q:$D(^XTMP("QACMIGR","HL","D",HL))
196 Q:$D(^XTMP("QACMIGR","HL","U",HL))
197 I $$TXTERR^QACI2C(HLNAME,30,0,1) D
198 . S HLNAME=$E(HLNAME,1,20)_$S($L(HLNAME>20):"...",1:"")
199 . S ERR=1 D ERREF^QACI2C("HL",HL,HLNAME_" - NAME missing or invalid") Q
200 ; Check to make sure station is on the list from std_institution table
201 I '$D(^XTMP("QACMIGR","STDINSTITUTION",HLINST)) D
202 . S ERR=1 D ERREF^QACI2C("HL",HL,HLINST_" is not a valid national station number") Q
203 ; Quit if there are errors, or if called from ^QACI0 to just print the error report.
204 Q:ERR=1
205 Q:QACI0
206 S ^XTMP("QACMIGR","HL","U",HL)=HL_"^"_HLNAME_"^"_HLINST_"^"
207 S PATSCNT("HL")=PATSCNT("HL")+1
208 Q
209 ;
210 ;
Note: See TracBrowser for help on using the repository browser.