source: FOIAVistA/trunk/r/INTEGRATED_PATIENT_FUNDS-PRPF-PFXIP/PRPFMR1.m@ 1800

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

initial load of FOIAVistA 6/30/08 version
File size: 8.4 KB
Line 
1PRPFMR1 ;BAYPINES/MJE DATA MIGRATION ROUTINE 1 ;05/15/03
2 ;;3.0;PATIENT FUNDS - MIGRATION 5.1;**16**;JUNE 1, 1989
3 ;ENTRY AT LINETAG ONLY
4 Q
5RPC(RESULTS,PARAM1,PARAM2) ;ENTRY POINT FOR VPFS RPC
6 S PRPFSEG=PARAM1
7 S PRPFJ=PARAM2
8 I PRPFSEG>1 D SENDSEG Q
9TEST S PRPFOUT1=1
10LEG ;LEGACY ENTRY POINT
11 S:'$D(PRPFOUT1) PRPFOUT1=2
12 K ^TMP("PRPF_EXTDATA")
13 S (PRPFHLD1,PRPFHLD2,PRPFHLD3,PRPFHLD4,CNTREC,CNTPREC,CNTTOT,PFG,PFX,PFXX)=0
14 S U="^"
15 S PFSITE=$P($$SITE^VASITE(),"^",3)
16 S:PFSITE="" PFSITE="###"
17 S (CNTSEG,CNTXREC)=1
18 F S PRPFHLD1=$O(^PRPF(470,PRPFHLD1)) Q:'PRPFHLD1 D
19 .S PFG=PFG+1 I PFG=100 W "." S PFG=0
20 .S CNTPREC=CNTPREC+1
21 .S PFNODE12=PFSITE
22 .D:$G(^PRPF(470,PRPFHLD1,0))'="" COMPU
23 .D NODE12
24 .D:$G(^PRPF(470,PRPFHLD1,0))'="" NODE0
25 .D:$G(^PRPF(470,PRPFHLD1,1))'="" NODE1
26 .D:$G(^PRPF(470,PRPFHLD1,2))'="" NODE2
27 .D:$O(^PRPF(470,PRPFHLD1,4,0))>0 NODE4
28 .D:$O(^PRPF(470,PRPFHLD1,5,0))>0 NODE5
29 .D:$O(^PRPF(470,PRPFHLD1,6,0))>0 NODE6
30 .D:$O(^PRPF(470,PRPFHLD1,7,0))>0 NODE7
31 .D:$O(^PRPF(470,PRPFHLD1,8,0))>0 NODE8
32 D:PRPFOUT1=1
33 .S CNTTOT=CNTTOT+CNTREC
34 .S ^TMP("PRPF_EXTDATA",$J,0)=DTIME_U_DTIME_U_"DATA FOR PRPF MIGRATION"
35 .S ^TMP("PRPF_EXTDATA",$J,1,0)="VPFS"_U_PFSITE_U_U_U_U_"0"_U_"A1"_U_CNTPREC_U_CNTTOT_U_$J
36 .D NOW^%DTC S Y=% D DD^%DT
37 .S $P(^TMP("PRPF_EXTDATA",$J,1,0),"^",3)="(VER#5.0) "_"RUN-DATE@TIME="_Y
38 .S RESULTS=$NA(^TMP("PRPF_EXTDATA",$J,1))
39 D:PRPFOUT1=2 OUT
40 D KILLIT
41 Q
42SENDSEG ;SEND A SEGMENT OF DATA TO MIGRATION JAVA APP
43 S RESULTS=$NA(^TMP("PRPF_EXTDATA",PRPFJ,PRPFSEG))
44 Q
45 ;***************************************************************
46COMPU ;
47 S PFNAME=$P($G(^DPT(PRPFHLD1,0)),"^",1)
48 S PFSSN=$P($G(^DPT(PRPFHLD1,0)),"^",9)
49 I PFNAME="" I PFSSN'="" S PFNAME="NAME-MISSING-SSN#"_PFSSN
50 I PFNAME="" I PFSSN="" S PFNAME="NAME-MISSING-NO-SSN-IEN#"_PRPFHLD1
51 S PFSSN=$P($G(^DPT(PRPFHLD1,0)),"^",9)
52 S PFDOB=$P($G(^DPT(PRPFHLD1,0)),"^",3)
53 S PFWARD=$P($G(^DPT(PRPFHLD1,.1)),"^",1)
54 S PFCLAIM=$P($G(^DPT(PRPFHLD1,.31)),"^",3)
55 S PFADDR1=$P($G(^DPT(PRPFHLD1,.11)),"^",1)
56 S PFADDR2=$P($G(^DPT(PRPFHLD1,.11)),"^",2)
57 S PFADDR3=$P($G(^DPT(PRPFHLD1,.11)),"^",3)
58 S PFCITY=$P($G(^DPT(PRPFHLD1,.11)),"^",4)
59 S PFSTATE=$P($G(^DPT(PRPFHLD1,.11)),"^",5)
60 S PFZIP=$P($G(^DPT(PRPFHLD1,.11)),"^",6)
61 ;S PFICN=$P($G(^DPT(PRPFHLD1,"MPI")),"^",1)
62 S PFICN=$P($$GETICN^MPIF001(PRPFHLD1),"^")
63 S:PFICN=-1 PFICN=""
64 ;S PFSITE=$$KSP^XUPARAM("INST")
65 S PFAUTH=$P(^PRPF(470,PRPFHLD1,0),"^",13)
66 I PFAUTH S PFAUTHRS=$P($G(^VA(200,PFAUTH,0)),"^",1)
67 E S PFAUTHRS=""
68 Q
69NODE0 S PFNODE0=^PRPF(470,PRPFHLD1,0)
70 S CNTREC=CNTREC+1
71 S ^TMP("PRPF_EXTDATA",$J,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_PFSSN_U_PFICN_U_CNTXREC_U_"D1"_U_PFNAME_U_PFSSN_U_PFDOB_U_PFWARD_U_PFCLAIM_U_PFADDR1_U_PFADDR2_U_PFADDR3_U_PFCITY_U_PFSTATE_U_PFZIP_U_PFAUTHRS_U_PFNODE12
72 D SEG
73 S CNTREC=CNTREC+1
74 S ^TMP("PRPF_EXTDATA",$J,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_PFSSN_U_PFICN_U_CNTXREC_U_"D2"_U_PFNODE0
75 D SEG
76 Q
77NODE1 S PFNODE1=^PRPF(470,PRPFHLD1,1)
78 S CNTREC=CNTREC+1
79 S ^TMP("PRPF_EXTDATA",$J,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_PFSSN_U_PFICN_U_CNTXREC_U_"B1"_U_PFNODE1
80 D SEG
81 Q
82NODE2 S PFNODE2=^PRPF(470,PRPFHLD1,2)
83 S CNTREC=CNTREC+1
84 S ^TMP("PRPF_EXTDATA",$J,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_PFSSN_U_PFICN_U_CNTXREC_U_"B2"_U_PFNODE2
85 D SEG
86 Q
87NODE4 S PRPFHLD2=0
88 F S PRPFHLD2=$O(^PRPF(470,PRPFHLD1,4,PRPFHLD2)) Q:'PRPFHLD2 D
89 .S PFNODE4=^PRPF(470,PRPFHLD1,4,PRPFHLD2,0)
90 .S PFNODE4D=$P(PFNODE4,"^",2)
91 .I $D(^PRPF(470.1,$P(PFNODE4,"^",1),0)) D
92 ..S PFNODE4T=^PRPF(470.1,$P(PFNODE4,"^",1),0)
93 ..S PFCLERK=$P(PFNODE4T,"^",14)
94 ..I $P(PFNODE4T,"^",11) D
95 ...S $P(PFNODE4T,"^",11)=$P($G(^PRPF(470.2,$P(PFNODE4T,"^",11),0)),"^",1)
96 ..I PFCLERK S PFCLERKN=$P($G(^VA(200,PFCLERK,0)),"^",1)
97 ..E S PFCLERKN=""
98 ..S $P(PFNODE4T,"^",14)=PFCLERKN
99 ..S CNTREC=CNTREC+1
100 ..S ^TMP("PRPF_EXTDATA",$J,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_PFSSN_U_PFICN_U_CNTXREC_U_"T1"_U_PFNODE4D_U_PFNODE4T
101 ..D SEG
102 Q
103NODE5 S (PRPFHLD2,PRPFHLD3,PRPFHLD4)=0
104 F S PRPFHLD2=$O(^PRPF(470,PRPFHLD1,5,PRPFHLD2)) Q:'PRPFHLD2 D
105 .S PFNODE5=$G(^PRPF(470,PRPFHLD1,5,PRPFHLD2,0))
106 .S CNTREC=CNTREC+1
107 .S ^TMP("PRPF_EXTDATA",$J,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_PFSSN_U_PFICN_U_CNTXREC_U_"S1"_U_PFNODE5
108 .D SEG
109 .S PRPFHLD3=0
110 .F S PRPFHLD3=$O(^PRPF(470,PRPFHLD1,5,PRPFHLD2,1,PRPFHLD3)) Q:'PRPFHLD3 D
111 ..S PFNODE51=$G(^PRPF(470,PRPFHLD1,5,PRPFHLD2,1,PRPFHLD3,0))
112 ..S PRPFHLD4=0
113 ..I $O(^PRPF(470,PRPFHLD1,5,PRPFHLD2,1,PRPFHLD3,1,PRPFHLD4))'>0 D
114 ...S CNTREC=CNTREC+1
115 ...S ^TMP("PRPF_EXTDATA",$J,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_PFSSN_U_PFICN_U_CNTXREC_U_"S2"_U_PFNODE51_U
116 ...D SEG
117 ..F S PRPFHLD4=$O(^PRPF(470,PRPFHLD1,5,PRPFHLD2,1,PRPFHLD3,1,PRPFHLD4)) Q:'PRPFHLD4 D
118 ...S PFNODE52=$G(^PRPF(470,PRPFHLD1,5,PRPFHLD2,1,PRPFHLD3,1,PRPFHLD4,0))
119 ...I $L(PFNODE52)<128 D
120 ....S CNTREC=CNTREC+1
121 ....S ^TMP("PRPF_EXTDATA",$J,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_PFSSN_U_PFICN_U_CNTXREC_U_"S2"_U_PFNODE51_U_PFNODE52
122 ....D SEG
123 ...I $L(PFNODE52)>127 D
124 ....S PFNODE53=$E(PFNODE52,128,256)
125 ....S PFNODE52=$E(PFNODE52,1,127)
126 ....S CNTREC=CNTREC+1
127 ....S ^TMP("PRPF_EXTDATA",$J,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_PFSSN_U_PFICN_U_CNTXREC_U_"S2"_U_PFNODE51_U_PFNODE52
128 ....D SEG
129 ....S CNTREC=CNTREC+1
130 ....S ^TMP("PRPF_EXTDATA",$J,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_PFSSN_U_PFICN_U_CNTXREC_U_"S3"_U_PFNODE51_U_PFNODE53
131 ....D SEG
132 Q
133NODE6 S PRPFHLD2=0
134 F S PRPFHLD2=$O(^PRPF(470,PRPFHLD1,6,PRPFHLD2)) Q:'PRPFHLD2 D
135 .S PFNODE6=^PRPF(470,PRPFHLD1,6,PRPFHLD2,0)
136 .S CNTREC=CNTREC+1
137 .S ^TMP("PRPF_EXTDATA",$J,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_PFSSN_U_PFICN_U_CNTXREC_U_"I1"_U_PFNODE6
138 .D SEG
139 Q
140NODE7 S PRPFHLD2=0
141 F S PRPFHLD2=$O(^PRPF(470,PRPFHLD1,7,PRPFHLD2)) Q:'PRPFHLD2 D
142 .S PFNODE7=^PRPF(470,PRPFHLD1,7,PRPFHLD2,0)
143 .I $L(PFNODE7)<128 D
144 ..S CNTREC=CNTREC+1
145 ..S ^TMP("PRPF_EXTDATA",$J,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_PFSSN_U_PFICN_U_CNTXREC_U_"R1"_U_PFNODE7
146 ..D SEG
147 .I $L(PFNODE7)>127 D
148 ..S PFNODE71=$E(PFNODE7,128,256)
149 ..S PFNODE7=$E(PFNODE7,1,127)
150 ..S CNTREC=CNTREC+1
151 ..S ^TMP("PRPF_EXTDATA",$J,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_PFSSN_U_PFICN_U_CNTXREC_U_"R1"_U_PFNODE7
152 ..D SEG
153 ..S CNTREC=CNTREC+1
154 ..S ^TMP("PRPF_EXTDATA",$J,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_PFSSN_U_PFICN_U_CNTXREC_U_"R2"_U_PFNODE71
155 ..D SEG
156 Q
157NODE8 S PRPFHLD2=0
158 F S PRPFHLD2=$O(^PRPF(470,PRPFHLD1,8,PRPFHLD2)) Q:'PRPFHLD2 D
159 .S PFNODE8=^PRPF(470,PRPFHLD1,8,PRPFHLD2,0)
160 .I $L(PFNODE8)<128 D
161 ..S CNTREC=CNTREC+1
162 ..S ^TMP("PRPF_EXTDATA",$J,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_PFSSN_U_PFICN_U_CNTXREC_U_"X1"_U_PFNODE8
163 ..D SEG
164 .I $L(PFNODE8)>127 D
165 ..S PFNODE81=$E(PFNODE8,128,256)
166 ..S PFNODE8=$E(PFNODE8,1,127)
167 ..S CNTREC=CNTREC+1
168 ..S ^TMP("PRPF_EXTDATA",$J,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_PFSSN_U_PFICN_U_CNTXREC_U_"X1"_U_PFNODE8
169 ..D SEG
170 ..S CNTREC=CNTREC+1
171 ..S ^TMP("PRPF_EXTDATA",$J,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_PFSSN_U_PFICN_U_CNTXREC_U_"X2"_U_PFNODE81
172 ..D SEG
173 Q
174NODE12 ;CHECK STATION ID
175 I $D(^PRPF(470,PRPFHLD1,12)) I ^PRPF(470,PRPFHLD1,12)'="" D
176 .S:$D(^DIC(4,$G(^PRPF(470,PRPFHLD1,12)),99)) PFNODE12=$P($G(^DIC(4,$G(^PRPF(470,PRPFHLD1,12)),99)),"^",1)
177 .S:'$D(^DIC(4,$G(^PRPF(470,PRPFHLD1,12)),99)) PFNODE12=PFSITE
178 S:'$D(^PRPF(470,PRPFHLD1,12)) PFNODE12=PFSITE
179 S:PFNODE12="" PFNODE12=PFSITE
180 ;S CNTREC=CNTREC+1
181 ;S ^TMP("PRPF_EXTDATA",$J,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_PFSSN_U_PFICN_U_CNTREC_U_"12"_U_PFNODE12
182 ;S ^TMP("PRPF_EXTDATA",$J,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_U_U_CNTREC_U_"12"_U_PFNODE12
183 ;D SEG
184 Q
185SEG ;SET UP NEW SEGMENT NODE
186 S CNTXREC=CNTXREC+1
187 D:CNTREC=10000
188 .S CNTSEG=CNTSEG+1
189 .S CNTTOT=CNTTOT+CNTREC
190 .S CNTREC=0
191 Q
192OUT ;WRITE OUT TO DEVICE
193 S CNTTOT=CNTTOT+CNTREC
194 W !
195 W !,"Please enter the output device for the detail report or ""^"" to exit:"
196 S %ZIS("B")="",%ZIS("HFSMODE")="W" D ^%ZIS K XION R X:2
197 I POP K ^TMP("PRPF_EXTDATA") Q
198 U IO
199 W "VPFS"_U_PFSITE_U_U_U_U_"0"_U_"A1"_U_CNTPREC_U_CNTXREC
200 F S PFX=$O(^TMP("PRPF_EXTDATA",$J,PFX)) Q:PFX="" D
201 .F S PFXX=$O(^TMP("PRPF_EXTDATA",$J,PFX,PFXX)) Q:PFXX="" D
202 ..W !,^TMP("PRPF_EXTDATA",$J,PFX,PFXX)
203 D ^%ZISC
204 K ^TMP("PRPF_EXTDATA")
205 Q
206KILLIT ;KILL LOCAL VARIABLES
207 K CNTPREC,CNTREC,CNTSEG,CNTTOT,CNTXREC,PARAMS,PFADDR1,PFADDR2,PFADDR3
208 K PFAUTH,PFAUTHRS,PFCITY,PFCLAIM,PFCLERK,PFCLERKN,PFDOB,PFG
209 K PFICN,PFNAME,PFNODE0,PFNODE1,PFNODE12,PFNODE2,PFNODE4,PFNODE4D
210 K PFNODE4T,PFNODE5,PFNODE51,PFNODE52,PFNODE53,PFNODE6,PFNODE7
211 K PFNODE71,PFNODE8,PFNODE81,PFSITE,PFSSN,PFSTATE,PFWARD,PFX
212 K PFXX,PFZIP,POP,PRPFHLD1,PRPFHLD2,PRPFHLD3,PRPFHLD4,PRPFJ
213 K PRPFOUT1,PRPFSEG,X
214 Q
Note: See TracBrowser for help on using the repository browser.