- 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 Feb 18, 2025@23:23:41 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