FBPMRG ;WCIOFO/SAB - FEE BASIS PATIENT MERGE ROUTINE ;6/4/2014
;;3.5;FEE BASIS;**19,41,59,154**;JAN 30, 1995;Build 12
;;Per VA Directive 6402, this routine should not be modified.
EN(ARRAY) ; Entry point
; Called during patient (file #2) merge due to AFFECTS RECORD MERGE
; in PACKAGE (#9.4) file.
; Input
; ARRAY - name of array with the PATIENT (#2) From IENs and To IENs
; format: name(ien_from,ien_to,"ien_from;DPT(","ien_to;DPT(")
; example: TEST(1000,500,"1000;DPT(","500;DPT(")=""
;
N FBFR,FBTO
; loop thru from ien of patients (file #2) being merged
S FBFR=0 F S FBFR=$O(@ARRAY@(FBFR)) Q:FBFR'>0 D
. S FBTO=$O(@ARRAY@(FBFR,0)) ; to ien
. ; check/update some Fee Basis files that normal merge can't handle
. D F161
. D F162^FBPMRG1
Q
;
F161 ; File 161 FEE BASIS PATIENT - The .01 field points to and is
; dinumed with the PATIENT (#2) file
; input
; FBFR - ien of patient (files #2,161) being merged from
; FBTO - ien of patient (files #2,161) being merged to
N FBFR1,FBTO1
N DA,DD,DIC,DIK,DINUM,DLAYGO,DO,X,Y
;
Q:'$D(^FBAAA(FBFR)) ; nothing to merge from
;
;
IDCARD ; if both records have id card numbers the pairs are removed from merge.
; all other cases will be handled by merge.
;
I $P($G(^FBAAA(FBFR,4)),U) D
.I $P($G(^FBAAA(FBTO,4)),U) D
..; remove pair from merge when there is a id number in the from and to
..S IENFRM=$O(@ARRAY@(FBFR,FBTO,""))
..S IENTO=$O(@ARRAY@(FBFR,FBTO,IENFRM,""))
..S IEN=""
..S IEN=+$G(@ARRAY@(FBFR,FBTO,IENFRM,IENTO))
..D RMOVPAIR^XDRDVAL1(FBFR,FBTO,IEN,ARRAY)
..N XMSUB,XMTEXT
..S XMSUB="MERGE PAIRS EXCLUDED DUE TO BOTH HAVE FEE BASIS ID CARDS"
..S ^TMP("DDB",$J,1)=" MERGE PAIR Patient records "_FBFR_" AND "_FBTO_" both have FB ID card numbers. Please cancel one of the IDs and resubmit the Merge Pair"
..S XMTEXT="^TMP(""DDB"",$J,"
..D SENDMESG^XDRDVAL1(XMSUB,XMTEXT)
..K IEN,IENTO,IENFRM
;
;
Q:'$D(^FBAAA(FBTO)) ; if only from ien exists then standard process OK
;
; both from ien and to ien are in the FEE BASIS PATIENT file.
; The AUTHORIZATION multiple and REPORT OF CONTACT multiple can have
; duplicate .01 values so they need to be handled here since the
; standard merge would inappropriately combine subfile entries whose
; .01 values match. Additionally, if the ien of an AUTHORIZATION must
; be changed when moved from the 'from ien' to the 'to ien', then
; the free-text pointers that reference that AUTHORIZATION will need
; to be updated.
;
; loop thru authorization multiple in 'from ien'
S FBFR1=0 F S FBFR1=$O(^FBAAA(FBFR,1,FBFR1)) Q:'FBFR1 D
. ;
. ; create new entry in authorization multiple of 'to ien'
. K DD,DO,DA
. S DIC="^FBAAA("_FBTO_",1,",DIC(0)="L"
. S DA(1)=FBTO
. S X=$P($G(^FBAAA(FBFR,1,FBFR1,0)),U)
. Q:X="" ; can't add without a from date
. I $D(@(DIC_FBFR1_")"))=0 S DINUM=FBFR1 ; use same ien if available
. S DLAYGO=161.01
. D FILE^DICN K DIC,DINUM,DLAYGO
. Q:$P(Y,U,3)'=1 ; couldn't add new authorization
. S FBTO1=+Y
. ;
. ; move data
. M ^FBAAA(FBTO,1,FBTO1)=^FBAAA(FBFR,1,FBFR1)
. ;
. ; delete 'from authorization'
. S DIK="^FBAAA("_FBFR_",1,"
. S DA(1)=FBFR,DA=FBFR1
. D ^DIK K DA,DIK
. ;
. ; index 'to authorization'
. S DIK="^FBAAA("_FBTO_",1,"
. S DA(1)=FBTO,DA=FBTO1
. D IX1^DIK K DA,DIK
. ;
. ; if authorization ien was changed then update any pointers to it
. I FBFR1'=FBTO1 D UAUTHP
;
; loop thru report of contact multiple in 'from ien'
S FBFR1=0 F S FBFR1=$O(^FBAAA(FBFR,2,FBFR1)) Q:'FBFR1 D
. ;
. ; create new entry in report of contact multiple of 'to ien'
. K DD,DO,DA
. S DIC="^FBAAA("_FBTO_",2,",DIC(0)="L"
. S DA(1)=FBTO
. S X=$P($G(^FBAAA(FBFR,1,FBFR1,0)),U)
. Q:X="" ; can't add without a date of contact
. I $D(@(DIC_FBFR1_")"))=0 S DINUM=FBFR1 ; use same ien if available
. S DLAYGO=161.02
. D FILE^DICN K DIC,DINUM,DLAYGO
. Q:$P(Y,U,3)'=1 ; couldn't add new report of contact
. S FBTO1=+Y
. ;
. ; move data
. M ^FBAAA(FBTO,2,FBTO1)=^FBAAA(FBFR,2,FBFR1)
. ;
. ; delete 'from report of contact'
. S DIK="^FBAAA("_FBFR_",2,"
. S DA(1)=FBFR,DA=FBFR1
. D ^DIK K DA,DIK
. ;
. ; index 'to report of contact'
. S DIK="^FBAAA("_FBTO_",2,"
. S DA(1)=FBTO,DA=FBTO1
. D IX1^DIK
;
Q
;
UAUTHP ; Update 'free-text' pointers to authorization
; input
; FBFR - ien of patient (files #2,161) being merged from
; FBFR1 - ien of authorization in FBFR
; FBTO - ien of patient (files #2,161) being merged to
; FBTO1 - ien of authorization in FBTO
N AUTHP,DA,DIE,DR,X,X1,Y
;
Q:FBFR1=FBTO1 ; same value so nothing to update
;
; update file 161.26 FEE BASIS PATIENT MRA
; use "B" x-ref to find patient
K DA S DA=0 F S DA=$O(^FBAA(161.26,"B",FBFR,DA)) Q:'DA D
. ; if existing authorization pointer refers to the authorization
. ; that was changed then update it
. S AUTHP=$P($G(^FBAA(161.26,DA,0)),U,3)
. I AUTHP=FBFR1 D
. . S DIE="^FBAA(161.26,"
. . S DR="2////^S X=FBTO1"
. . D ^DIE
;
; update file 162 FEE BASIS PAYMENT
; use "AFN" cross-reference on AUTHORIZATION POINTER (#15.5) field
K DA S DA(3)=FBFR ; patient
; loop thru vendor IENs
S DA(2)=0 F S DA(2)=$O(^FBAAC("AFN",FBFR1,DA(3),DA(2))) Q:'DA(2) D
. ; loop thru initial treatment date IENs
. S DA(1)=0
. F S DA(1)=$O(^FBAAC("AFN",FBFR1,DA(3),DA(2),DA(1))) Q:'DA(1) D
. . ; loop thru service provided IENs
. . S DA=0
. . F S DA=$O(^FBAAC("AFN",FBFR1,DA(3),DA(2),DA(1),DA)) Q:'DA D
. . . ; update authorization pointer in the service provided multiple
. . . S DIE="^FBAAC("_DA(3)_",1,"_DA(2)_",1,"_DA(1)_",1,"
. . . S DR="15.5////^S X=FBTO1"
. . . D ^DIE
;
; update file 162 FEE BASIS PAYMENT - TRAVEL PAYMENT DATE multiple
K DA S DA(1)=FBFR ; patient
; loop thru travel payments for patient
S DA=0 F S DA=$O(^FBAAC(DA(1),3,DA)) Q:'DA D
. ; if existing authorization pointer refers to the authorization
. ; that was changed then update it
. S AUTHP=$P($G(^FBAAC(DA(1),3,DA,1)),U,1)
. I AUTHP=FBFR1 D
. . S DIE="^FBAAC("_DA(1)_",3,"
. . S DR="15////^S X=FBTO1"
. . D ^DIE
;
; update file 162.1 FEE BASIS PHARMACY INVOICE
; use "AD" x-ref to find patient
; loop thru inverse dates for 'from patient'
K DA S X1="" F S X1=$O(^FBAA(162.1,"AD",FBFR,X1)) Q:X1="" D
. ; loop thru invoices
. S DA(1)=0 F S DA(1)=$O(^FBAA(162.1,"AD",FBFR,X1,DA(1))) Q:'DA(1) D
. . ; loop thru prescriptions
. . S DA=0 F S DA=$O(^FBAA(162.1,"AD",FBFR,X1,DA(1),DA)) Q:'DA D
. . . ; if existing authorization pointer refers to the authorization
. . . ; that was changed then update it
. . . S AUTHP=$P($G(^FBAA(162.1,DA(1),"RX",DA,2)),U,7)
. . . I AUTHP=FBFR1 D
. . . . S DIE="^FBAA(162.1,"_DA(1)_",""RX"","
. . . . S DR="27////^S X=FBTO1"
. . . . D ^DIE
;
; update file 162.3 FEE CNH ACTIVITY
; use "AE" x-ref to find patient
K DA S DA="" F S DA=$O(^FBAACNH("AE",FBFR,DA)) Q:'DA D
. ; if existing authorization pointer refers to the authorization
. ; that was changed then update it
. S AUTHP=$P($G(^FBAACNH(DA,0)),U,10)
. I AUTHP=FBFR1 D
. . S DIE="^FBAACNH("
. . S DR="9////^S X=FBTO1"
. . D ^DIE
;
; update file 162.7 FEE BASIS UNAUTHORIZED CLAIM
; using "D" x-ref to find patient
; loop thru claims for patient
K DA S DA=0 F S DA=$O(^FB583("D",FBFR,DA)) Q:'DA D
. ; if existing authorization pointer refers to the authorization
. ; that was changed then update it
. S AUTHP=$P($G(^FB583(DA,0)),U,27)
. I AUTHP=FBFR1 D
. . S DIE="^FB583("
. . S DR="30////^S X=FBTO1"
. . D ^DIE
Q
;
;FBPMRG
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBPMRG 7696 printed Sep 23, 2025@19:35:48 Page 2
FBPMRG ;WCIOFO/SAB - FEE BASIS PATIENT MERGE ROUTINE ;6/4/2014
+1 ;;3.5;FEE BASIS;**19,41,59,154**;JAN 30, 1995;Build 12
+2 ;;Per VA Directive 6402, this routine should not be modified.
EN(ARRAY) ; Entry point
+1 ; Called during patient (file #2) merge due to AFFECTS RECORD MERGE
+2 ; in PACKAGE (#9.4) file.
+3 ; Input
+4 ; ARRAY - name of array with the PATIENT (#2) From IENs and To IENs
+5 ; format: name(ien_from,ien_to,"ien_from;DPT(","ien_to;DPT(")
+6 ; example: TEST(1000,500,"1000;DPT(","500;DPT(")=""
+7 ;
+8 NEW FBFR,FBTO
+9 ; loop thru from ien of patients (file #2) being merged
+10 SET FBFR=0
FOR
SET FBFR=$ORDER(@ARRAY@(FBFR))
if FBFR'>0
QUIT
Begin DoDot:1
+11 ; to ien
SET FBTO=$ORDER(@ARRAY@(FBFR,0))
+12 ; check/update some Fee Basis files that normal merge can't handle
+13 DO F161
+14 DO F162^FBPMRG1
End DoDot:1
+15 QUIT
+16 ;
F161 ; File 161 FEE BASIS PATIENT - The .01 field points to and is
+1 ; dinumed with the PATIENT (#2) file
+2 ; input
+3 ; FBFR - ien of patient (files #2,161) being merged from
+4 ; FBTO - ien of patient (files #2,161) being merged to
+5 NEW FBFR1,FBTO1
+6 NEW DA,DD,DIC,DIK,DINUM,DLAYGO,DO,X,Y
+7 ;
+8 ; nothing to merge from
if '$DATA(^FBAAA(FBFR))
QUIT
+9 ;
+10 ;
IDCARD ; if both records have id card numbers the pairs are removed from merge.
+1 ; all other cases will be handled by merge.
+2 ;
+3 IF $PIECE($GET(^FBAAA(FBFR,4)),U)
Begin DoDot:1
+4 IF $PIECE($GET(^FBAAA(FBTO,4)),U)
Begin DoDot:2
+5 ; remove pair from merge when there is a id number in the from and to
+6 SET IENFRM=$ORDER(@ARRAY@(FBFR,FBTO,""))
+7 SET IENTO=$ORDER(@ARRAY@(FBFR,FBTO,IENFRM,""))
+8 SET IEN=""
+9 SET IEN=+$GET(@ARRAY@(FBFR,FBTO,IENFRM,IENTO))
+10 DO RMOVPAIR^XDRDVAL1(FBFR,FBTO,IEN,ARRAY)
+11 NEW XMSUB,XMTEXT
+12 SET XMSUB="MERGE PAIRS EXCLUDED DUE TO BOTH HAVE FEE BASIS ID CARDS"
+13 SET ^TMP("DDB",$JOB,1)=" MERGE PAIR Patient records "_FBFR_" AND "_FBTO_" both have FB ID card numbers. Please cancel one of the IDs and resubmit the Merge Pair"
+14 SET XMTEXT="^TMP(""DDB"",$J,"
+15 DO SENDMESG^XDRDVAL1(XMSUB,XMTEXT)
+16 KILL IEN,IENTO,IENFRM
End DoDot:2
End DoDot:1
+17 ;
+18 ;
+19 ; if only from ien exists then standard process OK
if '$DATA(^FBAAA(FBTO))
QUIT
+20 ;
+21 ; both from ien and to ien are in the FEE BASIS PATIENT file.
+22 ; The AUTHORIZATION multiple and REPORT OF CONTACT multiple can have
+23 ; duplicate .01 values so they need to be handled here since the
+24 ; standard merge would inappropriately combine subfile entries whose
+25 ; .01 values match. Additionally, if the ien of an AUTHORIZATION must
+26 ; be changed when moved from the 'from ien' to the 'to ien', then
+27 ; the free-text pointers that reference that AUTHORIZATION will need
+28 ; to be updated.
+29 ;
+30 ; loop thru authorization multiple in 'from ien'
+31 SET FBFR1=0
FOR
SET FBFR1=$ORDER(^FBAAA(FBFR,1,FBFR1))
if 'FBFR1
QUIT
Begin DoDot:1
+32 ;
+33 ; create new entry in authorization multiple of 'to ien'
+34 KILL DD,DO,DA
+35 SET DIC="^FBAAA("_FBTO_",1,"
SET DIC(0)="L"
+36 SET DA(1)=FBTO
+37 SET X=$PIECE($GET(^FBAAA(FBFR,1,FBFR1,0)),U)
+38 ; can't add without a from date
if X=""
QUIT
+39 ; use same ien if available
IF $DATA(@(DIC_FBFR1_")"))=0
SET DINUM=FBFR1
+40 SET DLAYGO=161.01
+41 DO FILE^DICN
KILL DIC,DINUM,DLAYGO
+42 ; couldn't add new authorization
if $PIECE(Y,U,3)'=1
QUIT
+43 SET FBTO1=+Y
+44 ;
+45 ; move data
+46 MERGE ^FBAAA(FBTO,1,FBTO1)=^FBAAA(FBFR,1,FBFR1)
+47 ;
+48 ; delete 'from authorization'
+49 SET DIK="^FBAAA("_FBFR_",1,"
+50 SET DA(1)=FBFR
SET DA=FBFR1
+51 DO ^DIK
KILL DA,DIK
+52 ;
+53 ; index 'to authorization'
+54 SET DIK="^FBAAA("_FBTO_",1,"
+55 SET DA(1)=FBTO
SET DA=FBTO1
+56 DO IX1^DIK
KILL DA,DIK
+57 ;
+58 ; if authorization ien was changed then update any pointers to it
+59 IF FBFR1'=FBTO1
DO UAUTHP
End DoDot:1
+60 ;
+61 ; loop thru report of contact multiple in 'from ien'
+62 SET FBFR1=0
FOR
SET FBFR1=$ORDER(^FBAAA(FBFR,2,FBFR1))
if 'FBFR1
QUIT
Begin DoDot:1
+63 ;
+64 ; create new entry in report of contact multiple of 'to ien'
+65 KILL DD,DO,DA
+66 SET DIC="^FBAAA("_FBTO_",2,"
SET DIC(0)="L"
+67 SET DA(1)=FBTO
+68 SET X=$PIECE($GET(^FBAAA(FBFR,1,FBFR1,0)),U)
+69 ; can't add without a date of contact
if X=""
QUIT
+70 ; use same ien if available
IF $DATA(@(DIC_FBFR1_")"))=0
SET DINUM=FBFR1
+71 SET DLAYGO=161.02
+72 DO FILE^DICN
KILL DIC,DINUM,DLAYGO
+73 ; couldn't add new report of contact
if $PIECE(Y,U,3)'=1
QUIT
+74 SET FBTO1=+Y
+75 ;
+76 ; move data
+77 MERGE ^FBAAA(FBTO,2,FBTO1)=^FBAAA(FBFR,2,FBFR1)
+78 ;
+79 ; delete 'from report of contact'
+80 SET DIK="^FBAAA("_FBFR_",2,"
+81 SET DA(1)=FBFR
SET DA=FBFR1
+82 DO ^DIK
KILL DA,DIK
+83 ;
+84 ; index 'to report of contact'
+85 SET DIK="^FBAAA("_FBTO_",2,"
+86 SET DA(1)=FBTO
SET DA=FBTO1
+87 DO IX1^DIK
End DoDot:1
+88 ;
+89 QUIT
+90 ;
UAUTHP ; Update 'free-text' pointers to authorization
+1 ; input
+2 ; FBFR - ien of patient (files #2,161) being merged from
+3 ; FBFR1 - ien of authorization in FBFR
+4 ; FBTO - ien of patient (files #2,161) being merged to
+5 ; FBTO1 - ien of authorization in FBTO
+6 NEW AUTHP,DA,DIE,DR,X,X1,Y
+7 ;
+8 ; same value so nothing to update
if FBFR1=FBTO1
QUIT
+9 ;
+10 ; update file 161.26 FEE BASIS PATIENT MRA
+11 ; use "B" x-ref to find patient
+12 KILL DA
SET DA=0
FOR
SET DA=$ORDER(^FBAA(161.26,"B",FBFR,DA))
if 'DA
QUIT
Begin DoDot:1
+13 ; if existing authorization pointer refers to the authorization
+14 ; that was changed then update it
+15 SET AUTHP=$PIECE($GET(^FBAA(161.26,DA,0)),U,3)
+16 IF AUTHP=FBFR1
Begin DoDot:2
+17 SET DIE="^FBAA(161.26,"
+18 SET DR="2////^S X=FBTO1"
+19 DO ^DIE
End DoDot:2
End DoDot:1
+20 ;
+21 ; update file 162 FEE BASIS PAYMENT
+22 ; use "AFN" cross-reference on AUTHORIZATION POINTER (#15.5) field
+23 ; patient
KILL DA
SET DA(3)=FBFR
+24 ; loop thru vendor IENs
+25 SET DA(2)=0
FOR
SET DA(2)=$ORDER(^FBAAC("AFN",FBFR1,DA(3),DA(2)))
if 'DA(2)
QUIT
Begin DoDot:1
+26 ; loop thru initial treatment date IENs
+27 SET DA(1)=0
+28 FOR
SET DA(1)=$ORDER(^FBAAC("AFN",FBFR1,DA(3),DA(2),DA(1)))
if 'DA(1)
QUIT
Begin DoDot:2
+29 ; loop thru service provided IENs
+30 SET DA=0
+31 FOR
SET DA=$ORDER(^FBAAC("AFN",FBFR1,DA(3),DA(2),DA(1),DA))
if 'DA
QUIT
Begin DoDot:3
+32 ; update authorization pointer in the service provided multiple
+33 SET DIE="^FBAAC("_DA(3)_",1,"_DA(2)_",1,"_DA(1)_",1,"
+34 SET DR="15.5////^S X=FBTO1"
+35 DO ^DIE
End DoDot:3
End DoDot:2
End DoDot:1
+36 ;
+37 ; update file 162 FEE BASIS PAYMENT - TRAVEL PAYMENT DATE multiple
+38 ; patient
KILL DA
SET DA(1)=FBFR
+39 ; loop thru travel payments for patient
+40 SET DA=0
FOR
SET DA=$ORDER(^FBAAC(DA(1),3,DA))
if 'DA
QUIT
Begin DoDot:1
+41 ; if existing authorization pointer refers to the authorization
+42 ; that was changed then update it
+43 SET AUTHP=$PIECE($GET(^FBAAC(DA(1),3,DA,1)),U,1)
+44 IF AUTHP=FBFR1
Begin DoDot:2
+45 SET DIE="^FBAAC("_DA(1)_",3,"
+46 SET DR="15////^S X=FBTO1"
+47 DO ^DIE
End DoDot:2
End DoDot:1
+48 ;
+49 ; update file 162.1 FEE BASIS PHARMACY INVOICE
+50 ; use "AD" x-ref to find patient
+51 ; loop thru inverse dates for 'from patient'
+52 KILL DA
SET X1=""
FOR
SET X1=$ORDER(^FBAA(162.1,"AD",FBFR,X1))
if X1=""
QUIT
Begin DoDot:1
+53 ; loop thru invoices
+54 SET DA(1)=0
FOR
SET DA(1)=$ORDER(^FBAA(162.1,"AD",FBFR,X1,DA(1)))
if 'DA(1)
QUIT
Begin DoDot:2
+55 ; loop thru prescriptions
+56 SET DA=0
FOR
SET DA=$ORDER(^FBAA(162.1,"AD",FBFR,X1,DA(1),DA))
if 'DA
QUIT
Begin DoDot:3
+57 ; if existing authorization pointer refers to the authorization
+58 ; that was changed then update it
+59 SET AUTHP=$PIECE($GET(^FBAA(162.1,DA(1),"RX",DA,2)),U,7)
+60 IF AUTHP=FBFR1
Begin DoDot:4
+61 SET DIE="^FBAA(162.1,"_DA(1)_",""RX"","
+62 SET DR="27////^S X=FBTO1"
+63 DO ^DIE
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+64 ;
+65 ; update file 162.3 FEE CNH ACTIVITY
+66 ; use "AE" x-ref to find patient
+67 KILL DA
SET DA=""
FOR
SET DA=$ORDER(^FBAACNH("AE",FBFR,DA))
if 'DA
QUIT
Begin DoDot:1
+68 ; if existing authorization pointer refers to the authorization
+69 ; that was changed then update it
+70 SET AUTHP=$PIECE($GET(^FBAACNH(DA,0)),U,10)
+71 IF AUTHP=FBFR1
Begin DoDot:2
+72 SET DIE="^FBAACNH("
+73 SET DR="9////^S X=FBTO1"
+74 DO ^DIE
End DoDot:2
End DoDot:1
+75 ;
+76 ; update file 162.7 FEE BASIS UNAUTHORIZED CLAIM
+77 ; using "D" x-ref to find patient
+78 ; loop thru claims for patient
+79 KILL DA
SET DA=0
FOR
SET DA=$ORDER(^FB583("D",FBFR,DA))
if 'DA
QUIT
Begin DoDot:1
+80 ; if existing authorization pointer refers to the authorization
+81 ; that was changed then update it
+82 SET AUTHP=$PIECE($GET(^FB583(DA,0)),U,27)
+83 IF AUTHP=FBFR1
Begin DoDot:2
+84 SET DIE="^FB583("
+85 SET DR="30////^S X=FBTO1"
+86 DO ^DIE
End DoDot:2
End DoDot:1
+87 QUIT
+88 ;
+89 ;FBPMRG
