FBPAID1 ;WOIFO/SAB - SERVER ROUTINE TO UPDATE PAYMENTS CON'T ;1/11/2012
;;3.5;FEE BASIS;**19,107,121,132,123**;JAN 30, 1995;Build 51
;;Per VA Directive 6402, this routine should not be modified.
PARSE ;set-up variables for payment record called from FBPAID
; FBPROG = 3 for Outpatient (file 162)
; = T for Travel (file 162)
; = 5 for Pharmacy (file 162.1)
; = 9 for Inpatient (file 162.5)
; = $E(XMRG,7) fee program and effected file
; FBACT = $E(XMRG,8) type of activity
; FBIEN(x)=$E(XMRG,9,38) IEN for payment record to update
; FBCKNUM= $E(XMRG,39,46) check number
; old format (when total length = 77)
; FBCKDT = $E(XMRG,47,52) check date
; FBINAMT= $E(XMRG,53,60) interest amount
; FBXDT = $E(XMRG,61,66) cancel date
; FBRCOD = $E(XMRG,67) reason code
; FBXCOD = $E(XMRG,68) cancel code
; FBDAMT = $E(XMRG,69,76) disbursed amount
; new format (when total length = 82)
; FBCKDT = $E(XMRG,47,54) check date
; FBINAMT= $E(XMRG,55,62) interest amount
; FBXDT = $E(XMRG,63,70) cancel date
; FBRCOD = $E(XMRG,71) reason code
; FBXCOD = $E(XMRG,72) cancel code
; FBDAMT = $E(XMRG,73,81) disbursed amount
; FBBRTG = $E(XMRG,82,90) bank routing number ;HIPAA 5010 P121
; FBBACC = $E(XMRG,91,107) bank account number ;HIPAA 5010 P121
; FBBNAM = $E(XMRG,108,138)bank name ;HIPAA 5010 P121
; FBAMT = Amount paid out of payment record
Q:$G(FBERR)
S FBPROG=$E(XMRG,7) I $S(FBPROG=3:0,FBPROG=5:0,FBPROG=9:0,FBPROG="T":0,1:1) S FBERR=1 Q
S FBACT=$E(XMRG,8) I $S(FBACT="C":0,FBACT="B":0,FBACT="X":0,1:1) S FBERR=1 Q
S FBIEN=$E(XMRG,9,38) D Q:$G(FBERR)
. I FBPROG=3 D Q:$G(FBERR)
..S FBIEN(3)=+$P(FBIEN,U),FBIEN(2)=+$P(FBIEN,U,2),FBIEN(1)=+$P(FBIEN,U,3),FBIEN=+$P(FBIEN,U,4)
..I '$D(^FBAAC(FBIEN(3),1,FBIEN(2),1,FBIEN(1),1,FBIEN,0)) D CHKMOVE
..I '$D(^FBAAC(FBIEN(3),1,FBIEN(2),1,FBIEN(1),1,FBIEN,0)) S FBERR=1,^TMP("FBERR",$J,3,I)=""
. ;
. I FBPROG=5 D Q:$G(FBERR)
..S FBIEN(1)=+$P(FBIEN,U),FBIEN=+$P(FBIEN,U,2)
..I '$D(^FBAA(162.1,FBIEN(1),"RX",FBIEN,0)) S FBERR=1,^TMP("FBERR",$J,3,I)=""
. ;
. I FBPROG=9 D Q:$G(FBERR)
..S FBIEN=+FBIEN I '$D(^FBAAI(FBIEN,0)) S FBERR=1,^TMP("FBERR",$J,3,I)=""
. ;
. I FBPROG="T" D Q:$G(FBERR)
..S FBIEN(1)=+$P(FBIEN,U),FBIEN=+$P(FBIEN,U,2)
..I '$D(^FBAAC(FBIEN(1),3,FBIEN,0)) D CHKMOVE
..I '$D(^FBAAC(FBIEN(1),3,FBIEN,0)) S FBERR=1,^TMP("FBERR",$J,3,I)=""
;
; esg - FB*3.5*123 - for IPAC payments, the check# is the IPAC document reference#. Don't strip leading zeros for IPAC.
S FBCKNUM=$E(XMRG,39,46)
I '$$IPACCHK(FBPROG,.FBIEN) S FBCKNUM=$$EXTRL^FBMRASVR(FBCKNUM,1)
;
S FBCKDT=$$DATE4^FBPAID1($E(XMRG,47,54))
S FBINAMT=$S(+$E(XMRG,55,62):+$E(XMRG,55,60)_"."_$E(XMRG,61,62),1:0)
S FBINAMT=$S(FBINAMT=0:0,$P(FBINAMT,".",2)'>0:$P(FBINAMT,"."),1:+FBINAMT)
S FBXDT=$$DATE4^FBPAID1($E(XMRG,63,70))
S FBRCOD=$E(XMRG,71),FBXCOD=$E(XMRG,72)
S FBRCOD=$O(^FB(162.95,"C",FBRCOD,0))
S FBDAMT=$S(+$E(XMRG,73,81):+$E(XMRG,73,79)_"."_$E(XMRG,80,81),1:0)
S FBDAMT=$S(FBDAMT=0:0,$P(FBDAMT,".",2)'>0:$P(FBDAMT,"."),1:+FBDAMT)
I $L(XMRG)=138 D ; process new format with bank fields HIPAA 5010 P121
. S FBBRTG=$$TRIM^XLFSTR($E(XMRG,82,90),"LR") ;bank routing number
. S FBBACC=$$TRIM^XLFSTR($E(XMRG,91,107),"LR") ;bank account number
. S FBBNAM=$$TRIM^XLFSTR($E(XMRG,108,137),"LR") ;bank name
Q
;
BUL ;create server bulletin message
S ^TMP("FBPAID",$J,0)=FBMCNT
Q
DATE(X) ;pass in 'X'=date in yymmdd format and return date in
;fileman format.
N Y I '$G(X) Q ""
S %DT="",X=$E(X,3,7)_$E(X,1,2) D ^%DT K %DT
Q $S(Y=-1:"",1:Y)
DATE4(X) ;pass in 'X'=date in yyyymmdd format and return date in
;fileman format.
N Y I '$G(X) Q ""
S %DT="",X=$E(X,5,6)_"/"_$E(X,7,8)_"/"_$E(X,1,4) D ^%DT K %DT
Q $S(Y=-1:"",1:Y)
CHKMOVE ;check if payment line item was moved by patient merge process
; input
; FBPROG - fee program (3 or "T")
; FBIEN - ien of payment (from austin)
; FBIEN() - ien(s) of higher level entries (1 for next higher, etc.)
; output
; FBIEN may be changed to reflect current value
; FBIEN() may be changed to reflect current value
N FBDA,FBFILE,FBNIENS,FBCIENS,FBSIENS
;
; determine file
S FBFILE=$S(FBPROG=3:162.03,FBPROG="T":162.04,1:"")
Q:FBFILE=""
;
; determine starting IEN string
I FBPROG="3" S FBSIENS=FBIEN_","_FBIEN(1)_","_FBIEN(2)_","_FBIEN(3)_","
I FBPROG="T" S FBSIENS=FBIEN_","_FBIEN(1)_","
Q:FBSIENS=""
;
S FBCIENS=FBSIENS ; init current IEN string as starting IEN string
;
; loop thru moves for current IENs until no more moves are found
F D Q:FBNIENS=""
. S FBNIENS="" ; init new IENs value for a move
. S FBDA=$O(^FBAA(161.45,"C",FBFILE,FBCIENS,0))
. Q:'FBDA ; no more moves
. S FBNIENS=$P($G(^FBAA(161.45,FBDA,0)),U,3) ; new IENs
. ; if new IEN is same as starting IEN, break out of the endless loop
. I FBNIENS=FBSIENS S FBNIENS="" Q
. ; set current IENs to the new value
. S:FBNIENS'="" FBCIENS=FBNIENS
;
; if current IENs is different from starting IENs update outputs
I FBCIENS'=FBSIENS D
. I FBPROG="3" D
. . S FBIEN=$P(FBCIENS,",",1)
. . S FBIEN(1)=$P(FBCIENS,",",2)
. . S FBIEN(2)=$P(FBCIENS,",",3)
. . S FBIEN(3)=$P(FBCIENS,",",4)
. I FBPROG="T" D
. . S FBIEN=$P(FBCIENS,",",1)
. . S FBIEN(1)=$P(FBCIENS,",",2)
Q
;
IPACCHK(FBPROG,FBIEN) ; check if payment is an IPAC payment (FB*3.5*123)
; Function value is 1 if the payment is an IPAC payment, 0 otherwise
; This is determined by the existence of a pointer value to file 161.95.
;
N RES,FBFILE,FBSIENS,FBFIELD
S RES=0
I '$F(".3.5.9.","."_+$G(FBPROG)_".") G IPACKX
;
; get variables by type
I FBPROG=3 S FBFILE=162.03,FBSIENS=FBIEN_","_FBIEN(1)_","_FBIEN(2)_","_FBIEN(3)_",",FBFIELD=.05 ; outpat/ancil
I FBPROG=5 S FBFILE=162.1,FBSIENS=FBIEN(1)_",",FBFIELD=14 ; pharmacy (top level)
I FBPROG=9 S FBFILE=162.5,FBSIENS=FBIEN_",",FBFIELD=87 ; inpatient
;
I +$$GET1^DIQ(FBFILE,FBSIENS,FBFIELD,"I") S RES=1 ; IPAC payment found
IPACKX ;
Q RES
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBPAID1 6232 printed Sep 23, 2025@19:35:27 Page 2
FBPAID1 ;WOIFO/SAB - SERVER ROUTINE TO UPDATE PAYMENTS CON'T ;1/11/2012
+1 ;;3.5;FEE BASIS;**19,107,121,132,123**;JAN 30, 1995;Build 51
+2 ;;Per VA Directive 6402, this routine should not be modified.
PARSE ;set-up variables for payment record called from FBPAID
+1 ; FBPROG = 3 for Outpatient (file 162)
+2 ; = T for Travel (file 162)
+3 ; = 5 for Pharmacy (file 162.1)
+4 ; = 9 for Inpatient (file 162.5)
+5 ; = $E(XMRG,7) fee program and effected file
+6 ; FBACT = $E(XMRG,8) type of activity
+7 ; FBIEN(x)=$E(XMRG,9,38) IEN for payment record to update
+8 ; FBCKNUM= $E(XMRG,39,46) check number
+9 ; old format (when total length = 77)
+10 ; FBCKDT = $E(XMRG,47,52) check date
+11 ; FBINAMT= $E(XMRG,53,60) interest amount
+12 ; FBXDT = $E(XMRG,61,66) cancel date
+13 ; FBRCOD = $E(XMRG,67) reason code
+14 ; FBXCOD = $E(XMRG,68) cancel code
+15 ; FBDAMT = $E(XMRG,69,76) disbursed amount
+16 ; new format (when total length = 82)
+17 ; FBCKDT = $E(XMRG,47,54) check date
+18 ; FBINAMT= $E(XMRG,55,62) interest amount
+19 ; FBXDT = $E(XMRG,63,70) cancel date
+20 ; FBRCOD = $E(XMRG,71) reason code
+21 ; FBXCOD = $E(XMRG,72) cancel code
+22 ; FBDAMT = $E(XMRG,73,81) disbursed amount
+23 ; FBBRTG = $E(XMRG,82,90) bank routing number ;HIPAA 5010 P121
+24 ; FBBACC = $E(XMRG,91,107) bank account number ;HIPAA 5010 P121
+25 ; FBBNAM = $E(XMRG,108,138)bank name ;HIPAA 5010 P121
+26 ; FBAMT = Amount paid out of payment record
+27 if $GET(FBERR)
QUIT
+28 SET FBPROG=$EXTRACT(XMRG,7)
IF $SELECT(FBPROG=3:0,FBPROG=5:0,FBPROG=9:0,FBPROG="T":0,1:1)
SET FBERR=1
QUIT
+29 SET FBACT=$EXTRACT(XMRG,8)
IF $SELECT(FBACT="C":0,FBACT="B":0,FBACT="X":0,1:1)
SET FBERR=1
QUIT
+30 SET FBIEN=$EXTRACT(XMRG,9,38)
Begin DoDot:1
+31 IF FBPROG=3
Begin DoDot:2
+32 SET FBIEN(3)=+$PIECE(FBIEN,U)
SET FBIEN(2)=+$PIECE(FBIEN,U,2)
SET FBIEN(1)=+$PIECE(FBIEN,U,3)
SET FBIEN=+$PIECE(FBIEN,U,4)
+33 IF '$DATA(^FBAAC(FBIEN(3),1,FBIEN(2),1,FBIEN(1),1,FBIEN,0))
DO CHKMOVE
+34 IF '$DATA(^FBAAC(FBIEN(3),1,FBIEN(2),1,FBIEN(1),1,FBIEN,0))
SET FBERR=1
SET ^TMP("FBERR",$JOB,3,I)=""
End DoDot:2
if $GET(FBERR)
QUIT
+35 ;
+36 IF FBPROG=5
Begin DoDot:2
+37 SET FBIEN(1)=+$PIECE(FBIEN,U)
SET FBIEN=+$PIECE(FBIEN,U,2)
+38 IF '$DATA(^FBAA(162.1,FBIEN(1),"RX",FBIEN,0))
SET FBERR=1
SET ^TMP("FBERR",$JOB,3,I)=""
End DoDot:2
if $GET(FBERR)
QUIT
+39 ;
+40 IF FBPROG=9
Begin DoDot:2
+41 SET FBIEN=+FBIEN
IF '$DATA(^FBAAI(FBIEN,0))
SET FBERR=1
SET ^TMP("FBERR",$JOB,3,I)=""
End DoDot:2
if $GET(FBERR)
QUIT
+42 ;
+43 IF FBPROG="T"
Begin DoDot:2
+44 SET FBIEN(1)=+$PIECE(FBIEN,U)
SET FBIEN=+$PIECE(FBIEN,U,2)
+45 IF '$DATA(^FBAAC(FBIEN(1),3,FBIEN,0))
DO CHKMOVE
+46 IF '$DATA(^FBAAC(FBIEN(1),3,FBIEN,0))
SET FBERR=1
SET ^TMP("FBERR",$JOB,3,I)=""
End DoDot:2
if $GET(FBERR)
QUIT
End DoDot:1
if $GET(FBERR)
QUIT
+47 ;
+48 ; esg - FB*3.5*123 - for IPAC payments, the check# is the IPAC document reference#. Don't strip leading zeros for IPAC.
+49 SET FBCKNUM=$EXTRACT(XMRG,39,46)
+50 IF '$$IPACCHK(FBPROG,.FBIEN)
SET FBCKNUM=$$EXTRL^FBMRASVR(FBCKNUM,1)
+51 ;
+52 SET FBCKDT=$$DATE4^FBPAID1($EXTRACT(XMRG,47,54))
+53 SET FBINAMT=$SELECT(+$EXTRACT(XMRG,55,62):+$EXTRACT(XMRG,55,60)_"."_$EXTRACT(XMRG,61,62),1:0)
+54 SET FBINAMT=$SELECT(FBINAMT=0:0,$PIECE(FBINAMT,".",2)'>0:$PIECE(FBINAMT,"."),1:+FBINAMT)
+55 SET FBXDT=$$DATE4^FBPAID1($EXTRACT(XMRG,63,70))
+56 SET FBRCOD=$EXTRACT(XMRG,71)
SET FBXCOD=$EXTRACT(XMRG,72)
+57 SET FBRCOD=$ORDER(^FB(162.95,"C",FBRCOD,0))
+58 SET FBDAMT=$SELECT(+$EXTRACT(XMRG,73,81):+$EXTRACT(XMRG,73,79)_"."_$EXTRACT(XMRG,80,81),1:0)
+59 SET FBDAMT=$SELECT(FBDAMT=0:0,$PIECE(FBDAMT,".",2)'>0:$PIECE(FBDAMT,"."),1:+FBDAMT)
+60 ; process new format with bank fields HIPAA 5010 P121
IF $LENGTH(XMRG)=138
Begin DoDot:1
+61 ;bank routing number
SET FBBRTG=$$TRIM^XLFSTR($EXTRACT(XMRG,82,90),"LR")
+62 ;bank account number
SET FBBACC=$$TRIM^XLFSTR($EXTRACT(XMRG,91,107),"LR")
+63 ;bank name
SET FBBNAM=$$TRIM^XLFSTR($EXTRACT(XMRG,108,137),"LR")
End DoDot:1
+64 QUIT
+65 ;
BUL ;create server bulletin message
+1 SET ^TMP("FBPAID",$JOB,0)=FBMCNT
+2 QUIT
DATE(X) ;pass in 'X'=date in yymmdd format and return date in
+1 ;fileman format.
+2 NEW Y
IF '$GET(X)
QUIT ""
+3 SET %DT=""
SET X=$EXTRACT(X,3,7)_$EXTRACT(X,1,2)
DO ^%DT
KILL %DT
+4 QUIT $SELECT(Y=-1:"",1:Y)
DATE4(X) ;pass in 'X'=date in yyyymmdd format and return date in
+1 ;fileman format.
+2 NEW Y
IF '$GET(X)
QUIT ""
+3 SET %DT=""
SET X=$EXTRACT(X,5,6)_"/"_$EXTRACT(X,7,8)_"/"_$EXTRACT(X,1,4)
DO ^%DT
KILL %DT
+4 QUIT $SELECT(Y=-1:"",1:Y)
CHKMOVE ;check if payment line item was moved by patient merge process
+1 ; input
+2 ; FBPROG - fee program (3 or "T")
+3 ; FBIEN - ien of payment (from austin)
+4 ; FBIEN() - ien(s) of higher level entries (1 for next higher, etc.)
+5 ; output
+6 ; FBIEN may be changed to reflect current value
+7 ; FBIEN() may be changed to reflect current value
+8 NEW FBDA,FBFILE,FBNIENS,FBCIENS,FBSIENS
+9 ;
+10 ; determine file
+11 SET FBFILE=$SELECT(FBPROG=3:162.03,FBPROG="T":162.04,1:"")
+12 if FBFILE=""
QUIT
+13 ;
+14 ; determine starting IEN string
+15 IF FBPROG="3"
SET FBSIENS=FBIEN_","_FBIEN(1)_","_FBIEN(2)_","_FBIEN(3)_","
+16 IF FBPROG="T"
SET FBSIENS=FBIEN_","_FBIEN(1)_","
+17 if FBSIENS=""
QUIT
+18 ;
+19 ; init current IEN string as starting IEN string
SET FBCIENS=FBSIENS
+20 ;
+21 ; loop thru moves for current IENs until no more moves are found
+22 FOR
Begin DoDot:1
+23 ; init new IENs value for a move
SET FBNIENS=""
+24 SET FBDA=$ORDER(^FBAA(161.45,"C",FBFILE,FBCIENS,0))
+25 ; no more moves
if 'FBDA
QUIT
+26 ; new IENs
SET FBNIENS=$PIECE($GET(^FBAA(161.45,FBDA,0)),U,3)
+27 ; if new IEN is same as starting IEN, break out of the endless loop
+28 IF FBNIENS=FBSIENS
SET FBNIENS=""
QUIT
+29 ; set current IENs to the new value
+30 if FBNIENS'=""
SET FBCIENS=FBNIENS
End DoDot:1
if FBNIENS=""
QUIT
+31 ;
+32 ; if current IENs is different from starting IENs update outputs
+33 IF FBCIENS'=FBSIENS
Begin DoDot:1
+34 IF FBPROG="3"
Begin DoDot:2
+35 SET FBIEN=$PIECE(FBCIENS,",",1)
+36 SET FBIEN(1)=$PIECE(FBCIENS,",",2)
+37 SET FBIEN(2)=$PIECE(FBCIENS,",",3)
+38 SET FBIEN(3)=$PIECE(FBCIENS,",",4)
End DoDot:2
+39 IF FBPROG="T"
Begin DoDot:2
+40 SET FBIEN=$PIECE(FBCIENS,",",1)
+41 SET FBIEN(1)=$PIECE(FBCIENS,",",2)
End DoDot:2
End DoDot:1
+42 QUIT
+43 ;
IPACCHK(FBPROG,FBIEN) ; check if payment is an IPAC payment (FB*3.5*123)
+1 ; Function value is 1 if the payment is an IPAC payment, 0 otherwise
+2 ; This is determined by the existence of a pointer value to file 161.95.
+3 ;
+4 NEW RES,FBFILE,FBSIENS,FBFIELD
+5 SET RES=0
+6 IF '$FIND(".3.5.9.","."_+$GET(FBPROG)_".")
GOTO IPACKX
+7 ;
+8 ; get variables by type
+9 ; outpat/ancil
IF FBPROG=3
SET FBFILE=162.03
SET FBSIENS=FBIEN_","_FBIEN(1)_","_FBIEN(2)_","_FBIEN(3)_","
SET FBFIELD=.05
+10 ; pharmacy (top level)
IF FBPROG=5
SET FBFILE=162.1
SET FBSIENS=FBIEN(1)_","
SET FBFIELD=14
+11 ; inpatient
IF FBPROG=9
SET FBFILE=162.5
SET FBSIENS=FBIEN_","
SET FBFIELD=87
+12 ;
+13 ; IPAC payment found
IF +$$GET1^DIQ(FBFILE,FBSIENS,FBFIELD,"I")
SET RES=1
IPACKX ;
+1 QUIT RES
+2 ;
