PRPFMR1 ;BAYPINES/MJE DATA MIGRATION ROUTINE 1 ;05/15/03
;;3.0;PATIENT FUNDS - MIGRATION 5.1;**16**;JUNE 1, 1989
;ENTRY AT LINETAG ONLY
Q
RPC(RESULTS,PARAM1,PARAM2) ;ENTRY POINT FOR VPFS RPC
S PRPFSEG=PARAM1
S PRPFJ=PARAM2
I PRPFSEG>1 D SENDSEG Q
TEST S PRPFOUT1=1
LEG ;LEGACY ENTRY POINT
S:'$D(PRPFOUT1) PRPFOUT1=2
K ^TMP("PRPF_EXTDATA")
S (PRPFHLD1,PRPFHLD2,PRPFHLD3,PRPFHLD4,CNTREC,CNTPREC,CNTTOT,PFG,PFX,PFXX)=0
S U="^"
S PFSITE=$P($$SITE^VASITE(),"^",3)
S:PFSITE="" PFSITE="###"
S (CNTSEG,CNTXREC)=1
F S PRPFHLD1=$O(^PRPF(470,PRPFHLD1)) Q:'PRPFHLD1 D
.S PFG=PFG+1 I PFG=100 W "." S PFG=0
.S CNTPREC=CNTPREC+1
.S PFNODE12=PFSITE
.D:$G(^PRPF(470,PRPFHLD1,0))'="" COMPU
.D NODE12
.D:$G(^PRPF(470,PRPFHLD1,0))'="" NODE0
.D:$G(^PRPF(470,PRPFHLD1,1))'="" NODE1
.D:$G(^PRPF(470,PRPFHLD1,2))'="" NODE2
.D:$O(^PRPF(470,PRPFHLD1,4,0))>0 NODE4
.D:$O(^PRPF(470,PRPFHLD1,5,0))>0 NODE5
.D:$O(^PRPF(470,PRPFHLD1,6,0))>0 NODE6
.D:$O(^PRPF(470,PRPFHLD1,7,0))>0 NODE7
.D:$O(^PRPF(470,PRPFHLD1,8,0))>0 NODE8
D:PRPFOUT1=1
.S CNTTOT=CNTTOT+CNTREC
.S ^TMP("PRPF_EXTDATA",$J,0)=DTIME_U_DTIME_U_"DATA FOR PRPF MIGRATION"
.S ^TMP("PRPF_EXTDATA",$J,1,0)="VPFS"_U_PFSITE_U_U_U_U_"0"_U_"A1"_U_CNTPREC_U_CNTTOT_U_$J
.D NOW^%DTC S Y=% D DD^%DT
.S $P(^TMP("PRPF_EXTDATA",$J,1,0),"^",3)="(VER#5.0) "_"RUN-DATE@TIME="_Y
.S RESULTS=$NA(^TMP("PRPF_EXTDATA",$J,1))
D:PRPFOUT1=2 OUT
D KILLIT
Q
SENDSEG ;SEND A SEGMENT OF DATA TO MIGRATION JAVA APP
S RESULTS=$NA(^TMP("PRPF_EXTDATA",PRPFJ,PRPFSEG))
Q
;***************************************************************
COMPU ;
S PFNAME=$P($G(^DPT(PRPFHLD1,0)),"^",1)
S PFSSN=$P($G(^DPT(PRPFHLD1,0)),"^",9)
I PFNAME="" I PFSSN'="" S PFNAME="NAME-MISSING-SSN#"_PFSSN
I PFNAME="" I PFSSN="" S PFNAME="NAME-MISSING-NO-SSN-IEN#"_PRPFHLD1
S PFSSN=$P($G(^DPT(PRPFHLD1,0)),"^",9)
S PFDOB=$P($G(^DPT(PRPFHLD1,0)),"^",3)
S PFWARD=$P($G(^DPT(PRPFHLD1,.1)),"^",1)
S PFCLAIM=$P($G(^DPT(PRPFHLD1,.31)),"^",3)
S PFADDR1=$P($G(^DPT(PRPFHLD1,.11)),"^",1)
S PFADDR2=$P($G(^DPT(PRPFHLD1,.11)),"^",2)
S PFADDR3=$P($G(^DPT(PRPFHLD1,.11)),"^",3)
S PFCITY=$P($G(^DPT(PRPFHLD1,.11)),"^",4)
S PFSTATE=$P($G(^DPT(PRPFHLD1,.11)),"^",5)
S PFZIP=$P($G(^DPT(PRPFHLD1,.11)),"^",6)
;S PFICN=$P($G(^DPT(PRPFHLD1,"MPI")),"^",1)
S PFICN=$P($$GETICN^MPIF001(PRPFHLD1),"^")
S:PFICN=-1 PFICN=""
;S PFSITE=$$KSP^XUPARAM("INST")
S PFAUTH=$P(^PRPF(470,PRPFHLD1,0),"^",13)
I PFAUTH S PFAUTHRS=$P($G(^VA(200,PFAUTH,0)),"^",1)
E S PFAUTHRS=""
Q
NODE0 S PFNODE0=^PRPF(470,PRPFHLD1,0)
S CNTREC=CNTREC+1
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
D SEG
S CNTREC=CNTREC+1
S ^TMP("PRPF_EXTDATA",$J,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_PFSSN_U_PFICN_U_CNTXREC_U_"D2"_U_PFNODE0
D SEG
Q
NODE1 S PFNODE1=^PRPF(470,PRPFHLD1,1)
S CNTREC=CNTREC+1
S ^TMP("PRPF_EXTDATA",$J,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_PFSSN_U_PFICN_U_CNTXREC_U_"B1"_U_PFNODE1
D SEG
Q
NODE2 S PFNODE2=^PRPF(470,PRPFHLD1,2)
S CNTREC=CNTREC+1
S ^TMP("PRPF_EXTDATA",$J,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_PFSSN_U_PFICN_U_CNTXREC_U_"B2"_U_PFNODE2
D SEG
Q
NODE4 S PRPFHLD2=0
F S PRPFHLD2=$O(^PRPF(470,PRPFHLD1,4,PRPFHLD2)) Q:'PRPFHLD2 D
.S PFNODE4=^PRPF(470,PRPFHLD1,4,PRPFHLD2,0)
.S PFNODE4D=$P(PFNODE4,"^",2)
.I $D(^PRPF(470.1,$P(PFNODE4,"^",1),0)) D
..S PFNODE4T=^PRPF(470.1,$P(PFNODE4,"^",1),0)
..S PFCLERK=$P(PFNODE4T,"^",14)
..I $P(PFNODE4T,"^",11) D
...S $P(PFNODE4T,"^",11)=$P($G(^PRPF(470.2,$P(PFNODE4T,"^",11),0)),"^",1)
..I PFCLERK S PFCLERKN=$P($G(^VA(200,PFCLERK,0)),"^",1)
..E S PFCLERKN=""
..S $P(PFNODE4T,"^",14)=PFCLERKN
..S CNTREC=CNTREC+1
..S ^TMP("PRPF_EXTDATA",$J,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_PFSSN_U_PFICN_U_CNTXREC_U_"T1"_U_PFNODE4D_U_PFNODE4T
..D SEG
Q
NODE5 S (PRPFHLD2,PRPFHLD3,PRPFHLD4)=0
F S PRPFHLD2=$O(^PRPF(470,PRPFHLD1,5,PRPFHLD2)) Q:'PRPFHLD2 D
.S PFNODE5=$G(^PRPF(470,PRPFHLD1,5,PRPFHLD2,0))
.S CNTREC=CNTREC+1
.S ^TMP("PRPF_EXTDATA",$J,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_PFSSN_U_PFICN_U_CNTXREC_U_"S1"_U_PFNODE5
.D SEG
.S PRPFHLD3=0
.F S PRPFHLD3=$O(^PRPF(470,PRPFHLD1,5,PRPFHLD2,1,PRPFHLD3)) Q:'PRPFHLD3 D
..S PFNODE51=$G(^PRPF(470,PRPFHLD1,5,PRPFHLD2,1,PRPFHLD3,0))
..S PRPFHLD4=0
..I $O(^PRPF(470,PRPFHLD1,5,PRPFHLD2,1,PRPFHLD3,1,PRPFHLD4))'>0 D
...S CNTREC=CNTREC+1
...S ^TMP("PRPF_EXTDATA",$J,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_PFSSN_U_PFICN_U_CNTXREC_U_"S2"_U_PFNODE51_U
...D SEG
..F S PRPFHLD4=$O(^PRPF(470,PRPFHLD1,5,PRPFHLD2,1,PRPFHLD3,1,PRPFHLD4)) Q:'PRPFHLD4 D
...S PFNODE52=$G(^PRPF(470,PRPFHLD1,5,PRPFHLD2,1,PRPFHLD3,1,PRPFHLD4,0))
...I $L(PFNODE52)<128 D
....S CNTREC=CNTREC+1
....S ^TMP("PRPF_EXTDATA",$J,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_PFSSN_U_PFICN_U_CNTXREC_U_"S2"_U_PFNODE51_U_PFNODE52
....D SEG
...I $L(PFNODE52)>127 D
....S PFNODE53=$E(PFNODE52,128,256)
....S PFNODE52=$E(PFNODE52,1,127)
....S CNTREC=CNTREC+1
....S ^TMP("PRPF_EXTDATA",$J,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_PFSSN_U_PFICN_U_CNTXREC_U_"S2"_U_PFNODE51_U_PFNODE52
....D SEG
....S CNTREC=CNTREC+1
....S ^TMP("PRPF_EXTDATA",$J,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_PFSSN_U_PFICN_U_CNTXREC_U_"S3"_U_PFNODE51_U_PFNODE53
....D SEG
Q
NODE6 S PRPFHLD2=0
F S PRPFHLD2=$O(^PRPF(470,PRPFHLD1,6,PRPFHLD2)) Q:'PRPFHLD2 D
.S PFNODE6=^PRPF(470,PRPFHLD1,6,PRPFHLD2,0)
.S CNTREC=CNTREC+1
.S ^TMP("PRPF_EXTDATA",$J,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_PFSSN_U_PFICN_U_CNTXREC_U_"I1"_U_PFNODE6
.D SEG
Q
NODE7 S PRPFHLD2=0
F S PRPFHLD2=$O(^PRPF(470,PRPFHLD1,7,PRPFHLD2)) Q:'PRPFHLD2 D
.S PFNODE7=^PRPF(470,PRPFHLD1,7,PRPFHLD2,0)
.I $L(PFNODE7)<128 D
..S CNTREC=CNTREC+1
..S ^TMP("PRPF_EXTDATA",$J,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_PFSSN_U_PFICN_U_CNTXREC_U_"R1"_U_PFNODE7
..D SEG
.I $L(PFNODE7)>127 D
..S PFNODE71=$E(PFNODE7,128,256)
..S PFNODE7=$E(PFNODE7,1,127)
..S CNTREC=CNTREC+1
..S ^TMP("PRPF_EXTDATA",$J,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_PFSSN_U_PFICN_U_CNTXREC_U_"R1"_U_PFNODE7
..D SEG
..S CNTREC=CNTREC+1
..S ^TMP("PRPF_EXTDATA",$J,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_PFSSN_U_PFICN_U_CNTXREC_U_"R2"_U_PFNODE71
..D SEG
Q
NODE8 S PRPFHLD2=0
F S PRPFHLD2=$O(^PRPF(470,PRPFHLD1,8,PRPFHLD2)) Q:'PRPFHLD2 D
.S PFNODE8=^PRPF(470,PRPFHLD1,8,PRPFHLD2,0)
.I $L(PFNODE8)<128 D
..S CNTREC=CNTREC+1
..S ^TMP("PRPF_EXTDATA",$J,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_PFSSN_U_PFICN_U_CNTXREC_U_"X1"_U_PFNODE8
..D SEG
.I $L(PFNODE8)>127 D
..S PFNODE81=$E(PFNODE8,128,256)
..S PFNODE8=$E(PFNODE8,1,127)
..S CNTREC=CNTREC+1
..S ^TMP("PRPF_EXTDATA",$J,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_PFSSN_U_PFICN_U_CNTXREC_U_"X1"_U_PFNODE8
..D SEG
..S CNTREC=CNTREC+1
..S ^TMP("PRPF_EXTDATA",$J,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_PFSSN_U_PFICN_U_CNTXREC_U_"X2"_U_PFNODE81
..D SEG
Q
NODE12 ;CHECK STATION ID
I $D(^PRPF(470,PRPFHLD1,12)) I ^PRPF(470,PRPFHLD1,12)'="" D
.S:$D(^DIC(4,$G(^PRPF(470,PRPFHLD1,12)),99)) PFNODE12=$P($G(^DIC(4,$G(^PRPF(470,PRPFHLD1,12)),99)),"^",1)
.S:'$D(^DIC(4,$G(^PRPF(470,PRPFHLD1,12)),99)) PFNODE12=PFSITE
S:'$D(^PRPF(470,PRPFHLD1,12)) PFNODE12=PFSITE
S:PFNODE12="" PFNODE12=PFSITE
;S CNTREC=CNTREC+1
;S ^TMP("PRPF_EXTDATA",$J,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_PFSSN_U_PFICN_U_CNTREC_U_"12"_U_PFNODE12
;S ^TMP("PRPF_EXTDATA",$J,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_U_U_CNTREC_U_"12"_U_PFNODE12
;D SEG
Q
SEG ;SET UP NEW SEGMENT NODE
S CNTXREC=CNTXREC+1
D:CNTREC=10000
.S CNTSEG=CNTSEG+1
.S CNTTOT=CNTTOT+CNTREC
.S CNTREC=0
Q
OUT ;WRITE OUT TO DEVICE
S CNTTOT=CNTTOT+CNTREC
W !
W !,"Please enter the output device for the detail report or ""^"" to exit:"
S %ZIS("B")="",%ZIS("HFSMODE")="W" D ^%ZIS K XION R X:2
I POP K ^TMP("PRPF_EXTDATA") Q
U IO
W "VPFS"_U_PFSITE_U_U_U_U_"0"_U_"A1"_U_CNTPREC_U_CNTXREC
F S PFX=$O(^TMP("PRPF_EXTDATA",$J,PFX)) Q:PFX="" D
.F S PFXX=$O(^TMP("PRPF_EXTDATA",$J,PFX,PFXX)) Q:PFXX="" D
..W !,^TMP("PRPF_EXTDATA",$J,PFX,PFXX)
D ^%ZISC
K ^TMP("PRPF_EXTDATA")
Q
KILLIT ;KILL LOCAL VARIABLES
K CNTPREC,CNTREC,CNTSEG,CNTTOT,CNTXREC,PARAMS,PFADDR1,PFADDR2,PFADDR3
K PFAUTH,PFAUTHRS,PFCITY,PFCLAIM,PFCLERK,PFCLERKN,PFDOB,PFG
K PFICN,PFNAME,PFNODE0,PFNODE1,PFNODE12,PFNODE2,PFNODE4,PFNODE4D
K PFNODE4T,PFNODE5,PFNODE51,PFNODE52,PFNODE53,PFNODE6,PFNODE7
K PFNODE71,PFNODE8,PFNODE81,PFSITE,PFSSN,PFSTATE,PFWARD,PFX
K PFXX,PFZIP,POP,PRPFHLD1,PRPFHLD2,PRPFHLD3,PRPFHLD4,PRPFJ
K PRPFOUT1,PRPFSEG,X
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRPFMR1 8815 printed Dec 13, 2024@02:01:46 Page 2
PRPFMR1 ;BAYPINES/MJE DATA MIGRATION ROUTINE 1 ;05/15/03
+1 ;;3.0;PATIENT FUNDS - MIGRATION 5.1;**16**;JUNE 1, 1989
+2 ;ENTRY AT LINETAG ONLY
+3 QUIT
RPC(RESULTS,PARAM1,PARAM2) ;ENTRY POINT FOR VPFS RPC
+1 SET PRPFSEG=PARAM1
+2 SET PRPFJ=PARAM2
+3 IF PRPFSEG>1
DO SENDSEG
QUIT
TEST SET PRPFOUT1=1
LEG ;LEGACY ENTRY POINT
+1 if '$DATA(PRPFOUT1)
SET PRPFOUT1=2
+2 KILL ^TMP("PRPF_EXTDATA")
+3 SET (PRPFHLD1,PRPFHLD2,PRPFHLD3,PRPFHLD4,CNTREC,CNTPREC,CNTTOT,PFG,PFX,PFXX)=0
+4 SET U="^"
+5 SET PFSITE=$PIECE($$SITE^VASITE(),"^",3)
+6 if PFSITE=""
SET PFSITE="###"
+7 SET (CNTSEG,CNTXREC)=1
+8 FOR
SET PRPFHLD1=$ORDER(^PRPF(470,PRPFHLD1))
if 'PRPFHLD1
QUIT
Begin DoDot:1
+9 SET PFG=PFG+1
IF PFG=100
WRITE "."
SET PFG=0
+10 SET CNTPREC=CNTPREC+1
+11 SET PFNODE12=PFSITE
+12 if $GET(^PRPF(470,PRPFHLD1,0))'=""
DO COMPU
+13 DO NODE12
+14 if $GET(^PRPF(470,PRPFHLD1,0))'=""
DO NODE0
+15 if $GET(^PRPF(470,PRPFHLD1,1))'=""
DO NODE1
+16 if $GET(^PRPF(470,PRPFHLD1,2))'=""
DO NODE2
+17 if $ORDER(^PRPF(470,PRPFHLD1,4,0))>0
DO NODE4
+18 if $ORDER(^PRPF(470,PRPFHLD1,5,0))>0
DO NODE5
+19 if $ORDER(^PRPF(470,PRPFHLD1,6,0))>0
DO NODE6
+20 if $ORDER(^PRPF(470,PRPFHLD1,7,0))>0
DO NODE7
+21 if $ORDER(^PRPF(470,PRPFHLD1,8,0))>0
DO NODE8
End DoDot:1
+22 if PRPFOUT1=1
Begin DoDot:1
+23 SET CNTTOT=CNTTOT+CNTREC
+24 SET ^TMP("PRPF_EXTDATA",$JOB,0)=DTIME_U_DTIME_U_"DATA FOR PRPF MIGRATION"
+25 SET ^TMP("PRPF_EXTDATA",$JOB,1,0)="VPFS"_U_PFSITE_U_U_U_U_"0"_U_"A1"_U_CNTPREC_U_CNTTOT_U_$JOB
+26 DO NOW^%DTC
SET Y=%
DO DD^%DT
+27 SET $PIECE(^TMP("PRPF_EXTDATA",$JOB,1,0),"^",3)="(VER#5.0) "_"RUN-DATE@TIME="_Y
+28 SET RESULTS=$NAME(^TMP("PRPF_EXTDATA",$JOB,1))
End DoDot:1
+29 if PRPFOUT1=2
DO OUT
+30 DO KILLIT
+31 QUIT
SENDSEG ;SEND A SEGMENT OF DATA TO MIGRATION JAVA APP
+1 SET RESULTS=$NAME(^TMP("PRPF_EXTDATA",PRPFJ,PRPFSEG))
+2 QUIT
+3 ;***************************************************************
COMPU ;
+1 SET PFNAME=$PIECE($GET(^DPT(PRPFHLD1,0)),"^",1)
+2 SET PFSSN=$PIECE($GET(^DPT(PRPFHLD1,0)),"^",9)
+3 IF PFNAME=""
IF PFSSN'=""
SET PFNAME="NAME-MISSING-SSN#"_PFSSN
+4 IF PFNAME=""
IF PFSSN=""
SET PFNAME="NAME-MISSING-NO-SSN-IEN#"_PRPFHLD1
+5 SET PFSSN=$PIECE($GET(^DPT(PRPFHLD1,0)),"^",9)
+6 SET PFDOB=$PIECE($GET(^DPT(PRPFHLD1,0)),"^",3)
+7 SET PFWARD=$PIECE($GET(^DPT(PRPFHLD1,.1)),"^",1)
+8 SET PFCLAIM=$PIECE($GET(^DPT(PRPFHLD1,.31)),"^",3)
+9 SET PFADDR1=$PIECE($GET(^DPT(PRPFHLD1,.11)),"^",1)
+10 SET PFADDR2=$PIECE($GET(^DPT(PRPFHLD1,.11)),"^",2)
+11 SET PFADDR3=$PIECE($GET(^DPT(PRPFHLD1,.11)),"^",3)
+12 SET PFCITY=$PIECE($GET(^DPT(PRPFHLD1,.11)),"^",4)
+13 SET PFSTATE=$PIECE($GET(^DPT(PRPFHLD1,.11)),"^",5)
+14 SET PFZIP=$PIECE($GET(^DPT(PRPFHLD1,.11)),"^",6)
+15 ;S PFICN=$P($G(^DPT(PRPFHLD1,"MPI")),"^",1)
+16 SET PFICN=$PIECE($$GETICN^MPIF001(PRPFHLD1),"^")
+17 if PFICN=-1
SET PFICN=""
+18 ;S PFSITE=$$KSP^XUPARAM("INST")
+19 SET PFAUTH=$PIECE(^PRPF(470,PRPFHLD1,0),"^",13)
+20 IF PFAUTH
SET PFAUTHRS=$PIECE($GET(^VA(200,PFAUTH,0)),"^",1)
+21 IF '$TEST
SET PFAUTHRS=""
+22 QUIT
NODE0 SET PFNODE0=^PRPF(470,PRPFHLD1,0)
+1 SET CNTREC=CNTREC+1
+2 SET ^TMP("PRPF_EXTDATA",$JOB,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
+3 DO SEG
+4 SET CNTREC=CNTREC+1
+5 SET ^TMP("PRPF_EXTDATA",$JOB,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_PFSSN_U_PFICN_U_CNTXREC_U_"D2"_U_PFNODE0
+6 DO SEG
+7 QUIT
NODE1 SET PFNODE1=^PRPF(470,PRPFHLD1,1)
+1 SET CNTREC=CNTREC+1
+2 SET ^TMP("PRPF_EXTDATA",$JOB,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_PFSSN_U_PFICN_U_CNTXREC_U_"B1"_U_PFNODE1
+3 DO SEG
+4 QUIT
NODE2 SET PFNODE2=^PRPF(470,PRPFHLD1,2)
+1 SET CNTREC=CNTREC+1
+2 SET ^TMP("PRPF_EXTDATA",$JOB,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_PFSSN_U_PFICN_U_CNTXREC_U_"B2"_U_PFNODE2
+3 DO SEG
+4 QUIT
NODE4 SET PRPFHLD2=0
+1 FOR
SET PRPFHLD2=$ORDER(^PRPF(470,PRPFHLD1,4,PRPFHLD2))
if 'PRPFHLD2
QUIT
Begin DoDot:1
+2 SET PFNODE4=^PRPF(470,PRPFHLD1,4,PRPFHLD2,0)
+3 SET PFNODE4D=$PIECE(PFNODE4,"^",2)
+4 IF $DATA(^PRPF(470.1,$PIECE(PFNODE4,"^",1),0))
Begin DoDot:2
+5 SET PFNODE4T=^PRPF(470.1,$PIECE(PFNODE4,"^",1),0)
+6 SET PFCLERK=$PIECE(PFNODE4T,"^",14)
+7 IF $PIECE(PFNODE4T,"^",11)
Begin DoDot:3
+8 SET $PIECE(PFNODE4T,"^",11)=$PIECE($GET(^PRPF(470.2,$PIECE(PFNODE4T,"^",11),0)),"^",1)
End DoDot:3
+9 IF PFCLERK
SET PFCLERKN=$PIECE($GET(^VA(200,PFCLERK,0)),"^",1)
+10 IF '$TEST
SET PFCLERKN=""
+11 SET $PIECE(PFNODE4T,"^",14)=PFCLERKN
+12 SET CNTREC=CNTREC+1
+13 SET ^TMP("PRPF_EXTDATA",$JOB,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_PFSSN_U_PFICN_U_CNTXREC_U_"T1"_U_PFNODE4D_U_PFNODE4T
+14 DO SEG
End DoDot:2
End DoDot:1
+15 QUIT
NODE5 SET (PRPFHLD2,PRPFHLD3,PRPFHLD4)=0
+1 FOR
SET PRPFHLD2=$ORDER(^PRPF(470,PRPFHLD1,5,PRPFHLD2))
if 'PRPFHLD2
QUIT
Begin DoDot:1
+2 SET PFNODE5=$GET(^PRPF(470,PRPFHLD1,5,PRPFHLD2,0))
+3 SET CNTREC=CNTREC+1
+4 SET ^TMP("PRPF_EXTDATA",$JOB,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_PFSSN_U_PFICN_U_CNTXREC_U_"S1"_U_PFNODE5
+5 DO SEG
+6 SET PRPFHLD3=0
+7 FOR
SET PRPFHLD3=$ORDER(^PRPF(470,PRPFHLD1,5,PRPFHLD2,1,PRPFHLD3))
if 'PRPFHLD3
QUIT
Begin DoDot:2
+8 SET PFNODE51=$GET(^PRPF(470,PRPFHLD1,5,PRPFHLD2,1,PRPFHLD3,0))
+9 SET PRPFHLD4=0
+10 IF $ORDER(^PRPF(470,PRPFHLD1,5,PRPFHLD2,1,PRPFHLD3,1,PRPFHLD4))'>0
Begin DoDot:3
+11 SET CNTREC=CNTREC+1
+12 SET ^TMP("PRPF_EXTDATA",$JOB,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_PFSSN_U_PFICN_U_CNTXREC_U_"S2"_U_PFNODE51_U
+13 DO SEG
End DoDot:3
+14 FOR
SET PRPFHLD4=$ORDER(^PRPF(470,PRPFHLD1,5,PRPFHLD2,1,PRPFHLD3,1,PRPFHLD4))
if 'PRPFHLD4
QUIT
Begin DoDot:3
+15 SET PFNODE52=$GET(^PRPF(470,PRPFHLD1,5,PRPFHLD2,1,PRPFHLD3,1,PRPFHLD4,0))
+16 IF $LENGTH(PFNODE52)<128
Begin DoDot:4
+17 SET CNTREC=CNTREC+1
+18 SET ^TMP("PRPF_EXTDATA",$JOB,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_PFSSN_U_PFICN_U_CNTXREC_U_"S2"_U_PFNODE51_U_PFNODE52
+19 DO SEG
End DoDot:4
+20 IF $LENGTH(PFNODE52)>127
Begin DoDot:4
+21 SET PFNODE53=$EXTRACT(PFNODE52,128,256)
+22 SET PFNODE52=$EXTRACT(PFNODE52,1,127)
+23 SET CNTREC=CNTREC+1
+24 SET ^TMP("PRPF_EXTDATA",$JOB,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_PFSSN_U_PFICN_U_CNTXREC_U_"S2"_U_PFNODE51_U_PFNODE52
+25 DO SEG
+26 SET CNTREC=CNTREC+1
+27 SET ^TMP("PRPF_EXTDATA",$JOB,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_PFSSN_U_PFICN_U_CNTXREC_U_"S3"_U_PFNODE51_U_PFNODE53
+28 DO SEG
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+29 QUIT
NODE6 SET PRPFHLD2=0
+1 FOR
SET PRPFHLD2=$ORDER(^PRPF(470,PRPFHLD1,6,PRPFHLD2))
if 'PRPFHLD2
QUIT
Begin DoDot:1
+2 SET PFNODE6=^PRPF(470,PRPFHLD1,6,PRPFHLD2,0)
+3 SET CNTREC=CNTREC+1
+4 SET ^TMP("PRPF_EXTDATA",$JOB,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_PFSSN_U_PFICN_U_CNTXREC_U_"I1"_U_PFNODE6
+5 DO SEG
End DoDot:1
+6 QUIT
NODE7 SET PRPFHLD2=0
+1 FOR
SET PRPFHLD2=$ORDER(^PRPF(470,PRPFHLD1,7,PRPFHLD2))
if 'PRPFHLD2
QUIT
Begin DoDot:1
+2 SET PFNODE7=^PRPF(470,PRPFHLD1,7,PRPFHLD2,0)
+3 IF $LENGTH(PFNODE7)<128
Begin DoDot:2
+4 SET CNTREC=CNTREC+1
+5 SET ^TMP("PRPF_EXTDATA",$JOB,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_PFSSN_U_PFICN_U_CNTXREC_U_"R1"_U_PFNODE7
+6 DO SEG
End DoDot:2
+7 IF $LENGTH(PFNODE7)>127
Begin DoDot:2
+8 SET PFNODE71=$EXTRACT(PFNODE7,128,256)
+9 SET PFNODE7=$EXTRACT(PFNODE7,1,127)
+10 SET CNTREC=CNTREC+1
+11 SET ^TMP("PRPF_EXTDATA",$JOB,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_PFSSN_U_PFICN_U_CNTXREC_U_"R1"_U_PFNODE7
+12 DO SEG
+13 SET CNTREC=CNTREC+1
+14 SET ^TMP("PRPF_EXTDATA",$JOB,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_PFSSN_U_PFICN_U_CNTXREC_U_"R2"_U_PFNODE71
+15 DO SEG
End DoDot:2
End DoDot:1
+16 QUIT
NODE8 SET PRPFHLD2=0
+1 FOR
SET PRPFHLD2=$ORDER(^PRPF(470,PRPFHLD1,8,PRPFHLD2))
if 'PRPFHLD2
QUIT
Begin DoDot:1
+2 SET PFNODE8=^PRPF(470,PRPFHLD1,8,PRPFHLD2,0)
+3 IF $LENGTH(PFNODE8)<128
Begin DoDot:2
+4 SET CNTREC=CNTREC+1
+5 SET ^TMP("PRPF_EXTDATA",$JOB,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_PFSSN_U_PFICN_U_CNTXREC_U_"X1"_U_PFNODE8
+6 DO SEG
End DoDot:2
+7 IF $LENGTH(PFNODE8)>127
Begin DoDot:2
+8 SET PFNODE81=$EXTRACT(PFNODE8,128,256)
+9 SET PFNODE8=$EXTRACT(PFNODE8,1,127)
+10 SET CNTREC=CNTREC+1
+11 SET ^TMP("PRPF_EXTDATA",$JOB,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_PFSSN_U_PFICN_U_CNTXREC_U_"X1"_U_PFNODE8
+12 DO SEG
+13 SET CNTREC=CNTREC+1
+14 SET ^TMP("PRPF_EXTDATA",$JOB,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_PFSSN_U_PFICN_U_CNTXREC_U_"X2"_U_PFNODE81
+15 DO SEG
End DoDot:2
End DoDot:1
+16 QUIT
NODE12 ;CHECK STATION ID
+1 IF $DATA(^PRPF(470,PRPFHLD1,12))
IF ^PRPF(470,PRPFHLD1,12)'=""
Begin DoDot:1
+2 if $DATA(^DIC(4,$GET(^PRPF(470,PRPFHLD1,12)),99))
SET PFNODE12=$PIECE($GET(^DIC(4,$GET(^PRPF(470,PRPFHLD1,12)),99)),"^",1)
+3 if '$DATA(^DIC(4,$GET(^PRPF(470,PRPFHLD1,12)),99))
SET PFNODE12=PFSITE
End DoDot:1
+4 if '$DATA(^PRPF(470,PRPFHLD1,12))
SET PFNODE12=PFSITE
+5 if PFNODE12=""
SET PFNODE12=PFSITE
+6 ;S CNTREC=CNTREC+1
+7 ;S ^TMP("PRPF_EXTDATA",$J,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_PFSSN_U_PFICN_U_CNTREC_U_"12"_U_PFNODE12
+8 ;S ^TMP("PRPF_EXTDATA",$J,CNTSEG,CNTREC)="VPFS"_U_PFSITE_U_PRPFHLD1_U_U_U_CNTREC_U_"12"_U_PFNODE12
+9 ;D SEG
+10 QUIT
SEG ;SET UP NEW SEGMENT NODE
+1 SET CNTXREC=CNTXREC+1
+2 if CNTREC=10000
Begin DoDot:1
+3 SET CNTSEG=CNTSEG+1
+4 SET CNTTOT=CNTTOT+CNTREC
+5 SET CNTREC=0
End DoDot:1
+6 QUIT
OUT ;WRITE OUT TO DEVICE
+1 SET CNTTOT=CNTTOT+CNTREC
+2 WRITE !
+3 WRITE !,"Please enter the output device for the detail report or ""^"" to exit:"
+4 SET %ZIS("B")=""
SET %ZIS("HFSMODE")="W"
DO ^%ZIS
KILL XION
READ X:2
+5 IF POP
KILL ^TMP("PRPF_EXTDATA")
QUIT
+6 USE IO
+7 WRITE "VPFS"_U_PFSITE_U_U_U_U_"0"_U_"A1"_U_CNTPREC_U_CNTXREC
+8 FOR
SET PFX=$ORDER(^TMP("PRPF_EXTDATA",$JOB,PFX))
if PFX=""
QUIT
Begin DoDot:1
+9 FOR
SET PFXX=$ORDER(^TMP("PRPF_EXTDATA",$JOB,PFX,PFXX))
if PFXX=""
QUIT
Begin DoDot:2
+10 WRITE !,^TMP("PRPF_EXTDATA",$JOB,PFX,PFXX)
End DoDot:2
End DoDot:1
+11 DO ^%ZISC
+12 KILL ^TMP("PRPF_EXTDATA")
+13 QUIT
KILLIT ;KILL LOCAL VARIABLES
+1 KILL CNTPREC,CNTREC,CNTSEG,CNTTOT,CNTXREC,PARAMS,PFADDR1,PFADDR2,PFADDR3
+2 KILL PFAUTH,PFAUTHRS,PFCITY,PFCLAIM,PFCLERK,PFCLERKN,PFDOB,PFG
+3 KILL PFICN,PFNAME,PFNODE0,PFNODE1,PFNODE12,PFNODE2,PFNODE4,PFNODE4D
+4 KILL PFNODE4T,PFNODE5,PFNODE51,PFNODE52,PFNODE53,PFNODE6,PFNODE7
+5 KILL PFNODE71,PFNODE8,PFNODE81,PFSITE,PFSSN,PFSTATE,PFWARD,PFX
+6 KILL PFXX,PFZIP,POP,PRPFHLD1,PRPFHLD2,PRPFHLD3,PRPFHLD4,PRPFJ
+7 KILL PRPFOUT1,PRPFSEG,X
+8 QUIT
