Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: FBUTL2

FBUTL2.m

Go to the documentation of this file.
  1. FBUTL2 ;WOIFO/SAB-FEE BASIS UTILITY ;7/1/2003
  1. ;;3.5;FEE BASIS;**61,73,158**;JAN 30, 1995;Build 94
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. Q
  1. ADJ(FBTAS,FBADJ,FBMAX,FBDT,FBADJD,FBNOOUT,FBRRMK,CLESSR) ; Prompt for adjustments
  1. ;
  1. ; Input
  1. ; FBTAS - required, total amount suspended, number, may be negative
  1. ; the sum of all adjustment amounts must equal this value
  1. ; FBADJ - required, array passed by reference
  1. ; will be initialized (killed)
  1. ; array of any entered adjustments
  1. ; format
  1. ; FBADJ(#)=FBADJR^FBADJG^FBADJA
  1. ; where
  1. ; # = sequentially assigned number starting with 1
  1. ; FBADJR = adjustment reason (internal value file 162.91)
  1. ; FBADJG = adjustment group (inernal value file 162.92)
  1. ; FBADJA = adjustment amount (dollar value)
  1. ; FBMAX - optional, number, default to 1
  1. ; maximum number of adjustments that may be entered by user
  1. ; FBDT - optional, effective date, FileMan internal format
  1. ; default to current date, used to determine available codes
  1. ; FBADJD - optional, array passed by reference
  1. ; same format as FBADJ
  1. ; if passed, it will be used to supply default values
  1. ; normally only used when editing an existing payment
  1. ; FBNOOUT- optional, boolean value, default 0, set =1 if user
  1. ; should not be allowed to exit using an uparrow
  1. ; CLESSR - CARCless RARCs flag; prompt for if 'true'
  1. ;
  1. ; Result (value of $$ADJ extrinsic function)
  1. ; FBRET - boulean value (0 or 1)
  1. ; = 1 when valid adjustments entered
  1. ; = 0 when processed ended due to time-out or entry of '^'
  1. ; Output
  1. ; FBADJ - the FBADJ input array passed by reference will be modified
  1. ; if the result = 1 then it will contain entered adjustments
  1. ; if the result = 0 then it will be undefined
  1. ; FBRRMK - array of remittance remark codes
  1. ;
  1. DBG ;
  1. N FBADJR,FBCAS,FBCNT,FBEDIT,FBERR,FBI,FBNEW,FBRET,FBRRMKD
  1. N DIR,DIRUT,DTOUT,DUOUT,X,Y,FBXX,FBCORES
  1. S FBRET=1
  1. S FBMAX=$G(FBMAX,1)
  1. S FBDT=$G(FBDT,DT)
  1. S FBNOOUT=$G(FBNOOUT,0)
  1. S FBTAS=+FBTAS
  1. K FBADJ
  1. ;
  1. I +FBTAS=0 G EXIT ; no adjustment since total amount susp. is 0
  1. ;
  1. ; if default adjustments exist then load them into array
  1. I $D(FBADJD) M FBADJ=FBADJD
  1. S (FBCNT,FBCAS)=0
  1. I $D(FBADJ) S FBI=0 F S FBI=$O(FBADJ(FBI)) Q:'FBI D
  1. . S FBCNT=FBCNT+1
  1. . S FBCAS=FBCAS+$P(FBADJ(FBI),U,3)
  1. ;
  1. ; if more than one adjustment can be entered then display number
  1. ;
  1. ;
  1. ASKADJ ; multiply prompt for adjustments
  1. ;
  1. ; get default core scenario
  1. S FBCORES=""
  1. I $D(FBADJ(1)) D
  1. . S FBCORES=$P(^FB(161.91,$P(FBADJ(1),U),0),U,3) ;CORE Scenario
  1. ;
  1. ; display current list of adjustments when more than 1 allowed
  1. I FBMAX>1!(FBCNT>1) D
  1. . W !!,"Current list of Adjustments: "
  1. . I '$O(FBADJ(0)) W "none"
  1. . S FBI=0 F S FBI=$O(FBADJ(FBI)) Q:'FBI D
  1. . . W ?30,"Code: "
  1. . . W:$P(FBADJ(FBI),U)]"" $P($G(^FB(161.91,$P(FBADJ(FBI),U),0)),U)
  1. . . W ?44,"Group: "
  1. . . W:$P(FBADJ(FBI),U,2)]"" $P($G(^FB(161.92,$P(FBADJ(FBI),U,2),0)),U)
  1. . . W ?56,"Amount: "
  1. . . W "$",$FN($P(FBADJ(FBI),U,3),"",2),!
  1. ;
  1. ; prompt for adjustment reason
  1. ; if max is 1 and reason already on list then automatically select it
  1. I FBMAX=1,FBCNT=1 D
  1. . N FBI,FBADJR
  1. . S FBI=$O(FBADJ(0))
  1. . S:FBI FBADJR=$P(FBADJ(FBI),U)
  1. . I FBADJR S Y=FBADJR_U_$P($G(^FB(161.91,FBADJR,0)),U)
  1. E D I $D(DTOUT)!$D(DUOUT) S FBRET=0 G EXIT ; prompt user
  1. . S DIR(0)="PO^161.91:EMZ"
  1. . S DIR("A")="Select ADJUSTMENT REASON"
  1. . S DIR("S")="I $P($$AR^FBUTL1(Y,,FBDT,,FBCORES),U,4)=1"
  1. . S DIR("?")="Select a HIPAA Adjustment (suspense) Reason Code"
  1. . S DIR("?",1)="Adjustment reason codes explain why the amount paid differs"
  1. . S DIR("?",2)="from the amount claimed."
  1. . D ^DIR K DIR
  1. ; if value was entered then process it and ask another if not max and
  1. ; total amount suspended has not been accounted for
  1. I +Y>0 D G:FBRET=0 EXIT I FBCNT<FBMAX,FBCAS'=FBTAS G ASKADJ
  1. . S FBADJR=+Y
  1. . ; if specified adj. reason already in list set FBEDIT = it's number
  1. . S (FBI,FBEDIT)=0 F S FBI=$O(FBADJ(FBI)) Q:'FBI D Q:FBEDIT
  1. . . I $P(FBADJ(FBI),U)=FBADJR S FBEDIT=FBI
  1. . S FBNEW=$S(FBEDIT:0,1:1) ; flag as new if not on list
  1. . ; if in list then edit the existing adj. reason
  1. . I FBEDIT D Q:$D(DIRUT) Q:FBADJR=""
  1. . . S DIR(0)="162.558,.01"
  1. . . S DIR("B")=$P($G(^FB(161.91,FBADJR,0)),U)
  1. . . D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S:FBMAX=1 FBRET=0 Q
  1. . . I X="@" D Q ; "@" removes from list
  1. . . . D DEL(FBEDIT)
  1. . . . S FBADJR=""
  1. . . . W " (deleted)"
  1. . . I +Y>0 D S FBADJR=+Y
  1. . . . I +Y'=FBADJR K FBRRMK(FBADJR) ;get rid of rarcs associated with old reason
  1. . . ; ensure new value of edited reason is not already on list
  1. . . S FBI=0 F S FBI=$O(FBADJ(FBI)) Q:'FBI D Q:FBADJR=""
  1. . . . 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."
  1. . . Q:FBADJR=""
  1. . . ; upate the existing reason
  1. . . S $P(FBADJ(FBEDIT),U)=FBADJR
  1. . ;
  1. . ; if new reason then add to list
  1. . I 'FBEDIT D Q:FBADJR=""
  1. . . I (FBCNT+1)>FBMAX D Q
  1. . . . S FBADJR=""
  1. . . . W !,$C(7),"ERROR: A new reason would exceed maximum number (",FBMAX,") allowed for this invoice."
  1. . . . W !," Select a reason code on the current list instead."
  1. . . S FBEDIT=$O(FBADJ(" "),-1)+1
  1. . . S $P(FBADJ(FBEDIT),U)=FBADJR,FBCNT=FBCNT+1
  1. . ;
  1. . ; ask for RARCs
  1. . ;I '$D(FBPRICE),$G(FBEXMPT)="Y",'$G(FBDEN) D
  1. . I $D(FBRRMK) M FBRRMKD=FBRRMK
  1. . S FBXX=$$RR^FBUTL4(.FBRRMK,2,FBDT,.FBRRMKD,FBADJR)
  1. . ;
  1. . ; let's do some group processing
  1. . S GRPS=","
  1. . I $D(FBRRMK(FBADJR)) D ;RARCs first
  1. . . S I="" F S I=$O(FBRRMK(FBADJR,I)) Q:'I D
  1. . . . S RRIEN=FBRRMK(FBADJR,I)
  1. . . . I RRIEN,$D(^FB(161.93,RRIEN,3)) D ;if the RARC has groups...
  1. . . . . S AGI=0 F S AGI=$O(^FB(161.93,RRIEN,3,AGI)) Q:'AGI D ;group associations
  1. . . . . . S GIEN=$P(^FB(161.93,RRIEN,3,AGI,0),U)
  1. . . . . . Q:'$D(^FB(161.92,GIEN,0))
  1. . . . . . S GCD=$P(^FB(161.92,GIEN,0),U)
  1. . . . . . I GRPS'[GCD S GRPS=GRPS_GCD_","
  1. . I GRPS=",",$D(^FB(161.91,FBADJR,3)) D ;if the RARCs didn't have groups and the CARC has groups...
  1. . . S AGI=0 F S AGI=$O(^FB(161.91,FBADJR,3,AGI)) Q:'AGI D
  1. . . . S GIEN=$P(^FB(161.91,FBADJR,3,AGI,0),U)
  1. . . . I $D(^FB(161.92,GIEN)) D ;get the codes and string them together
  1. . . . . S GCD=$P(^FB(161.92,GIEN,0),U)
  1. . . . . S GRPS=GRPS_GCD_","
  1. . ; ask for adjustment group
  1. . S DIC=161.92,DIC(0)="AQZ",DIC("A")="ADJUSTMENT GROUP: "
  1. . I $P(FBADJ(FBEDIT),U,2)]"" S DIC("B")=$P($G(^FB(161.92,$P(FBADJ(FBEDIT),U,2),0)),U)
  1. . S DIC("S")="I (GRPS="","")!(GRPS[$P(^(0),U))"
  1. . D ^DIC
  1. . I $D(DTOUT)!$D(DUOUT)!(Y=-1) D:FBNEW DEL(FBEDIT) Q
  1. . S $P(FBADJ(FBEDIT),U,2)=+Y
  1. . K DIC
  1. . ;
  1. . ; ask for adjustment amount
  1. . S DIR(0)="162.558,2"
  1. . ;S DIR(0)="NA^-9999999.99:9999999.99:2^K:+X=0 X"
  1. . ;S DIR("A")=" ADJUSTMENT AMOUNT: "
  1. . S DIR("B")=$FN(FBTAS-FBCAS+$P(FBADJ(FBEDIT),U,3),"",2)
  1. . D ^DIR K DIR I $D(DIRUT) D:FBNEW DEL(FBEDIT) Q
  1. . S FBCAS=FBCAS-$P($G(FBADJ(FBEDIT)),U,3)+Y
  1. . S $P(FBADJ(FBEDIT),U,3)=+Y
  1. ;
  1. VAL ; validate
  1. S FBERR=0
  1. I FBCAS'=FBTAS D
  1. . S FBERR=1
  1. . W !,$C(7),"ERROR: Must account for $",$FN(FBTAS-FBCAS,"",2)," more to cover the total amount suspended."
  1. . W !," The current sum of adjustments is $",$FN(FBCAS,"",2),"."
  1. . W !," The total amount suspended is $",$FN(FBTAS,"",2),"."
  1. I FBCNT>FBMAX D
  1. . S FBERR=1
  1. . W !,$C(7),"ERROR: Maximum number of adjustment reasons (",FBMAX,") have been exceeded."
  1. I FBERR G ASKADJ
  1. ;
  1. EXIT ;
  1. ;CARCless RARCs
  1. S:$G(CLESSR) FBXX=$$CLESSR^FBUTL4A(.FBADJ,FBMAX,.FBRRMK)
  1. ;
  1. XEXIT ;
  1. ; if time-out or uparrow and total amount not covered then check if
  1. ; exit is allowed by the calling routine. (not allowed during edit)
  1. I FBRET=0,FBNOOUT S FBRET=1 I FBTAS'=FBCAS G VAL
  1. I FBRET=0 K FBADJ
  1. ;
  1. Q FBRET
  1. ;
  1. DEL(FBI) ; delete adjustment reason from list
  1. S FBCAS=FBCAS-$P($G(FBADJ(FBI)),U,3)
  1. S FBCNT=FBCNT-1
  1. K FBADJ(FBI),FBRRMK(FBADJR)
  1. S FBADJR=""
  1. W " (reason deleted)"
  1. Q
  1. ;
  1. ADJL(FBADJ) ; build list of adjustments extrinsic function
  1. ; Input
  1. ; FBADJ - required, array passed by reference
  1. ; array adjustments
  1. ; format
  1. ; FBADJ(#)=FBADJR^FBADJG^FBADJA
  1. ; where
  1. ; # = integer number greater than 0
  1. ; FBADJR = adjustment reason (internal value file 162.91)
  1. ; FBADJG = adjustment group (inernal value file 162.92)
  1. ; FBADJA = adjustment amount (dollar value)
  1. ; Result
  1. ; string containing sorted list (by external reason) of adjustments
  1. ; format
  1. ; FBADJRE 1^FBADJGE 1^FBADJAE 1^FBADJRE 2^FBADJGE 2^FBADJAE 2
  1. ; where
  1. ; FBADJRE = adjustment reason (external value)
  1. ; FBADJGE = adjustment group (external value)
  1. ; FBADJAE = adjustment amount (with cents)
  1. N FBRET
  1. N FBARJR,FBADJRE,FBADJG,FBADJGE,FBADJA,FBADJAE
  1. N FBI,FBADJS
  1. S FBRET=""
  1. ;
  1. ; build sorted array containing external values
  1. S FBI=0 F S FBI=$O(FBADJ(FBI)) Q:'FBI D
  1. . ; obtain internal values
  1. . S FBADJR=$P(FBADJ(FBI),U)
  1. . S FBADJG=$P(FBADJ(FBI),U,2)
  1. . S FBADJA=$P(FBADJ(FBI),U,3)
  1. . ; convert to external values
  1. . S FBADJRE=$S(FBADJR:$P($G(^FB(161.91,FBADJR,0)),U),1:"")
  1. . S FBADJGE=$S(FBADJG:$P($G(^FB(161.92,FBADJG,0)),U),1:"")
  1. . S FBADJAE=$FN(FBADJA,"",2)
  1. . ; store in sorted array
  1. . S FBADJS(FBADJRE_U_FBI)=FBADJRE_U_FBADJGE_U_FBADJAE_U
  1. ;
  1. ; build list from sorted array
  1. S FBI="" F S FBI=$O(FBADJS(FBI)) Q:FBI="" D
  1. . S FBRET=FBRET_FBADJS(FBI)
  1. ; strip trailing "^" from list
  1. I $E(FBRET,$L(FBRET))="^" S FBRET=$E(FBRET,1,$L(FBRET)-1)
  1. ;
  1. Q FBRET
  1. ;
  1. ADJLR(FBADJL) ; build list of adjustment reasons extrinsic function
  1. ; Input
  1. ; FBADJL - required, string containing sorted list
  1. ; (by external reason) of adjustments (see $$ADJL result)
  1. ; Result
  1. ; sting of adjustment reasons delimited by commas
  1. ;
  1. N FBRET,FBADJRE
  1. N FBI
  1. S FBRET=""
  1. F FBI=1:3 S FBADJRE=$P(FBADJL,U,FBI) Q:FBADJRE="" S FBRET=FBRET_FBADJRE_","
  1. ; strip trailing "," from list
  1. I $E(FBRET,$L(FBRET))="," S FBRET=$E(FBRET,1,$L(FBRET)-1)
  1. ;
  1. Q FBRET
  1. ;
  1. ADJLA(FBADJL) ; build list of adjustment amounts extrinsic function
  1. ; Input
  1. ; FBADJL - required, string containing sorted list
  1. ; (by external reason) of adjustments (see $$ADJL result)
  1. ; Result
  1. ; sting of adjustment reasons delimited by commas
  1. ;
  1. N FBRET,FBADJRE
  1. N FBI
  1. S FBRET=""
  1. F FBI=3:3 S FBADJRE=$P(FBADJL,U,FBI) Q:FBADJRE="" S FBRET=FBRET_FBADJRE_","
  1. ; strip trailing "," from list
  1. I $E(FBRET,$L(FBRET))="," S FBRET=$E(FBRET,1,$L(FBRET)-1)
  1. ;
  1. Q FBRET
  1. ;
  1. ;FBUTL2