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 Oct 16, 2024@17:57:39 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
