- 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 Apr 23, 2025@18:11:13 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
