- 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 Jan 18, 2025@02:56:58 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