- FBAAUTL4 ;AISC/CMR,dmk,WCIOFO/SAB-UTILITY ROUTINE ; 8/21/12 3:39pm
- ;;3.5;FEE BASIS;**4,32,77,81,144**;JAN 30, 1995;Build 8
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- CPT(X,Y,FBSRVDT) ;return external format of CPT code
- ;INPUT X = ien of CPT
- ;optional Y I Y return description, I 'Y return external format of CPT
- ;optional FBSRVDT - date of service
- ;OUTPUT external format of CPT code or description of CPT code
- I '$G(X) Q ""
- N Z
- S Z=$$CPT^ICPTCOD(X,$S($G(FBSRVDT)>0:+$G(FBSRVDT),1:""),1)
- Q $S('$G(Y):$P(Z,U,2),1:$P(Z,U,3))
- ;
- MOD(X,Y,FBSRVDT) ;return external format of modifier
- ;INPUT X = ien of modifier
- ;optional Y I Y return description, I 'Y return external format of mod
- ;optional FBSRVDT - date of service
- ;OUTPUT external format of modifier or description of CPT code
- I '$G(X) Q ""
- N Z
- S Z=$$MOD^ICPTMOD(X,"I",$S($G(FBSRVDT)>0:+$G(FBSRVDT),1:""),1)
- Q $S('$G(Y):$P(Z,U,2),1:$P(Z,U,3))
- ;
- CPTDATA(W,X,Y,Z) ;get internal value of CPT
- ; input
- ; W = IEN of PATIENT in file 162
- ; X = IEN of VENDOR multiple in file 162
- ; Y = IEN of INITIAL TREATMENT DATE multiple in file 162
- ; Z = IEN of SERVICE PROVIDED multiple in file 162
- ; returns
- ; value of SERVICE PROVIDED (internal)
- ;
- I '$G(W)!('$G(X))!('$G(Y))!('$G(Z)) Q ""
- Q $P($G(^FBAAC(W,1,X,1,Y,1,Z,0)),U)
- ;
- MODDATA(W,X,Y,Z) ;get internal values of CPT Modifier
- ; input
- ; W = IEN of PATIENT in file 162
- ; X = IEN of VENDOR multiple in file 162
- ; Y = IEN of INITIAL TREATMENT DATE multiple in file 162
- ; Z = IEN of SERVICE PROVIDED multiple in file 162
- ; output
- ; FBMODA( array of CPT MODIFIERs
- ; FBMODA(#)=CPT MODIFIER (internal value)
- ; where # is the IEN for an entry in the CPT MODIFIER multiple
- K FBMODA
- I '$G(W)!('$G(X))!('$G(Y))!('$G(Z)) Q
- N FBI,FBMOD
- S FBI=0 F S FBI=$O(^FBAAC(W,1,X,1,Y,1,Z,"M",FBI)) Q:'FBI D
- . S FBMOD=$P($G(^FBAAC(W,1,X,1,Y,1,Z,"M",FBI,0)),U)
- . Q:FBMOD=""
- . S FBMODA(FBI)=FBMOD
- Q
- ;
- APS(FBJ,FBK,FBL,FBM) ; amount paid symbol
- ; input
- ; FBJ = IEN of PATIENT in file 162
- ; FBK = IEN of VENDOR multiple in file 162
- ; FBL = IEN of INITIAL TREATMENT DATE multiple in file 162
- ; FBM = IEN of SERVICE PROVIDED multiple in file 162
- ; returns symbol
- ; where value is M (Mill Bill emergency care - 38 U.S.C. 1725)
- ; R (RBRVS fee schedule amount)
- ; F (VA fee schedule amount)
- ; C (contracted service amount)
- ; U (usual & customary - claimed)
- ; null if no amount paid
- N FBAP,FBRET,FBY0,FBY2
- S FBRET=""
- S FBY0=$G(^FBAAC(FBJ,1,FBK,1,FBL,1,FBM,0))
- S FBY2=$G(^FBAAC(FBJ,1,FBK,1,FBL,1,FBM,2))
- S FBAP=$P(FBY0,U,3)
- I FBAP>0 D
- . ; FB*3.5*144 Changed order of evaluation, setting Mill-Bill first as
- . ; this coding takes precedence.
- . ; Mill Bill payments
- . I "^39^52^"[(U_$P($G(^FBAA(161.82,+$P(FBY0,U,18),0)),U,3)_U) S FBRET="M" Q
- . ; use fee schedule info for payment (if any)
- . I +FBAP=+$P(FBY2,U,12) S FBRET=$P(FBY2,U,13) Q:FBRET]""
- . ; if no fee schedule info then calc 75th percentile and check
- . I $P(FBY2,U,12)="" D Q:FBRET]""
- . . S FBCPT=$$CPT($P(FBY0,U))
- . . S FBMODL=$$MODL("^FBAAC("_FBJ_",1,"_FBK_",1,"_FBL_",1,"_FBM_",""M"")","E")
- . . S FBDOS=$P($G(^FBAAC(FBJ,1,FBK,1,FBL,0)),U)
- . . I +FBAP=+$$PRCTL^FBAAFSF(FBCPT,FBMODL,FBDOS) S FBRET="F"
- . ; since not paid by a fee schedule, check prompt pay type
- . I $P(FBY2,U,2) S FBRET="C" Q
- . ; all other payments considered u&c
- . S FBRET="U"
- Q FBRET
- ;
- CHKBI(X,Y) ;called to determine if batch number or invoice number
- ;already exists
- ;X= next batch/invoice number
- ;Y=1 if Batch
- ;Y undefined if invoice number passed
- ;returns a truth if X is ok for next batch/invoice #
- ;
- I 'X Q ""
- I $G(Y) Q $S($D(^FBAA(161.7,"B",X)):"",1:1)
- I '$G(Y) Q $S($D(^FBAA(162.1,"B",X)):"",$D(^FBAAI("B",X)):"",$D(^FBAAC("C",X)):"",1:1)
- ;
- MODL(FBAN,FBFLAG) ;return sorted list given array of modifiers
- ; Input
- ; FBAN - closed root of array containing modifiers
- ; the data must be in nodes descendent from this root.
- ; The subscripts of the nodes below FBAN must be
- ; positive numbers. The CPT MODIFIER internal value
- ; must be the first piece in these nodes or in the
- ; 0-node descendent from these nodes.
- ; i.e.
- ; ARRAY(number)=CPT MODIFIER (internal value)
- ; OR
- ; ARRAY(number,0)=CPT MODIFIER (internal value)
- ; FBFLAG - (optional) flag, E or I, default I
- ; I to return internal values of modifiers
- ; E to return external values of modifiers
- ; Returns string of sorted modifiers (e.g. "1,3,7")
- ;
- N FBI,FBRET,FBSORT,FBX,FBZERO
- S FBRET=""
- S FBFLAG=$G(FBFLAG,"I")
- ;
- ; if any descendent data then determine if it is 0-node descendent
- S FBZERO=0 I $O(@FBAN@(0)),$D(@FBAN@($O(@FBAN@(0)),0))#2 S FBZERO=1
- ;
- ; loop thru input array and place modifiers in a sort array
- S FBI=0 F S FBI=$O(@FBAN@(FBI)) Q:'FBI D
- . ; get the cpt modifier
- . I FBZERO S FBX=$P(@FBAN@(FBI,0),U)
- . E S FBX=$P(@FBAN@(FBI),U)
- . I FBFLAG="E" D
- . . ; convert to external value
- . . S FBX=$$MOD^ICPTMOD(FBX,"I")
- . . I FBX>0 S FBX=$P(FBX,U,2)
- . . E S FBX=""
- . I FBX]"" S FBSORT(FBX)=""
- ;
- ; loop thru sorted array and add the modifiers to return value
- S FBX="" F S FBX=$O(FBSORT(FBX)) Q:FBX="" S FBRET=FBRET_","_FBX
- ;
- ; strip leading comma (if any)
- I $E(FBRET)="," S FBRET=$E(FBRET,2,999)
- ;
- ; return value
- Q FBRET
- ;
- REPMOD(FBJ,FBK,FBL,FBM) ; Replace CPT Modifier(s) in payment
- ; input
- ; FBJ = IEN of PATIENT in file 162
- ; FBK = IEN of VENDOR multiple in file 162
- ; FBL = IEN of INITIAL TREATMENT DATE multiple in file 162
- ; FBM = IEN of SERVICE PROVIDED multiple in file 162
- ; FBMODA( array of modifiers
- ; where FBMODA(number)=CPT Modifier (internal)
- ;
- N FBI,FBIENS,FBFDA
- S FBIENS=FBM_","_FBL_","_FBK_","_FBJ_","
- ;
- ; delete any existing CPT MODIFIER entries from global
- I $O(^FBAAC(FBJ,1,FBK,1,FBL,1,FBM,"M",0)) D
- . K FBFDA S FBI=0
- . F S FBI=$O(^FBAAC(FBJ,1,FBK,1,FBL,1,FBM,"M",FBI)) Q:'FBI D
- . . S FBFDA(162.06,FBI_","_FBIENS,.01)="@"
- . D FILE^DIE("","FBFDA") D MSG^DIALOG()
- ;
- ; create CPT MODIFIER entries from data in array FBMODA
- I $O(FBMODA(0)) D
- . K FBFDA S FBI=0 F S FBI=$O(FBMODA(FBI)) Q:'FBI D
- . . S FBFDA(162.06,"+"_FBI_","_FBIENS,.01)=FBMODA(FBI)
- . D UPDATE^DIE("","FBFDA") D MSG^DIALOG()
- ;
- Q
- ;
- ;FBAAUTL4
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAAUTL4 6603 printed Jan 18, 2025@02:58:02 Page 2
- FBAAUTL4 ;AISC/CMR,dmk,WCIOFO/SAB-UTILITY ROUTINE ; 8/21/12 3:39pm
- +1 ;;3.5;FEE BASIS;**4,32,77,81,144**;JAN 30, 1995;Build 8
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 ;
- CPT(X,Y,FBSRVDT) ;return external format of CPT code
- +1 ;INPUT X = ien of CPT
- +2 ;optional Y I Y return description, I 'Y return external format of CPT
- +3 ;optional FBSRVDT - date of service
- +4 ;OUTPUT external format of CPT code or description of CPT code
- +5 IF '$GET(X)
- QUIT ""
- +6 NEW Z
- +7 SET Z=$$CPT^ICPTCOD(X,$SELECT($GET(FBSRVDT)>0:+$GET(FBSRVDT),1:""),1)
- +8 QUIT $SELECT('$GET(Y):$PIECE(Z,U,2),1:$PIECE(Z,U,3))
- +9 ;
- MOD(X,Y,FBSRVDT) ;return external format of modifier
- +1 ;INPUT X = ien of modifier
- +2 ;optional Y I Y return description, I 'Y return external format of mod
- +3 ;optional FBSRVDT - date of service
- +4 ;OUTPUT external format of modifier or description of CPT code
- +5 IF '$GET(X)
- QUIT ""
- +6 NEW Z
- +7 SET Z=$$MOD^ICPTMOD(X,"I",$SELECT($GET(FBSRVDT)>0:+$GET(FBSRVDT),1:""),1)
- +8 QUIT $SELECT('$GET(Y):$PIECE(Z,U,2),1:$PIECE(Z,U,3))
- +9 ;
- CPTDATA(W,X,Y,Z) ;get internal value of CPT
- +1 ; input
- +2 ; W = IEN of PATIENT in file 162
- +3 ; X = IEN of VENDOR multiple in file 162
- +4 ; Y = IEN of INITIAL TREATMENT DATE multiple in file 162
- +5 ; Z = IEN of SERVICE PROVIDED multiple in file 162
- +6 ; returns
- +7 ; value of SERVICE PROVIDED (internal)
- +8 ;
- +9 IF '$GET(W)!('$GET(X))!('$GET(Y))!('$GET(Z))
- QUIT ""
- +10 QUIT $PIECE($GET(^FBAAC(W,1,X,1,Y,1,Z,0)),U)
- +11 ;
- MODDATA(W,X,Y,Z) ;get internal values of CPT Modifier
- +1 ; input
- +2 ; W = IEN of PATIENT in file 162
- +3 ; X = IEN of VENDOR multiple in file 162
- +4 ; Y = IEN of INITIAL TREATMENT DATE multiple in file 162
- +5 ; Z = IEN of SERVICE PROVIDED multiple in file 162
- +6 ; output
- +7 ; FBMODA( array of CPT MODIFIERs
- +8 ; FBMODA(#)=CPT MODIFIER (internal value)
- +9 ; where # is the IEN for an entry in the CPT MODIFIER multiple
- +10 KILL FBMODA
- +11 IF '$GET(W)!('$GET(X))!('$GET(Y))!('$GET(Z))
- QUIT
- +12 NEW FBI,FBMOD
- +13 SET FBI=0
- FOR
- SET FBI=$ORDER(^FBAAC(W,1,X,1,Y,1,Z,"M",FBI))
- if 'FBI
- QUIT
- Begin DoDot:1
- +14 SET FBMOD=$PIECE($GET(^FBAAC(W,1,X,1,Y,1,Z,"M",FBI,0)),U)
- +15 if FBMOD=""
- QUIT
- +16 SET FBMODA(FBI)=FBMOD
- End DoDot:1
- +17 QUIT
- +18 ;
- APS(FBJ,FBK,FBL,FBM) ; amount paid symbol
- +1 ; input
- +2 ; FBJ = IEN of PATIENT in file 162
- +3 ; FBK = IEN of VENDOR multiple in file 162
- +4 ; FBL = IEN of INITIAL TREATMENT DATE multiple in file 162
- +5 ; FBM = IEN of SERVICE PROVIDED multiple in file 162
- +6 ; returns symbol
- +7 ; where value is M (Mill Bill emergency care - 38 U.S.C. 1725)
- +8 ; R (RBRVS fee schedule amount)
- +9 ; F (VA fee schedule amount)
- +10 ; C (contracted service amount)
- +11 ; U (usual & customary - claimed)
- +12 ; null if no amount paid
- +13 NEW FBAP,FBRET,FBY0,FBY2
- +14 SET FBRET=""
- +15 SET FBY0=$GET(^FBAAC(FBJ,1,FBK,1,FBL,1,FBM,0))
- +16 SET FBY2=$GET(^FBAAC(FBJ,1,FBK,1,FBL,1,FBM,2))
- +17 SET FBAP=$PIECE(FBY0,U,3)
- +18 IF FBAP>0
- Begin DoDot:1
- +19 ; FB*3.5*144 Changed order of evaluation, setting Mill-Bill first as
- +20 ; this coding takes precedence.
- +21 ; Mill Bill payments
- +22 IF "^39^52^"[(U_$PIECE($GET(^FBAA(161.82,+$PIECE(FBY0,U,18),0)),U,3)_U)
- SET FBRET="M"
- QUIT
- +23 ; use fee schedule info for payment (if any)
- +24 IF +FBAP=+$PIECE(FBY2,U,12)
- SET FBRET=$PIECE(FBY2,U,13)
- if FBRET]""
- QUIT
- +25 ; if no fee schedule info then calc 75th percentile and check
- +26 IF $PIECE(FBY2,U,12)=""
- Begin DoDot:2
- +27 SET FBCPT=$$CPT($PIECE(FBY0,U))
- +28 SET FBMODL=$$MODL("^FBAAC("_FBJ_",1,"_FBK_",1,"_FBL_",1,"_FBM_",""M"")","E")
- +29 SET FBDOS=$PIECE($GET(^FBAAC(FBJ,1,FBK,1,FBL,0)),U)
- +30 IF +FBAP=+$$PRCTL^FBAAFSF(FBCPT,FBMODL,FBDOS)
- SET FBRET="F"
- End DoDot:2
- if FBRET]""
- QUIT
- +31 ; since not paid by a fee schedule, check prompt pay type
- +32 IF $PIECE(FBY2,U,2)
- SET FBRET="C"
- QUIT
- +33 ; all other payments considered u&c
- +34 SET FBRET="U"
- End DoDot:1
- +35 QUIT FBRET
- +36 ;
- CHKBI(X,Y) ;called to determine if batch number or invoice number
- +1 ;already exists
- +2 ;X= next batch/invoice number
- +3 ;Y=1 if Batch
- +4 ;Y undefined if invoice number passed
- +5 ;returns a truth if X is ok for next batch/invoice #
- +6 ;
- +7 IF 'X
- QUIT ""
- +8 IF $GET(Y)
- QUIT $SELECT($DATA(^FBAA(161.7,"B",X)):"",1:1)
- +9 IF '$GET(Y)
- QUIT $SELECT($DATA(^FBAA(162.1,"B",X)):"",$DATA(^FBAAI("B",X)):"",$DATA(^FBAAC("C",X)):"",1:1)
- +10 ;
- MODL(FBAN,FBFLAG) ;return sorted list given array of modifiers
- +1 ; Input
- +2 ; FBAN - closed root of array containing modifiers
- +3 ; the data must be in nodes descendent from this root.
- +4 ; The subscripts of the nodes below FBAN must be
- +5 ; positive numbers. The CPT MODIFIER internal value
- +6 ; must be the first piece in these nodes or in the
- +7 ; 0-node descendent from these nodes.
- +8 ; i.e.
- +9 ; ARRAY(number)=CPT MODIFIER (internal value)
- +10 ; OR
- +11 ; ARRAY(number,0)=CPT MODIFIER (internal value)
- +12 ; FBFLAG - (optional) flag, E or I, default I
- +13 ; I to return internal values of modifiers
- +14 ; E to return external values of modifiers
- +15 ; Returns string of sorted modifiers (e.g. "1,3,7")
- +16 ;
- +17 NEW FBI,FBRET,FBSORT,FBX,FBZERO
- +18 SET FBRET=""
- +19 SET FBFLAG=$GET(FBFLAG,"I")
- +20 ;
- +21 ; if any descendent data then determine if it is 0-node descendent
- +22 SET FBZERO=0
- IF $ORDER(@FBAN@(0))
- IF $DATA(@FBAN@($ORDER(@FBAN@(0)),0))#2
- SET FBZERO=1
- +23 ;
- +24 ; loop thru input array and place modifiers in a sort array
- +25 SET FBI=0
- FOR
- SET FBI=$ORDER(@FBAN@(FBI))
- if 'FBI
- QUIT
- Begin DoDot:1
- +26 ; get the cpt modifier
- +27 IF FBZERO
- SET FBX=$PIECE(@FBAN@(FBI,0),U)
- +28 IF '$TEST
- SET FBX=$PIECE(@FBAN@(FBI),U)
- +29 IF FBFLAG="E"
- Begin DoDot:2
- +30 ; convert to external value
- +31 SET FBX=$$MOD^ICPTMOD(FBX,"I")
- +32 IF FBX>0
- SET FBX=$PIECE(FBX,U,2)
- +33 IF '$TEST
- SET FBX=""
- End DoDot:2
- +34 IF FBX]""
- SET FBSORT(FBX)=""
- End DoDot:1
- +35 ;
- +36 ; loop thru sorted array and add the modifiers to return value
- +37 SET FBX=""
- FOR
- SET FBX=$ORDER(FBSORT(FBX))
- if FBX=""
- QUIT
- SET FBRET=FBRET_","_FBX
- +38 ;
- +39 ; strip leading comma (if any)
- +40 IF $EXTRACT(FBRET)=","
- SET FBRET=$EXTRACT(FBRET,2,999)
- +41 ;
- +42 ; return value
- +43 QUIT FBRET
- +44 ;
- REPMOD(FBJ,FBK,FBL,FBM) ; Replace CPT Modifier(s) in payment
- +1 ; input
- +2 ; FBJ = IEN of PATIENT in file 162
- +3 ; FBK = IEN of VENDOR multiple in file 162
- +4 ; FBL = IEN of INITIAL TREATMENT DATE multiple in file 162
- +5 ; FBM = IEN of SERVICE PROVIDED multiple in file 162
- +6 ; FBMODA( array of modifiers
- +7 ; where FBMODA(number)=CPT Modifier (internal)
- +8 ;
- +9 NEW FBI,FBIENS,FBFDA
- +10 SET FBIENS=FBM_","_FBL_","_FBK_","_FBJ_","
- +11 ;
- +12 ; delete any existing CPT MODIFIER entries from global
- +13 IF $ORDER(^FBAAC(FBJ,1,FBK,1,FBL,1,FBM,"M",0))
- Begin DoDot:1
- +14 KILL FBFDA
- SET FBI=0
- +15 FOR
- SET FBI=$ORDER(^FBAAC(FBJ,1,FBK,1,FBL,1,FBM,"M",FBI))
- if 'FBI
- QUIT
- Begin DoDot:2
- +16 SET FBFDA(162.06,FBI_","_FBIENS,.01)="@"
- End DoDot:2
- +17 DO FILE^DIE("","FBFDA")
- DO MSG^DIALOG()
- End DoDot:1
- +18 ;
- +19 ; create CPT MODIFIER entries from data in array FBMODA
- +20 IF $ORDER(FBMODA(0))
- Begin DoDot:1
- +21 KILL FBFDA
- SET FBI=0
- FOR
- SET FBI=$ORDER(FBMODA(FBI))
- if 'FBI
- QUIT
- Begin DoDot:2
- +22 SET FBFDA(162.06,"+"_FBI_","_FBIENS,.01)=FBMODA(FBI)
- End DoDot:2
- +23 DO UPDATE^DIE("","FBFDA")
- DO MSG^DIALOG()
- End DoDot:1
- +24 ;
- +25 QUIT
- +26 ;
- +27 ;FBAAUTL4