- FBUTL4 ;WOIFO/SAB-FEE BASIS UTILITY ;7/6/2003
- ;;3.5;FEE BASIS;**61,158**;JAN 30, 1995;Build 94
- ;;Per VA Directive 6402, this routine should not be modified.
- ;;Per VA Directive 6402, this routine should not be modified.
- Q
- RR(FBRRMK,FBMAX,FBDT,FBRRMKD,FBADJ) ; Prompt for Remittance Remarks
- ;
- ; Input
- ; FBRRMK - required, array passed by reference
- ; will be initialized (killed)
- ; array of any entered remark codes
- ; format
- ; FBRRMK(#)=FBRRMKC
- ; where
- ; # = sequentially assigned number starting with 1
- ; FBRRMKC = remittance remark (internal value file 162.93)
- ; FBMAX - optional, number, default to 2
- ; maximum number of remarks that may be entered by user
- ; 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
- ; FBADJ - adjustment reason code IEN
- ; 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,FBADJI
- S FBADJI=0
- S FBRET=1
- S FBMAX=$G(FBMAX,2)
- S FBDT=$G(FBDT,DT)
- K FBRRMK(FBADJ)
- ;
- ; if default remarks exist then load them into array
- I $D(FBRRMKD(FBADJ)) M FBRRMK(FBADJ)=FBRRMKD(FBADJ)
- S FBCNT=0
- I $D(FBRRMK(FBADJ)) S FBI=0 F S FBI=$O(FBRRMK(FBADJ,FBI)) Q:'FBI S FBCNT=FBCNT+1
- ;
- ASKRR ; multiply prompt for remarks
- ;
- ; display current list of remarks when more than 1 allowed
- I FBMAX>1!(FBCNT>1) D
- . W !!,"Current list of Remittance Remarks: "
- . I '$O(FBRRMK(FBADJ,0)) W "none"
- . S FBI=0 F S FBI=$O(FBRRMK(FBADJ,FBI)) Q:'FBI D
- . . W:$P(FBRRMK(FBADJ,FBI),U)]"" $P($G(^FB(161.93,$P(FBRRMK(FBADJ,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(FBADJ,0))
- . S:FBI FBRRMKC=$P(FBRRMK(FBADJ,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 REMITTANCE REMARK"
- . S DIR("S")="I $P($$RR^FBUTL1(Y,,FBDT,,FBADJ),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 I FBCNT<FBMAX!(FBRRMKC="") G ASKRR
- 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(FBADJ,FBI)) Q:'FBI D Q:FBEDIT
- . . I $P(FBRRMK(FBADJ,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(FBADJ,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(FBADJ,FBI)) Q:'FBI D Q:FBRRMKC=""
- . . . I $P(FBRRMK(FBADJ,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(FBADJ,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(FBADJ," "),-1)+1
- . . S $P(FBRRMK(FBADJ,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(FBADJ,FBI) ; delete remark from list
- S FBCNT=FBCNT-1
- K FBRRMK(FBADJ,FBI)
- S FBRRMKC=""
- W " (deleted)"
- Q
- ;
- RRL(FBRRMK) ; build list of remittance remarks extrinsic function
- ; Input
- ; FBRRMK- required, array passed by reference
- ; array of remittance remarks
- ; format
- ; FBRRMK(ADJI,#)=FBRRMKC
- ; where
- ; ADJI = Adjustment Reason IEN
- ; # = 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,FBRRMKC,FBRRMKCE,FBRRMKS,FBI,ADJI
- S FBRET=""
- S ADJI=""
- F S ADJI=$O(FBRRMK(ADJI)) Q:'ADJI D
- . S FBI=0
- . F S FBI=$O(FBRRMK(ADJI,FBI)) Q:'FBI D
- . . ; obtain internal values
- . . S FBRRMKC=$P(FBRRMK(ADJI,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
- ;
- ;FBUTL4
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBUTL4 6119 printed Jan 18, 2025@03:01:58 Page 2
- FBUTL4 ;WOIFO/SAB-FEE BASIS UTILITY ;7/6/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 ;;Per VA Directive 6402, this routine should not be modified.
- +4 QUIT
- RR(FBRRMK,FBMAX,FBDT,FBRRMKD,FBADJ) ; Prompt for Remittance Remarks
- +1 ;
- +2 ; Input
- +3 ; FBRRMK - required, array passed by reference
- +4 ; will be initialized (killed)
- +5 ; array of any entered remark codes
- +6 ; format
- +7 ; FBRRMK(#)=FBRRMKC
- +8 ; where
- +9 ; # = sequentially assigned number starting with 1
- +10 ; FBRRMKC = remittance remark (internal value file 162.93)
- +11 ; FBMAX - optional, number, default to 2
- +12 ; maximum number of remarks that may be entered by user
- +13 ; FBDT - optional, effective date, FileMan internal format
- +14 ; default to current date, used to determine available codes
- +15 ; FBRRMKD- optional, array passed by reference
- +16 ; same format as FBRRMK
- +17 ; if passed, it will be used to supply default values
- +18 ; normally only used when editing an existing payment
- +19 ; FBADJ - adjustment reason code IEN
- +20 ; Result (value of $$RR extrinsic function)
- +21 ; FBRET - boulean value (0 or 1)
- +22 ; = 1 when process did not end due to time-out or "^"
- +23 ; = 0 when process ended due to time-out OR "^"
- +24 ; Output
- +25 ; FBRRMK- the FBRRMK input array passed by reference will be modified
- +26 ; it will contain any entered remarks
- +27 ;
- +28 NEW FBRRMKC,FBCNT,FBEDIT,FBERR,FBI,FBNEW,FBRET
- +29 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y,FBADJI
- +30 SET FBADJI=0
- +31 SET FBRET=1
- +32 SET FBMAX=$GET(FBMAX,2)
- +33 SET FBDT=$GET(FBDT,DT)
- +34 KILL FBRRMK(FBADJ)
- +35 ;
- +36 ; if default remarks exist then load them into array
- +37 IF $DATA(FBRRMKD(FBADJ))
- MERGE FBRRMK(FBADJ)=FBRRMKD(FBADJ)
- +38 SET FBCNT=0
- +39 IF $DATA(FBRRMK(FBADJ))
- SET FBI=0
- FOR
- SET FBI=$ORDER(FBRRMK(FBADJ,FBI))
- if 'FBI
- QUIT
- SET FBCNT=FBCNT+1
- +40 ;
- ASKRR ; multiply prompt for remarks
- +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: "
- +5 IF '$ORDER(FBRRMK(FBADJ,0))
- WRITE "none"
- +6 SET FBI=0
- FOR
- SET FBI=$ORDER(FBRRMK(FBADJ,FBI))
- if 'FBI
- QUIT
- Begin DoDot:2
- +7 if $PIECE(FBRRMK(FBADJ,FBI),U)]""
- WRITE $PIECE($GET(^FB(161.93,$PIECE(FBRRMK(FBADJ,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(FBADJ,0))
- +15 if FBI
- SET FBRRMKC=$PIECE(FBRRMK(FBADJ,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 REMITTANCE REMARK"
- +20 SET DIR("S")="I $P($$RR^FBUTL1(Y,,FBDT,,FBADJ),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 ;I +Y>0 D G:FBRET=0 EXIT I FBCNT<FBMAX!(FBRRMKC="") G ASKRR
- +28 IF +Y>0
- Begin DoDot:1
- +29 SET FBRRMKC=+Y
- +30 ; if specified remark already in list set FBEDIT = it's number
- +31 SET (FBI,FBEDIT)=0
- FOR
- SET FBI=$ORDER(FBRRMK(FBADJ,FBI))
- if 'FBI
- QUIT
- Begin DoDot:2
- +32 IF $PIECE(FBRRMK(FBADJ,FBI),U)=FBRRMKC
- SET FBEDIT=FBI
- End DoDot:2
- if FBEDIT
- QUIT
- +33 ; flag as new if not on list
- SET FBNEW=$SELECT(FBEDIT:0,1:1)
- +34 ; if in list then edit the existing remark
- +35 IF FBEDIT
- Begin DoDot:2
- +36 SET DIR(0)="162.559,.01"
- +37 SET DIR("B")=$PIECE($GET(^FB(161.93,FBRRMKC,0)),U)
- +38 DO ^DIR
- KILL DIR
- IF $DATA(DTOUT)!$DATA(DUOUT)
- if FBMAX=1
- SET FBRET=0
- QUIT
- +39 ; "@" removes from list
- IF X="@"
- Begin DoDot:3
- +40 DO DEL(FBADJ,FBEDIT)
- End DoDot:3
- QUIT
- +41 IF +Y>0
- SET FBRRMKC=+Y
- +42 ; ensure new value of edited remark is not already on list
- +43 SET FBI=0
- FOR
- SET FBI=$ORDER(FBRRMK(FBADJ,FBI))
- if 'FBI
- QUIT
- Begin DoDot:3
- +44 IF $PIECE(FBRRMK(FBADJ,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
- +45 if FBRRMKC=""
- QUIT
- +46 ; upate the existing reason
- +47 SET $PIECE(FBRRMK(FBADJ,FBEDIT),U)=FBRRMKC
- End DoDot:2
- if $DATA(DIRUT)
- QUIT
- if FBRRMKC=""
- QUIT
- +48 ;
- +49 ; if new reason then add to list
- +50 IF 'FBEDIT
- Begin DoDot:2
- +51 IF (FBCNT+1)>FBMAX
- Begin DoDot:3
- +52 SET FBRRMKC=""
- +53 WRITE !!,$CHAR(7),"ERROR: A new reason would exceed maximum number (",FBMAX,") allowed for this invoice."
- +54 WRITE !," If necessary, a code on the current list can be selected and changed."
- End DoDot:3
- QUIT
- +55 SET FBEDIT=$ORDER(FBRRMK(FBADJ," "),-1)+1
- +56 SET $PIECE(FBRRMK(FBADJ,FBEDIT),U)=FBRRMKC
- SET FBCNT=FBCNT+1
- End DoDot:2
- if FBRRMKC=""
- QUIT
- End DoDot:1
- if FBRET=0
- GOTO EXIT
- GOTO ASKRR
- +57 ;
- +58 ; validate
- +59 IF FBCNT>FBMAX
- Begin DoDot:1
- +60 WRITE !!,$CHAR(7),"ERROR: Maximum number of remittance remark codes (",FBMAX,") have been exceeded."
- End DoDot:1
- GOTO ASKRR
- +61 ;
- EXIT ;
- +1 QUIT FBRET
- +2 ;
- DEL(FBADJ,FBI) ; delete remark from list
- +1 SET FBCNT=FBCNT-1
- +2 KILL FBRRMK(FBADJ,FBI)
- +3 SET FBRRMKC=""
- +4 WRITE " (deleted)"
- +5 QUIT
- +6 ;
- 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(ADJI,#)=FBRRMKC
- +6 ; where
- +7 ; ADJI = Adjustment Reason IEN
- +8 ; # = integer number greater than 0
- +9 ; FBRRMKC = remittance remark (internal value file 162.93)
- +10 ; Result
- +11 ; string containing sorted list (by external code) of remarks
- +12 ; format
- +13 ; FBRRMKCE 1, FBRRMKCE 2
- +14 ; where
- +15 ; FBRRMKCE = remittance remark code (external value)
- +16 NEW FBRET,FBRRMKC,FBRRMKCE,FBRRMKS,FBI,ADJI
- +17 SET FBRET=""
- +18 SET ADJI=""
- +19 FOR
- SET ADJI=$ORDER(FBRRMK(ADJI))
- if 'ADJI
- QUIT
- Begin DoDot:1
- +20 SET FBI=0
- +21 FOR
- SET FBI=$ORDER(FBRRMK(ADJI,FBI))
- if 'FBI
- QUIT
- Begin DoDot:2
- +22 ; obtain internal values
- +23 SET FBRRMKC=$PIECE(FBRRMK(ADJI,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:2
- 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 ;FBUTL4