FBAAVR5 ;WOIFO/SAB - GENERATE VOUCHER BATCH MSG ;9/12/2012
;;3.5;FEE BASIS;**132,158**;JAN 30, 1995;Build 94
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; ICRs
; #2053 FILE^DIE
; #2054 CLEAN^DILF
; #2056 $$GET1^DIQ
; #2729 SENDMSG^XMXAPI
; #10104 $$LG^XLFSTR, $$RJ^XLFSTR
Q
;
VBMSG(FBN) ; Generate Voucher Batch Message
; input
; FBN - Batch IEN (file 161.7)
; returns value
; =message number if successful
; =0^error message if unsuccessful
;
N FBAUS,FBCNT,FBHD,FBLN,FBNUM,FBRET,FBSTUB,FBTYPE
K ^TMP($J,"FBVBM")
;
; check for required input
I '$G(FBN) S FBRET="0^Batch IEN not provided." G END
;
; retrieve batch data
S FBNUM=$$GET1^DIQ(161.7,FBN_",",.01) ; NUMBER
I $D(DIERR) S FBRET="0^Error getting batch data." G END
S FBTYPE=$$GET1^DIQ(161.7,FBN_",",2,"I") ; TYPE
I "^B2^B3^B5^B9^"'[("^"_FBTYPE_"^") S FBRET="0^Invalid batch type" G END
;
; determine subsystem identifier
D HD^FBAAUTL
I $G(FBHD)="" S FBRET="0^Error obtaining Subsystem Identifier." G END
;
; determine string values to transmit
S FBAUS("SN")=$$LJ^XLFSTR($$STANUM(FBN),6) ; station number
S FBAUS("DT")=$$AUSDT^FBAAV3(DT) ; date
S FBAUS("PT")=$S(FBTYPE="B2":"T",1:$E(FBTYPE,2)) ; payment type
;
S FBCNT=0 ; init reject line count
;
; determine stub string for voucher batch reject line
S FBSTUB=FBAUS("SN")_FBAUS("DT")_"V"_FBAUS("PT")
;
; loop thru line items rejected from batch
I FBTYPE="B2" D
. N FBIEN,FBIENS
. S FBIEN(1)=0
. F S FBIEN(1)=$O(^FBAAC("AG",FBN,FBIEN(1))) Q:'FBIEN(1) D
. . S FBIEN=0
. . F S FBIEN=$O(^FBAAC("AG",FBN,FBIEN(1),FBIEN)) Q:'FBIEN D
. . . S FBIENS=FBIEN_","_FBIEN(1)_","
. . . Q:$$GET1^DIQ(162.04,FBIENS,6.3,"I")=1 ; skip interface rej.
. . . S FBPICN=FBIEN(1)_"^"_FBIEN
. . . S FBPICN=$$ORGICN(162.04,FBPICN) ; send original ICN
. . . D ADDLN
;
I FBTYPE="B3" D
. N FBIEN,FBIENS,FBPICN
. S FBIEN(3)=0
. F S FBIEN(3)=$O(^FBAAC("AH",FBN,FBIEN(3))) Q:'FBIEN(3) D
. . S FBIEN(2)=0
. . F S FBIEN(2)=$O(^FBAAC("AH",FBN,FBIEN(3),FBIEN(2))) Q:'FBIEN(2) D
. . . S FBIEN(1)=0
. . . F S FBIEN(1)=$O(^FBAAC("AH",FBN,FBIEN(3),FBIEN(2),FBIEN(1))) Q:'FBIEN(1) D
. . . . S FBIEN=0
. . . . F S FBIEN=$O(^FBAAC("AH",FBN,FBIEN(3),FBIEN(2),FBIEN(1),FBIEN)) Q:'FBIEN D
. . . . . S FBIENS=FBIEN_","_FBIEN(1)_","_FBIEN(2)_","_FBIEN(3)_","
. . . . . Q:$$GET1^DIQ(162.03,FBIENS,21.3,"I")=1 ; skip interface rej.
. . . . . S FBPICN=FBIEN(3)_"^"_FBIEN(2)_"^"_FBIEN(1)_"^"_FBIEN
. . . . . S FBPICN=$$ORGICN(162.03,FBPICN) ; send orignal ICN
. . . . . D ADDLN
;
I FBTYPE="B5" D
. N FBIEN,FBIENS,FBPICN
. S FBIEN(1)=0
. F S FBIEN(1)=$O(^FBAA(162.1,"AF",FBN,FBIEN(1))) Q:'FBIEN(1) D
. . S FBIEN=0
. . F S FBIEN=$O(^FBAA(162.1,"AF",FBN,FBIEN(1),FBIEN)) Q:'FBIEN D
. . . S FBIENS=FBIEN_","_FBIEN(1)_","
. . . Q:$$GET1^DIQ(162.11,FBIENS,19.3,"I")=1 ; skip interface rej.
. . . S FBPICN=FBIEN(1)_"^"_FBIEN
. . . D ADDLN
;
I FBTYPE="B9" D
. N FBIEN,FBIENS,FBPICN
. S FBIEN=0
. F S FBIEN=$O(^FBAAI("AH",FBN,FBIEN)) Q:'FBIEN D
. . S FBIENS=FBIEN_","
. . Q:$$GET1^DIQ(162.5,FBIENS,15.3,"I")=1 ; skip interface rej.
. . S FBPICN=FBIEN
. . D ADDLN
;
; build message header line - FB*3.5*158
S ^TMP($J,"FBVBM",1)=FBHD_"V"_FBAUS("PT")_FBAUS("DT")_FBAUS("SN")_$$RJ^XLFSTR(FBNUM,7,"0")_$$RJ^XLFSTR(FBCNT,3,"0")_"$"
;
; address and send message
D
. N FBINSTR,XMDUZ,XMERR,XMSUBJ,XMY,XMZ
. S XMSUBJ="FEE BASIS VOUCHER MESSAGE BATCH "_FBNUM
. S FBINSTR("ADDR FLAGS")="R"
. D RECIP
. D SENDMSG^XMXAPI(XMDUZ,XMSUBJ,"^TMP("_$J_",""FBVBM"")",.XMY,.FBINSTR,.XMZ)
. I $G(XMERR) S FBRET="0^Error generating mail message"
. I '$G(XMERR) S FBRET=XMZ
;
; if message created update batch
I FBRET D
. N DIERR,FBFDA,FBX
. S FBFDA(161.7,FBN_",",21)=DT ; VOUCHER MSG DATE
. S FBFDA(161.7,FBN_",",22)="P" ; VOUCHER MSG ACK STATUS
. D FILE^DIE("","FBFDA")
. D CLEAN^DILF
;
END ;
K ^TMP($J,"FBVBM")
Q FBRET
;
ADDLN ; add detail line
S FBCNT=FBCNT+1
S ^TMP($J,"FBVBM",FBCNT+1)=FBSTUB_$$RJ^XLFSTR(FBPICN,30,"0")_"$"
Q
;
STANUM(FBN) ; determine station number to transmit
;
N FBRET,FBX,FBY0
S FBRET=""
;
; determine station number based on obligation of batch
I $G(FBN) D
. S FBY0=$G(^FBAA(161.7,FBN,0))
. S FBX=$$SUB^FBAAUTL5(+$P(FBY0,U,8)_"-"_$P(FBY0,U,2))
. I FBX]"" S FBRET=FBX
;
; if station number not found use default station number
I FBRET="" D
. S FBX=$P($G(^FBAA(161.4,1,1)),"^",3)
. S:FBX FBRET=$$STA^XUAF4(FBX)
;
Q FBRET
;
RECIP ; determine message recipients
; input
; DUZ
; output
; XMDUZ
; XMY(
N FBXMFEE,FBXMNVP
S XMDUZ=DUZ
;
; get recipients from TRANSMISISON ROUTERS files
D
. N FBI,FBVAR,VAT,VATERR,VATNAME
. D ADDRESS^FBAAV01
;
; set XMY array and XMDUZ
D
. N FBFLAG,FBI,XMD,XMLOC,XMMG,XMN,X,Y
. D ROUT^FBAAV01
Q
;
ORGICN(FBFILE,FBICN) ; return original ICN value for a line item
; input
; FBFILE - sub-file (162.03 or 162.04)
; FBICN - ICN value
; return value = the original ICN value
;
N FBRET
S FBRET=$G(FBICN)
;
I "^162.03^162.04^"[("^"_$G(FBFILE)_"^"),$G(FBICN)'="" D
. N FBCIENS,FBOIENS,FBSIENS
. ; determine starting IEN string
. I FBFILE=162.03 S FBSIENS=$P(FBICN,"^",4)_","_$P(FBICN,"^",3)_","_$P(FBICN,"^",2)_","_$P(FBICN,"^",1)_","
. I FBFILE=162.04 S FBSIENS=$P(FBICN,"^",2)_","_$P(FBICN,"^",1)_","
. ;
. 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:FBOIENS=""
. . N FBDA
. . S FBOIENS="" ; init old IENs value for a move
. . S FBDA=$O(^FBAA(161.45,"AN",FBFILE,FBCIENS,0))
. . Q:'FBDA ; no more moves
. . S FBOIENS=$P($G(^FBAA(161.45,FBDA,0)),U,2) ; old IENs
. . ; if old IEN is same as starting IEN, break out of the endless loop
. . I FBOIENS=FBSIENS S FBOIENS="" Q
. . ; set current IENs to the new value
. . S:FBOIENS'="" FBCIENS=FBOIENS
. ;
. ; if current IENs is different from starting IENs update outputs
. I FBCIENS'=FBSIENS D
. . I FBFILE=162.03 S FBRET=$P(FBCIENS,",",4)_"^"_$P(FBCIENS,",",3)_"^"_$P(FBCIENS,",",2)_"^"_$P(FBCIENS,",",1)
. . I FBFILE=162.04 S FBRET=$P(FBCIENS,",",2)_"^"_$P(FBCIENS,",",1)
;
Q FBRET
;
;FBAAVR5
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAAVR5 6366 printed Sep 23, 2025@19:33:20 Page 2
FBAAVR5 ;WOIFO/SAB - GENERATE VOUCHER BATCH MSG ;9/12/2012
+1 ;;3.5;FEE BASIS;**132,158**;JAN 30, 1995;Build 94
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; ICRs
+5 ; #2053 FILE^DIE
+6 ; #2054 CLEAN^DILF
+7 ; #2056 $$GET1^DIQ
+8 ; #2729 SENDMSG^XMXAPI
+9 ; #10104 $$LG^XLFSTR, $$RJ^XLFSTR
+10 QUIT
+11 ;
VBMSG(FBN) ; Generate Voucher Batch Message
+1 ; input
+2 ; FBN - Batch IEN (file 161.7)
+3 ; returns value
+4 ; =message number if successful
+5 ; =0^error message if unsuccessful
+6 ;
+7 NEW FBAUS,FBCNT,FBHD,FBLN,FBNUM,FBRET,FBSTUB,FBTYPE
+8 KILL ^TMP($JOB,"FBVBM")
+9 ;
+10 ; check for required input
+11 IF '$GET(FBN)
SET FBRET="0^Batch IEN not provided."
GOTO END
+12 ;
+13 ; retrieve batch data
+14 ; NUMBER
SET FBNUM=$$GET1^DIQ(161.7,FBN_",",.01)
+15 IF $DATA(DIERR)
SET FBRET="0^Error getting batch data."
GOTO END
+16 ; TYPE
SET FBTYPE=$$GET1^DIQ(161.7,FBN_",",2,"I")
+17 IF "^B2^B3^B5^B9^"'[("^"_FBTYPE_"^")
SET FBRET="0^Invalid batch type"
GOTO END
+18 ;
+19 ; determine subsystem identifier
+20 DO HD^FBAAUTL
+21 IF $GET(FBHD)=""
SET FBRET="0^Error obtaining Subsystem Identifier."
GOTO END
+22 ;
+23 ; determine string values to transmit
+24 ; station number
SET FBAUS("SN")=$$LJ^XLFSTR($$STANUM(FBN),6)
+25 ; date
SET FBAUS("DT")=$$AUSDT^FBAAV3(DT)
+26 ; payment type
SET FBAUS("PT")=$SELECT(FBTYPE="B2":"T",1:$EXTRACT(FBTYPE,2))
+27 ;
+28 ; init reject line count
SET FBCNT=0
+29 ;
+30 ; determine stub string for voucher batch reject line
+31 SET FBSTUB=FBAUS("SN")_FBAUS("DT")_"V"_FBAUS("PT")
+32 ;
+33 ; loop thru line items rejected from batch
+34 IF FBTYPE="B2"
Begin DoDot:1
+35 NEW FBIEN,FBIENS
+36 SET FBIEN(1)=0
+37 FOR
SET FBIEN(1)=$ORDER(^FBAAC("AG",FBN,FBIEN(1)))
if 'FBIEN(1)
QUIT
Begin DoDot:2
+38 SET FBIEN=0
+39 FOR
SET FBIEN=$ORDER(^FBAAC("AG",FBN,FBIEN(1),FBIEN))
if 'FBIEN
QUIT
Begin DoDot:3
+40 SET FBIENS=FBIEN_","_FBIEN(1)_","
+41 ; skip interface rej.
if $$GET1^DIQ(162.04,FBIENS,6.3,"I")=1
QUIT
+42 SET FBPICN=FBIEN(1)_"^"_FBIEN
+43 ; send original ICN
SET FBPICN=$$ORGICN(162.04,FBPICN)
+44 DO ADDLN
End DoDot:3
End DoDot:2
End DoDot:1
+45 ;
+46 IF FBTYPE="B3"
Begin DoDot:1
+47 NEW FBIEN,FBIENS,FBPICN
+48 SET FBIEN(3)=0
+49 FOR
SET FBIEN(3)=$ORDER(^FBAAC("AH",FBN,FBIEN(3)))
if 'FBIEN(3)
QUIT
Begin DoDot:2
+50 SET FBIEN(2)=0
+51 FOR
SET FBIEN(2)=$ORDER(^FBAAC("AH",FBN,FBIEN(3),FBIEN(2)))
if 'FBIEN(2)
QUIT
Begin DoDot:3
+52 SET FBIEN(1)=0
+53 FOR
SET FBIEN(1)=$ORDER(^FBAAC("AH",FBN,FBIEN(3),FBIEN(2),FBIEN(1)))
if 'FBIEN(1)
QUIT
Begin DoDot:4
+54 SET FBIEN=0
+55 FOR
SET FBIEN=$ORDER(^FBAAC("AH",FBN,FBIEN(3),FBIEN(2),FBIEN(1),FBIEN))
if 'FBIEN
QUIT
Begin DoDot:5
+56 SET FBIENS=FBIEN_","_FBIEN(1)_","_FBIEN(2)_","_FBIEN(3)_","
+57 ; skip interface rej.
if $$GET1^DIQ(162.03,FBIENS,21.3,"I")=1
QUIT
+58 SET FBPICN=FBIEN(3)_"^"_FBIEN(2)_"^"_FBIEN(1)_"^"_FBIEN
+59 ; send orignal ICN
SET FBPICN=$$ORGICN(162.03,FBPICN)
+60 DO ADDLN
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+61 ;
+62 IF FBTYPE="B5"
Begin DoDot:1
+63 NEW FBIEN,FBIENS,FBPICN
+64 SET FBIEN(1)=0
+65 FOR
SET FBIEN(1)=$ORDER(^FBAA(162.1,"AF",FBN,FBIEN(1)))
if 'FBIEN(1)
QUIT
Begin DoDot:2
+66 SET FBIEN=0
+67 FOR
SET FBIEN=$ORDER(^FBAA(162.1,"AF",FBN,FBIEN(1),FBIEN))
if 'FBIEN
QUIT
Begin DoDot:3
+68 SET FBIENS=FBIEN_","_FBIEN(1)_","
+69 ; skip interface rej.
if $$GET1^DIQ(162.11,FBIENS,19.3,"I")=1
QUIT
+70 SET FBPICN=FBIEN(1)_"^"_FBIEN
+71 DO ADDLN
End DoDot:3
End DoDot:2
End DoDot:1
+72 ;
+73 IF FBTYPE="B9"
Begin DoDot:1
+74 NEW FBIEN,FBIENS,FBPICN
+75 SET FBIEN=0
+76 FOR
SET FBIEN=$ORDER(^FBAAI("AH",FBN,FBIEN))
if 'FBIEN
QUIT
Begin DoDot:2
+77 SET FBIENS=FBIEN_","
+78 ; skip interface rej.
if $$GET1^DIQ(162.5,FBIENS,15.3,"I")=1
QUIT
+79 SET FBPICN=FBIEN
+80 DO ADDLN
End DoDot:2
End DoDot:1
+81 ;
+82 ; build message header line - FB*3.5*158
+83 SET ^TMP($JOB,"FBVBM",1)=FBHD_"V"_FBAUS("PT")_FBAUS("DT")_FBAUS("SN")_$$RJ^XLFSTR(FBNUM,7,"0")_$$RJ^XLFSTR(FBCNT,3,"0")_"$"
+84 ;
+85 ; address and send message
+86 Begin DoDot:1
+87 NEW FBINSTR,XMDUZ,XMERR,XMSUBJ,XMY,XMZ
+88 SET XMSUBJ="FEE BASIS VOUCHER MESSAGE BATCH "_FBNUM
+89 SET FBINSTR("ADDR FLAGS")="R"
+90 DO RECIP
+91 DO SENDMSG^XMXAPI(XMDUZ,XMSUBJ,"^TMP("_$JOB_",""FBVBM"")",.XMY,.FBINSTR,.XMZ)
+92 IF $GET(XMERR)
SET FBRET="0^Error generating mail message"
+93 IF '$GET(XMERR)
SET FBRET=XMZ
End DoDot:1
+94 ;
+95 ; if message created update batch
+96 IF FBRET
Begin DoDot:1
+97 NEW DIERR,FBFDA,FBX
+98 ; VOUCHER MSG DATE
SET FBFDA(161.7,FBN_",",21)=DT
+99 ; VOUCHER MSG ACK STATUS
SET FBFDA(161.7,FBN_",",22)="P"
+100 DO FILE^DIE("","FBFDA")
+101 DO CLEAN^DILF
End DoDot:1
+102 ;
END ;
+1 KILL ^TMP($JOB,"FBVBM")
+2 QUIT FBRET
+3 ;
ADDLN ; add detail line
+1 SET FBCNT=FBCNT+1
+2 SET ^TMP($JOB,"FBVBM",FBCNT+1)=FBSTUB_$$RJ^XLFSTR(FBPICN,30,"0")_"$"
+3 QUIT
+4 ;
STANUM(FBN) ; determine station number to transmit
+1 ;
+2 NEW FBRET,FBX,FBY0
+3 SET FBRET=""
+4 ;
+5 ; determine station number based on obligation of batch
+6 IF $GET(FBN)
Begin DoDot:1
+7 SET FBY0=$GET(^FBAA(161.7,FBN,0))
+8 SET FBX=$$SUB^FBAAUTL5(+$PIECE(FBY0,U,8)_"-"_$PIECE(FBY0,U,2))
+9 IF FBX]""
SET FBRET=FBX
End DoDot:1
+10 ;
+11 ; if station number not found use default station number
+12 IF FBRET=""
Begin DoDot:1
+13 SET FBX=$PIECE($GET(^FBAA(161.4,1,1)),"^",3)
+14 if FBX
SET FBRET=$$STA^XUAF4(FBX)
End DoDot:1
+15 ;
+16 QUIT FBRET
+17 ;
RECIP ; determine message recipients
+1 ; input
+2 ; DUZ
+3 ; output
+4 ; XMDUZ
+5 ; XMY(
+6 NEW FBXMFEE,FBXMNVP
+7 SET XMDUZ=DUZ
+8 ;
+9 ; get recipients from TRANSMISISON ROUTERS files
+10 Begin DoDot:1
+11 NEW FBI,FBVAR,VAT,VATERR,VATNAME
+12 DO ADDRESS^FBAAV01
End DoDot:1
+13 ;
+14 ; set XMY array and XMDUZ
+15 Begin DoDot:1
+16 NEW FBFLAG,FBI,XMD,XMLOC,XMMG,XMN,X,Y
+17 DO ROUT^FBAAV01
End DoDot:1
+18 QUIT
+19 ;
ORGICN(FBFILE,FBICN) ; return original ICN value for a line item
+1 ; input
+2 ; FBFILE - sub-file (162.03 or 162.04)
+3 ; FBICN - ICN value
+4 ; return value = the original ICN value
+5 ;
+6 NEW FBRET
+7 SET FBRET=$GET(FBICN)
+8 ;
+9 IF "^162.03^162.04^"[("^"_$GET(FBFILE)_"^")
IF $GET(FBICN)'=""
Begin DoDot:1
+10 NEW FBCIENS,FBOIENS,FBSIENS
+11 ; determine starting IEN string
+12 IF FBFILE=162.03
SET FBSIENS=$PIECE(FBICN,"^",4)_","_$PIECE(FBICN,"^",3)_","_$PIECE(FBICN,"^",2)_","_$PIECE(FBICN,"^",1)_","
+13 IF FBFILE=162.04
SET FBSIENS=$PIECE(FBICN,"^",2)_","_$PIECE(FBICN,"^",1)_","
+14 ;
+15 ; init current IEN string as starting IEN string
SET FBCIENS=FBSIENS
+16 ;
+17 ;loop thru moves for current IENs until no more moves are found
+18 FOR
Begin DoDot:2
+19 NEW FBDA
+20 ; init old IENs value for a move
SET FBOIENS=""
+21 SET FBDA=$ORDER(^FBAA(161.45,"AN",FBFILE,FBCIENS,0))
+22 ; no more moves
if 'FBDA
QUIT
+23 ; old IENs
SET FBOIENS=$PIECE($GET(^FBAA(161.45,FBDA,0)),U,2)
+24 ; if old IEN is same as starting IEN, break out of the endless loop
+25 IF FBOIENS=FBSIENS
SET FBOIENS=""
QUIT
+26 ; set current IENs to the new value
+27 if FBOIENS'=""
SET FBCIENS=FBOIENS
End DoDot:2
if FBOIENS=""
QUIT
+28 ;
+29 ; if current IENs is different from starting IENs update outputs
+30 IF FBCIENS'=FBSIENS
Begin DoDot:2
+31 IF FBFILE=162.03
SET FBRET=$PIECE(FBCIENS,",",4)_"^"_$PIECE(FBCIENS,",",3)_"^"_$PIECE(FBCIENS,",",2)_"^"_$PIECE(FBCIENS,",",1)
+32 IF FBFILE=162.04
SET FBRET=$PIECE(FBCIENS,",",2)_"^"_$PIECE(FBCIENS,",",1)
End DoDot:2
End DoDot:1
+33 ;
+34 QUIT FBRET
+35 ;
+36 ;FBAAVR5
