FBUTL2 ;WOIFO/SAB-FEE BASIS UTILITY ;7/1/2003
;;3.5;FEE BASIS;**61,73,158**;JAN 30, 1995;Build 94
;;Per VA Directive 6402, this routine should not be modified.
Q
ADJ(FBTAS,FBADJ,FBMAX,FBDT,FBADJD,FBNOOUT,FBRRMK,CLESSR) ; Prompt for adjustments
;
; Input
; FBTAS - required, total amount suspended, number, may be negative
; the sum of all adjustment amounts must equal this value
; FBADJ - required, array passed by reference
; will be initialized (killed)
; array of any entered adjustments
; format
; FBADJ(#)=FBADJR^FBADJG^FBADJA
; where
; # = sequentially assigned number starting with 1
; FBADJR = adjustment reason (internal value file 162.91)
; FBADJG = adjustment group (inernal value file 162.92)
; FBADJA = adjustment amount (dollar value)
; FBMAX - optional, number, default to 1
; maximum number of adjustments that may be entered by user
; FBDT - optional, effective date, FileMan internal format
; default to current date, used to determine available codes
; FBADJD - optional, array passed by reference
; same format as FBADJ
; if passed, it will be used to supply default values
; normally only used when editing an existing payment
; FBNOOUT- optional, boolean value, default 0, set =1 if user
; should not be allowed to exit using an uparrow
; CLESSR - CARCless RARCs flag; prompt for if 'true'
;
; Result (value of $$ADJ extrinsic function)
; FBRET - boulean value (0 or 1)
; = 1 when valid adjustments entered
; = 0 when processed ended due to time-out or entry of '^'
; Output
; FBADJ - the FBADJ input array passed by reference will be modified
; if the result = 1 then it will contain entered adjustments
; if the result = 0 then it will be undefined
; FBRRMK - array of remittance remark codes
;
DBG ;
N FBADJR,FBCAS,FBCNT,FBEDIT,FBERR,FBI,FBNEW,FBRET,FBRRMKD
N DIR,DIRUT,DTOUT,DUOUT,X,Y,FBXX,FBCORES
S FBRET=1
S FBMAX=$G(FBMAX,1)
S FBDT=$G(FBDT,DT)
S FBNOOUT=$G(FBNOOUT,0)
S FBTAS=+FBTAS
K FBADJ
;
I +FBTAS=0 G EXIT ; no adjustment since total amount susp. is 0
;
; if default adjustments exist then load them into array
I $D(FBADJD) M FBADJ=FBADJD
S (FBCNT,FBCAS)=0
I $D(FBADJ) S FBI=0 F S FBI=$O(FBADJ(FBI)) Q:'FBI D
. S FBCNT=FBCNT+1
. S FBCAS=FBCAS+$P(FBADJ(FBI),U,3)
;
; if more than one adjustment can be entered then display number
;
;
ASKADJ ; multiply prompt for adjustments
;
; get default core scenario
S FBCORES=""
I $D(FBADJ(1)) D
. S FBCORES=$P(^FB(161.91,$P(FBADJ(1),U),0),U,3) ;CORE Scenario
;
; display current list of adjustments when more than 1 allowed
I FBMAX>1!(FBCNT>1) D
. W !!,"Current list of Adjustments: "
. I '$O(FBADJ(0)) W "none"
. S FBI=0 F S FBI=$O(FBADJ(FBI)) Q:'FBI D
. . W ?30,"Code: "
. . W:$P(FBADJ(FBI),U)]"" $P($G(^FB(161.91,$P(FBADJ(FBI),U),0)),U)
. . W ?44,"Group: "
. . W:$P(FBADJ(FBI),U,2)]"" $P($G(^FB(161.92,$P(FBADJ(FBI),U,2),0)),U)
. . W ?56,"Amount: "
. . W "$",$FN($P(FBADJ(FBI),U,3),"",2),!
;
; prompt for adjustment reason
; if max is 1 and reason already on list then automatically select it
I FBMAX=1,FBCNT=1 D
. N FBI,FBADJR
. S FBI=$O(FBADJ(0))
. S:FBI FBADJR=$P(FBADJ(FBI),U)
. I FBADJR S Y=FBADJR_U_$P($G(^FB(161.91,FBADJR,0)),U)
E D I $D(DTOUT)!$D(DUOUT) S FBRET=0 G EXIT ; prompt user
. S DIR(0)="PO^161.91:EMZ"
. S DIR("A")="Select ADJUSTMENT REASON"
. S DIR("S")="I $P($$AR^FBUTL1(Y,,FBDT,,FBCORES),U,4)=1"
. S DIR("?")="Select a HIPAA Adjustment (suspense) Reason Code"
. S DIR("?",1)="Adjustment reason codes explain why the amount paid differs"
. S DIR("?",2)="from the amount claimed."
. D ^DIR K DIR
; if value was entered then process it and ask another if not max and
; total amount suspended has not been accounted for
I +Y>0 D G:FBRET=0 EXIT I FBCNT<FBMAX,FBCAS'=FBTAS G ASKADJ
. S FBADJR=+Y
. ; if specified adj. reason already in list set FBEDIT = it's number
. S (FBI,FBEDIT)=0 F S FBI=$O(FBADJ(FBI)) Q:'FBI D Q:FBEDIT
. . I $P(FBADJ(FBI),U)=FBADJR S FBEDIT=FBI
. S FBNEW=$S(FBEDIT:0,1:1) ; flag as new if not on list
. ; if in list then edit the existing adj. reason
. I FBEDIT D Q:$D(DIRUT) Q:FBADJR=""
. . S DIR(0)="162.558,.01"
. . S DIR("B")=$P($G(^FB(161.91,FBADJR,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)
. . . S FBADJR=""
. . . W " (deleted)"
. . I +Y>0 D S FBADJR=+Y
. . . I +Y'=FBADJR K FBRRMK(FBADJR) ;get rid of rarcs associated with old reason
. . ; ensure new value of edited reason is not already on list
. . S FBI=0 F S FBI=$O(FBADJ(FBI)) Q:'FBI D Q:FBADJR=""
. . . I $P(FBADJ(FBI),U)=FBADJR,FBI'=FBEDIT S FBADJR="" W !,$C(7)," Change was not accepted because the new value is already on the list."
. . Q:FBADJR=""
. . ; upate the existing reason
. . S $P(FBADJ(FBEDIT),U)=FBADJR
. ;
. ; if new reason then add to list
. I 'FBEDIT D Q:FBADJR=""
. . I (FBCNT+1)>FBMAX D Q
. . . S FBADJR=""
. . . W !,$C(7),"ERROR: A new reason would exceed maximum number (",FBMAX,") allowed for this invoice."
. . . W !," Select a reason code on the current list instead."
. . S FBEDIT=$O(FBADJ(" "),-1)+1
. . S $P(FBADJ(FBEDIT),U)=FBADJR,FBCNT=FBCNT+1
. ;
. ; ask for RARCs
. ;I '$D(FBPRICE),$G(FBEXMPT)="Y",'$G(FBDEN) D
. I $D(FBRRMK) M FBRRMKD=FBRRMK
. S FBXX=$$RR^FBUTL4(.FBRRMK,2,FBDT,.FBRRMKD,FBADJR)
. ;
. ; let's do some group processing
. S GRPS=","
. I $D(FBRRMK(FBADJR)) D ;RARCs first
. . S I="" F S I=$O(FBRRMK(FBADJR,I)) Q:'I D
. . . S RRIEN=FBRRMK(FBADJR,I)
. . . I RRIEN,$D(^FB(161.93,RRIEN,3)) D ;if the RARC has groups...
. . . . S AGI=0 F S AGI=$O(^FB(161.93,RRIEN,3,AGI)) Q:'AGI D ;group associations
. . . . . S GIEN=$P(^FB(161.93,RRIEN,3,AGI,0),U)
. . . . . Q:'$D(^FB(161.92,GIEN,0))
. . . . . S GCD=$P(^FB(161.92,GIEN,0),U)
. . . . . I GRPS'[GCD S GRPS=GRPS_GCD_","
. I GRPS=",",$D(^FB(161.91,FBADJR,3)) D ;if the RARCs didn't have groups and the CARC has groups...
. . S AGI=0 F S AGI=$O(^FB(161.91,FBADJR,3,AGI)) Q:'AGI D
. . . S GIEN=$P(^FB(161.91,FBADJR,3,AGI,0),U)
. . . I $D(^FB(161.92,GIEN)) D ;get the codes and string them together
. . . . S GCD=$P(^FB(161.92,GIEN,0),U)
. . . . S GRPS=GRPS_GCD_","
. ; ask for adjustment group
. S DIC=161.92,DIC(0)="AQZ",DIC("A")="ADJUSTMENT GROUP: "
. I $P(FBADJ(FBEDIT),U,2)]"" S DIC("B")=$P($G(^FB(161.92,$P(FBADJ(FBEDIT),U,2),0)),U)
. S DIC("S")="I (GRPS="","")!(GRPS[$P(^(0),U))"
. D ^DIC
. I $D(DTOUT)!$D(DUOUT)!(Y=-1) D:FBNEW DEL(FBEDIT) Q
. S $P(FBADJ(FBEDIT),U,2)=+Y
. K DIC
. ;
. ; ask for adjustment amount
. S DIR(0)="162.558,2"
. ;S DIR(0)="NA^-9999999.99:9999999.99:2^K:+X=0 X"
. ;S DIR("A")=" ADJUSTMENT AMOUNT: "
. S DIR("B")=$FN(FBTAS-FBCAS+$P(FBADJ(FBEDIT),U,3),"",2)
. D ^DIR K DIR I $D(DIRUT) D:FBNEW DEL(FBEDIT) Q
. S FBCAS=FBCAS-$P($G(FBADJ(FBEDIT)),U,3)+Y
. S $P(FBADJ(FBEDIT),U,3)=+Y
;
VAL ; validate
S FBERR=0
I FBCAS'=FBTAS D
. S FBERR=1
. W !,$C(7),"ERROR: Must account for $",$FN(FBTAS-FBCAS,"",2)," more to cover the total amount suspended."
. W !," The current sum of adjustments is $",$FN(FBCAS,"",2),"."
. W !," The total amount suspended is $",$FN(FBTAS,"",2),"."
I FBCNT>FBMAX D
. S FBERR=1
. W !,$C(7),"ERROR: Maximum number of adjustment reasons (",FBMAX,") have been exceeded."
I FBERR G ASKADJ
;
EXIT ;
;CARCless RARCs
S:$G(CLESSR) FBXX=$$CLESSR^FBUTL4A(.FBADJ,FBMAX,.FBRRMK)
;
XEXIT ;
; if time-out or uparrow and total amount not covered then check if
; exit is allowed by the calling routine. (not allowed during edit)
I FBRET=0,FBNOOUT S FBRET=1 I FBTAS'=FBCAS G VAL
I FBRET=0 K FBADJ
;
Q FBRET
;
DEL(FBI) ; delete adjustment reason from list
S FBCAS=FBCAS-$P($G(FBADJ(FBI)),U,3)
S FBCNT=FBCNT-1
K FBADJ(FBI),FBRRMK(FBADJR)
S FBADJR=""
W " (reason deleted)"
Q
;
ADJL(FBADJ) ; build list of adjustments extrinsic function
; Input
; FBADJ - required, array passed by reference
; array adjustments
; format
; FBADJ(#)=FBADJR^FBADJG^FBADJA
; where
; # = integer number greater than 0
; FBADJR = adjustment reason (internal value file 162.91)
; FBADJG = adjustment group (inernal value file 162.92)
; FBADJA = adjustment amount (dollar value)
; Result
; string containing sorted list (by external reason) of adjustments
; format
; FBADJRE 1^FBADJGE 1^FBADJAE 1^FBADJRE 2^FBADJGE 2^FBADJAE 2
; where
; FBADJRE = adjustment reason (external value)
; FBADJGE = adjustment group (external value)
; FBADJAE = adjustment amount (with cents)
N FBRET
N FBARJR,FBADJRE,FBADJG,FBADJGE,FBADJA,FBADJAE
N FBI,FBADJS
S FBRET=""
;
; build sorted array containing external values
S FBI=0 F S FBI=$O(FBADJ(FBI)) Q:'FBI D
. ; obtain internal values
. S FBADJR=$P(FBADJ(FBI),U)
. S FBADJG=$P(FBADJ(FBI),U,2)
. S FBADJA=$P(FBADJ(FBI),U,3)
. ; convert to external values
. S FBADJRE=$S(FBADJR:$P($G(^FB(161.91,FBADJR,0)),U),1:"")
. S FBADJGE=$S(FBADJG:$P($G(^FB(161.92,FBADJG,0)),U),1:"")
. S FBADJAE=$FN(FBADJA,"",2)
. ; store in sorted array
. S FBADJS(FBADJRE_U_FBI)=FBADJRE_U_FBADJGE_U_FBADJAE_U
;
; build list from sorted array
S FBI="" F S FBI=$O(FBADJS(FBI)) Q:FBI="" D
. S FBRET=FBRET_FBADJS(FBI)
; strip trailing "^" from list
I $E(FBRET,$L(FBRET))="^" S FBRET=$E(FBRET,1,$L(FBRET)-1)
;
Q FBRET
;
ADJLR(FBADJL) ; build list of adjustment reasons extrinsic function
; Input
; FBADJL - required, string containing sorted list
; (by external reason) of adjustments (see $$ADJL result)
; Result
; sting of adjustment reasons delimited by commas
;
N FBRET,FBADJRE
N FBI
S FBRET=""
F FBI=1:3 S FBADJRE=$P(FBADJL,U,FBI) Q:FBADJRE="" S FBRET=FBRET_FBADJRE_","
; strip trailing "," from list
I $E(FBRET,$L(FBRET))="," S FBRET=$E(FBRET,1,$L(FBRET)-1)
;
Q FBRET
;
ADJLA(FBADJL) ; build list of adjustment amounts extrinsic function
; Input
; FBADJL - required, string containing sorted list
; (by external reason) of adjustments (see $$ADJL result)
; Result
; sting of adjustment reasons delimited by commas
;
N FBRET,FBADJRE
N FBI
S FBRET=""
F FBI=3:3 S FBADJRE=$P(FBADJL,U,FBI) Q:FBADJRE="" S FBRET=FBRET_FBADJRE_","
; strip trailing "," from list
I $E(FBRET,$L(FBRET))="," S FBRET=$E(FBRET,1,$L(FBRET)-1)
;
Q FBRET
;
;FBUTL2
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBUTL2 10930 printed Dec 13, 2024@02:00:43 Page 2
FBUTL2 ;WOIFO/SAB-FEE BASIS UTILITY ;7/1/2003
+1 ;;3.5;FEE BASIS;**61,73,158**;JAN 30, 1995;Build 94
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
ADJ(FBTAS,FBADJ,FBMAX,FBDT,FBADJD,FBNOOUT,FBRRMK,CLESSR) ; Prompt for adjustments
+1 ;
+2 ; Input
+3 ; FBTAS - required, total amount suspended, number, may be negative
+4 ; the sum of all adjustment amounts must equal this value
+5 ; FBADJ - required, array passed by reference
+6 ; will be initialized (killed)
+7 ; array of any entered adjustments
+8 ; format
+9 ; FBADJ(#)=FBADJR^FBADJG^FBADJA
+10 ; where
+11 ; # = sequentially assigned number starting with 1
+12 ; FBADJR = adjustment reason (internal value file 162.91)
+13 ; FBADJG = adjustment group (inernal value file 162.92)
+14 ; FBADJA = adjustment amount (dollar value)
+15 ; FBMAX - optional, number, default to 1
+16 ; maximum number of adjustments that may be entered by user
+17 ; FBDT - optional, effective date, FileMan internal format
+18 ; default to current date, used to determine available codes
+19 ; FBADJD - optional, array passed by reference
+20 ; same format as FBADJ
+21 ; if passed, it will be used to supply default values
+22 ; normally only used when editing an existing payment
+23 ; FBNOOUT- optional, boolean value, default 0, set =1 if user
+24 ; should not be allowed to exit using an uparrow
+25 ; CLESSR - CARCless RARCs flag; prompt for if 'true'
+26 ;
+27 ; Result (value of $$ADJ extrinsic function)
+28 ; FBRET - boulean value (0 or 1)
+29 ; = 1 when valid adjustments entered
+30 ; = 0 when processed ended due to time-out or entry of '^'
+31 ; Output
+32 ; FBADJ - the FBADJ input array passed by reference will be modified
+33 ; if the result = 1 then it will contain entered adjustments
+34 ; if the result = 0 then it will be undefined
+35 ; FBRRMK - array of remittance remark codes
+36 ;
DBG ;
+1 NEW FBADJR,FBCAS,FBCNT,FBEDIT,FBERR,FBI,FBNEW,FBRET,FBRRMKD
+2 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y,FBXX,FBCORES
+3 SET FBRET=1
+4 SET FBMAX=$GET(FBMAX,1)
+5 SET FBDT=$GET(FBDT,DT)
+6 SET FBNOOUT=$GET(FBNOOUT,0)
+7 SET FBTAS=+FBTAS
+8 KILL FBADJ
+9 ;
+10 ; no adjustment since total amount susp. is 0
IF +FBTAS=0
GOTO EXIT
+11 ;
+12 ; if default adjustments exist then load them into array
+13 IF $DATA(FBADJD)
MERGE FBADJ=FBADJD
+14 SET (FBCNT,FBCAS)=0
+15 IF $DATA(FBADJ)
SET FBI=0
FOR
SET FBI=$ORDER(FBADJ(FBI))
if 'FBI
QUIT
Begin DoDot:1
+16 SET FBCNT=FBCNT+1
+17 SET FBCAS=FBCAS+$PIECE(FBADJ(FBI),U,3)
End DoDot:1
+18 ;
+19 ; if more than one adjustment can be entered then display number
+20 ;
+21 ;
ASKADJ ; multiply prompt for adjustments
+1 ;
+2 ; get default core scenario
+3 SET FBCORES=""
+4 IF $DATA(FBADJ(1))
Begin DoDot:1
+5 ;CORE Scenario
SET FBCORES=$PIECE(^FB(161.91,$PIECE(FBADJ(1),U),0),U,3)
End DoDot:1
+6 ;
+7 ; display current list of adjustments when more than 1 allowed
+8 IF FBMAX>1!(FBCNT>1)
Begin DoDot:1
+9 WRITE !!,"Current list of Adjustments: "
+10 IF '$ORDER(FBADJ(0))
WRITE "none"
+11 SET FBI=0
FOR
SET FBI=$ORDER(FBADJ(FBI))
if 'FBI
QUIT
Begin DoDot:2
+12 WRITE ?30,"Code: "
+13 if $PIECE(FBADJ(FBI),U)]""
WRITE $PIECE($GET(^FB(161.91,$PIECE(FBADJ(FBI),U),0)),U)
+14 WRITE ?44,"Group: "
+15 if $PIECE(FBADJ(FBI),U,2)]""
WRITE $PIECE($GET(^FB(161.92,$PIECE(FBADJ(FBI),U,2),0)),U)
+16 WRITE ?56,"Amount: "
+17 WRITE "$",$FNUMBER($PIECE(FBADJ(FBI),U,3),"",2),!
End DoDot:2
End DoDot:1
+18 ;
+19 ; prompt for adjustment reason
+20 ; if max is 1 and reason already on list then automatically select it
+21 IF FBMAX=1
IF FBCNT=1
Begin DoDot:1
+22 NEW FBI,FBADJR
+23 SET FBI=$ORDER(FBADJ(0))
+24 if FBI
SET FBADJR=$PIECE(FBADJ(FBI),U)
+25 IF FBADJR
SET Y=FBADJR_U_$PIECE($GET(^FB(161.91,FBADJR,0)),U)
End DoDot:1
+26 ; prompt user
IF '$TEST
Begin DoDot:1
+27 SET DIR(0)="PO^161.91:EMZ"
+28 SET DIR("A")="Select ADJUSTMENT REASON"
+29 SET DIR("S")="I $P($$AR^FBUTL1(Y,,FBDT,,FBCORES),U,4)=1"
+30 SET DIR("?")="Select a HIPAA Adjustment (suspense) Reason Code"
+31 SET DIR("?",1)="Adjustment reason codes explain why the amount paid differs"
+32 SET DIR("?",2)="from the amount claimed."
+33 DO ^DIR
KILL DIR
End DoDot:1
IF $DATA(DTOUT)!$DATA(DUOUT)
SET FBRET=0
GOTO EXIT
+34 ; if value was entered then process it and ask another if not max and
+35 ; total amount suspended has not been accounted for
+36 IF +Y>0
Begin DoDot:1
+37 SET FBADJR=+Y
+38 ; if specified adj. reason already in list set FBEDIT = it's number
+39 SET (FBI,FBEDIT)=0
FOR
SET FBI=$ORDER(FBADJ(FBI))
if 'FBI
QUIT
Begin DoDot:2
+40 IF $PIECE(FBADJ(FBI),U)=FBADJR
SET FBEDIT=FBI
End DoDot:2
if FBEDIT
QUIT
+41 ; flag as new if not on list
SET FBNEW=$SELECT(FBEDIT:0,1:1)
+42 ; if in list then edit the existing adj. reason
+43 IF FBEDIT
Begin DoDot:2
+44 SET DIR(0)="162.558,.01"
+45 SET DIR("B")=$PIECE($GET(^FB(161.91,FBADJR,0)),U)
+46 DO ^DIR
KILL DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
if FBMAX=1
SET FBRET=0
QUIT
+47 ; "@" removes from list
IF X="@"
Begin DoDot:3
+48 DO DEL(FBEDIT)
+49 SET FBADJR=""
+50 WRITE " (deleted)"
End DoDot:3
QUIT
+51 IF +Y>0
Begin DoDot:3
+52 ;get rid of rarcs associated with old reason
IF +Y'=FBADJR
KILL FBRRMK(FBADJR)
End DoDot:3
SET FBADJR=+Y
+53 ; ensure new value of edited reason is not already on list
+54 SET FBI=0
FOR
SET FBI=$ORDER(FBADJ(FBI))
if 'FBI
QUIT
Begin DoDot:3
+55 IF $PIECE(FBADJ(FBI),U)=FBADJR
IF FBI'=FBEDIT
SET FBADJR=""
WRITE !,$CHAR(7)," Change was not accepted because the new value is already on the list."
End DoDot:3
if FBADJR=""
QUIT
+56 if FBADJR=""
QUIT
+57 ; upate the existing reason
+58 SET $PIECE(FBADJ(FBEDIT),U)=FBADJR
End DoDot:2
if $DATA(DIRUT)
QUIT
if FBADJR=""
QUIT
+59 ;
+60 ; if new reason then add to list
+61 IF 'FBEDIT
Begin DoDot:2
+62 IF (FBCNT+1)>FBMAX
Begin DoDot:3
+63 SET FBADJR=""
+64 WRITE !,$CHAR(7),"ERROR: A new reason would exceed maximum number (",FBMAX,") allowed for this invoice."
+65 WRITE !," Select a reason code on the current list instead."
End DoDot:3
QUIT
+66 SET FBEDIT=$ORDER(FBADJ(" "),-1)+1
+67 SET $PIECE(FBADJ(FBEDIT),U)=FBADJR
SET FBCNT=FBCNT+1
End DoDot:2
if FBADJR=""
QUIT
+68 ;
+69 ; ask for RARCs
+70 ;I '$D(FBPRICE),$G(FBEXMPT)="Y",'$G(FBDEN) D
+71 IF $DATA(FBRRMK)
MERGE FBRRMKD=FBRRMK
+72 SET FBXX=$$RR^FBUTL4(.FBRRMK,2,FBDT,.FBRRMKD,FBADJR)
+73 ;
+74 ; let's do some group processing
+75 SET GRPS=","
+76 ;RARCs first
IF $DATA(FBRRMK(FBADJR))
Begin DoDot:2
+77 SET I=""
FOR
SET I=$ORDER(FBRRMK(FBADJR,I))
if 'I
QUIT
Begin DoDot:3
+78 SET RRIEN=FBRRMK(FBADJR,I)
+79 ;if the RARC has groups...
IF RRIEN
IF $DATA(^FB(161.93,RRIEN,3))
Begin DoDot:4
+80 ;group associations
SET AGI=0
FOR
SET AGI=$ORDER(^FB(161.93,RRIEN,3,AGI))
if 'AGI
QUIT
Begin DoDot:5
+81 SET GIEN=$PIECE(^FB(161.93,RRIEN,3,AGI,0),U)
+82 if '$DATA(^FB(161.92,GIEN,0))
QUIT
+83 SET GCD=$PIECE(^FB(161.92,GIEN,0),U)
+84 IF GRPS'[GCD
SET GRPS=GRPS_GCD_","
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
+85 ;if the RARCs didn't have groups and the CARC has groups...
IF GRPS=","
IF $DATA(^FB(161.91,FBADJR,3))
Begin DoDot:2
+86 SET AGI=0
FOR
SET AGI=$ORDER(^FB(161.91,FBADJR,3,AGI))
if 'AGI
QUIT
Begin DoDot:3
+87 SET GIEN=$PIECE(^FB(161.91,FBADJR,3,AGI,0),U)
+88 ;get the codes and string them together
IF $DATA(^FB(161.92,GIEN))
Begin DoDot:4
+89 SET GCD=$PIECE(^FB(161.92,GIEN,0),U)
+90 SET GRPS=GRPS_GCD_","
End DoDot:4
End DoDot:3
End DoDot:2
+91 ; ask for adjustment group
+92 SET DIC=161.92
SET DIC(0)="AQZ"
SET DIC("A")="ADJUSTMENT GROUP: "
+93 IF $PIECE(FBADJ(FBEDIT),U,2)]""
SET DIC("B")=$PIECE($GET(^FB(161.92,$PIECE(FBADJ(FBEDIT),U,2),0)),U)
+94 SET DIC("S")="I (GRPS="","")!(GRPS[$P(^(0),U))"
+95 DO ^DIC
+96 IF $DATA(DTOUT)!$DATA(DUOUT)!(Y=-1)
if FBNEW
DO DEL(FBEDIT)
QUIT
+97 SET $PIECE(FBADJ(FBEDIT),U,2)=+Y
+98 KILL DIC
+99 ;
+100 ; ask for adjustment amount
+101 SET DIR(0)="162.558,2"
+102 ;S DIR(0)="NA^-9999999.99:9999999.99:2^K:+X=0 X"
+103 ;S DIR("A")=" ADJUSTMENT AMOUNT: "
+104 SET DIR("B")=$FNUMBER(FBTAS-FBCAS+$PIECE(FBADJ(FBEDIT),U,3),"",2)
+105 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
if FBNEW
DO DEL(FBEDIT)
QUIT
+106 SET FBCAS=FBCAS-$PIECE($GET(FBADJ(FBEDIT)),U,3)+Y
+107 SET $PIECE(FBADJ(FBEDIT),U,3)=+Y
End DoDot:1
if FBRET=0
GOTO EXIT
IF FBCNT<FBMAX
IF FBCAS'=FBTAS
GOTO ASKADJ
+108 ;
VAL ; validate
+1 SET FBERR=0
+2 IF FBCAS'=FBTAS
Begin DoDot:1
+3 SET FBERR=1
+4 WRITE !,$CHAR(7),"ERROR: Must account for $",$FNUMBER(FBTAS-FBCAS,"",2)," more to cover the total amount suspended."
+5 WRITE !," The current sum of adjustments is $",$FNUMBER(FBCAS,"",2),"."
+6 WRITE !," The total amount suspended is $",$FNUMBER(FBTAS,"",2),"."
End DoDot:1
+7 IF FBCNT>FBMAX
Begin DoDot:1
+8 SET FBERR=1
+9 WRITE !,$CHAR(7),"ERROR: Maximum number of adjustment reasons (",FBMAX,") have been exceeded."
End DoDot:1
+10 IF FBERR
GOTO ASKADJ
+11 ;
EXIT ;
+1 ;CARCless RARCs
+2 if $GET(CLESSR)
SET FBXX=$$CLESSR^FBUTL4A(.FBADJ,FBMAX,.FBRRMK)
+3 ;
XEXIT ;
+1 ; if time-out or uparrow and total amount not covered then check if
+2 ; exit is allowed by the calling routine. (not allowed during edit)
+3 IF FBRET=0
IF FBNOOUT
SET FBRET=1
IF FBTAS'=FBCAS
GOTO VAL
+4 IF FBRET=0
KILL FBADJ
+5 ;
+6 QUIT FBRET
+7 ;
DEL(FBI) ; delete adjustment reason from list
+1 SET FBCAS=FBCAS-$PIECE($GET(FBADJ(FBI)),U,3)
+2 SET FBCNT=FBCNT-1
+3 KILL FBADJ(FBI),FBRRMK(FBADJR)
+4 SET FBADJR=""
+5 WRITE " (reason deleted)"
+6 QUIT
+7 ;
ADJL(FBADJ) ; build list of adjustments extrinsic function
+1 ; Input
+2 ; FBADJ - required, array passed by reference
+3 ; array adjustments
+4 ; format
+5 ; FBADJ(#)=FBADJR^FBADJG^FBADJA
+6 ; where
+7 ; # = integer number greater than 0
+8 ; FBADJR = adjustment reason (internal value file 162.91)
+9 ; FBADJG = adjustment group (inernal value file 162.92)
+10 ; FBADJA = adjustment amount (dollar value)
+11 ; Result
+12 ; string containing sorted list (by external reason) of adjustments
+13 ; format
+14 ; FBADJRE 1^FBADJGE 1^FBADJAE 1^FBADJRE 2^FBADJGE 2^FBADJAE 2
+15 ; where
+16 ; FBADJRE = adjustment reason (external value)
+17 ; FBADJGE = adjustment group (external value)
+18 ; FBADJAE = adjustment amount (with cents)
+19 NEW FBRET
+20 NEW FBARJR,FBADJRE,FBADJG,FBADJGE,FBADJA,FBADJAE
+21 NEW FBI,FBADJS
+22 SET FBRET=""
+23 ;
+24 ; build sorted array containing external values
+25 SET FBI=0
FOR
SET FBI=$ORDER(FBADJ(FBI))
if 'FBI
QUIT
Begin DoDot:1
+26 ; obtain internal values
+27 SET FBADJR=$PIECE(FBADJ(FBI),U)
+28 SET FBADJG=$PIECE(FBADJ(FBI),U,2)
+29 SET FBADJA=$PIECE(FBADJ(FBI),U,3)
+30 ; convert to external values
+31 SET FBADJRE=$SELECT(FBADJR:$PIECE($GET(^FB(161.91,FBADJR,0)),U),1:"")
+32 SET FBADJGE=$SELECT(FBADJG:$PIECE($GET(^FB(161.92,FBADJG,0)),U),1:"")
+33 SET FBADJAE=$FNUMBER(FBADJA,"",2)
+34 ; store in sorted array
+35 SET FBADJS(FBADJRE_U_FBI)=FBADJRE_U_FBADJGE_U_FBADJAE_U
End DoDot:1
+36 ;
+37 ; build list from sorted array
+38 SET FBI=""
FOR
SET FBI=$ORDER(FBADJS(FBI))
if FBI=""
QUIT
Begin DoDot:1
+39 SET FBRET=FBRET_FBADJS(FBI)
End DoDot:1
+40 ; strip trailing "^" from list
+41 IF $EXTRACT(FBRET,$LENGTH(FBRET))="^"
SET FBRET=$EXTRACT(FBRET,1,$LENGTH(FBRET)-1)
+42 ;
+43 QUIT FBRET
+44 ;
ADJLR(FBADJL) ; build list of adjustment reasons extrinsic function
+1 ; Input
+2 ; FBADJL - required, string containing sorted list
+3 ; (by external reason) of adjustments (see $$ADJL result)
+4 ; Result
+5 ; sting of adjustment reasons delimited by commas
+6 ;
+7 NEW FBRET,FBADJRE
+8 NEW FBI
+9 SET FBRET=""
+10 FOR FBI=1:3
SET FBADJRE=$PIECE(FBADJL,U,FBI)
if FBADJRE=""
QUIT
SET FBRET=FBRET_FBADJRE_","
+11 ; strip trailing "," from list
+12 IF $EXTRACT(FBRET,$LENGTH(FBRET))=","
SET FBRET=$EXTRACT(FBRET,1,$LENGTH(FBRET)-1)
+13 ;
+14 QUIT FBRET
+15 ;
ADJLA(FBADJL) ; build list of adjustment amounts extrinsic function
+1 ; Input
+2 ; FBADJL - required, string containing sorted list
+3 ; (by external reason) of adjustments (see $$ADJL result)
+4 ; Result
+5 ; sting of adjustment reasons delimited by commas
+6 ;
+7 NEW FBRET,FBADJRE
+8 NEW FBI
+9 SET FBRET=""
+10 FOR FBI=3:3
SET FBADJRE=$PIECE(FBADJL,U,FBI)
if FBADJRE=""
QUIT
SET FBRET=FBRET_FBADJRE_","
+11 ; strip trailing "," from list
+12 IF $EXTRACT(FBRET,$LENGTH(FBRET))=","
SET FBRET=$EXTRACT(FBRET,1,$LENGTH(FBRET)-1)
+13 ;
+14 QUIT FBRET
+15 ;
+16 ;FBUTL2
