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 Apr 09, 2024@21:01:35 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
