FBCHFR ;WOIFO/SAB-FILE REMITTANCE REMARKS FOR CH/CNH PAYMENT ;7/17/2003
;;3.5;FEE BASIS;**61,158**;JAN 30, 1995;Build 94
;;Per VA Directive 6402, this routine should not be modified.
Q
FILERR(FBIENS,FBRRMK) ; File Remittance Remarks
;
; Input
; FBIENS - required, internal entry numbers for subfile 162.5
; in standard format as specified for FileMan DBS calls
; FBRRMK - required, array passed by reference
; array of remittance remarks to file
; array does not have to contain any data or be defined
; format
; FBRRMK(FBADJ,#)=FBRRMKC
; where
; FBADJ = Adjustment Reason IEN (#161.91)
; # = sequentially assigned number starting with 1
; FBRRMKC = remittance remark (internal value file 162.93)
; Output
; Data in File 162.5 will be modified
;
N FB,FBFDA,FBI,FBSIENS
;
; delete remitance remarks currently on file
D GETS^DIQ(162.5,FBIENS,"59*","","FB")
K FBFDA
S FBSIENS="" F S FBSIENS=$O(FB(162.559,FBSIENS)) Q:FBSIENS="" D
. S FBFDA(162.559,FBSIENS,.01)="@"
I $D(FBFDA) D FILE^DIE("","FBFDA")
;
; file remarks from input array
K FBFDA
S (FBADJ,CNTR)=0
D DA^DILF(FBIENS,.FBDA)
F S FBADJ=$O(FBRRMK(FBADJ)) Q:'FBADJ D
. S ADJDA=$S(FBADJ'=999:$$GETADJI(FBADJ,.FBDA),1:FBADJ) ;999 indicates a CARCless RARC
. S FBI=0
. F S FBI=$O(FBRRMK(FBADJ,FBI)) Q:'FBI D
. . S CNTR=CNTR+1
. . S FBFDA(162.559,"+"_CNTR_","_FBIENS,.01)=$P(FBRRMK(FBADJ,FBI),U)
. . S FBFDA(162.559,"+"_CNTR_","_FBIENS,1)=ADJDA
I $D(FBFDA) D UPDATE^DIE("","FBFDA")
;
Q
;
GETADJI(ADJI,FBDA) ; get correct DA from ADJUSTMENT multiple
;
N DA
I $D(FBDA)'=1 Q ""
S DA=""
I $G(ADJI),$D(^FBAAI(FBDA,8,"B",ADJI)) D
. S DA=$O(^FBAAI(FBDA,8,"B",ADJI,DA))
Q DA
;
LOADRR(FBIENS,FBRRMK) ; Load Remittance Remarks
; Input
; FBIENS - required, internal entry numbers for subfile 162.5
; in standard format as specified for FileMan DBS calls
; FBRRMK - required, array passed by reference
; array to load adjustments into
; Output
; FBRRMK - the FBRRMK input array passed by reference will be modified
; format
; FBRRMK(#)=FBRRMKC
; where
; # = sequentially assigned number starting with 1
; FBRRMKC = remittance remark (internal value file 162.93)
; if no remarks are on file then the array will be undefined
N FBC,FBI,FBSIENS,ADJMI,FBDA,ADJI,RRI,FB
;
K FBRRMK
;
S FBC=0,ADJMI=""
D DA^DILF(FBIENS,.FBDA)
D GETS^DIQ(162.5,FBIENS,"59*","I","FB")
S FBSIENS=""
F S FBSIENS=$O(FB(162.559,FBSIENS)) Q:FBSIENS="" D
. S RRI=FB(162.559,FBSIENS,.01,"I")
. S ADJMI=FB(162.559,FBSIENS,1,"I")
. I ADJMI,$D(^FBAAI(FBDA,8,ADJMI,0)) S ADJI=$P(^FBAAI(FBDA,8,ADJMI,0),U)
. E S ADJI=999
. S FBC=$S($D(FBRRMK(ADJI)):$O(FBRRMK(ADJI,FBC)),1:0)
. S FBRRMK(ADJI,FBC+1)=RRI
;
Q
;
RRL(FBIENS) ; Remittance Remarks List Extrinsic Function
; Input
; FBIENS - required, internal entry number for file 162.5
; in standard format as specified for FileMan DBS calls
; Result
; string containing sorted list (by external code) of remarks
; format
; FBRRMKCE 1, FBRRMKCE 2
; where
; FBRRMKCE = remittance remark code (external value)
N FBRET,FBRRMK
D LOADRR^FBCHFR(FBIENS,.FBRRMK)
S FBRET=$$RRL^FBUTL4(.FBRRMK)
Q FBRET
;
KILLRR(X,DA) ; Called from FEE BASIS INVOICE (#162.5),
; ADJUSTMENT (#58), ADJUSTMENT REASON (.01)
; to delete REMITTANCE REMARK (#59) entries associated
; with adjustment reasons being deleted.
;
N FBIENS,FB,FBFDA,FBSIENS
;
S FBIENS=$G(DA(1))_","
D GETS^DIQ(162.5,FBIENS,"59*","","FB")
;
S FBSIENS="" F S FBSIENS=$O(FB(162.559,FBSIENS)) Q:FBSIENS="" D
. I FB(162.559,FBSIENS,1)=$G(DA) S FBFDA(162.559,FBSIENS,.01)="@"
I $D(FBFDA) D FILE^DIE("","FBFDA")
;
Q
;FBCHFR
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBCHFR 4044 printed Dec 13, 2024@01:57:45 Page 2
FBCHFR ;WOIFO/SAB-FILE REMITTANCE REMARKS FOR CH/CNH PAYMENT ;7/17/2003
+1 ;;3.5;FEE BASIS;**61,158**;JAN 30, 1995;Build 94
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
FILERR(FBIENS,FBRRMK) ; File Remittance Remarks
+1 ;
+2 ; Input
+3 ; FBIENS - required, internal entry numbers for subfile 162.5
+4 ; in standard format as specified for FileMan DBS calls
+5 ; FBRRMK - required, array passed by reference
+6 ; array of remittance remarks to file
+7 ; array does not have to contain any data or be defined
+8 ; format
+9 ; FBRRMK(FBADJ,#)=FBRRMKC
+10 ; where
+11 ; FBADJ = Adjustment Reason IEN (#161.91)
+12 ; # = sequentially assigned number starting with 1
+13 ; FBRRMKC = remittance remark (internal value file 162.93)
+14 ; Output
+15 ; Data in File 162.5 will be modified
+16 ;
+17 NEW FB,FBFDA,FBI,FBSIENS
+18 ;
+19 ; delete remitance remarks currently on file
+20 DO GETS^DIQ(162.5,FBIENS,"59*","","FB")
+21 KILL FBFDA
+22 SET FBSIENS=""
FOR
SET FBSIENS=$ORDER(FB(162.559,FBSIENS))
if FBSIENS=""
QUIT
Begin DoDot:1
+23 SET FBFDA(162.559,FBSIENS,.01)="@"
End DoDot:1
+24 IF $DATA(FBFDA)
DO FILE^DIE("","FBFDA")
+25 ;
+26 ; file remarks from input array
+27 KILL FBFDA
+28 SET (FBADJ,CNTR)=0
+29 DO DA^DILF(FBIENS,.FBDA)
+30 FOR
SET FBADJ=$ORDER(FBRRMK(FBADJ))
if 'FBADJ
QUIT
Begin DoDot:1
+31 ;999 indicates a CARCless RARC
SET ADJDA=$SELECT(FBADJ'=999:$$GETADJI(FBADJ,.FBDA),1:FBADJ)
+32 SET FBI=0
+33 FOR
SET FBI=$ORDER(FBRRMK(FBADJ,FBI))
if 'FBI
QUIT
Begin DoDot:2
+34 SET CNTR=CNTR+1
+35 SET FBFDA(162.559,"+"_CNTR_","_FBIENS,.01)=$PIECE(FBRRMK(FBADJ,FBI),U)
+36 SET FBFDA(162.559,"+"_CNTR_","_FBIENS,1)=ADJDA
End DoDot:2
End DoDot:1
+37 IF $DATA(FBFDA)
DO UPDATE^DIE("","FBFDA")
+38 ;
+39 QUIT
+40 ;
GETADJI(ADJI,FBDA) ; get correct DA from ADJUSTMENT multiple
+1 ;
+2 NEW DA
+3 IF $DATA(FBDA)'=1
QUIT ""
+4 SET DA=""
+5 IF $GET(ADJI)
IF $DATA(^FBAAI(FBDA,8,"B",ADJI))
Begin DoDot:1
+6 SET DA=$ORDER(^FBAAI(FBDA,8,"B",ADJI,DA))
End DoDot:1
+7 QUIT DA
+8 ;
LOADRR(FBIENS,FBRRMK) ; Load Remittance Remarks
+1 ; Input
+2 ; FBIENS - required, internal entry numbers for subfile 162.5
+3 ; in standard format as specified for FileMan DBS calls
+4 ; FBRRMK - required, array passed by reference
+5 ; array to load adjustments into
+6 ; Output
+7 ; FBRRMK - the FBRRMK input array passed by reference will be modified
+8 ; format
+9 ; FBRRMK(#)=FBRRMKC
+10 ; where
+11 ; # = sequentially assigned number starting with 1
+12 ; FBRRMKC = remittance remark (internal value file 162.93)
+13 ; if no remarks are on file then the array will be undefined
+14 NEW FBC,FBI,FBSIENS,ADJMI,FBDA,ADJI,RRI,FB
+15 ;
+16 KILL FBRRMK
+17 ;
+18 SET FBC=0
SET ADJMI=""
+19 DO DA^DILF(FBIENS,.FBDA)
+20 DO GETS^DIQ(162.5,FBIENS,"59*","I","FB")
+21 SET FBSIENS=""
+22 FOR
SET FBSIENS=$ORDER(FB(162.559,FBSIENS))
if FBSIENS=""
QUIT
Begin DoDot:1
+23 SET RRI=FB(162.559,FBSIENS,.01,"I")
+24 SET ADJMI=FB(162.559,FBSIENS,1,"I")
+25 IF ADJMI
IF $DATA(^FBAAI(FBDA,8,ADJMI,0))
SET ADJI=$PIECE(^FBAAI(FBDA,8,ADJMI,0),U)
+26 IF '$TEST
SET ADJI=999
+27 SET FBC=$SELECT($DATA(FBRRMK(ADJI)):$ORDER(FBRRMK(ADJI,FBC)),1:0)
+28 SET FBRRMK(ADJI,FBC+1)=RRI
End DoDot:1
+29 ;
+30 QUIT
+31 ;
RRL(FBIENS) ; Remittance Remarks List Extrinsic Function
+1 ; Input
+2 ; FBIENS - required, internal entry number for file 162.5
+3 ; in standard format as specified for FileMan DBS calls
+4 ; Result
+5 ; string containing sorted list (by external code) of remarks
+6 ; format
+7 ; FBRRMKCE 1, FBRRMKCE 2
+8 ; where
+9 ; FBRRMKCE = remittance remark code (external value)
+10 NEW FBRET,FBRRMK
+11 DO LOADRR^FBCHFR(FBIENS,.FBRRMK)
+12 SET FBRET=$$RRL^FBUTL4(.FBRRMK)
+13 QUIT FBRET
+14 ;
KILLRR(X,DA) ; Called from FEE BASIS INVOICE (#162.5),
+1 ; ADJUSTMENT (#58), ADJUSTMENT REASON (.01)
+2 ; to delete REMITTANCE REMARK (#59) entries associated
+3 ; with adjustment reasons being deleted.
+4 ;
+5 NEW FBIENS,FB,FBFDA,FBSIENS
+6 ;
+7 SET FBIENS=$GET(DA(1))_","
+8 DO GETS^DIQ(162.5,FBIENS,"59*","","FB")
+9 ;
+10 SET FBSIENS=""
FOR
SET FBSIENS=$ORDER(FB(162.559,FBSIENS))
if FBSIENS=""
QUIT
Begin DoDot:1
+11 IF FB(162.559,FBSIENS,1)=$GET(DA)
SET FBFDA(162.559,FBSIENS,.01)="@"
End DoDot:1
+12 IF $DATA(FBFDA)
DO FILE^DIE("","FBFDA")
+13 ;
+14 QUIT
+15 ;FBCHFR
