FBPMRG1 ;WCIOFO/SAB-FEE BASIS PATIENT MERGE ROUTINE (cont) ;12/15/2001
;;3.5;FEE BASIS;**19,41**;JAN 30, 1995
Q
F162 ; File 162 FEE BASIS PAYMENT - The .01 field points to and is
; dinumed with the PATIENT (#2) file
; input
; FBFR - ien of patient (files #2,162) being merged from
; FBTO - ien of patient (files #2,162) being merged to
N FBAUTHP,FBFR1,FBFR2,FBFR3,FBFRIENS,FBTO1,FBTO2,FBTO3,FBTOIENS
N DA,DD,DO,DIC,DIK,DINUM,DLAYGO,X,Y
;
Q:'$D(^FBAAC(FBFR)) ; nothing to merge from
;
; since a 'from ien' exists, we'll need to keep track of the old
; and new 'iens' of payments that may have been reported to the
; Austin Automation Center (AAC). The AAC returns data concerning the
; payments and the 'iens' are used to locate the appropriate entry to
; update.
;
; Additionally, if both the from ien and to ien are in the FEE BASIS
; PAYMENT file then the SERVICE PROVIDED multiple and the TRAVEL
; PAYMENT DATE multiple will need to be handled here since they
; are allowed to have duplicate .01 values and a standard merge could
; inappropriately combine subfile entries whose .01 values match.
;
; medical payments
; loop thru vendor multiple
S FBFR1=0 F S FBFR1=$O(^FBAAC(FBFR,1,FBFR1)) Q:'FBFR1 D
. ; loop thru initial treatment date multiple
. S FBFR2=0 F S FBFR2=$O(^FBAAC(FBFR,1,FBFR1,1,FBFR2)) Q:'FBFR2 D
. . S FBAUTHP=$P($G(^FBAAC(FBFR,1,FBFR1,1,FBFR2,0)),U,4) ; auth pointer
. . ; loop thru service provided multiple
. . S FBFR3=0
. . F S FBFR3=$O(^FBAAC(FBFR,1,FBFR1,1,FBFR2,1,FBFR3)) Q:'FBFR3 D
. . . S FBFRIENS=FBFR3_","_FBFR2_","_FBFR1_","_FBFR_","
. . . ; If the 'to ien' does not exist then only the patient ien will be
. . . ; different on payments sent to the AAC. We just need to save
. . . ; the iens and the normal merge will take care of moving the data.
. . . I '$D(^FBAAC(FBTO)) S FBTOIENS=FBFR3_","_FBFR2_","_FBFR1_","_FBTO_","
. . . E D
. . . . ; both from ien and to ien are in the FEE BASIS PAYMENT file
. . . . S (FBTO1,FBTO2,FBTO3,FBTOIENS)="" ; initialize new iens
. . . . ;
. . . . ; create new service provided entry in 'to ien'
. . . . ; find or create vendor subentry in 'to ien'
. . . . I $D(^FBAAC(FBTO,1,FBFR1)) S FBTO1=FBFR1
. . . . E D
. . . . . ; need to add vendor subentry
. . . . . K DA,DD,DO
. . . . . S DA(1)=FBTO
. . . . . S DIC="^FBAAC("_DA(1)_",1,"
. . . . . S DIC(0)="L"
. . . . . S X=$P($G(^FBAAC(FBFR,1,FBFR1,0)),U)
. . . . . Q:X=""
. . . . . S DINUM=X,DLAYGO=162.01
. . . . . D FILE^DICN K DIC,DINUM,DLAYGO
. . . . . Q:$P(Y,U,3)'=1 ; couldn't add vendor subentry
. . . . . S FBTO1=+Y
. . . . Q:'$G(FBTO1) ; couldn't find or add the vendor in FBTO
. . . . ;
. . . . ; find or create initial treatment date subentry in 'to ien'
. . . . ;
. . . . S X=$P($G(^FBAAC(FBFR,1,FBFR1,1,FBFR2,0)),U) ; init treat date
. . . . Q:X=""
. . . . S FBTO2=$O(^FBAAC(FBTO,FBTO1,"AD",(9999999.9999-X),0))
. . . . I 'FBTO2 D
. . . . . ; need to add initial treatment date subentry
. . . . . K DA,DD,DO
. . . . . S DA(2)=FBTO
. . . . . S DA(1)=FBTO1
. . . . . S DIC="^FBAAC("_DA(2)_",1,"_DA(1)_",1,"
. . . . . S DIC(0)="L"
. . . . . S:FBAUTHP DIC("DR")="3////^S X=FBAUTHP" ;authorization pointer
. . . . . I $D(@(DIC_FBFR2_")"))=0 S DINUM=FBFR2 ; use same ien if avail
. . . . . S DLAYGO=162.02
. . . . . D FILE^DICN K DIC,DINUM,DLAYGO
. . . . . Q:$P(Y,U,3)'=1 ; couldn't add init treat date subentry
. . . . . S FBTO2=+Y
. . . . Q:'$G(FBTO2) ; couldn't find or add the init treat date in FBTO
. . . . ;
. . . . ; create new entry in service provided multiple of 'to ien'
. . . . K DA,DD,DO
. . . . S DA(3)=FBTO,DA(2)=FBTO1,DA(1)=FBTO2
. . . . S DIC="^FBAAC("_DA(3)_",1,"_DA(2)_",1,"_DA(1)_",1,"
. . . . S DIC(0)="L"
. . . . S X=$P($G(^FBAAC(FBFR,1,FBFR1,1,FBFR2,1,FBFR3,0)),U)
. . . . Q:X="" ; can't add without a service provided
. . . . I $D(@(DIC_FBFR3_")"))=0 S DINUM=FBFR3 ; use same ien if avail.
. . . . S DLAYGO=162.03
. . . . D FILE^DICN K DIC,DINUM,DLAYGO
. . . . Q:$P(Y,U,3)'=1 ; couldn't add new subentry
. . . . S FBTO3=+Y
. . . . S FBTOIENS=FBTO3_","_FBTO2_","_FBTO1_","_FBTO_","
. . . . ;
. . . . ; move service provided data
. . . . M ^FBAAC(FBTO,1,FBTO1,1,FBTO2,1,FBTO3)=^FBAAC(FBFR,1,FBFR1,1,FBFR2,1,FBFR3)
. . . . ;
. . . . ; delete 'from' service provided
. . . . K DA S DA(3)=FBFR,DA(2)=FBFR1,DA(1)=FBFR2,DA=FBFR3
. . . . S DIK="^FBAAC("_DA(3)_",1,"_DA(2)_",1,"_DA(1)_",1,"
. . . . D ^DIK K DA,DIK
. . . . ;
. . . . ; index 'to' service provided
. . . . K DA S DA(3)=FBTO,DA(2)=FBTO1,DA(1)=FBTO2,DA=FBTO3
. . . . S DIK="^FBAAC("_DA(3)_",1,"_DA(2)_",1,"_DA(1)_",1,"
. . . . D IX1^DIK K DA,DIK
. . . . ;
. . . Q:$G(FBTOIENS)="" ; unable to move service provided to FBTO
. . . ; save iens (FBFRIENS and FBTOIENS) to file
. . . D SAVIENS(162.03,FBFRIENS,FBTOIENS)
. . ; if all service provided entries moved then delete the treat. date
. . I $P($G(^FBAAC(FBFR,1,FBFR1,1,FBFR2,1,0)),U,4)=0 D
. . . K DA S DA(2)=FBFR,DA(1)=FBFR1,DA=FBFR2
. . . S DIK="^FBAAC("_DA(2)_",1,"_DA(1)_",1,"
. . . D ^DIK K DA,DIK
. ; if all initial treatment dates moved then delete the vendor
. I $P($G(^FBAAC(FBFR,1,FBFR1,1,0)),U,4)=0 D
. . K DA S DA(1)=FBFR,DA=FBFR1
. . S DIK="^FBAAC("_DA(1)_",1,"
. . D ^DIK K DA,DIK
;
; travel payments
; loop thru travel payment date multiple
S FBFR1=0 F S FBFR1=$O(^FBAAC(FBFR,3,FBFR1)) Q:'FBFR1 D
. S FBFRIENS=FBFR1_","_FBFR_","
. ; If the 'to ien' does not exist then only the patient ien will be
. ; different on payments sent to the AAC. We just need to save
. ; the iens and the normal merge will take care of moving the data.
. I '$D(^FBAAC(FBTO)) S FBTOIENS=FBFR1_","_FBTO_","
. E D
. . ; both from ien and to ien are in the FEE BASIS PAYMENT file
. . ; create travel payment date subentry in to ien
. . S (FBTO1,FBTOIENS)="" ; initialize new iens
. . K DA,DD,DO
. . S DA(1)=FBTO
. . S DIC="^FBAAC("_DA(1)_",3,"
. . S DIC(0)="L"
. . S X=$P($G(^FBAAC(FBFR,3,FBFR1,0)),U)
. . Q:X="" ; can't add without a travel payment date
. . I $D(@(DIC_FBFR1_")"))=0 S DINUM=FBFR1 ; use same ien if avail.
. . S DLAYGO=162.04
. . D FILE^DICN K DIC,DINUM,DLAYGO
. . Q:$P(Y,U,3)'=1 ; couldn't add new subentry
. . S FBTO1=+Y
. . S FBTOIENS=FBTO1_","_FBTO_","
. . ;
. . ; move data
. . M ^FBAAC(FBTO,3,FBTO1)=^FBAAC(FBFR,3,FBFR1)
. . ;
. . ; delete from ien
. . K DA S DA(1)=FBFR,DA=FBFR1
. . S DIK="^FBAAC("_DA(1)_",3,"
. . D ^DIK K DA,DIK
. . ;
. . ; index to ien
. . K DA S DA(1)=FBTO,DA=FBTO1
. . S DIK="^FBAAC("_DA(1)_",3,"
. . D IX1^DIK K DA,DIK
. ;
. Q:$G(FBTOIENS)="" ; unable to move travel payment date to FBTO
. ; save iens (FBFRIENS and FBTOIENS) to file
. D SAVIENS(162.04,FBFRIENS,FBTOIENS)
;
Q
;
SAVIENS(FBFILE,FBOLDIEN,FBNEWIEN) ; save old & new iens in file 161.45
N DA,DD,DIC,DLAYGO,DO,X,Y
S DIC="^FBAA(161.45,",DIC(0)="L"
S X=FBFILE
Q:X="" ; can't add without a from date
S DIC("DR")="1////^S X=FBOLDIEN;2////^S X=FBNEWIEN"
S DLAYGO=161.45
D FILE^DICN K DIC,DLAYGO
Q
;
;FBPMRG1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBPMRG1 7229 printed Nov 22, 2024@17:09:54 Page 2
FBPMRG1 ;WCIOFO/SAB-FEE BASIS PATIENT MERGE ROUTINE (cont) ;12/15/2001
+1 ;;3.5;FEE BASIS;**19,41**;JAN 30, 1995
+2 QUIT
F162 ; File 162 FEE BASIS PAYMENT - The .01 field points to and is
+1 ; dinumed with the PATIENT (#2) file
+2 ; input
+3 ; FBFR - ien of patient (files #2,162) being merged from
+4 ; FBTO - ien of patient (files #2,162) being merged to
+5 NEW FBAUTHP,FBFR1,FBFR2,FBFR3,FBFRIENS,FBTO1,FBTO2,FBTO3,FBTOIENS
+6 NEW DA,DD,DO,DIC,DIK,DINUM,DLAYGO,X,Y
+7 ;
+8 ; nothing to merge from
if '$DATA(^FBAAC(FBFR))
QUIT
+9 ;
+10 ; since a 'from ien' exists, we'll need to keep track of the old
+11 ; and new 'iens' of payments that may have been reported to the
+12 ; Austin Automation Center (AAC). The AAC returns data concerning the
+13 ; payments and the 'iens' are used to locate the appropriate entry to
+14 ; update.
+15 ;
+16 ; Additionally, if both the from ien and to ien are in the FEE BASIS
+17 ; PAYMENT file then the SERVICE PROVIDED multiple and the TRAVEL
+18 ; PAYMENT DATE multiple will need to be handled here since they
+19 ; are allowed to have duplicate .01 values and a standard merge could
+20 ; inappropriately combine subfile entries whose .01 values match.
+21 ;
+22 ; medical payments
+23 ; loop thru vendor multiple
+24 SET FBFR1=0
FOR
SET FBFR1=$ORDER(^FBAAC(FBFR,1,FBFR1))
if 'FBFR1
QUIT
Begin DoDot:1
+25 ; loop thru initial treatment date multiple
+26 SET FBFR2=0
FOR
SET FBFR2=$ORDER(^FBAAC(FBFR,1,FBFR1,1,FBFR2))
if 'FBFR2
QUIT
Begin DoDot:2
+27 ; auth pointer
SET FBAUTHP=$PIECE($GET(^FBAAC(FBFR,1,FBFR1,1,FBFR2,0)),U,4)
+28 ; loop thru service provided multiple
+29 SET FBFR3=0
+30 FOR
SET FBFR3=$ORDER(^FBAAC(FBFR,1,FBFR1,1,FBFR2,1,FBFR3))
if 'FBFR3
QUIT
Begin DoDot:3
+31 SET FBFRIENS=FBFR3_","_FBFR2_","_FBFR1_","_FBFR_","
+32 ; If the 'to ien' does not exist then only the patient ien will be
+33 ; different on payments sent to the AAC. We just need to save
+34 ; the iens and the normal merge will take care of moving the data.
+35 IF '$DATA(^FBAAC(FBTO))
SET FBTOIENS=FBFR3_","_FBFR2_","_FBFR1_","_FBTO_","
+36 IF '$TEST
Begin DoDot:4
+37 ; both from ien and to ien are in the FEE BASIS PAYMENT file
+38 ; initialize new iens
SET (FBTO1,FBTO2,FBTO3,FBTOIENS)=""
+39 ;
+40 ; create new service provided entry in 'to ien'
+41 ; find or create vendor subentry in 'to ien'
+42 IF $DATA(^FBAAC(FBTO,1,FBFR1))
SET FBTO1=FBFR1
+43 IF '$TEST
Begin DoDot:5
+44 ; need to add vendor subentry
+45 KILL DA,DD,DO
+46 SET DA(1)=FBTO
+47 SET DIC="^FBAAC("_DA(1)_",1,"
+48 SET DIC(0)="L"
+49 SET X=$PIECE($GET(^FBAAC(FBFR,1,FBFR1,0)),U)
+50 if X=""
QUIT
+51 SET DINUM=X
SET DLAYGO=162.01
+52 DO FILE^DICN
KILL DIC,DINUM,DLAYGO
+53 ; couldn't add vendor subentry
if $PIECE(Y,U,3)'=1
QUIT
+54 SET FBTO1=+Y
End DoDot:5
+55 ; couldn't find or add the vendor in FBTO
if '$GET(FBTO1)
QUIT
+56 ;
+57 ; find or create initial treatment date subentry in 'to ien'
+58 ;
+59 ; init treat date
SET X=$PIECE($GET(^FBAAC(FBFR,1,FBFR1,1,FBFR2,0)),U)
+60 if X=""
QUIT
+61 SET FBTO2=$ORDER(^FBAAC(FBTO,FBTO1,"AD",(9999999.9999-X),0))
+62 IF 'FBTO2
Begin DoDot:5
+63 ; need to add initial treatment date subentry
+64 KILL DA,DD,DO
+65 SET DA(2)=FBTO
+66 SET DA(1)=FBTO1
+67 SET DIC="^FBAAC("_DA(2)_",1,"_DA(1)_",1,"
+68 SET DIC(0)="L"
+69 ;authorization pointer
if FBAUTHP
SET DIC("DR")="3////^S X=FBAUTHP"
+70 ; use same ien if avail
IF $DATA(@(DIC_FBFR2_")"))=0
SET DINUM=FBFR2
+71 SET DLAYGO=162.02
+72 DO FILE^DICN
KILL DIC,DINUM,DLAYGO
+73 ; couldn't add init treat date subentry
if $PIECE(Y,U,3)'=1
QUIT
+74 SET FBTO2=+Y
End DoDot:5
+75 ; couldn't find or add the init treat date in FBTO
if '$GET(FBTO2)
QUIT
+76 ;
+77 ; create new entry in service provided multiple of 'to ien'
+78 KILL DA,DD,DO
+79 SET DA(3)=FBTO
SET DA(2)=FBTO1
SET DA(1)=FBTO2
+80 SET DIC="^FBAAC("_DA(3)_",1,"_DA(2)_",1,"_DA(1)_",1,"
+81 SET DIC(0)="L"
+82 SET X=$PIECE($GET(^FBAAC(FBFR,1,FBFR1,1,FBFR2,1,FBFR3,0)),U)
+83 ; can't add without a service provided
if X=""
QUIT
+84 ; use same ien if avail.
IF $DATA(@(DIC_FBFR3_")"))=0
SET DINUM=FBFR3
+85 SET DLAYGO=162.03
+86 DO FILE^DICN
KILL DIC,DINUM,DLAYGO
+87 ; couldn't add new subentry
if $PIECE(Y,U,3)'=1
QUIT
+88 SET FBTO3=+Y
+89 SET FBTOIENS=FBTO3_","_FBTO2_","_FBTO1_","_FBTO_","
+90 ;
+91 ; move service provided data
+92 MERGE ^FBAAC(FBTO,1,FBTO1,1,FBTO2,1,FBTO3)=^FBAAC(FBFR,1,FBFR1,1,FBFR2,1,FBFR3)
+93 ;
+94 ; delete 'from' service provided
+95 KILL DA
SET DA(3)=FBFR
SET DA(2)=FBFR1
SET DA(1)=FBFR2
SET DA=FBFR3
+96 SET DIK="^FBAAC("_DA(3)_",1,"_DA(2)_",1,"_DA(1)_",1,"
+97 DO ^DIK
KILL DA,DIK
+98 ;
+99 ; index 'to' service provided
+100 KILL DA
SET DA(3)=FBTO
SET DA(2)=FBTO1
SET DA(1)=FBTO2
SET DA=FBTO3
+101 SET DIK="^FBAAC("_DA(3)_",1,"_DA(2)_",1,"_DA(1)_",1,"
+102 DO IX1^DIK
KILL DA,DIK
+103 ;
End DoDot:4
+104 ; unable to move service provided to FBTO
if $GET(FBTOIENS)=""
QUIT
+105 ; save iens (FBFRIENS and FBTOIENS) to file
+106 DO SAVIENS(162.03,FBFRIENS,FBTOIENS)
End DoDot:3
+107 ; if all service provided entries moved then delete the treat. date
+108 IF $PIECE($GET(^FBAAC(FBFR,1,FBFR1,1,FBFR2,1,0)),U,4)=0
Begin DoDot:3
+109 KILL DA
SET DA(2)=FBFR
SET DA(1)=FBFR1
SET DA=FBFR2
+110 SET DIK="^FBAAC("_DA(2)_",1,"_DA(1)_",1,"
+111 DO ^DIK
KILL DA,DIK
End DoDot:3
End DoDot:2
+112 ; if all initial treatment dates moved then delete the vendor
+113 IF $PIECE($GET(^FBAAC(FBFR,1,FBFR1,1,0)),U,4)=0
Begin DoDot:2
+114 KILL DA
SET DA(1)=FBFR
SET DA=FBFR1
+115 SET DIK="^FBAAC("_DA(1)_",1,"
+116 DO ^DIK
KILL DA,DIK
End DoDot:2
End DoDot:1
+117 ;
+118 ; travel payments
+119 ; loop thru travel payment date multiple
+120 SET FBFR1=0
FOR
SET FBFR1=$ORDER(^FBAAC(FBFR,3,FBFR1))
if 'FBFR1
QUIT
Begin DoDot:1
+121 SET FBFRIENS=FBFR1_","_FBFR_","
+122 ; If the 'to ien' does not exist then only the patient ien will be
+123 ; different on payments sent to the AAC. We just need to save
+124 ; the iens and the normal merge will take care of moving the data.
+125 IF '$DATA(^FBAAC(FBTO))
SET FBTOIENS=FBFR1_","_FBTO_","
+126 IF '$TEST
Begin DoDot:2
+127 ; both from ien and to ien are in the FEE BASIS PAYMENT file
+128 ; create travel payment date subentry in to ien
+129 ; initialize new iens
SET (FBTO1,FBTOIENS)=""
+130 KILL DA,DD,DO
+131 SET DA(1)=FBTO
+132 SET DIC="^FBAAC("_DA(1)_",3,"
+133 SET DIC(0)="L"
+134 SET X=$PIECE($GET(^FBAAC(FBFR,3,FBFR1,0)),U)
+135 ; can't add without a travel payment date
if X=""
QUIT
+136 ; use same ien if avail.
IF $DATA(@(DIC_FBFR1_")"))=0
SET DINUM=FBFR1
+137 SET DLAYGO=162.04
+138 DO FILE^DICN
KILL DIC,DINUM,DLAYGO
+139 ; couldn't add new subentry
if $PIECE(Y,U,3)'=1
QUIT
+140 SET FBTO1=+Y
+141 SET FBTOIENS=FBTO1_","_FBTO_","
+142 ;
+143 ; move data
+144 MERGE ^FBAAC(FBTO,3,FBTO1)=^FBAAC(FBFR,3,FBFR1)
+145 ;
+146 ; delete from ien
+147 KILL DA
SET DA(1)=FBFR
SET DA=FBFR1
+148 SET DIK="^FBAAC("_DA(1)_",3,"
+149 DO ^DIK
KILL DA,DIK
+150 ;
+151 ; index to ien
+152 KILL DA
SET DA(1)=FBTO
SET DA=FBTO1
+153 SET DIK="^FBAAC("_DA(1)_",3,"
+154 DO IX1^DIK
KILL DA,DIK
End DoDot:2
+155 ;
+156 ; unable to move travel payment date to FBTO
if $GET(FBTOIENS)=""
QUIT
+157 ; save iens (FBFRIENS and FBTOIENS) to file
+158 DO SAVIENS(162.04,FBFRIENS,FBTOIENS)
End DoDot:1
+159 ;
+160 QUIT
+161 ;
SAVIENS(FBFILE,FBOLDIEN,FBNEWIEN) ; save old & new iens in file 161.45
+1 NEW DA,DD,DIC,DLAYGO,DO,X,Y
+2 SET DIC="^FBAA(161.45,"
SET DIC(0)="L"
+3 SET X=FBFILE
+4 ; can't add without a from date
if X=""
QUIT
+5 SET DIC("DR")="1////^S X=FBOLDIEN;2////^S X=FBNEWIEN"
+6 SET DLAYGO=161.45
+7 DO FILE^DICN
KILL DIC,DLAYGO
+8 QUIT
+9 ;
+10 ;FBPMRG1
