source: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMCHLZ.m@ 636

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

initial load of FOIAVistA 6/30/08 version
File size: 7.1 KB
Line 
1SCMCHLZ ;BP/DJB - PCMM HL7 Bld ZPC Segment ; 3/7/00 1:08pm
2 ;;5.3;Scheduling;**177,210,212,245,286,515**;AUG 13, 1993;Build 14
3 ;
4ZPC(SCSTR,SCID,SCDATA,SCSEQ) ;Main entry point for building ZPC segment
5 ;
6 ;Input:
7 ; SCSTR...: String of fields requested separated by commas
8 ; SCID....: Provider Assignment ID. Unique ID string that
9 ; Austin uses for the key field.
10 ; SCDATA..: "^" Delimited string that contains all data needed
11 ; to build a ZPC segment. If all pieces are "", Austin
12 ; does a deletion.
13 ; Format:
14 ; ProviderIEN^DateAssign^DateUnassign^Type
15 ; Examples:
16 ; 3^2980605^2990203^PCP
17 ; 6^2980605^2990203^AP
18 ; ""^""^""^"" (deletion)
19 ; SCSEQ...: Sequentially number multiple ZPC segments.
20 ; djb/bp Patch 210.
21 ;Output:
22 ; ZPC segment string.
23 ;
24 NEW CS,FS,QT,SCZPC,SS
25 ;
26 ;Initialize variables
27 D INIT
28 I $G(SCID)="" Q SCZPC
29 ;
30 I SCSTR[",1," D ID ;........Provider Assignment ID
31 I SCSTR[",2," D PROV ;......Provider
32 I SCSTR[",3," D PROVDA ;....Date provider assigned
33 I SCSTR[",4," D PROVDU ;....Date provider unassigned
34 I SCSTR[",5," D PROVT ;.....Provider Type code
35 I SCSTR[",6," D PROVPC ;....Provider Person Class PATCH 515
36 I SCSTR[",8," D PROVSSN ;...Provider SSN;bp/ar and alb/rpm Patch 212
37 I SCSTR[",9," D STATION ;....5 or 6 digit station number Patch 286
38 I SCSTR[",10," D TEAM ;....Team Name - Patch 515
39 I SCSTR[",11," D TMIEN ;....Team IEN - Patch 515
40 I SCSTR[",16," D TMPUR ;...Team Purpose Patch 515
41 I $L(SCZPC)>245 D ADJUST ;..If length>245 add continuation node
42 Q SCZPC
43 ;
44ID ;Provider Assignment ID
45 ;Convert ID to IEN of file 404.49 since it's alot shorter.
46 ;ID format:
47 ; IEN404.43 - IEN404.52 - IEN404.53 - AP/PCP
48 ; Examples: "2290-405-34-PCP"
49 ; "2290-406-0-AP"
50 ;
51 NEW FAC,ID,OLDID,SCERR,SCFDA,SCIEN
52 ;
53 ;Find ID in PCMM HL7 ID file (404.49), and use IEN.
54 S ID=$O(^SCPT(404.49,"B",SCID,""))
55 ;
56 ;If ID not found, add it to 404.49 now.
57 I 'ID D ;
58 . S SCFDA(404.49,"+1,",.01)=SCID
59 . D UPDATE^DIE("E","SCFDA","SCIEN","SCERR")
60 . S ID=$G(SCIEN(1))
61 ;
62 ;bp/djb Patch 210
63 ;New code begins
64 ;If this is a site integration entry, use old ID.
65 S FAC=SCFAC ;..Facility
66 S OLDID=$P($G(^SCPT(404.49,ID,0)),U,2)
67 I OLDID]"" D ;
68 . S FAC=$P(OLDID,"-",1)
69 . S ID=$P(OLDID,"-",2)
70 ;New code ends
71 ;
72 ;Add ID to ZPC segment
73 S $P(SCZPC,FS,2)=FAC_"-"_ID
74 Q
75 ;
76STATION ; Add station # suffix patch SD*5.3*286
77 NEW STAT,SNUM,SCTP,TEAM,TEAMP
78 S $P(SCZPC,FS,10)=""
79 S SCTP=+$P(SCZPC,"-",2),SCTP=+$P($G(^SCPT(404.49,SCTP,0)),"-",1) D
80 .IF SCTP S TEAMP=$$GET1^DIQ(404.43,SCTP_",",.02,"I") D
81 ..IF TEAMP S SNUM=$$GET1^DIQ(404.57,TEAMP_",",.02,"I") D
82 ...IF SNUM S TEAM=$$GET1^DIQ(404.51,SNUM_",",.07,"I") D
83 ....IF TEAM S STAT=$$GET1^DIQ(4,TEAM_",",99) D
84 .....IF STAT S $P(SCZPC,FS,10)=STAT
85 Q
86 ;
87TEAM ;Add Team Name patch SD*5.3*515
88 NEW SNUM,SCTP,TEAM,TEAMP
89 S $P(SCZPC,FS,11)=QT
90 Q:'$L(($P(SCDATA,U,2)))
91 S SCTP=+$P(SCZPC,"-",2),SCTP=+$P($G(^SCPT(404.49,SCTP,0)),"-",1) D
92 .IF SCTP S TEAMP=$$GET1^DIQ(404.43,SCTP_",",.02,"I") D
93 ..IF TEAMP S SNUM=$$GET1^DIQ(404.57,TEAMP_",",.02,"I") D
94 ...IF SNUM S TEAM=$$GET1^DIQ(404.51,SNUM_",",.01,"I") D
95 ....IF $L(TEAM)>0 S $P(SCZPC,FS,11)=TEAM
96 Q
97 ;
98TMIEN ;Add Team IEN patch SD*5.3*515
99 NEW SNUM,SCTP,TEAMP
100 S $P(SCZPC,FS,12)=QT
101 Q:'$L(($P(SCDATA,U,2)))
102 S SCTP=+$P(SCZPC,"-",2),SCTP=+$P($G(^SCPT(404.49,SCTP,0)),"-",1) D
103 .IF SCTP S TEAMP=$$GET1^DIQ(404.43,SCTP_",",.02,"I") D
104 ..IF TEAMP S SNUM=$$GET1^DIQ(404.57,TEAMP_",",.02,"I") D
105 ...IF SNUM S $P(SCZPC,FS,12)=SNUM
106 Q
107 ;
108PROV ;Provider
109 NEW PROV,PTR200,SCNAM,SCNAME,SCTMP,X
110 ;
111 S $P(SCZPC,FS,3)=QT
112 S PTR200=+SCDATA
113 Q:'PTR200
114 ;
115 ;Get External Provider ID
116 D PERSON^VAFHLRO3(PTR200,"SCTMP",QT)
117 Q:'$D(SCTMP)
118 S PROV=SCTMP(1,1,1)_SS_SCTMP(1,1,2)
119 S $P(PROV,CS,8)=SCTMP(1,8)
120 ;rpm/alb patch 210-Stuff facility in Assigning Facility(component 14)
121 S $P(PROV,CS,14)=SCTMP(1,1,2)
122 ;rpm/alb patch 210
123 ;Get Standardized Name using Kernel API
124 ;Standardized Name retrieval allowed by IA #3065
125 S SCNAM("FILE")=200
126 S SCNAM("IENS")=PTR200_","
127 S SCNAM("FIELD")=.01
128 S SCNAME=$$HLNAME^XLFNAME(.SCNAM,"",FS)
129 F X=2:1:7 S $P(PROV,CS,X)=$P(SCNAME,FS,X-1)
130 F X=9:1:13 S $P(PROV,CS,X)=""
131 ;
132 ;Add provider to ZPC segment
133 S $P(SCZPC,FS,3)=PROV
134 Q
135 ;
136PROVDA ;Provider - Date Assigned
137 NEW DATE
138 S $P(SCZPC,FS,4)=QT
139 S DATE=$P(SCDATA,U,2)
140 Q:'DATE
141 S $P(SCZPC,FS,4)=$$HLDATE^HLFNC(DATE,"DT")
142 Q
143 ;
144PROVDU ;Provider - Date Unassigned
145 NEW DATE
146 S $P(SCZPC,FS,5)=QT
147 S DATE=$P(SCDATA,U,3)
148 Q:'DATE
149 S $P(SCZPC,FS,5)=$$HLDATE^HLFNC(DATE,"DT")
150 Q
151 ;
152PROVT ;Provider - Type code
153 NEW PT
154 S $P(SCZPC,FS,6)=QT
155 S PT=$P(SCDATA,U,4)
156 Q:PT']""
157 S $P(SCZPC,FS,6)=PT
158 Q
159 ;
160PROVPC ;Provider - Person Class
161 NEW CODE,PTR200
162 S $P(SCZPC,FS,7)=QT
163 S PTR200=+SCDATA
164 Q:'PTR200
165 S CODE=$$GET^XUA4A72(PTR200)
166 ; PATCH 515 OLD CODE
167 ; I CODE=-1!'CODE Q
168 ; S $P(SCZPC,FS,7)=$P(CODE,"^",7)_CS_CS_"VA8932.1"
169 I CODE=-1!'CODE S CODE=""
170 S CODE=$P(CODE,"^",7)
171 S $P(SCZPC,FS,7)=CODE_CS_CS_"VA8932.1"
172 Q
173 ;
174PROVSSN ;Provider - Social Security Number
175 ;bp/ar and alb/rpm Patch 212
176 NEW SCSNN,PTR200,SC200,SCARRY
177 S $P(SCZPC,FS,9)=QT
178 S PTR200=+SCDATA
179 Q:'PTR200
180 S SC200=$$NEWPERSN^SCMCGU(PTR200,"SCARRY")
181 I SC200'=1 Q
182 S SCSNN=$P($G(SCARRY(PTR200)),U,6)
183 Q:SCSNN'?9N
184 S $P(SCZPC,FS,9)=SCSNN
185 Q
186 ;
187TMPUR ; TEAM PURPOSE ADDED PATCH 515 send in BOTH DELETE & ADD
188 S $P(SCZPC,FS,17)=QT
189 ; Q:SCDATA="^^^" COMMENT OUT SO SEND W DELETE TOO
190 NEW SCTMPI,SCTMP,SCTPD,SCTM,TMD,ND,SCTP
191 ; Read PATIENT TEAM ASS FILE
192 S ND=$G(^SCPT(404.43,$P(SCID,"-",1),0))
193 Q:ND=""
194 S SCTP=$P(ND,U,2) ; TP
195 ; READ TP REC (57)
196 S SCTPD=$G(^SCTM(404.57,SCTP,0))
197 Q:SCTPD=""
198 S SCTM=$P(SCTPD,U,2)
199 ; READ TEAM FILE (404.51
200 S TMD=^SCTM(404.51,SCTM,0)
201 S SCTMP=$P(TMD,U,3)
202 Q:SCTMP=""
203 S SCTMPI=SCTMP
204 S SCTMP=$G(^SD(403.47,SCTMP,0))
205 Q:SCTMP=""
206 S SCTMP=$P(SCTMP,U,1)
207 Q:SCTMP=""
208 S $P(SCZPC,FS,17)=SCTMPI_CS_SCTMP
209 Q
210 ;
211INIT ;Initialize variables
212 ;
213 ;Set delimeter values
214 S FS=HL("FS") ;.........^
215 S CS=$E(HL("ECH"),1) ;..~
216 S SS=$E(HL("ECH"),4) ;..&
217 S QT=HL("Q") ;..........""
218 ;
219 ;Default SCSEQ to 1. djb/bp Patch 210
220 S:'$G(SCSEQ) SCSEQ=1
221 ;
222 ;Initialize ZPC segment to all nulls.
223 ;bp/ar and alb/rpm Patch 212
224 ;S $P(SCZPC,FS,5)="^" ;Initialize as empty; not null.
225 ;S SCZPC="ZPC"_FS_SCZPC_FS_SCSEQ ;djb/bp Patch 210
226 S $P(SCZPC,FS,9)=""
227 S $P(SCZPC,FS,10)="" ; PATCH 286
228 S $P(SCZPC,FS,11)="" ; PATCH 515
229 S $P(SCZPC,FS,12)="" ; PATCH 515
230 ; DEBBIE LEVY TPA CHGS 20070518 PATCH 515
231 S $P(SCZPC,FS,17)=""
232 S $P(SCZPC,FS,1)="ZPC"
233 S $P(SCZPC,FS,8)=SCSEQ
234 ;
235 ;Initialize SCSTR to fields user requested.
236 S SCSTR=$G(SCSTR)
237 ;bp/ar and alb/rpm Added "8" to default fields Patch 212
238 ; Added "9" to default fields Patch 286
239 ; DEBBIE LEVY TPA CHGS 20070518 PATCH 515
240 ; added team (10), team IEN (11) and team purpose (16)
241 ;I SCSTR']"" S SCSTR="1,2,3,4,5,6,8,9" ;Default fields
242 I SCSTR']"" S SCSTR="1,2,3,4,5,6,8,9,10,11,16" ;Default fields
243 ;Add starting and ending comma.
244 I $E(SCSTR)'="," S SCSTR=","_SCSTR
245 I $E(SCSTR,$L(SCSTR))'="," S SCSTR=SCSTR_","
246 Q
247 ;
248ADJUST ;Add a continuation node if length is greater than 245.
249 Q:$L(SCZPC)'>245
250 S SCZPC(1)=$E(SCZPC,246,999) ;
251 S SCZPC=$E(SCZPC,1,245)
252 Q
Note: See TracBrowser for help on using the repository browser.