source: FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCMCHLB.m@ 677

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

initial load of FOIAVistA 6/30/08 version
File size: 9.1 KB
Line 
1SCMCHLB ;BP/DJB - PCMM HL7 Bld Segment Array ; 3/2/00 2:12pm
2 ;;5.3;Scheduling;**177,204,210,224,515**;AUG 13, 1993;Build 14
3 ;
4BUILD(VARPTR,HL,XMITARRY) ;Build an array of HL7 segments based on EVENT
5 ;POINTER field in PCMM HL7 EVENT file (#404.48).
6 ;
7 ;Input:
8 ; VARPTR - EVENT POINTER field in PCMM HL7 EVENT file.
9 ; HL - Array of HL7 variables (pass by reference).
10 ; Output of call to INIT^HLFNC2().
11 ; XMITARRY - Array to store HL7 segments (full global ref).
12 ; Default=^TMP("HLS",$J)
13 ;Output:
14 ; XMITARRY(n,segment) array of segments.
15 ; Examples:
16 ; ^TMP("PCMM","HL7",$J,2290,"PID")...= PID segment
17 ; ^TMP("PCMM","HL7",$J,2290,"ZPC",ID)= ZPC segments
18 ; -1^Error = Unable to build message / bad input
19 ;
20 ;Note: The calling program must initialize (i.e. KILL) XMITARRY.
21 ;
22 ;Declare variables
23 NEW RESULT,SCIEN,SCGLB
24 NEW HLECH,HLEID,HLFS,HLQ
25 ;
26 ;Convert VARPTR (ien;global) to SCIEN & SCGLB
27 S RESULT=$$CHECK^SCMCHLB1($G(VARPTR))
28 ;
29 I 'RESULT Q "-1^Did not pass valid variable pointer"
30 ;
31 ;Initialize HL7 variables
32 S HLECH=HL("ECH")
33 S HLFS=HL("FS")
34 S HLQ=HL("Q")
35 ;
36 I RESULT=2 D G QUIT ;........................Process a deletion
37 . I SCGLB="SCPT(404.43," D PTP^SCMCHLB2 Q ;..Delete - File 404.43
38 . I SCGLB="SCTM(404.52," D POS^SCMCHLB2 Q ;..Delete - File 404.52
39 . I SCGLB="SCTM(404.53," D PRE^SCMCHLB2 Q ;..Delete - File 404.53
40 I SCGLB="SCPT(404.43," D PTP(SCIEN,"") G QUIT ;..File 404.43
41 I SCGLB="SCTM(404.52," D POS G QUIT ;.........File 404.52
42 I SCGLB="SCTM(404.53," D PRE G QUIT ;.........File 404.53
43QUIT Q 1
44 ;
45 ;==================================================================
46 ;
47PTP(PTPI,SCTPAIN) ;Patient Team Position Assignment (#404.43).
48 ;Input: PTPI - Patient Team Position Assignment IEN
49 ;
50 ;To keep VISTA and NPCD in sync, for this PT TM POS ASSIGN send
51 ;down a delete for all previous entries, and then send down data
52 ;for current valid entries.
53 ;
54 ;NEW DFN,ERROR,ND,ZDATE,ZPTP
55 ;djb/bp Added SCSEQ per Patch 210, replace above line with below line
56 ;NEW DFN,ERROR,ND,SCSEQ,ZDATE,ZPTP
57 ; ADDED SCLOW SCTPTPA PATCH 515 DLL
58 NEW DFN,ERROR,ND,SCSEQ,ZDATE,ZPTP,SCLOW,SCTPTPA
59 ;
60 ;Get data
61 S ND=$G(^SCPT(404.43,PTPI,0))
62 S DFN=$$DFN^SCMCHLB1(ND) Q:'DFN ;..Patient
63 ;
64 ;Get only valid entries for this PT TM POS ASSIGN. This call returns
65 ;provider array for a patient team position assignment.
66 ;Example: ZPTP(8944,"AP","8944-909-0-AP")=data
67 ; ZPTP(8944,"PCP","8944-911-157-PCP")=data
68 KILL ZPTP
69 D SETDATE ;Set date array
70 S RESULT=$$PRPTTPC^SCAPMC(PTPI,"ZDATE","ZPTP","ERROR","",1)
71 ; add check if primary PATCH 515 BEGIN
72 ; S SCTPTPA=$$TPACHK("",PTPI,SCTPAIN
73 S SCTPTPA=$$TPACHK("",PTPI,"")
74 ; If not primary then call GETOEF to find others
75 S SCLOW=PTPI
76 IF SCTPTPA=1 S SCLOW=$$GETOEF(PTPI,"","")
77 ; PATCH 515 END
78 ;
79 ;If no valid history don't build any segments
80 Q:'$D(ZPTP)
81 ;
82 ;Build EVN & PID segments
83 D SEGMENTS^SCMCHLB1(DFN,PTPI)
84 ;
85 ;Generate deletes for all ID's starting with this PT TM POS ASSIGN.
86 ; PATCH 515 - CHG ALWAYS DELETE TO NOT IF TPA
87 ; OLD CODE = D PTPD^SCMCHLB2(PTPI)
88 IF SCTPTPA'=1 S NUM=PTPI D PTPD^SCMCHLB2(PTPI)
89 ;
90 ;Build data type ZPC segments.
91 D ZPC^SCMCHLB1(.ZPTP)
92 ;alb/rpm;Patch 224 Decrement max msg counter
93 I $D(SCLIMIT) S SCLIMIT=SCLIMIT-1
94 Q
95 ;
96POS ;Position Assign History (#404.52)
97 ;
98 ;To keep VISTA and NPCD in sync, for every primary care entry in Pt
99 ;Tm Pos Assign for this TEAM POSITION, send down all valid entries.
100 ;
101 NEW TMPOS,TP
102 ;
103 ;Team Position pointer
104 S TMPOS=$P($G(^SCTM(404.52,SCIEN,0)),U,1)
105 Q:'TMPOS
106 ;
107 ;Get History entries for each PT TM POS ASSIGN
108 D POS1(TMPOS)
109 ;
110 ;What if this TEAM POSITION is also a preceptor? Find every TEAM
111 ;POSITION being precepted by this TEAM POSITION and for each, find
112 ;every PT TM POS ASSIGN and send down all valid History entries.
113 ;
114 S TP=0
115 F S TP=$O(^SCTM(404.53,"AD",TMPOS,TP)) Q:'TP D POS1(TP)
116 Q
117 ;
118POS1(TMPOS) ;Find every primary care PT TM POS ASSIGN for this TEAM POSITION
119 ;and get all valid History entries.
120 ;Input:
121 ; TMPOS - TEAM POSITION pointer
122 ;
123 Q:'$G(TMPOS)
124 NEW IFN,ND,TM,SCTPTPA
125 S SCTPTPA=$$TPACHK(TMPOS,"","")
126 ;
127 ; ..; PTA CHG 20070518 SD*5.3*515
128 ; OLD CODE = S TM=0 (WAS MISSING PEOPLE)
129 S TM=""
130 F S TM=$O(^SCPT(404.43,"APTPA",TMPOS,TM)) Q:'TM D ;
131 . S IFN=0
132 . F S IFN=$O(^SCPT(404.43,"APTPA",TMPOS,TM,IFN)) Q:'IFN D ;
133 .. S ND=$G(^SCPT(404.43,IFN,0))
134 ..; Q:($P(ND,U,5)'=1) ; Must be Primary Care
135 ..; PTA CHG 20070518 SD*5.3*515
136 ..Q:(($P(ND,U,5)'=1)&(SCTPTPA=0)) ; Must be Primary Care OR PTA
137 ..; D PTP(IFN,SCTPTPA) ;..........Bld segments for this PT TM POS ASSIGN
138 ..D PTP(IFN,"") ;..........Bld segments for this PT TM POS ASSIGN
139 Q
140 ;
141PRE ;Preceptor Assign History (#404.53)
142 ;
143 ;Get TEAM POSITION pointer of preceptee. Find every primary care
144 ;PT TM POS ASSIGN for this TEAM POSITION and send down all valid
145 ;History entries.
146 ;
147 NEW TMPOS
148 ;
149 ;Preceptee TEAM POSITION pointer
150 S TMPOS=$P($G(^SCTM(404.53,SCIEN,0)),U,1)
151 Q:'TMPOS
152 D POS1(TMPOS) ;Get History entries for each PT TM POS ASSIGN
153 ;
154 ;Preceptor TEAM POSITION pointer
155 S TMPOS=$P($G(^SCTM(404.53,SCIEN,0)),U,6)
156 Q:'TMPOS
157 D POS1(TMPOS) ;Get History entries for each PT TM POS ASSIGN
158 Q
159 ;
160SETDATE ;Set all encompassing date array
161 S ZDATE("BEGIN")=2800101
162 S ZDATE("END")=9991231
163 S ZDATE("INCL")=0
164 Q
165TPACHK(SCTP,SCPTPI,SCROLEP) ; CHECK IF TEAM POSITION IS A PTA
166 ; levyd 20070518 SD*5.3*515
167 ;Get data FROM 43
168 NEW ND,SCPC,SCTPD,SCTPX,SCROL,SCTM,SCTPA,TMD,SCTMP,SCTPTA,SCTPA,SCROLX,SCPURX,SCUP,SCLOW,SCROLY
169 S SCTPA=0
170 S SCPURX="OIF OEF"
171 S SCROLX="/TPA/PM/CCM/"
172 S SCUP="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
173 S SCLOW="abcdefghijklmnopqrstuvwxyz"
174 I $L(SCPTPI) D ;
175 .S ND=$G(^SCPT(404.43,SCPTPI,0))
176 .; DEBBIE LEVY PTA CHGS 20070518
177 .; PRIMARY CARE ROLE CHECK
178 .IF $L(ND) S SCPC=$P(ND,U,5) D ;
179 ..IF SCPC'=1 S SCTP=$P(ND,U,2) ; TP
180 ; READ TP REC (57)
181 IF SCTP="" Q SCTPA
182 S SCTPD=$G(^SCTM(404.57,SCTP,0))
183 S SCTPX=$P(SCTPD,U,4) ;not primary
184 IF SCTPX=1 Q SCTPA
185 S SCROL=$P(SCTPD,U,3)
186 S SCROL=$P(^SD(403.46,SCROL,0),U,1)
187 IF $G(SCROLEP)=1 S SCROL=$$TPACHGRL(SCROL) Q SCROL
188 IF $G(SCROLEP)="" S SCROL=$$TPACHGRL(SCROL)
189 S SCTM=$P(SCTPD,U,2)
190 S SCROLY="/"_SCROL_"/"
191 S SCTPA=0 I SCROLX[SCROLY S SCTPA=1 ; OEF ROLE
192 ; READ TEAM FILE (404.51
193 S TMD=^SCTM(404.51,SCTM,0)
194 S SCTMP=$P(TMD,U,3)
195 S SCTMP=^SD(403.47,SCTMP,0)
196 ; CONVERT STR LOWER CASE TO UPPER CASE
197 S SCTMP=$TR(SCTMP,SCLOW,SCUP)
198 S SCTPTA=0 I SCTMP[SCPURX S SCTPTA=1
199 I ((SCTPA=1)&(SCTPTA=1)) S SCTPA=1
200QT Q SCTPA
201 ;
202GETOEF(PTPI,EFFDT,ENDDT) ;Find All OIF OEF RELATIONSHIPS FOR THIS TP in TPS array
203 ; NEW RTN ADDED W PATCH 515 BY DLL
204 ;Input: TP - Team Position IEN
205 ; EFFDT = Team Position EFFECTIVE DATE (OPTIONAL)
206 ; ENDDT = Team Position EXPIRATION DATE (OPTIONAL)
207 NEW TP,COUNT,TPD,TPX,TPDX,TPXX,TPDXX,SCOLDPAT,SCOLDTM,SCOLDTP,SCLOW,DFNX,DFNY
208 S SCLOW=PTPI
209 IF ENDDT="" S ENDDT=9991231
210 K SCTPS,SCPCP
211 ; save original trigger TP, person and team
212 S SCOLD43I=PTPI
213 ;Get data
214 S ND=$G(^SCPT(404.43,PTPI,0))
215 S DFNY=$P(ND,U,1)
216 S DFNX=$G(^SCPT(404.42,DFNY,0))
217 S SCOLDTP=$P(ND,U,2)
218 S SCOLDPAT=$P(DFNX,U,1)
219 S SCOLDTM=$P(DFNX,U,3)
220 ; read thru the patient assignments for this person in 42 ^SCPT(404.42,"B",3994,6930)
221 S TPX=""
222 S COUNT=0
223 F S TPX=$O(^SCPT(404.42,"B",SCOLDPAT,TPX)) Q:'TPX D
224 . S TPDX=$G(^SCPT(404.42,TPX,0))
225 . Q:$P(TPDX,U,3)'=SCOLDTM ;MUST be SAME TEAM
226 . ; red thru the the assignments for this patient ass in 43 ^SCPT(404.43,"B",6930
227 .S TPXX=""
228 .F S TPXX=$O(^SCPT(404.43,"B",TPX,TPXX)) Q:'TPXX D
229 ..S TPDXX=$G(^SCPT(404.43,TPXX,0))
230 ..S TP=$P(TPDXX,U,2)
231 ..IF $G(SCPCP(TP))'=1 D ; TP NOT THERE ALREADY THEN ADD IT TO SCTPS
232 ...S COUNT=COUNT+1
233 ...S SCTPS(COUNT)=TP
234 ...S SCPCP(TP)=1
235 ...IF TP'=SCOLDTP D
236 ....S RESULT=$$PRPTTPC^SCAPMC(TPXX,"ZDATE","ZPTP","ERROR","",1)
237 S SCLOW=$$TPAIDS(.ZPTP,.PTPI)
238 Q SCLOW
239TPACHGRL(SCROLEIN) ;ROLE ABBREVIATION
240 NEW SCUP,SCLOW,SCPURX
241 S SCPURX="OIF OEF"
242 S SCROLOUT=""
243 Q:$L($G(SCROLEIN))=0
244 S SCUP="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
245 S SCLOW="abcdefghijklmnopqrstuvwxyz"
246 ; CONVERT STR LOWer case TO UPper case
247 S SCROLEIN=$TR(SCROLEIN,SCLOW,SCUP)
248 IF (SCROLEIN["TRANSITION PATIENT ADV")&(SCROLEIN[SCPURX) S SCROLOUT="TPA"
249 IF (SCROLEIN["PROGRAM MANA")&(SCROLEIN[SCPURX) S SCROLOUT="PM"
250 IF (SCROLEIN["CLINICAL CASE MAN")&(SCROLEIN[SCPURX) S SCROLOUT="CCM"
251 Q SCROLOUT
252TPAIDS(ARRAY,OLDPTPI) ;GET ROLE FROM ID & CHANGE
253 NEW DATA,ID,SCNEWID,NUM,TYPE,SCROLE,SCNEWROL,SCLOW,SCPTPI
254 S SCLOW=""
255 S NUM=0
256 F S NUM=$O(ARRAY(NUM)) Q:'NUM D ;
257 .S TYPE=""
258 .F S TYPE=$O(ARRAY(NUM,TYPE)) Q:TYPE="" D ;
259 ..S ID=""
260 ..F S ID=$O(ARRAY(NUM,TYPE,ID)) Q:ID="" D ;
261 ...S DATA=$G(ARRAY(NUM,TYPE,ID))
262 ...; GET ROLE FROM ID & CHANGE
263 ...S SCROLE=$P(ID,"-",4)
264 ...S SCPTPI=$P(ID,"-",1)
265 ...IF SCROLE="PCP" D ;
266 ....S SCNEWROL=$$TPACHK^SCMCHLB("",$P(ID,"-",1),1)
267 ....IF $L(SCNEWROL) D
268 .....S SCNEWID=ID
269 .....S $P(SCNEWID,"-",4)=SCNEWROL
270 .....S ARRAY(OLDPTPI,SCPTPI,SCNEWID)=DATA
271 .....K ARRAY(NUM,TYPE,ID)
272 .....S NUMX=NUM
273 .....S NUM=OLDPTPI
274 .....D PTPD^SCMCHLB2(SCPTPI)
275 .....S NUM=NUMX
276 .....; XMITARRY="^TMP("PCMM","HL7",546445648)"
277 .....; K ^TMP("PCMM","HL7",$J,SCPTPI,"EVN")
278 .....; K ^TMP("PCMM","HL7",$J,SCPTPI,"PID")
279 .....K @XMITARRY@(SCPTPI,"EVN",1)
280 .....K @XMITARRY@(SCPTPI,"PID",1)
281 Q SCLOW
Note: See TracBrowser for help on using the repository browser.