- 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 Jan 18, 2025@03:01:56 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