| 1 | FBAAPAA ;AISC/DMK-ADD/EDIT FEE SCHEDULE ;3/17/2003
|
|---|
| 2 | ;;3.5;FEE BASIS;**4,21,55**;JAN 30, 1995
|
|---|
| 3 | ;;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | 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
|
|---|
| 5 | W ! S DIE=DIC,DR="[FBAA EDIT SCHEDULE]" D ^DIE G ASK
|
|---|
| 6 | END K DA,DIC,DIE,DLAYGO,DR,X,Y Q
|
|---|
| 7 | ;write CPT & MOD as identifiers
|
|---|
| 8 | ; Input: (optional) FBDTSRV - date for Code Set Versioning
|
|---|
| 9 | WRITE ; if FBDTSRV is not defined then today will be used as a date
|
|---|
| 10 | N FBAAFS,FBAACP,FBCPTX,FBI,FBMOD,FBMODLE,FBMODX,FBCPTFL,FBMODFL
|
|---|
| 11 | S (FBCPTFL,FBMODFL)=0
|
|---|
| 12 | S FBAAFS=$P(^FBAA(163.99,+Y,0),U)
|
|---|
| 13 | I +$G(FBDTSRV)=0 N FBDTSRV D
|
|---|
| 14 | . N X D NOW^%DTC S FBDTSRV=X
|
|---|
| 15 | S FBAACP=$P(FBAAFS,"-")
|
|---|
| 16 | S FBMODLE=$P(FBAAFS,"-",2)
|
|---|
| 17 | I $X>19 W !
|
|---|
| 18 | S FBCPTX=$$CPT^ICPTCOD(FBAACP,$G(FBDTSRV),1)
|
|---|
| 19 | I $G(FBDTSRV),+FBCPTX>0,$P(FBCPTX,U,7)=0 S FBCPTFL=1
|
|---|
| 20 | W ?20,"CPT: ",$S(FBCPTFL:$E($P(FBCPTX,U,3),1,25),1:$P(FBCPTX,U,3)) ; short name of CPT
|
|---|
| 21 | W:FBCPTFL ?50," - INACTIVE on ",$$FMTE^XLFDT(FBDTSRV) ;inactive on FBDTSRV
|
|---|
| 22 | I FBMODLE]"" F FBI=1:1 S FBMOD=$P(FBMODLE,",",FBI) Q:FBMOD="" D
|
|---|
| 23 | . S FBMODX=$$MOD^ICPTMOD(FBMOD,"E",$G(FBDTSRV))
|
|---|
| 24 | . ; if modifier data not obtained then try another API to resolve it
|
|---|
| 25 | . ; since there can be duplicate modifiers with same external value
|
|---|
| 26 | . I $P(FBMODX,U)'>0 D
|
|---|
| 27 | . . N FBY
|
|---|
| 28 | . . S FBY=$$MODP^ICPTMOD(FBAACP,FBMOD,"E",$G(FBDTSRV))
|
|---|
| 29 | . . I $P(FBY,U)>0 S FBMODX=$$MOD^ICPTMOD($P(FBY,U),"I",$G(FBDTSRV))
|
|---|
| 30 | . I $G(FBDTSRV),+FBMODX>0,$P(FBMODX,U,7)=0 S FBMODFL=1
|
|---|
| 31 | . W !?20,"MOD: ",FBMOD," ",$S(FBMODFL:$E($P(FBMODX,U,3),1,20),1:$P(FBMODX,U,3))
|
|---|
| 32 | . W:FBMODFL ?50," - INACTIVE on ",$$FMTE^XLFDT(FBDTSRV) ;inactive on FBDTSRV
|
|---|
| 33 | Q
|
|---|
