PRCAFBD ;WASH-ISC@ALTOONA,PA/CLH-Build FMS Billing Document ;8/2/95 3:14 PM
V ;;4.5;Accounts Receivable;**16,48,86,90,119,165,204,203,173,220,184,270,275**;Mar 20, 1995;Build 72
;;Per VHA Directive 2004-038, this routine should not be modified.
EN(BILL,ERR) ;Process NEW BILL to FMS
N PRCMD
S ERR=-1,PRCMD=""
Q:$D(RCONVERT)
I '$D(^PRCA(430,BILL,11)) S ERR="1^ACCOUNTING INFORMATION MISSING. CANNOT PROCESS BILL" Q
;
; funds 5014 (old), 2431 (old), 528701,03,04,09 and 4032 should not create a BD
S %=$P($G(^PRCA(430,BILL,11)),"^",17)
I %=5014!(%=2431)!(%=4032) Q
I %[5287 Q:$$PTACCT^PRCAACC(%)
;
I '$D(PRCA("SITE")) S PRCA("SITE")=$S($G(BILL):$P($P($G(^PRCA(430,BILL,0)),"^"),"-"),1:$$SITE^RCMSITE)
K ^TMP("PRCABD",$J)
I $G(BILL)="" S ERR="1^Missing Bill Number"
I $D(^PRCA(430,BILL,0)),$P(^(0),U,9)="" S ERR="1^No debtor for bill" Q
N GECSFMS,REC,REC11,VENCODE,BFY,EFY,LINEFUND,%,%I,%H,X,VEN,CAT,CP,ADDR,AC,RJ,FMSNUM,FMSNUM1,VENDORID,ADD,DA,Y
D NOW^%DTC
I '$G(PRCA("AUTO_AUDIT")) W !,"Building FMS Billing Document. Please hold...",!
S REC=$G(^PRCA(430,BILL,0)),REC11=$G(^PRCA(430,BILL,11)),FMSNUM=$P($P(REC,U),"-")_$P($P(REC,U),"-",2)
;gather vendor information
S VENCODE=$$VENDORID^RCXFMSUV(BILL)
I VENCODE="UNKNOWN" S ERR="1^Need FMS Vendor ID for BD Document" Q
I VENCODE="LINK" S ERR="1^Debtor must be linked to vendor file" Q
S ADD=$$SADD^RCFN01(5)
I (VENCODE="PERSONOTH")!(VENCODE="XEMPL")!(VENCODE="CUREMPL")!($E(VENCODE,1,4)="CHMP")!($E(VENCODE,1,3)="TRI")!(VENCODE="INELIG") D
. N I F I=1:1:6 S ADDR(I)=$P(ADD,U,I)
. I ADDR(6)["-" S ADDR(7)=$P(ADDR(6),"-",2),ADDR(6)=$P(ADDR(6),"-")
. Q
; PRCA*4.5*270 Doc# not unique for corrected claims, remove from file 347 before creating new one to send
; PRCA*4.5*275 Don't delete, causes matching issues for FMS between original and new E records.
; Assign batch header id instead for unique ID (pass PRCMD=1 for modify flag).
;I '$G(REFMS),$$GSTAT^RCFMFN02("BD-"_FMSNUM_" ")>-1 D DEL^RCFMFN02("BD-"_FMSNUM_" ") S PRCMD=1
N FMSDT S FMSDT=$$FMSDATE^RCBEUTRA(DT)
; PRCA*4.5*275 If this is a corrected claim wait 24 hours before sending new E record
; to avoid possible collision at FMS if original E record was rejected.
I '$G(REFMS),$$GSTAT^RCFMFN02("BD-"_FMSNUM_" ")>-1 S FMSDT=$$FMADD^XLFDT(FMSDT,1),PRCMD=1
S ^TMP("PRCABD",$J,1)="BD2^"_$E(FMSDT,4,5)_U_$E(FMSDT,6,7)_U_$E(FMSDT,2,3)_"^^^^^^E^"_$E(VENCODE,1,9)_U_$E(VENCODE,10,11)_U_$J($P(REC,U,3),0,2)_"^^^^"_$E($G(ADDR(1)),1,30)_U_$E($G(ADDR(2)),1,30)_U_$E($G(ADDR(3)),1,30)
S ^TMP("PRCABD",$J,1)=^TMP("PRCABD",$J,1)_U_$E($G(ADDR(4)),1,19)_U_$G(ADDR(5))_U_$G(ADDR(6))_U_$G(ADDR(7))_"^N^^^^^^W^~"
S ^TMP("PRCABD",$J,2)="LIN^~"
;accouting information - stored on 11th node file 430
S ^TMP("PRCABD",$J,3)="BDA^"_$$LINE^RCXFMSC1(BILL)_"^"_$P(REC11,U,15)_U_$P(REC11,U,16)_U_$P(REC11,U,17)_U_$P(REC11,U,8)_U_$P(REC11,U,11)_U_$P(REC11,U,20)_U_$P(REC11,U,6)_U_$P(REC11,U,7)_U_$P(REC11,U,21)_U_$P(REC11,U,5)
S ^TMP("PRCABD",$J,3)=^TMP("PRCABD",$J,3)_U_$P(REC11,U,12)_U_$P(REC11,U,14)_"^^"_$J($P(REC,U,3),0,2)_"^I^AR_INTERFACE^^^^"
S ^TMP("PRCABD",$J,3)=^TMP("PRCABD",$J,3)_$P(REC11,U,10)_"^^^^^^^^"_$P(REC11,U,2)_U_$P(REC11,U,3)_"^~"
I $E($P(REC11,U,17),1,4)=5287 S $P(^TMP("PRCABD",$J,3),U,3)="05"
;build control segment prca*4.5*275 If corrected claim, send modified flag (PRCMD=1) so that batch # is appended to record
;D CONTROL^GECSUFMS("A",PRCA("SITE"),FMSNUM,"BD",10,"","","Billing Document")
D CONTROL^GECSUFMS("A",PRCA("SITE"),FMSNUM,"BD",10,$G(PRCMD),"","Billing Document")
S FMSNUM1=$P($G(GECSFMS("DOC")),U,3)_"-"_$P($G(GECSFMS("DOC")),U,4)
; if corrected record, add batch# PRCA*4.5*275
S:$G(PRCMD)=1 FMSNUM1=$P($G(GECSFMS("DOC")),U,3)_"-"_$P($G(GECSFMS("DOC")),U,4)_"-"_$P($G(GECSFMS("BAT")),U,3)
;build and send document to FTH
S DA=0 F S DA=$O(^TMP("PRCABD",$J,DA)) Q:'DA D SETCS^GECSSTAA(GECSFMS("DA"),^(DA))
D OPEN^RCFMDRV1(FMSNUM1,6,"B"_BILL,.ENT,.ERR,BILL) I ERR]"" D
. S ERR=-1
. N Z S Z="Unable to create an entry in AR Document file."
. I '$G(PRCA("AUTO_AUDIT")) W !!,Z,! Q
. D SETERR^PRCAUDT("BILL: "_$$BILL^PRCAUDT(BILL)),SETERR^PRCAUDT(Z)
D SETCODE^GECSSDCT(GECSFMS("DA"),"D RETN^RCFMFN02")
D SETSTAT^GECSSTAA(GECSFMS("DA"),"Q")
D SSTAT^RCFMFN02(FMSNUM1,1)
I '$G(PRCA("AUTO_AUDIT")) D
. S Y=FMSDT D DD^%DT
. W !!,"FMS document, # ",GECSFMS("DA"),", built and queued for transmission on "_Y,!!
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCAFBD 4459 printed Oct 16, 2024@17:40:18 Page 2
PRCAFBD ;WASH-ISC@ALTOONA,PA/CLH-Build FMS Billing Document ;8/2/95 3:14 PM
V ;;4.5;Accounts Receivable;**16,48,86,90,119,165,204,203,173,220,184,270,275**;Mar 20, 1995;Build 72
+1 ;;Per VHA Directive 2004-038, this routine should not be modified.
EN(BILL,ERR) ;Process NEW BILL to FMS
+1 NEW PRCMD
+2 SET ERR=-1
SET PRCMD=""
+3 if $DATA(RCONVERT)
QUIT
+4 IF '$DATA(^PRCA(430,BILL,11))
SET ERR="1^ACCOUNTING INFORMATION MISSING. CANNOT PROCESS BILL"
QUIT
+5 ;
+6 ; funds 5014 (old), 2431 (old), 528701,03,04,09 and 4032 should not create a BD
+7 SET %=$PIECE($GET(^PRCA(430,BILL,11)),"^",17)
+8 IF %=5014!(%=2431)!(%=4032)
QUIT
+9 IF %[5287
if $$PTACCT^PRCAACC(%)
QUIT
+10 ;
+11 IF '$DATA(PRCA("SITE"))
SET PRCA("SITE")=$SELECT($GET(BILL):$PIECE($PIECE($GET(^PRCA(430,BILL,0)),"^"),"-"),1:$$SITE^RCMSITE)
+12 KILL ^TMP("PRCABD",$JOB)
+13 IF $GET(BILL)=""
SET ERR="1^Missing Bill Number"
+14 IF $DATA(^PRCA(430,BILL,0))
IF $PIECE(^(0),U,9)=""
SET ERR="1^No debtor for bill"
QUIT
+15 NEW GECSFMS,REC,REC11,VENCODE,BFY,EFY,LINEFUND,%,%I,%H,X,VEN,CAT,CP,ADDR,AC,RJ,FMSNUM,FMSNUM1,VENDORID,ADD,DA,Y
+16 DO NOW^%DTC
+17 IF '$GET(PRCA("AUTO_AUDIT"))
WRITE !,"Building FMS Billing Document. Please hold...",!
+18 SET REC=$GET(^PRCA(430,BILL,0))
SET REC11=$GET(^PRCA(430,BILL,11))
SET FMSNUM=$PIECE($PIECE(REC,U),"-")_$PIECE($PIECE(REC,U),"-",2)
+19 ;gather vendor information
+20 SET VENCODE=$$VENDORID^RCXFMSUV(BILL)
+21 IF VENCODE="UNKNOWN"
SET ERR="1^Need FMS Vendor ID for BD Document"
QUIT
+22 IF VENCODE="LINK"
SET ERR="1^Debtor must be linked to vendor file"
QUIT
+23 SET ADD=$$SADD^RCFN01(5)
+24 IF (VENCODE="PERSONOTH")!(VENCODE="XEMPL")!(VENCODE="CUREMPL")!($EXTRACT(VENCODE,1,4)="CHMP")!($EXTRACT(VENCODE,1,3)="TRI")!(VENCODE="INELIG")
Begin DoDot:1
+25 NEW I
FOR I=1:1:6
SET ADDR(I)=$PIECE(ADD,U,I)
+26 IF ADDR(6)["-"
SET ADDR(7)=$PIECE(ADDR(6),"-",2)
SET ADDR(6)=$PIECE(ADDR(6),"-")
+27 QUIT
End DoDot:1
+28 ; PRCA*4.5*270 Doc# not unique for corrected claims, remove from file 347 before creating new one to send
+29 ; PRCA*4.5*275 Don't delete, causes matching issues for FMS between original and new E records.
+30 ; Assign batch header id instead for unique ID (pass PRCMD=1 for modify flag).
+31 ;I '$G(REFMS),$$GSTAT^RCFMFN02("BD-"_FMSNUM_" ")>-1 D DEL^RCFMFN02("BD-"_FMSNUM_" ") S PRCMD=1
+32 NEW FMSDT
SET FMSDT=$$FMSDATE^RCBEUTRA(DT)
+33 ; PRCA*4.5*275 If this is a corrected claim wait 24 hours before sending new E record
+34 ; to avoid possible collision at FMS if original E record was rejected.
+35 IF '$GET(REFMS)
IF $$GSTAT^RCFMFN02("BD-"_FMSNUM_" ")>-1
SET FMSDT=$$FMADD^XLFDT(FMSDT,1)
SET PRCMD=1
+36 SET ^TMP("PRCABD",$JOB,1)="BD2^"_$EXTRACT(FMSDT,4,5)_U_$EXTRACT(FMSDT,6,7)_U_$EXTRACT(FMSDT,2,3)_"^^^^^^E^"_$EXTRACT(VENCODE,1,9)_U_$EXTRACT(VENCODE,10,11)_U_...
... $JUSTIFY($PIECE(REC,U,3),0,2)_"^^^^"_$EXTRACT($GET(ADDR(1)),1,30)_U_$EXTRACT($GET(ADDR(2)),1,30)_U_$EXTRACT($GET(ADDR(3)),1,30)
+37 SET ^TMP("PRCABD",$JOB,1)=^TMP("PRCABD",$JOB,1)_U_$EXTRACT($GET(ADDR(4)),1,19)_U_$GET(ADDR(5))_U_$GET(ADDR(6))_U_$GET(ADDR(7))_"^N^^^^^^W^~"
+38 SET ^TMP("PRCABD",$JOB,2)="LIN^~"
+39 ;accouting information - stored on 11th node file 430
+40 SET ^TMP("PRCABD",$JOB,3)="BDA^"_$$LINE^RCXFMSC1(BILL)_"^"_$PIECE(REC11,U,15)_U_$PIECE(REC11,U,16)_U_$PIECE(REC11,U,17)_U_$PIECE(REC11,U,8)_U_$PIECE(REC11,U,11)_U_$PIECE(REC11,U,20)_U_$PIECE(REC11,U,6)_U_...
... $PIECE(REC11,U,7)_U_$PIECE(REC11,U,21)_U_$PIECE(REC11,U,5)
+41 SET ^TMP("PRCABD",$JOB,3)=^TMP("PRCABD",$JOB,3)_U_$PIECE(REC11,U,12)_U_$PIECE(REC11,U,14)_"^^"_$JUSTIFY($PIECE(REC,U,3),0,2)_"^I^AR_INTERFACE^^^^"
+42 SET ^TMP("PRCABD",$JOB,3)=^TMP("PRCABD",$JOB,3)_$PIECE(REC11,U,10)_"^^^^^^^^"_$PIECE(REC11,U,2)_U_$PIECE(REC11,U,3)_"^~"
+43 IF $EXTRACT($PIECE(REC11,U,17),1,4)=5287
SET $PIECE(^TMP("PRCABD",$JOB,3),U,3)="05"
+44 ;build control segment prca*4.5*275 If corrected claim, send modified flag (PRCMD=1) so that batch # is appended to record
+45 ;D CONTROL^GECSUFMS("A",PRCA("SITE"),FMSNUM,"BD",10,"","","Billing Document")
+46 DO CONTROL^GECSUFMS("A",PRCA("SITE"),FMSNUM,"BD",10,$GET(PRCMD),"","Billing Document")
+47 SET FMSNUM1=$PIECE($GET(GECSFMS("DOC")),U,3)_"-"_$PIECE($GET(GECSFMS("DOC")),U,4)
+48 ; if corrected record, add batch# PRCA*4.5*275
+49 if $GET(PRCMD)=1
SET FMSNUM1=$PIECE($GET(GECSFMS("DOC")),U,3)_"-"_$PIECE($GET(GECSFMS("DOC")),U,4)_"-"_$PIECE($GET(GECSFMS("BAT")),U,3)
+50 ;build and send document to FTH
+51 SET DA=0
FOR
SET DA=$ORDER(^TMP("PRCABD",$JOB,DA))
if 'DA
QUIT
DO SETCS^GECSSTAA(GECSFMS("DA"),^(DA))
+52 DO OPEN^RCFMDRV1(FMSNUM1,6,"B"_BILL,.ENT,.ERR,BILL)
IF ERR]""
Begin DoDot:1
+53 SET ERR=-1
+54 NEW Z
SET Z="Unable to create an entry in AR Document file."
+55 IF '$GET(PRCA("AUTO_AUDIT"))
WRITE !!,Z,!
QUIT
+56 DO SETERR^PRCAUDT("BILL: "_$$BILL^PRCAUDT(BILL))
DO SETERR^PRCAUDT(Z)
End DoDot:1
+57 DO SETCODE^GECSSDCT(GECSFMS("DA"),"D RETN^RCFMFN02")
+58 DO SETSTAT^GECSSTAA(GECSFMS("DA"),"Q")
+59 DO SSTAT^RCFMFN02(FMSNUM1,1)
+60 IF '$GET(PRCA("AUTO_AUDIT"))
Begin DoDot:1
+61 SET Y=FMSDT
DO DD^%DT
+62 WRITE !!,"FMS document, # ",GECSFMS("DA"),", built and queued for transmission on "_Y,!!
End DoDot:1
+63 QUIT
+64 ;
