source: ccr/trunk/p/C0CACTOR.m@ 1746

Last change on this file since 1746 was 1586, checked in by Sam Habiel, 12 years ago

Changed license to AGPL. Some clean-up for XINDEX
  • Property svn:mergeinfo set to (toggle deleted branches)
    /ccr/branches/ohum/o-old/p/C0CACTOR.m1290
    /ccr/branches/ohum/p/C0CACTOR.m1291-1543
    /ccr/branches/ohum/p/p/C0CACTOR.m1287-1289
File size: 10.6 KB
Line 
1C0CACTOR ; CCDCCR/GPL - CCR/CCD PROCESSING FOR ACTORS ; 7/3/08 ; 10/29/12 4:04pm
2 ;;1.2;CCD/CCR GENERATION UTILITIES;;Oct 30, 2012;Build 50
3 ;Copyright 2008,2009 George Lilly, University of Minnesota.
4 ;
5 ; This program is free software: you can redistribute it and/or modify
6 ; it under the terms of the GNU Affero General Public License as
7 ; published by the Free Software Foundation, either version 3 of the
8 ; License, or (at your option) any later version.
9 ;
10 ; This program is distributed in the hope that it will be useful,
11 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 ; GNU Affero General Public License for more details.
14 ;
15 ; You should have received a copy of the GNU Affero General Public License
16 ; along with this program. If not, see <http://www.gnu.org/licenses/>.
17 ;
18 ; PROCESS THE ACTORS SECTION OF THE CCR
19 ;
20 ; ===Revision History===
21 ; 0.1 Initial Writing of Skeleton--GPL
22 ; 0.2 Patient Data Extraction--SMH
23 ; 0.3 Information System Info Extraction--SMH
24 ; 0.4 Patient data rouine refactored; adjustments here--SMH
25 ;
26EXTRACT(IPXML,ALST,AXML) ; EXTRACT ACTOR FROM ALST INTO PROVIDED XML TEMPLATE
27 ; IPXML is the Input Actor Template into which we substitute values
28 ; This is straight XML. Values to be substituted are in @@VAL@@ format.
29 ; ALST is the actor list global generated by ACTLST^C0CCCR and has format:
30 ; ^TMP(7542,1,"ACTORS",0)=Count
31 ; ^TMP(7542,1,"ACTORS",n)="ActorID^ActorType^ActorIEN"
32 ; ActorType is an enum containing either "PROVIDER" "PATIENT" "SYSTEM"
33 ; AXML is the output arrary, to contain XML.
34 ;
35 N I,J,AMAP,AOID,ATYP,AIEN
36 D CP^C0CXPATH(IPXML,AXML) ; MAKE A COPY OF ACTORS XML
37 D REPLACE^C0CXPATH(AXML,"","//Actors") ; DELETE THE INSIDES
38 I DEBUG W "PROCESSING ACTORS ",!
39 F I=1:1:@ALST@(0) D ; PROCESS ALL ACTORS IN THE LIST
40 . I @ALST@(I)["@@" Q ; NOT A VALID ACTOR
41 . S AOID=$P(@ALST@(I),"^",1) ; ACTOR OBJECT ID
42 . S ATYP=$P(@ALST@(I),"^",2) ; ACTOR TYPE
43 . S AIEN=$P(@ALST@(I),"^",3) ; ACTOR RECORD NUMBER
44 . I AIEN="" D Q ; IEN CAN'T BE NULL
45 . . W "WARING NUL ACTOR: ",ATYP,!
46 . I ATYP="" Q ; NOT A VALID ACTOR
47 . ;
48 . I DEBUG W AOID_" "_ATYP_" "_AIEN,!
49 . I ATYP="PATIENT" D ; PATIENT ACTOR TYPE
50 . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-PATIENT","ATMP")
51 . . D PATIENT("ATMP",AIEN,AOID,"ATMP2")
52 . ;
53 . I ATYP="SYSTEM" D ; SYSTEM ACTOR TYPE
54 . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-SYSTEM","ATMP")
55 . . D SYSTEM("ATMP",AIEN,AOID,"ATMP2")
56 . ;
57 . I ATYP="NOK" D ; NOK ACTOR TYPE
58 . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-NOK","ATMP")
59 . . D NOK("ATMP",AIEN,AOID,"ATMP2")
60 . ;
61 . I ATYP="PROVIDER" D ; PROVIDER ACTOR TYPE
62 . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-PROVIDER","ATMP")
63 . . D PROVIDER("ATMP",AIEN,AOID,"ATMP2")
64 . ;
65 . I ATYP="ORGANIZATION" D ; PROVIDER ACTOR TYPE
66 . . D QUERY^C0CXPATH(IPXML,"//Actors/ACTOR-ORG","ATMP")
67 . . D ORG("ATMP",AIEN,AOID,"ATMP2")
68 . ;
69 . W "PROCESSING:",ATYP," ",AIEN,!
70 . ;I @ATMP2@(0)=0 Q ; NOTHING RETURNED, SKIP THIS ONE
71 . D INSINNER^C0CXPATH(AXML,"ATMP2") ; INSERT INTO ROOT
72 . K ATYP,AIEN,AOID,ATMP,ATMP2 ; BE SURE TO GET THE NEXT ONE
73 ;
74 N ACTTMP
75 D MISSING^C0CXPATH(AXML,"ACTTMP") ; SEARCH XML FOR MISSING VARS
76 I ACTTMP(0)>0 D ; IF THERE ARE MISSING VARS -
77 . ; STRINGS MARKED AS @@X@@
78 . W "ACTORS Missing list: ",!
79 . F I=1:1:ACTTMP(0) W ACTTMP(I),!
80 Q
81 ;
82PATIENT(INXML,AIEN,AOID,OUTXML) ; PROCESS A PATIENT ACTOR
83 I DEBUG W "PROCESSING ACTOR PATIENT ",AIEN,!
84 ;GPL SEPARATED EXTRACT FROM MAP FOR PROCESSING PATIENTS - TO MAKE
85 ; CODE REUSABLE FROM ERX
86 N AMAP
87 S AMAP=$NA(^TMP($J,"AMAP"))
88 K @AMAP
89 D PEXTRACT(AMAP,AIEN,AOID) ;EXTRACT THE PATIENT ACTOR
90 I $P($$SITE^VASITE(),U,2)="OROVILLE HOSPITAL" S C0CDE=1
91 I $G(C0CDE)'="" D DEIDENT(AMAP,AIEN) ; DEIDENTIFY THE CCR
92 D MAP(INXML,AMAP,OUTXML) ;MAP TO XML
93 K @AMAP ; CLEAN UP BEHIND US
94 Q
95 ;
96DEIDENT(GPL,ZDFN) ; QUICK WAY TO DEIDENTIFY THE CCR
97 S @GPL@("ACTORADDRESSCITY")="ALTON"
98 S @GPL@("ACTORADDRESSLINE1")="1234 Somewhere Lane"
99 S @GPL@("ACTORADDRESSLINE2")=""
100 S @GPL@("ACTORADDRESSSOURCEID")="ACTORPATIENT_"_ZDFN
101 S @GPL@("ACTORADDRESSSTATE")="KANSAS"
102 S @GPL@("ACTORADDRESSTYPE")="Home"
103 S @GPL@("ACTORADDRESSZIPCODE")=67623
104 S @GPL@("ACTORCELLTEL")=""
105 S @GPL@("ACTORCELLTELTEXT")=""
106 S @GPL@("ACTORDATEOFBIRTH")="1957-12-25"
107 S @GPL@("ACTOREMAIL")=""
108 S @GPL@("ACTORFAMILYNAME")="ZZ PATIENT"_ZDFN
109 ;S @GPL@("ACTORGENDER")="MALE"
110 S @GPL@("ACTORGIVENNAME")="TEST"_ZDFN
111 S @GPL@("ACTORIEN")=2
112 S @GPL@("ACTORMIDDLENAME")="TWO"
113 S @GPL@("ACTOROBJECTID")="ACTORPATIENT_"_ZDFN
114 S @GPL@("ACTORRESTEL")="888-555-1212"
115 S @GPL@("ACTORRESTELTEXT")="Residential Telephone"
116 S @GPL@("ACTORSOURCEID")="ACTORSYSTEM_1"
117 S @GPL@("ACTORSSN")="769122557P"
118 S @GPL@("ACTORSSNSOURCEID")="ACTORPATIENT_"_ZDFN
119 S @GPL@("ACTORSSNTEXT")="SSN"
120 S @GPL@("ACTORSUFFIXNAME")=""
121 S @GPL@("ACTORWORKTEL")="888-121-1212"
122 S @GPL@("ACTORWORKTELTEXT")="Work Telephone"
123 Q
124 ;
125PEXTRACT(AMAP,AIEN,AOID) ; EXTRACT TO RETURN ARRAY RARY PASSED BY NAME
126 N ZX
127 S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID
128 S @AMAP@("ACTORGIVENNAME")=$$GIVEN^C0CDPT(AIEN)
129 S @AMAP@("ACTORMIDDLENAME")=$$MIDDLE^C0CDPT(AIEN)
130 S @AMAP@("ACTORFAMILYNAME")=$$FAMILY^C0CDPT(AIEN)
131 S @AMAP@("ACTORDATEOFBIRTH")=$$DOB^C0CDPT(AIEN)
132 S @AMAP@("ACTORGENDER")=$P($$GENDER^C0CDPT(AIEN),U,2)
133 S @AMAP@("ACTORGENDERCODE")=$P($$GENDER^C0CDPT(AIEN),U,1)
134 S @AMAP@("ACTORSSN")=""
135 S @AMAP@("ACTORSSNTEXT")=""
136 S @AMAP@("ACTORSSNSOURCEID")=""
137 S X="MSCDPTID" ; ROUTINE TO TEST FOR MRN ON OPENVISTA
138 X ^%ZOSF("TEST") ; TEST TO SEE IF THE ROUTINE EXISTS
139 I $T S MRN=$$^MSCDPTID(DFN) ;TEST FOR MRN ON OPENVISTA ;GPL
140 I $G(MRN)'="" D ; IF MRN IS PRESENT
141 . S @AMAP@("ACTORSSN")=MRN
142 . S @AMAP@("ACTORSSNTEXT")="MRN"
143 . S @AMAP@("ACTORSSNSOURCEID")=AOID
144 E D ; NO MRN, USE SSN
145 . S ZX=$$SSN^C0CDPT(AIEN)
146 . I ZX'="" D ; IF THERE IS A SSN IN THE RECORD
147 . . S @AMAP@("ACTORSSN")=ZX
148 . . S @AMAP@("ACTORSSNTEXT")="SSN"
149 . . S @AMAP@("ACTORSSNSOURCEID")=AOID
150 S @AMAP@("ACTORADDRESSTYPE")=$$ADDRTYPE^C0CDPT(AIEN)
151 S @AMAP@("ACTORADDRESSLINE1")=$$ADDR1^C0CDPT(AIEN)
152 S @AMAP@("ACTORADDRESSLINE2")=$$ADDR2^C0CDPT(AIEN)
153 S @AMAP@("ACTORADDRESSCITY")=$$CITY^C0CDPT(AIEN)
154 S @AMAP@("ACTORADDRESSSTATE")=$$STATE^C0CDPT(AIEN)
155 S @AMAP@("ACTORADDRESSZIPCODE")=$$ZIP^C0CDPT(AIEN)
156 S @AMAP@("ACTORRESTEL")=""
157 S @AMAP@("ACTORRESTELTEXT")=""
158 S ZX=$$RESTEL^C0CDPT(AIEN)
159 I ZX'="" D ; IF THERE IS A RESIDENT PHONE IN THE RECORD
160 . S @AMAP@("ACTORRESTEL")=ZX
161 . S @AMAP@("ACTORRESTELTEXT")="Residential Telephone"
162 S @AMAP@("ACTORWORKTEL")=""
163 S @AMAP@("ACTORWORKTELTEXT")=""
164 S ZX=$$WORKTEL^C0CDPT(AIEN)
165 I ZX'="" D ; IF THERE IS A RESIDENT PHONE IN THE RECORD
166 . S @AMAP@("ACTORWORKTEL")=ZX
167 . S @AMAP@("ACTORWORKTELTEXT")="Work Telephone"
168 S @AMAP@("ACTORCELLTEL")=""
169 S @AMAP@("ACTORCELLTELTEXT")=""
170 S ZX=$$CELLTEL^C0CDPT(AIEN)
171 I ZX'="" D ; IF THERE IS A CELL PHONE IN THE RECORD
172 . S @AMAP@("ACTORCELLTEL")=ZX
173 . S @AMAP@("ACTORCELLTELTEXT")="Cell Phone"
174 S @AMAP@("ACTOREMAIL")=$$EMAIL^C0CDPT(AIEN)
175 S @AMAP@("ACTORADDRESSSOURCEID")=AOID
176 S @AMAP@("ACTORIEN")=AIEN
177 S @AMAP@("ACTORSUFFIXNAME")="" ; DOES VISTA STORE THE SUFFIX
178 S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" ; THE SYSTEM IS THE SOURCE
179 Q
180 ;
181MAP(INXML,AMAP,OUTXML) ;MAP ANY ACTOR TO XML
182 D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE
183 Q
184 ;
185SYSTEM(INXML,AIEN,AOID,OUTXML) ; PROCESS A SYSTEM ACTOR
186 ;
187 ; N AMAP
188 S AMAP=$NA(^TMP($J,"AMAP"))
189 K @AMAP
190 S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID
191 S @AMAP@("ACTORINFOSYSNAME")=$$SYSNAME^C0CSYS
192 S @AMAP@("ACTORINFOSYSVER")=$$SYSVER^C0CSYS
193 S @AMAP@("ACTORINFOSYSSOURCEID")=AOID
194 D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE
195 Q
196 ;
197NOK(INXML,AIEN,AOID,OUTXML) ; PROCESS A NEXT OF KIN TYPE ACTOR
198 ;
199 ; N AMAP
200 S AMAP=$NA(^TMP($J,"AMAP"))
201 K @AMAP
202 S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID
203 S @AMAP@("ACTORDISPLAYNAME")=""
204 S @AMAP@("ACTORRELATION")=""
205 S @AMAP@("ACTORRELATIONSOURCEID")=""
206 S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" ; THE SYSTEM IS THE SOURCE
207 D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE
208 Q
209 ;
210ORG(INXML,AIEN,AOID,OUTXML) ; PROCESS AN ORGANIZATION TYPE ACTOR
211 ;
212 N AMAP,ZIEN,ZSITE
213 S AMAP=$NA(^TMP($J,"AMAP"))
214 K @AMAP
215 S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID
216 S ZSITE=$$SITE^VASITE ; SITE FORMAT IEN^NAME^DATE
217 S ZIEN=$P(ZSITE,"^",1)
218 S @AMAP@("ORGANIZATIONNAME")=$P(ZSITE,U,2)
219 S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1"
220 S @AMAP@("ACTORADDRESSTYPE")="Office"
221 S @AMAP@("ACTORADDRESSLINE1")=$$GET1^DIQ(4,ZIEN_",",1.01)
222 S @AMAP@("ACTORADDRESSLINE2")=$$GET1^DIQ(4,ZIEN_",",1.02)
223 S @AMAP@("ACTORADDRESSCITY")=$$GET1^DIQ(4,ZIEN_",",1.03)
224 S @AMAP@("ACTORADDRESSSTATE")=$$GET1^DIQ(4,ZIEN_",",.02)
225 S @AMAP@("ACTORPOSTALCODE")=$$GET1^DIQ(4,ZIEN_",",1.04)
226 S @AMAP@("ACTORTELEPHONE")=""
227 S @AMAP@("ACTORTELEPHONETYPE")=""
228 S ZX=$$GET1^DIQ(4.03,"1,"_ZIEN_",",.03)
229 I ZX'="" D ; THERE IS A PHONE NUMBER AVAILABLE
230 . S @AMAP@("ACTORTELEPHONE")=ZX
231 . S @AMAP@("ACTORTELEPHONETYPE")="Office"
232 D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE
233 K @AMAP
234 Q
235 ;
236PROVIDER(INXML,AIEN,AOID,OUTXML) ; PROCESS A PROVIDER TYPE ACTOR
237 ;
238 ; N AMAP
239 S AMAP=$NA(^TMP($J,"AMAP"))
240 K @AMAP
241 I '$D(^VA(200,AIEN,0)) D Q ; IF NO PROVIDER RECORD (SHOULDN'T HAPPEN)
242 . W "WARNING - MISSING PROVIDER: ",AIEN,!
243 . S @OUTXML@(0)=0 ; SIGNAL NO OUTPUT
244 S @AMAP@("ACTOROBJECTID")=AOID ;ACTOR OBJECT ID
245 S @AMAP@("ACTORGIVENNAME")=$$GIVEN^C0CVA200(AIEN)
246 S @AMAP@("ACTORMIDDLENAME")=$$MIDDLE^C0CVA200(AIEN)
247 S @AMAP@("ACTORFAMILYNAME")=$$FAMILY^C0CVA200(AIEN)
248 S @AMAP@("ACTORTITLE")=$$TITLE^C0CVA200(AIEN)
249 S @AMAP@("IDTYPE")=$P($$NPI^C0CVA200(AIEN),U,1)
250 S @AMAP@("ID")=$P($$NPI^C0CVA200(AIEN),U,2)
251 S @AMAP@("IDDESC")=$P($$NPI^C0CVA200(AIEN),U,3)
252 S @AMAP@("ACTORSPECIALITY")=$$SPEC^C0CVA200(AIEN)
253 S @AMAP@("ACTORADDRESSTYPE")=$$ADDTYPE^C0CVA200(AIEN)
254 S @AMAP@("ACTORADDRESSLINE1")=$$ADDLINE1^C0CVA200(AIEN)
255 S @AMAP@("ACTORADDRESSCITY")=$$CITY^C0CVA200(AIEN)
256 S @AMAP@("ACTORADDRESSSTATE")=$$STATE^C0CVA200(AIEN)
257 S @AMAP@("ACTORPOSTALCODE")=$$POSTCODE^C0CVA200(AIEN)
258 S @AMAP@("ACTORTELEPHONE")=""
259 S @AMAP@("ACTORTELEPHONETYPE")=""
260 S ZX=$$TEL^C0CVA200(AIEN)
261 I ZX'="" D ; THERE IS A PHONE NUMBER AVAILABLE
262 . S @AMAP@("ACTORTELEPHONE")=ZX
263 . S @AMAP@("ACTORTELEPHONETYPE")=$$TELTYPE^C0CVA200(AIEN)
264 S @AMAP@("ACTOREMAIL")=$$EMAIL^C0CVA200(AIEN)
265 S @AMAP@("ACTORADDRESSSOURCEID")="ACTORSYSTEM_1"
266 S @AMAP@("ACTORSOURCEID")="ACTORSYSTEM_1" ; THE SYSTEM IS THE SOURCE
267 S @AMAP@("ACTORORGLINK")="ACTORORGANIZATION_1"
268 D MAP^C0CXPATH(INXML,AMAP,OUTXML) ; MAP THE VARIABLE
269 Q
270 ;
Note: See TracBrowser for help on using the repository browser.