- FBAAPAA ;AISC/DMK-ADD/EDIT FEE SCHEDULE ;3/17/2003
- ;;3.5;FEE BASIS;**4,21,55**;JAN 30, 1995
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- ASK W ! S DIC="^FBAA(163.99,",DIC(0)="AEQLM",DLAYGO=163.99 D ^DIC G END:X=""!(X="^"),ASK:Y<0 S DA=+Y
- W ! S DIE=DIC,DR="[FBAA EDIT SCHEDULE]" D ^DIE G ASK
- END K DA,DIC,DIE,DLAYGO,DR,X,Y Q
- ;write CPT & MOD as identifiers
- ; Input: (optional) FBDTSRV - date for Code Set Versioning
- WRITE ; if FBDTSRV is not defined then today will be used as a date
- N FBAAFS,FBAACP,FBCPTX,FBI,FBMOD,FBMODLE,FBMODX,FBCPTFL,FBMODFL
- S (FBCPTFL,FBMODFL)=0
- S FBAAFS=$P(^FBAA(163.99,+Y,0),U)
- I +$G(FBDTSRV)=0 N FBDTSRV D
- . N X D NOW^%DTC S FBDTSRV=X
- S FBAACP=$P(FBAAFS,"-")
- S FBMODLE=$P(FBAAFS,"-",2)
- I $X>19 W !
- S FBCPTX=$$CPT^ICPTCOD(FBAACP,$G(FBDTSRV),1)
- I $G(FBDTSRV),+FBCPTX>0,$P(FBCPTX,U,7)=0 S FBCPTFL=1
- W ?20,"CPT: ",$S(FBCPTFL:$E($P(FBCPTX,U,3),1,25),1:$P(FBCPTX,U,3)) ; short name of CPT
- W:FBCPTFL ?50," - INACTIVE on ",$$FMTE^XLFDT(FBDTSRV) ;inactive on FBDTSRV
- I FBMODLE]"" F FBI=1:1 S FBMOD=$P(FBMODLE,",",FBI) Q:FBMOD="" D
- . S FBMODX=$$MOD^ICPTMOD(FBMOD,"E",$G(FBDTSRV))
- . ; if modifier data not obtained then try another API to resolve it
- . ; since there can be duplicate modifiers with same external value
- . I $P(FBMODX,U)'>0 D
- . . N FBY
- . . S FBY=$$MODP^ICPTMOD(FBAACP,FBMOD,"E",$G(FBDTSRV))
- . . I $P(FBY,U)>0 S FBMODX=$$MOD^ICPTMOD($P(FBY,U),"I",$G(FBDTSRV))
- . I $G(FBDTSRV),+FBMODX>0,$P(FBMODX,U,7)=0 S FBMODFL=1
- . W !?20,"MOD: ",FBMOD," ",$S(FBMODFL:$E($P(FBMODX,U,3),1,20),1:$P(FBMODX,U,3))
- . W:FBMODFL ?50," - INACTIVE on ",$$FMTE^XLFDT(FBDTSRV) ;inactive on FBDTSRV
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAAPAA 1690 printed Jan 18, 2025@02:57:07 Page 2
- FBAAPAA ;AISC/DMK-ADD/EDIT FEE SCHEDULE ;3/17/2003
- +1 ;;3.5;FEE BASIS;**4,21,55**;JAN 30, 1995
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- ASK WRITE !
- SET DIC="^FBAA(163.99,"
- SET DIC(0)="AEQLM"
- SET DLAYGO=163.99
- DO ^DIC
- if X=""!(X="^")
- GOTO END
- if Y<0
- GOTO ASK
- SET DA=+Y
- +1 WRITE !
- SET DIE=DIC
- SET DR="[FBAA EDIT SCHEDULE]"
- DO ^DIE
- GOTO ASK
- END KILL DA,DIC,DIE,DLAYGO,DR,X,Y
- QUIT
- +1 ;write CPT & MOD as identifiers
- +2 ; Input: (optional) FBDTSRV - date for Code Set Versioning
- WRITE ; if FBDTSRV is not defined then today will be used as a date
- +1 NEW FBAAFS,FBAACP,FBCPTX,FBI,FBMOD,FBMODLE,FBMODX,FBCPTFL,FBMODFL
- +2 SET (FBCPTFL,FBMODFL)=0
- +3 SET FBAAFS=$PIECE(^FBAA(163.99,+Y,0),U)
- +4 IF +$GET(FBDTSRV)=0
- NEW FBDTSRV
- Begin DoDot:1
- +5 NEW X
- DO NOW^%DTC
- SET FBDTSRV=X
- End DoDot:1
- +6 SET FBAACP=$PIECE(FBAAFS,"-")
- +7 SET FBMODLE=$PIECE(FBAAFS,"-",2)
- +8 IF $X>19
- WRITE !
- +9 SET FBCPTX=$$CPT^ICPTCOD(FBAACP,$GET(FBDTSRV),1)
- +10 IF $GET(FBDTSRV)
- IF +FBCPTX>0
- IF $PIECE(FBCPTX,U,7)=0
- SET FBCPTFL=1
- +11 ; short name of CPT
- WRITE ?20,"CPT: ",$SELECT(FBCPTFL:$EXTRACT($PIECE(FBCPTX,U,3),1,25),1:$PIECE(FBCPTX,U,3))
- +12 ;inactive on FBDTSRV
- if FBCPTFL
- WRITE ?50," - INACTIVE on ",$$FMTE^XLFDT(FBDTSRV)
- +13 IF FBMODLE]""
- FOR FBI=1:1
- SET FBMOD=$PIECE(FBMODLE,",",FBI)
- if FBMOD=""
- QUIT
- Begin DoDot:1
- +14 SET FBMODX=$$MOD^ICPTMOD(FBMOD,"E",$GET(FBDTSRV))
- +15 ; if modifier data not obtained then try another API to resolve it
- +16 ; since there can be duplicate modifiers with same external value
- +17 IF $PIECE(FBMODX,U)'>0
- Begin DoDot:2
- +18 NEW FBY
- +19 SET FBY=$$MODP^ICPTMOD(FBAACP,FBMOD,"E",$GET(FBDTSRV))
- +20 IF $PIECE(FBY,U)>0
- SET FBMODX=$$MOD^ICPTMOD($PIECE(FBY,U),"I",$GET(FBDTSRV))
- End DoDot:2
- +21 IF $GET(FBDTSRV)
- IF +FBMODX>0
- IF $PIECE(FBMODX,U,7)=0
- SET FBMODFL=1
- +22 WRITE !?20,"MOD: ",FBMOD," ",$SELECT(FBMODFL:$EXTRACT($PIECE(FBMODX,U,3),1,20),1:$PIECE(FBMODX,U,3))
- +23 ;inactive on FBDTSRV
- if FBMODFL
- WRITE ?50," - INACTIVE on ",$$FMTE^XLFDT(FBDTSRV)
- End DoDot:1
- +24 QUIT