FBUTL4A ;WOIFO/SAB-FEE BASIS UTILITY ;7/6/2003
;;3.5;FEE BASIS;**61,158**;JAN 30, 1995;Build 94
Q
;
CLESSR(FBADJ,AMAX,FBRRMK) ; CARCless RARCs
; Input:
; FBADJ -> required, array of Adjustment Reasons
; AMAX -> required, maximum allowed number of adjustment reasons
; FBRRMK -> required, array of remittance remarks
N ADJI,RMAX,CLESS,FBRET,FBRRMKD
S (CLESS,ADJI)=999
I $D(FBADJ),$O(FBADJ("")) S ADJI=$O(FBADJ(ADJI),-1)
I ADJI=AMAX K FBRRMK(CLESS) Q 0 ;no room in this invoice for additional RARCS
S RMAX=$S(ADJI=999:AMAX*2,1:(AMAX-ADJI)*2) ;determine how many CARCless RARCs are allowed
;#44 - determine whether current carcless rarc list exceeds the max allowed. If so, delete them all.
S RCNT=$O(FBRRMK(CLESS,11),-1)
I RCNT>RMAX K FBRRMK(CLESS)
;
I $D(FBRRMK(CLESS)) M FBRRMKD(CLESS)=FBRRMK(CLESS)
S FBDT=$G(FBDT,DT)
S FBRET=$$RR(.FBRRMK,RMAX,FBDT,.FBRRMKD)
Q FBRET
;
RR(FBRRMK,FBMAX,FBDT,FBRRMKD) ; Prompt for CARCless Remittance Remarks
;
; Input
; FBRRMK - required, array passed by reference
; will be initialized (killed)
; array of any entered CARCless remark codes
; format
; FBRRMK(999,#)=FBRRMKC
; where
; # = sequentially assigned number starting with 1
; FBRRMKC = remittance remark (internal value file 162.93)
; FBMAX - maximum number of RARCs
; FBDT - optional, effective date, FileMan internal format
; default to current date, used to determine available codes
; FBRRMKD- optional, array passed by reference
; same format as FBRRMK
; if passed, it will be used to supply default values
; normally only used when editing an existing payment
; Result (value of $$RR extrinsic function)
; FBRET - boulean value (0 or 1)
; = 1 when process did not end due to time-out or "^"
; = 0 when process ended due to time-out OR "^"
; Output
; FBRRMK- the FBRRMK input array passed by reference will be modified
; it will contain any entered remarks
;
N FBRRMKC,FBCNT,FBEDIT,FBERR,FBI,FBNEW,FBRET
N DIR,DIRUT,DTOUT,DUOUT,X,Y
S FBRET=1
K FBRRMK(999)
; if default remarks exist then load them into array
I $D(FBRRMKD(999)) M FBRRMK(999)=FBRRMKD(999)
S FBCNT=0
I $D(FBRRMK(999)) S FBI=0 F S FBI=$O(FBRRMK(999,FBI)) Q:'FBI S FBCNT=FBCNT+1
;
ASKRR ; multiple prompts for CARCless RARCs
;
; display current list of remarks when more than 1 allowed
I FBMAX>1!(FBCNT>1) D
. W !!,"Current list of Remittance Remarks (CARCless RARCs): "
. I '$O(FBRRMK(999,0)) W "none"
. S FBI=0 F S FBI=$O(FBRRMK(999,FBI)) Q:'FBI D
. . W:$P(FBRRMK(999,FBI),U)]"" $P($G(^FB(161.93,$P(FBRRMK(999,FBI),U),0)),U),", "
. W !
;
; prompt for remark
; if max is 1 and reason already on list then automatically select it
I FBMAX=1,FBCNT=1 D
. N FBI,FBRRMKC
. S FBI=$O(FBRRMK(999,0))
. S:FBI FBRRMKC=$P(FBRRMK(999,FBI),U)
. I FBRRMKC S Y=FBRRMKC_U_$P($G(^FB(161.93,FBRRMKC,0)),U)
E D I $D(DTOUT)!$D(DUOUT) S FBRET=0 G EXIT ; prompt user
. S DIR(0)="PO^161.93:EMZ"
. S DIR("A")="Select additional REMITTANCE REMARK"
. S DIR("S")="I $P($$RR^FBUTL1(Y,,FBDT),U,4)=1"
. S DIR("?")="Select a HIPAA Remittance Remark Code."
. S DIR("?",1)="Select a remittance remark code to provide non-financial"
. S DIR("?",2)="information critical to understanding the adjudication of the claim."
. D ^DIR K DIR
;
; if value was entered then process it and ask another if not max
I +Y>0 D G:FBRET=0 EXIT G ASKRR
. S FBRRMKC=+Y
. ; if specified remark already in list set FBEDIT = it's number
. S (FBI,FBEDIT)=0 F S FBI=$O(FBRRMK(999,FBI)) Q:'FBI D Q:FBEDIT
. . I $P(FBRRMK(999,FBI),U)=FBRRMKC S FBEDIT=FBI
. S FBNEW=$S(FBEDIT:0,1:1) ; flag as new if not on list
. ; if in list then edit the existing remark
. I FBEDIT D Q:$D(DIRUT) Q:FBRRMKC=""
. . S DIR(0)="162.559,.01"
. . S DIR("B")=$P($G(^FB(161.93,FBRRMKC,0)),U)
. . D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S:FBMAX=1 FBRET=0 Q
. . I X="@" D Q ; "@" removes from list
. . . D DEL(FBEDIT)
. . I +Y>0 S FBRRMKC=+Y
. . ; ensure new value of edited remark is not already on list
. . S FBI=0 F S FBI=$O(FBRRMK(999,FBI)) Q:'FBI D Q:FBRRMKC=""
. . . I $P(FBRRMK(999,FBI),U)=FBRRMKC,FBI'=FBEDIT S FBRRMKC="" W !,$C(7)," Change was not accepted because the new value is already on the list."
. . Q:FBRRMKC=""
. . ; upate the existing reason
. . S $P(FBRRMK(999,FBEDIT),U)=FBRRMKC
. ;
. ; if new reason then add to list
. I 'FBEDIT D Q:FBRRMKC=""
. . I (FBCNT+1)>FBMAX D Q
. . . S FBRRMKC=""
. . . W !!,$C(7),"ERROR: A new reason would exceed maximum number (",FBMAX,") allowed for this invoice."
. . . W !," If necessary, a code on the current list can be selected and changed."
. . S FBEDIT=$O(FBRRMK(999," "),-1)+1
. . S $P(FBRRMK(999,FBEDIT),U)=FBRRMKC,FBCNT=FBCNT+1
;
; validate
I FBCNT>FBMAX D G ASKRR
. W !!,$C(7),"ERROR: Maximum number of remittance remark codes (",FBMAX,") have been exceeded."
;
EXIT ;
Q FBRET
;
DEL(FBI) ; delete remark from list
S FBCNT=FBCNT-1
K FBRRMK(999,FBI)
S FBRRMKC=""
W " (deleted)"
Q
;
TSTCR ;
N FBADJ,FBRRMK
;CARCs
S IENS="1,2,1096,7169710,"
D LOADADJ^FBAAFA(IENS,.FBADJ)
;RARCs
D LOADRR^FBAAFR(IENS,.FBRRMK)
;
S RET=$$CLESSR(.FBADJ,5,.FBRRMK)
Q
;
RRL(FBRRMK) ; build list of remittance remarks extrinsic function
; Input
; FBRRMK- required, array passed by reference
; array of remittance remarks
; format
; FBRRMK(#)=FBRRMKC
; where
; # = integer number greater than 0
; FBRRMKC = remittance remark (internal value file 162.93)
; Result
; string containing sorted list (by external code) of remarks
; format
; FBRRMKCE 1, FBRRMKCE 2
; where
; FBRRMKCE = remittance remark code (external value)
N FBRET
N FBRRMKC,FBRRMKCE
N FBRRMKS,FBI
S FBRET=""
;
; build sorted array containing external values
S FBI=0 F S FBI=$O(FBRRMK(FBI)) Q:'FBI D
. ; obtain internal values
. S FBRRMKC=$P(FBRRMK(FBI),U)
. ; convert to external values
. S FBRRMKCE=$S(FBRRMKC:$P($G(^FB(161.93,FBRRMKC,0)),U),1:"")
. ; store in sorted array
. S FBRRMKS(FBRRMKCE_U_FBI)=FBRRMKCE_","
;
; build list from sorted array
S FBI="" F S FBI=$O(FBRRMKS(FBI)) Q:FBI="" D
. S FBRET=FBRET_FBRRMKS(FBI)
; strip trailing "," from list
I $E(FBRET,$L(FBRET))="," S FBRET=$E(FBRET,1,$L(FBRET)-1)
;
Q FBRET
;
;FBUTL4A
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBUTL4A 6666 printed Oct 16, 2024@18:01:36 Page 2
FBUTL4A ;WOIFO/SAB-FEE BASIS UTILITY ;7/6/2003
+1 ;;3.5;FEE BASIS;**61,158**;JAN 30, 1995;Build 94
+2 QUIT
+3 ;
CLESSR(FBADJ,AMAX,FBRRMK) ; CARCless RARCs
+1 ; Input:
+2 ; FBADJ -> required, array of Adjustment Reasons
+3 ; AMAX -> required, maximum allowed number of adjustment reasons
+4 ; FBRRMK -> required, array of remittance remarks
+5 NEW ADJI,RMAX,CLESS,FBRET,FBRRMKD
+6 SET (CLESS,ADJI)=999
+7 IF $DATA(FBADJ)
IF $ORDER(FBADJ(""))
SET ADJI=$ORDER(FBADJ(ADJI),-1)
+8 ;no room in this invoice for additional RARCS
IF ADJI=AMAX
KILL FBRRMK(CLESS)
QUIT 0
+9 ;determine how many CARCless RARCs are allowed
SET RMAX=$SELECT(ADJI=999:AMAX*2,1:(AMAX-ADJI)*2)
+10 ;#44 - determine whether current carcless rarc list exceeds the max allowed. If so, delete them all.
+11 SET RCNT=$ORDER(FBRRMK(CLESS,11),-1)
+12 IF RCNT>RMAX
KILL FBRRMK(CLESS)
+13 ;
+14 IF $DATA(FBRRMK(CLESS))
MERGE FBRRMKD(CLESS)=FBRRMK(CLESS)
+15 SET FBDT=$GET(FBDT,DT)
+16 SET FBRET=$$RR(.FBRRMK,RMAX,FBDT,.FBRRMKD)
+17 QUIT FBRET
+18 ;
RR(FBRRMK,FBMAX,FBDT,FBRRMKD) ; Prompt for CARCless Remittance Remarks
+1 ;
+2 ; Input
+3 ; FBRRMK - required, array passed by reference
+4 ; will be initialized (killed)
+5 ; array of any entered CARCless remark codes
+6 ; format
+7 ; FBRRMK(999,#)=FBRRMKC
+8 ; where
+9 ; # = sequentially assigned number starting with 1
+10 ; FBRRMKC = remittance remark (internal value file 162.93)
+11 ; FBMAX - maximum number of RARCs
+12 ; FBDT - optional, effective date, FileMan internal format
+13 ; default to current date, used to determine available codes
+14 ; FBRRMKD- optional, array passed by reference
+15 ; same format as FBRRMK
+16 ; if passed, it will be used to supply default values
+17 ; normally only used when editing an existing payment
+18 ; Result (value of $$RR extrinsic function)
+19 ; FBRET - boulean value (0 or 1)
+20 ; = 1 when process did not end due to time-out or "^"
+21 ; = 0 when process ended due to time-out OR "^"
+22 ; Output
+23 ; FBRRMK- the FBRRMK input array passed by reference will be modified
+24 ; it will contain any entered remarks
+25 ;
+26 NEW FBRRMKC,FBCNT,FBEDIT,FBERR,FBI,FBNEW,FBRET
+27 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
+28 SET FBRET=1
+29 KILL FBRRMK(999)
+30 ; if default remarks exist then load them into array
+31 IF $DATA(FBRRMKD(999))
MERGE FBRRMK(999)=FBRRMKD(999)
+32 SET FBCNT=0
+33 IF $DATA(FBRRMK(999))
SET FBI=0
FOR
SET FBI=$ORDER(FBRRMK(999,FBI))
if 'FBI
QUIT
SET FBCNT=FBCNT+1
+34 ;
ASKRR ; multiple prompts for CARCless RARCs
+1 ;
+2 ; display current list of remarks when more than 1 allowed
+3 IF FBMAX>1!(FBCNT>1)
Begin DoDot:1
+4 WRITE !!,"Current list of Remittance Remarks (CARCless RARCs): "
+5 IF '$ORDER(FBRRMK(999,0))
WRITE "none"
+6 SET FBI=0
FOR
SET FBI=$ORDER(FBRRMK(999,FBI))
if 'FBI
QUIT
Begin DoDot:2
+7 if $PIECE(FBRRMK(999,FBI),U)]""
WRITE $PIECE($GET(^FB(161.93,$PIECE(FBRRMK(999,FBI),U),0)),U),", "
End DoDot:2
+8 WRITE !
End DoDot:1
+9 ;
+10 ; prompt for remark
+11 ; if max is 1 and reason already on list then automatically select it
+12 IF FBMAX=1
IF FBCNT=1
Begin DoDot:1
+13 NEW FBI,FBRRMKC
+14 SET FBI=$ORDER(FBRRMK(999,0))
+15 if FBI
SET FBRRMKC=$PIECE(FBRRMK(999,FBI),U)
+16 IF FBRRMKC
SET Y=FBRRMKC_U_$PIECE($GET(^FB(161.93,FBRRMKC,0)),U)
End DoDot:1
+17 ; prompt user
IF '$TEST
Begin DoDot:1
+18 SET DIR(0)="PO^161.93:EMZ"
+19 SET DIR("A")="Select additional REMITTANCE REMARK"
+20 SET DIR("S")="I $P($$RR^FBUTL1(Y,,FBDT),U,4)=1"
+21 SET DIR("?")="Select a HIPAA Remittance Remark Code."
+22 SET DIR("?",1)="Select a remittance remark code to provide non-financial"
+23 SET DIR("?",2)="information critical to understanding the adjudication of the claim."
+24 DO ^DIR
KILL DIR
End DoDot:1
IF $DATA(DTOUT)!$DATA(DUOUT)
SET FBRET=0
GOTO EXIT
+25 ;
+26 ; if value was entered then process it and ask another if not max
+27 IF +Y>0
Begin DoDot:1
+28 SET FBRRMKC=+Y
+29 ; if specified remark already in list set FBEDIT = it's number
+30 SET (FBI,FBEDIT)=0
FOR
SET FBI=$ORDER(FBRRMK(999,FBI))
if 'FBI
QUIT
Begin DoDot:2
+31 IF $PIECE(FBRRMK(999,FBI),U)=FBRRMKC
SET FBEDIT=FBI
End DoDot:2
if FBEDIT
QUIT
+32 ; flag as new if not on list
SET FBNEW=$SELECT(FBEDIT:0,1:1)
+33 ; if in list then edit the existing remark
+34 IF FBEDIT
Begin DoDot:2
+35 SET DIR(0)="162.559,.01"
+36 SET DIR("B")=$PIECE($GET(^FB(161.93,FBRRMKC,0)),U)
+37 DO ^DIR
KILL DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
if FBMAX=1
SET FBRET=0
QUIT
+38 ; "@" removes from list
IF X="@"
Begin DoDot:3
+39 DO DEL(FBEDIT)
End DoDot:3
QUIT
+40 IF +Y>0
SET FBRRMKC=+Y
+41 ; ensure new value of edited remark is not already on list
+42 SET FBI=0
FOR
SET FBI=$ORDER(FBRRMK(999,FBI))
if 'FBI
QUIT
Begin DoDot:3
+43 IF $PIECE(FBRRMK(999,FBI),U)=FBRRMKC
IF FBI'=FBEDIT
SET FBRRMKC=""
WRITE !,$CHAR(7)," Change was not accepted because the new value is already on the list."
End DoDot:3
if FBRRMKC=""
QUIT
+44 if FBRRMKC=""
QUIT
+45 ; upate the existing reason
+46 SET $PIECE(FBRRMK(999,FBEDIT),U)=FBRRMKC
End DoDot:2
if $DATA(DIRUT)
QUIT
if FBRRMKC=""
QUIT
+47 ;
+48 ; if new reason then add to list
+49 IF 'FBEDIT
Begin DoDot:2
+50 IF (FBCNT+1)>FBMAX
Begin DoDot:3
+51 SET FBRRMKC=""
+52 WRITE !!,$CHAR(7),"ERROR: A new reason would exceed maximum number (",FBMAX,") allowed for this invoice."
+53 WRITE !," If necessary, a code on the current list can be selected and changed."
End DoDot:3
QUIT
+54 SET FBEDIT=$ORDER(FBRRMK(999," "),-1)+1
+55 SET $PIECE(FBRRMK(999,FBEDIT),U)=FBRRMKC
SET FBCNT=FBCNT+1
End DoDot:2
if FBRRMKC=""
QUIT
End DoDot:1
if FBRET=0
GOTO EXIT
GOTO ASKRR
+56 ;
+57 ; validate
+58 IF FBCNT>FBMAX
Begin DoDot:1
+59 WRITE !!,$CHAR(7),"ERROR: Maximum number of remittance remark codes (",FBMAX,") have been exceeded."
End DoDot:1
GOTO ASKRR
+60 ;
EXIT ;
+1 QUIT FBRET
+2 ;
DEL(FBI) ; delete remark from list
+1 SET FBCNT=FBCNT-1
+2 KILL FBRRMK(999,FBI)
+3 SET FBRRMKC=""
+4 WRITE " (deleted)"
+5 QUIT
+6 ;
TSTCR ;
+1 NEW FBADJ,FBRRMK
+2 ;CARCs
+3 SET IENS="1,2,1096,7169710,"
+4 DO LOADADJ^FBAAFA(IENS,.FBADJ)
+5 ;RARCs
+6 DO LOADRR^FBAAFR(IENS,.FBRRMK)
+7 ;
+8 SET RET=$$CLESSR(.FBADJ,5,.FBRRMK)
+9 QUIT
+10 ;
RRL(FBRRMK) ; build list of remittance remarks extrinsic function
+1 ; Input
+2 ; FBRRMK- required, array passed by reference
+3 ; array of remittance remarks
+4 ; format
+5 ; FBRRMK(#)=FBRRMKC
+6 ; where
+7 ; # = integer number greater than 0
+8 ; FBRRMKC = remittance remark (internal value file 162.93)
+9 ; Result
+10 ; string containing sorted list (by external code) of remarks
+11 ; format
+12 ; FBRRMKCE 1, FBRRMKCE 2
+13 ; where
+14 ; FBRRMKCE = remittance remark code (external value)
+15 NEW FBRET
+16 NEW FBRRMKC,FBRRMKCE
+17 NEW FBRRMKS,FBI
+18 SET FBRET=""
+19 ;
+20 ; build sorted array containing external values
+21 SET FBI=0
FOR
SET FBI=$ORDER(FBRRMK(FBI))
if 'FBI
QUIT
Begin DoDot:1
+22 ; obtain internal values
+23 SET FBRRMKC=$PIECE(FBRRMK(FBI),U)
+24 ; convert to external values
+25 SET FBRRMKCE=$SELECT(FBRRMKC:$PIECE($GET(^FB(161.93,FBRRMKC,0)),U),1:"")
+26 ; store in sorted array
+27 SET FBRRMKS(FBRRMKCE_U_FBI)=FBRRMKCE_","
End DoDot:1
+28 ;
+29 ; build list from sorted array
+30 SET FBI=""
FOR
SET FBI=$ORDER(FBRRMKS(FBI))
if FBI=""
QUIT
Begin DoDot:1
+31 SET FBRET=FBRET_FBRRMKS(FBI)
End DoDot:1
+32 ; strip trailing "," from list
+33 IF $EXTRACT(FBRET,$LENGTH(FBRET))=","
SET FBRET=$EXTRACT(FBRET,1,$LENGTH(FBRET)-1)
+34 ;
+35 QUIT FBRET
+36 ;
+37 ;FBUTL4A
