FBAASOUT ;AISC/DMK-OUTPUT FOR CPT FEE SCHEDULE ;4/17/2000
;;3.5;FEE BASIS;**1,4,21**;JAN 30, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
ASKDT S %DT="AE",%DT("A")="Select Fiscal Year: " D ^%DT K %DT("A") G END:Y<0 S FBFY=$S('$E(Y,4,7):($E(Y,1,3)+1700),$E(Y,4,5)>9:($E(Y,1,3)+1701),1:($E(Y,1,3)+1700)) I '$D(^FBAA(163.99,"AC",FBFY)) G HELP
S VAR="FBFY",VAL=FBFY,PGM="START^FBAASOUT" D ZIS^FBAAUTL G:FBPOP END
;
START S FBAAOUT=0,FBPAGE=1,FBDASH=$$REPEAT^XLFSTR("-",80)
K ^TMP("FBCPT",$J)
U IO W:$E(IOST,1,2)["C-" @IOF D HEAD
;locate schedule for selected fiscal year and set in ^TMP for sort
S I=0 F S I=$O(^FBAA(163.99,I)) Q:'I!(FBAAOUT) I $D(^FBAA(163.99,I,"FY",FBFY)) S FBY(0)=^(FBFY,0),FBCPT=$P($G(^FBAA(163.99,I,0)),U) D:FBCPT]""
. S ^TMP("FBCPT",$J,1_$P(FBCPT,"-"),$S(FBCPT'["-":0,1:$P(FBCPT,"-",2)))=FBY(0)
;go through TMP and print out in cpt order
S FBI=0,FBJ=""
F S FBI=$O(^TMP("FBCPT",$J,FBI)) Q:FBI']""!($G(FBAAOUT)) F S FBJ=$O(^TMP("FBCPT",$J,FBI,FBJ)) Q:FBJ=""!($G(FBAAOUT)) S FBY(0)=^(FBJ),FBCPT=$E(FBI,2,99)_$S(FBJ=0:"",1:"-"_FBJ) D PRINT
D END Q
;
PRINT I $Y+5>IOSL D HANG^FBAAUTL1:$E(IOST,1,2)["C-" Q:FBAAOUT W @IOF S FBPAGE=FBPAGE+1 D HEAD
F FBY=1,2,5,6,7,8 S FBY(FBY)=$P(FBY(0),"^",FBY)
I $E(FBY(7),6,7)="00" S FBY(7)=$E(FBY(7),1,5)_"01"
F K=6,7,8 S FBY(K)=$$DATX^FBAAUTL($P(FBY(K),"."))
W !,FBCPT,?12,FBY(2),?26,$J(FBY(5),1,2),?42,FBY(6),?60,$S(FBY(7)]"":FBY(7)_" - "_FBY(8),1:" Add/Edit")
W !,?2,$E($P($$CPT^ICPTCOD($P(FBCPT,"-"),"",1),U,3),1,39)
I $P(FBCPT,"-",2)]"" D Q:FBAAOUT
. N FBI,FBMOD,FBMODX,FBPOS
. S FBPOS=$L($E($P($$CPT^ICPTCOD($P(FBCPT,"-"),"",1),U,3),1,39))+2
. F FBI=1:1 S FBMOD=$P($P(FBCPT,"-",2),",",FBI) Q:FBMOD="" D Q:FBAAOUT
. . I $Y+5>IOSL D HANG^FBAAUTL1:$E(IOST,1,2)="C-" Q:FBAAOUT W @IOF S FBPAGE=FBPAGE+1 D HEAD W " continued"
. . W ?FBPOS,"-"
. . S FBMODX=$$MOD^ICPTMOD(FBMOD,"E")
. . ; 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($P(FBCPT,"-"),FBMOD,"E")
. . . I $P(FBY,U)>0 S FBMODX=$$MOD^ICPTMOD($P(FBY,U),"I")
. . W $E($S($P(FBMODX,U)>0:$P(FBMODX,U,3),1:FBMOD),1,36),!
E W !
W FBDASH
Q
;
HEAD W !!,?19,"**** REPORT OF FEE SCHEDULE ****",!!,?26,"For Fiscal Year ",FBFY,?70,"Page ",$G(FBPAGE),!!,$$REPEAT^XLFSTR("=",80)
W !!,"CPT-MOD",?10,"Total #",?25,"75 %ile",?40,"Date Compiled",?65,"Date Range ",!,?2,"Description",!,$$REPEAT^XLFSTR("=",80),!
Q
;
END K DIRUT,DUOUT,DTOUT,FBCPT,FBAAOUT,FBFY,FBI,FBJ,FBPAGE,FBY,I,K,PGM,Q,QQ,VAL,VAR,X,Y,FBDESC,^TMP("FBCPT",$J),FBDASH
D CLOSE^FBAAUTL
Q
;
HELP W *7,!!,"There is no data on file for fiscal year ",FBFY,! G ASKDT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAASOUT 2805 printed Sep 23, 2025@19:32:47 Page 2
FBAASOUT ;AISC/DMK-OUTPUT FOR CPT FEE SCHEDULE ;4/17/2000
+1 ;;3.5;FEE BASIS;**1,4,21**;JAN 30, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
ASKDT SET %DT="AE"
SET %DT("A")="Select Fiscal Year: "
DO ^%DT
KILL %DT("A")
if Y<0
GOTO END
SET FBFY=$SELECT('$EXTRACT(Y,4,7):($EXTRACT(Y,1,3)+1700),$EXTRACT(Y,4,5)>9:($EXTRACT(Y,1,3)+1701),1:($EXTRACT(Y,1,3)+1700))
IF '$DATA(^FBAA(163.99,"AC",FBFY))
GOTO HELP
+1 SET VAR="FBFY"
SET VAL=FBFY
SET PGM="START^FBAASOUT"
DO ZIS^FBAAUTL
if FBPOP
GOTO END
+2 ;
START SET FBAAOUT=0
SET FBPAGE=1
SET FBDASH=$$REPEAT^XLFSTR("-",80)
+1 KILL ^TMP("FBCPT",$JOB)
+2 USE IO
if $EXTRACT(IOST,1,2)["C-"
WRITE @IOF
DO HEAD
+3 ;locate schedule for selected fiscal year and set in ^TMP for sort
+4 SET I=0
FOR
SET I=$ORDER(^FBAA(163.99,I))
if 'I!(FBAAOUT)
QUIT
IF $DATA(^FBAA(163.99,I,"FY",FBFY))
SET FBY(0)=^(FBFY,0)
SET FBCPT=$PIECE($GET(^FBAA(163.99,I,0)),U)
if FBCPT]""
Begin DoDot:1
+5 SET ^TMP("FBCPT",$JOB,1_$PIECE(FBCPT,"-"),$SELECT(FBCPT'["-":0,1:$PIECE(FBCPT,"-",2)))=FBY(0)
End DoDot:1
+6 ;go through TMP and print out in cpt order
+7 SET FBI=0
SET FBJ=""
+8 FOR
SET FBI=$ORDER(^TMP("FBCPT",$JOB,FBI))
if FBI']""!($GET(FBAAOUT))
QUIT
FOR
SET FBJ=$ORDER(^TMP("FBCPT",$JOB,FBI,FBJ))
if FBJ=""!($GET(FBAAOUT))
QUIT
SET FBY(0)=^(FBJ)
SET FBCPT=$EXTRACT(FBI,2,99)_$SELECT(FBJ=0:"",1:"-"_FBJ)
DO PRINT
+9 DO END
QUIT
+10 ;
PRINT IF $Y+5>IOSL
if $EXTRACT(IOST,1,2)["C-"
DO HANG^FBAAUTL1
if FBAAOUT
QUIT
WRITE @IOF
SET FBPAGE=FBPAGE+1
DO HEAD
+1 FOR FBY=1,2,5,6,7,8
SET FBY(FBY)=$PIECE(FBY(0),"^",FBY)
+2 IF $EXTRACT(FBY(7),6,7)="00"
SET FBY(7)=$EXTRACT(FBY(7),1,5)_"01"
+3 FOR K=6,7,8
SET FBY(K)=$$DATX^FBAAUTL($PIECE(FBY(K),"."))
+4 WRITE !,FBCPT,?12,FBY(2),?26,$JUSTIFY(FBY(5),1,2),?42,FBY(6),?60,$SELECT(FBY(7)]"":FBY(7)_" - "_FBY(8),1:" Add/Edit")
+5 WRITE !,?2,$EXTRACT($PIECE($$CPT^ICPTCOD($PIECE(FBCPT,"-"),"",1),U,3),1,39)
+6 IF $PIECE(FBCPT,"-",2)]""
Begin DoDot:1
+7 NEW FBI,FBMOD,FBMODX,FBPOS
+8 SET FBPOS=$LENGTH($EXTRACT($PIECE($$CPT^ICPTCOD($PIECE(FBCPT,"-"),"",1),U,3),1,39))+2
+9 FOR FBI=1:1
SET FBMOD=$PIECE($PIECE(FBCPT,"-",2),",",FBI)
if FBMOD=""
QUIT
Begin DoDot:2
+10 IF $Y+5>IOSL
if $EXTRACT(IOST,1,2)="C-"
DO HANG^FBAAUTL1
if FBAAOUT
QUIT
WRITE @IOF
SET FBPAGE=FBPAGE+1
DO HEAD
WRITE " continued"
+11 WRITE ?FBPOS,"-"
+12 SET FBMODX=$$MOD^ICPTMOD(FBMOD,"E")
+13 ; if modifier data not obtained then try another API to resolve it
+14 ; since there can be duplicate modifiers with same external value
+15 IF $PIECE(FBMODX,U)'>0
Begin DoDot:3
+16 NEW FBY
+17 SET FBY=$$MODP^ICPTMOD($PIECE(FBCPT,"-"),FBMOD,"E")
+18 IF $PIECE(FBY,U)>0
SET FBMODX=$$MOD^ICPTMOD($PIECE(FBY,U),"I")
End DoDot:3
+19 WRITE $EXTRACT($SELECT($PIECE(FBMODX,U)>0:$PIECE(FBMODX,U,3),1:FBMOD),1,36),!
End DoDot:2
if FBAAOUT
QUIT
End DoDot:1
if FBAAOUT
QUIT
+20 IF '$TEST
WRITE !
+21 WRITE FBDASH
+22 QUIT
+23 ;
HEAD WRITE !!,?19,"**** REPORT OF FEE SCHEDULE ****",!!,?26,"For Fiscal Year ",FBFY,?70,"Page ",$GET(FBPAGE),!!,$$REPEAT^XLFSTR("=",80)
+1 WRITE !!,"CPT-MOD",?10,"Total #",?25,"75 %ile",?40,"Date Compiled",?65,"Date Range ",!,?2,"Description",!,$$REPEAT^XLFSTR("=",80),!
+2 QUIT
+3 ;
END KILL DIRUT,DUOUT,DTOUT,FBCPT,FBAAOUT,FBFY,FBI,FBJ,FBPAGE,FBY,I,K,PGM,Q,QQ,VAL,VAR,X,Y,FBDESC,^TMP("FBCPT",$JOB),FBDASH
+1 DO CLOSE^FBAAUTL
+2 QUIT
+3 ;
HELP WRITE *7,!!,"There is no data on file for fiscal year ",FBFY,!
GOTO ASKDT
