FBAALU ;AISC/GRR,WCIOFO/SAB-CPT CODE & MODIFIER LOOKUP ;7/15/1999
;;3.5;FEE BASIS;**4,77,85**;JAN 30, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
CPTM(FBDOS,FBDFN,FBCPT,FBMODL) ; Ask CPT Code and optional CPT Modifiers
; input
; FBDOS - (optional) date of service, fileman format
; FBDFN - (optional) patient DFN, pointer to file #2 and file #161
; FBCPT - (optional) default CPT value (internal)
; FBMODL- (optional) list of default modifiers (internal)
; delimited by commas
; only used when FBCPT accepted by user
; output
; FBAACP - CPT code (internal)
; OR null if not selected
; OR @ if default value (FBCPT) was supplied and user
; entered an @ at the service provided prompt.
; FBX - CPT code (external) OR null if not selected
; FBMODA( - (optional) CPT modifier array
; FBMODA(#) = CPT modifier (internal)
; where # is a integer greater than 0
; FBGOT - flag (0 or 1) =1 if CPT code was specified and confirmed
;
INIT ; initialize optional input variables and FBGOT
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
N FBCATX,FBCPTX,FBEDIT,FBI,FBLAST,FBMOD,FBMODLE,FBMODX,FBTX
S:$G(FBDOS)="" FBDOS=DT
S FBDFN=$G(FBDFN)
S FBGOT=0
;
ASKCPT ; prompt for CPT code
S DIR(0)="PO^81:EMZ"
S DIR("A")=$S($G(FBCPT)>0:"",1:"Select ")_"Service Provided"
I $G(FBCPT)>0 S DIR("B")=$$CPT^FBAAUTL4(FBCPT)
S DIR("?",1)="The Current Procedural Terminology Code (CPT Code) as"
S DIR("?",2)="specified on the vendors invoice identifying the service"
S DIR("?")="the vendor provided to the veteran."
S ICPTVDT=$G(FBDOS) D ^DIR K DIR,ICPTVDT I $D(DTOUT)!$D(DUOUT) G EXIT
I $G(FBCPT)]"",X="@" D G:FBGOT EXIT G ASKCPT
. S DIR(0)="Y"
. S DIR("A")="SURE YOU WANT TO DELETE THE ENTIRE SERVICE PROVIDED"
. D ^DIR K DIR I Y S FBGOT=1,FBAACP="@",FBX="" K FBMODA
I Y>0 S FBAACP=+Y,FBX=$P(Y,U,2)
E G EXIT
; *** PASS 3RD PARAMETER TO INCLUDE VA NATIONAL/LOCAL CODES
S FBCPTX=$$CPT^ICPTCOD(FBAACP,FBDOS,1)
I '$P(FBCPTX,U,7) D G ASKCPT
. W $C(7),!," CPT code inactive on date of service ("
. W $$FMTE^XLFDT(FBDOS),")"
;
K FBMODA
I $G(FBCPT)>0,FBCPT=FBAACP,$G(FBMODL)]"" D
. N FBI,FBMOD
. F FBI=1:1 S FBMOD=$P(FBMODL,",",FBI) Q:FBMOD="" S FBMODA(FBI)=FBMOD
;
ASKMOD ; multiply prompt for CPT modifiers
; determine highest number used in list
S FBLAST=$O(FBMODA(" "),-1)
; prompt for CPT modifier
S DIR(0)="PO^81.3:EMZ"
S DIR("A")="Select CPT MODIFIER"
S DIR("?")="^D MODHLP^FBAALU"
; *** COMMENT FOLLOWING LINE IF ACCURACY OF API IS NOT FIXED
;S DIR("S")="I $$MODP^ICPTMOD(FBAACP,Y,""I"",FBDOS,1)>0"
S FBMODLE=$$MODL^FBAAUTL4("FBMODA","E")
W !!,"Current list of modifiers: ",$S(FBMODLE]"":FBMODLE,1:"none")
S ICPTVDT=$G(FBDOS) D ^DIR K DIR,ICPTVDT I $D(DTOUT)!$D(DUOUT) G EXIT
; if value was entered then process it and ask another
I +Y>0 D G ASKMOD
. S FBMOD=+Y
. ; if specified CPT modifier already in list set FBEDIT = it's number
. S (FBI,FBEDIT)=0 F S FBI=$O(FBMODA(FBI)) Q:'FBI D Q:FBEDIT
. . I FBMODA(FBI)=FBMOD S FBEDIT=FBI
. ; if in list then edit the existing modifier
. I FBEDIT D Q:$D(DIRUT)
. . S DIR(0)="PO^81.3:EMZ"
. . S DIR("A")=" CPT MODIFIER"
. . S DIR("B")=$$MOD^FBAAUTL4(FBMODA(FBEDIT))
. . ; *** COMMENT FOLLOWING LINE IF ACCURACY OF API IS NOT FIXED
. . ;S DIR("S")="I $$MODP^ICPTMOD(FBAACP,Y,""I"",FBDOS,1)>0"
. . S ICPTVDT=$G(FBDOS) D ^DIR K DIR,ICPTVDT
. . I X="@" K FBMODA(FBEDIT) W " (deleted)" ; "@" removes from list
. . I +Y>0 S FBMOD=+Y
. ; validate entered modifier
. S FBMODX=$$MOD^ICPTMOD(FBMOD,"I",FBDOS,1)
. I '$P(FBMODX,U,7) D Q
. . W $C(7),!," CPT Modifier inactive on date of service ("
. . W $$FMTE^XLFDT(FBDOS),")"
. ; ensure new value of edited modifier is not already on list
. I FBEDIT D Q:FBMOD=""
. . S FBI=0 F S FBI=$O(FBMODA(FBI)) Q:'FBI D Q:FBMOD=""
. . . I FBMODA(FBI)=FBMOD,FBI'=FBEDIT S FBMOD="" W !,$C(7)," Change was not accepted because the new value is already on the list."
. ; update list
. I FBEDIT S FBMODA(FBEDIT)=FBMOD ; updated existing modifier
. E S FBLAST=FBLAST+1,FBMODA(FBLAST)=FBMOD ; added new modifier
;
DIS ; display entered data
; if default CPT code exists and default code and modifiers were not
; changed then skip display and confirm steps.
I $G(FBCPT)>0,FBCPT=FBAACP,$G(FBMODL)=$$MODL^FBAAUTL4("FBMODA","I") S FBGOT=1 G EXIT
S FBCATX=$$CAT^ICPTAPIU($P(FBCPTX,U,4))
W !!,"Major Category: " W:$P(FBCATX,U)'=-1 $P(FBCATX,U,4)
W !,?2,"Sub-Category: " W:$P(FBCATX,U)'=-1 $P(FBCATX,U)
W !,?6,"Procedure: ",$P(FBCPTX,U,2)," ",$P(FBCPTX,U,3)
I $O(FBMODA(0)) D
. W !,?6,"Modifiers: "
. S FBI=0 F S FBI=$O(FBMODA(FBI)) Q:'FBI D
. . S FBMODX=$$MOD^ICPTMOD(FBMODA(FBI),"I",FBDOS,1)
. . W ?22,"-",$P(FBMODX,U,2)," ",$P(FBMODX,U,3),!
E W !
W !,?20,"Detail Description ",!,?20,"=================="
K FBTX
S X=$$CPTD^ICPTCOD(FBAACP,"FBTX",$G(FBDFN),$G(FBDOS))
S FBI=0 F S FBI=$O(FBTX(FBI)) Q:'FBI W !,FBTX(FBI)
;
CONF ; confirm entered data
S DIR(0)="Y",DIR("A")="Is this correct",DIR("B")="YES"
D ^DIR K DIR I $D(DIRUT) G EXIT
I 'Y W ! G ASKCPT
S FBGOT=1
;
EXIT ; exit point
I 'FBGOT S FBAACP="",FBX="" K FBMODA
Q
;
MODHLP ; CPT MODIFIER prompt help text
; input
; FBMODA( - (optional) array of modifiers
; FBMODA(#)=CPT MODIFIER (internal)
;
N DIR,DIROUT,DIRUT,DTOUT,DUOUT
N FBI,FBL,FBMODX,FBQUIT,FBTX
;
; compile help text for modifier prompt including a list of
; previously entered modifiers.
S FBTX(1)="Modifiers are used to better describe the service (CPT)"
S FBTX(2)="rendered. Modifier(s) will be combined with the CPT code"
S FBTX(3)="for Fee Schedule calculations and to check for duplicate"
S FBTX(4)="payment entry."
I $O(FBMODA(0)) D
. N FBI,FBL,FBMODX
. S FBTX(5)=" "
. S FBL=5
. S FBI=0 F S FBI=$O(FBMODA(FBI)) Q:'FBI D
. . S FBMODX=$$MOD^ICPTMOD(FBMODA(FBI),"I",$G(FBDOS),1)
. . S FBL=FBL+1,FBTX(FBL)=" "_$P(FBMODX,U,2)_" "_$P(FBMODX,U,3)
;
; display the help text
S FBL=0 F S FBL=$O(FBTX(FBL)) Q:'FBL D Q:$D(DIRUT)
. ; pause between screens of data (22 lines)
. I $E(IOST,1,2)="C-",'(FBL#22) S DIR(0)="E" D ^DIR K DIR Q:$D(DIRUT)
. ; write a line of text
. W !,FBTX(FBL)
;
Q
;
;FBAALU
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAALU 6456 printed Sep 23, 2025@19:31:50 Page 2
FBAALU ;AISC/GRR,WCIOFO/SAB-CPT CODE & MODIFIER LOOKUP ;7/15/1999
+1 ;;3.5;FEE BASIS;**4,77,85**;JAN 30, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
CPTM(FBDOS,FBDFN,FBCPT,FBMODL) ; Ask CPT Code and optional CPT Modifiers
+1 ; input
+2 ; FBDOS - (optional) date of service, fileman format
+3 ; FBDFN - (optional) patient DFN, pointer to file #2 and file #161
+4 ; FBCPT - (optional) default CPT value (internal)
+5 ; FBMODL- (optional) list of default modifiers (internal)
+6 ; delimited by commas
+7 ; only used when FBCPT accepted by user
+8 ; output
+9 ; FBAACP - CPT code (internal)
+10 ; OR null if not selected
+11 ; OR @ if default value (FBCPT) was supplied and user
+12 ; entered an @ at the service provided prompt.
+13 ; FBX - CPT code (external) OR null if not selected
+14 ; FBMODA( - (optional) CPT modifier array
+15 ; FBMODA(#) = CPT modifier (internal)
+16 ; where # is a integer greater than 0
+17 ; FBGOT - flag (0 or 1) =1 if CPT code was specified and confirmed
+18 ;
INIT ; initialize optional input variables and FBGOT
+1 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+2 NEW FBCATX,FBCPTX,FBEDIT,FBI,FBLAST,FBMOD,FBMODLE,FBMODX,FBTX
+3 if $GET(FBDOS)=""
SET FBDOS=DT
+4 SET FBDFN=$GET(FBDFN)
+5 SET FBGOT=0
+6 ;
ASKCPT ; prompt for CPT code
+1 SET DIR(0)="PO^81:EMZ"
+2 SET DIR("A")=$SELECT($GET(FBCPT)>0:"",1:"Select ")_"Service Provided"
+3 IF $GET(FBCPT)>0
SET DIR("B")=$$CPT^FBAAUTL4(FBCPT)
+4 SET DIR("?",1)="The Current Procedural Terminology Code (CPT Code) as"
+5 SET DIR("?",2)="specified on the vendors invoice identifying the service"
+6 SET DIR("?")="the vendor provided to the veteran."
+7 SET ICPTVDT=$GET(FBDOS)
DO ^DIR
KILL DIR,ICPTVDT
IF $DATA(DTOUT)!$DATA(DUOUT)
GOTO EXIT
+8 IF $GET(FBCPT)]""
IF X="@"
Begin DoDot:1
+9 SET DIR(0)="Y"
+10 SET DIR("A")="SURE YOU WANT TO DELETE THE ENTIRE SERVICE PROVIDED"
+11 DO ^DIR
KILL DIR
IF Y
SET FBGOT=1
SET FBAACP="@"
SET FBX=""
KILL FBMODA
End DoDot:1
if FBGOT
GOTO EXIT
GOTO ASKCPT
+12 IF Y>0
SET FBAACP=+Y
SET FBX=$PIECE(Y,U,2)
+13 IF '$TEST
GOTO EXIT
+14 ; *** PASS 3RD PARAMETER TO INCLUDE VA NATIONAL/LOCAL CODES
+15 SET FBCPTX=$$CPT^ICPTCOD(FBAACP,FBDOS,1)
+16 IF '$PIECE(FBCPTX,U,7)
Begin DoDot:1
+17 WRITE $CHAR(7),!," CPT code inactive on date of service ("
+18 WRITE $$FMTE^XLFDT(FBDOS),")"
End DoDot:1
GOTO ASKCPT
+19 ;
+20 KILL FBMODA
+21 IF $GET(FBCPT)>0
IF FBCPT=FBAACP
IF $GET(FBMODL)]""
Begin DoDot:1
+22 NEW FBI,FBMOD
+23 FOR FBI=1:1
SET FBMOD=$PIECE(FBMODL,",",FBI)
if FBMOD=""
QUIT
SET FBMODA(FBI)=FBMOD
End DoDot:1
+24 ;
ASKMOD ; multiply prompt for CPT modifiers
+1 ; determine highest number used in list
+2 SET FBLAST=$ORDER(FBMODA(" "),-1)
+3 ; prompt for CPT modifier
+4 SET DIR(0)="PO^81.3:EMZ"
+5 SET DIR("A")="Select CPT MODIFIER"
+6 SET DIR("?")="^D MODHLP^FBAALU"
+7 ; *** COMMENT FOLLOWING LINE IF ACCURACY OF API IS NOT FIXED
+8 ;S DIR("S")="I $$MODP^ICPTMOD(FBAACP,Y,""I"",FBDOS,1)>0"
+9 SET FBMODLE=$$MODL^FBAAUTL4("FBMODA","E")
+10 WRITE !!,"Current list of modifiers: ",$SELECT(FBMODLE]"":FBMODLE,1:"none")
+11 SET ICPTVDT=$GET(FBDOS)
DO ^DIR
KILL DIR,ICPTVDT
IF $DATA(DTOUT)!$DATA(DUOUT)
GOTO EXIT
+12 ; if value was entered then process it and ask another
+13 IF +Y>0
Begin DoDot:1
+14 SET FBMOD=+Y
+15 ; if specified CPT modifier already in list set FBEDIT = it's number
+16 SET (FBI,FBEDIT)=0
FOR
SET FBI=$ORDER(FBMODA(FBI))
if 'FBI
QUIT
Begin DoDot:2
+17 IF FBMODA(FBI)=FBMOD
SET FBEDIT=FBI
End DoDot:2
if FBEDIT
QUIT
+18 ; if in list then edit the existing modifier
+19 IF FBEDIT
Begin DoDot:2
+20 SET DIR(0)="PO^81.3:EMZ"
+21 SET DIR("A")=" CPT MODIFIER"
+22 SET DIR("B")=$$MOD^FBAAUTL4(FBMODA(FBEDIT))
+23 ; *** COMMENT FOLLOWING LINE IF ACCURACY OF API IS NOT FIXED
+24 ;S DIR("S")="I $$MODP^ICPTMOD(FBAACP,Y,""I"",FBDOS,1)>0"
+25 SET ICPTVDT=$GET(FBDOS)
DO ^DIR
KILL DIR,ICPTVDT
+26 ; "@" removes from list
IF X="@"
KILL FBMODA(FBEDIT)
WRITE " (deleted)"
+27 IF +Y>0
SET FBMOD=+Y
End DoDot:2
if $DATA(DIRUT)
QUIT
+28 ; validate entered modifier
+29 SET FBMODX=$$MOD^ICPTMOD(FBMOD,"I",FBDOS,1)
+30 IF '$PIECE(FBMODX,U,7)
Begin DoDot:2
+31 WRITE $CHAR(7),!," CPT Modifier inactive on date of service ("
+32 WRITE $$FMTE^XLFDT(FBDOS),")"
End DoDot:2
QUIT
+33 ; ensure new value of edited modifier is not already on list
+34 IF FBEDIT
Begin DoDot:2
+35 SET FBI=0
FOR
SET FBI=$ORDER(FBMODA(FBI))
if 'FBI
QUIT
Begin DoDot:3
+36 IF FBMODA(FBI)=FBMOD
IF FBI'=FBEDIT
SET FBMOD=""
WRITE !,$CHAR(7)," Change was not accepted because the new value is already on the list."
End DoDot:3
if FBMOD=""
QUIT
End DoDot:2
if FBMOD=""
QUIT
+37 ; update list
+38 ; updated existing modifier
IF FBEDIT
SET FBMODA(FBEDIT)=FBMOD
+39 ; added new modifier
IF '$TEST
SET FBLAST=FBLAST+1
SET FBMODA(FBLAST)=FBMOD
End DoDot:1
GOTO ASKMOD
+40 ;
DIS ; display entered data
+1 ; if default CPT code exists and default code and modifiers were not
+2 ; changed then skip display and confirm steps.
+3 IF $GET(FBCPT)>0
IF FBCPT=FBAACP
IF $GET(FBMODL)=$$MODL^FBAAUTL4("FBMODA","I")
SET FBGOT=1
GOTO EXIT
+4 SET FBCATX=$$CAT^ICPTAPIU($PIECE(FBCPTX,U,4))
+5 WRITE !!,"Major Category: "
if $PIECE(FBCATX,U)'=-1
WRITE $PIECE(FBCATX,U,4)
+6 WRITE !,?2,"Sub-Category: "
if $PIECE(FBCATX,U)'=-1
WRITE $PIECE(FBCATX,U)
+7 WRITE !,?6,"Procedure: ",$PIECE(FBCPTX,U,2)," ",$PIECE(FBCPTX,U,3)
+8 IF $ORDER(FBMODA(0))
Begin DoDot:1
+9 WRITE !,?6,"Modifiers: "
+10 SET FBI=0
FOR
SET FBI=$ORDER(FBMODA(FBI))
if 'FBI
QUIT
Begin DoDot:2
+11 SET FBMODX=$$MOD^ICPTMOD(FBMODA(FBI),"I",FBDOS,1)
+12 WRITE ?22,"-",$PIECE(FBMODX,U,2)," ",$PIECE(FBMODX,U,3),!
End DoDot:2
End DoDot:1
+13 IF '$TEST
WRITE !
+14 WRITE !,?20,"Detail Description ",!,?20,"=================="
+15 KILL FBTX
+16 SET X=$$CPTD^ICPTCOD(FBAACP,"FBTX",$GET(FBDFN),$GET(FBDOS))
+17 SET FBI=0
FOR
SET FBI=$ORDER(FBTX(FBI))
if 'FBI
QUIT
WRITE !,FBTX(FBI)
+18 ;
CONF ; confirm entered data
+1 SET DIR(0)="Y"
SET DIR("A")="Is this correct"
SET DIR("B")="YES"
+2 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
GOTO EXIT
+3 IF 'Y
WRITE !
GOTO ASKCPT
+4 SET FBGOT=1
+5 ;
EXIT ; exit point
+1 IF 'FBGOT
SET FBAACP=""
SET FBX=""
KILL FBMODA
+2 QUIT
+3 ;
MODHLP ; CPT MODIFIER prompt help text
+1 ; input
+2 ; FBMODA( - (optional) array of modifiers
+3 ; FBMODA(#)=CPT MODIFIER (internal)
+4 ;
+5 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT
+6 NEW FBI,FBL,FBMODX,FBQUIT,FBTX
+7 ;
+8 ; compile help text for modifier prompt including a list of
+9 ; previously entered modifiers.
+10 SET FBTX(1)="Modifiers are used to better describe the service (CPT)"
+11 SET FBTX(2)="rendered. Modifier(s) will be combined with the CPT code"
+12 SET FBTX(3)="for Fee Schedule calculations and to check for duplicate"
+13 SET FBTX(4)="payment entry."
+14 IF $ORDER(FBMODA(0))
Begin DoDot:1
+15 NEW FBI,FBL,FBMODX
+16 SET FBTX(5)=" "
+17 SET FBL=5
+18 SET FBI=0
FOR
SET FBI=$ORDER(FBMODA(FBI))
if 'FBI
QUIT
Begin DoDot:2
+19 SET FBMODX=$$MOD^ICPTMOD(FBMODA(FBI),"I",$GET(FBDOS),1)
+20 SET FBL=FBL+1
SET FBTX(FBL)=" "_$PIECE(FBMODX,U,2)_" "_$PIECE(FBMODX,U,3)
End DoDot:2
End DoDot:1
+21 ;
+22 ; display the help text
+23 SET FBL=0
FOR
SET FBL=$ORDER(FBTX(FBL))
if 'FBL
QUIT
Begin DoDot:1
+24 ; pause between screens of data (22 lines)
+25 IF $EXTRACT(IOST,1,2)="C-"
IF '(FBL#22)
SET DIR(0)="E"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
+26 ; write a line of text
+27 WRITE !,FBTX(FBL)
End DoDot:1
if $DATA(DIRUT)
QUIT
+28 ;
+29 QUIT
+30 ;
+31 ;FBAALU
