| 1 | FBAAPAY ;AISC/DMK-COMPILE CPT CODE SCHEDULE ;6/14/1999
|
|---|
| 2 | ;;3.5;FEE BASIS;**4,69**;JAN 30, 1995
|
|---|
| 3 | ;;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | ASKDT S FBFL=0,FBFY="" W !!,?20,"*** DATE RANGE SELECTION ***",!!,?12,"Enter fiscal year or date range within fiscal year.",!!
|
|---|
| 5 | S %DT="AE",%DT("A")=" Beginning Date : " D ^%DT Q:Y<0 G FYCK:'$E(Y,4,7) S BEGDATE=Y-.1,%DT(0)=Y W ! S %DT("A")=" Ending Date : " D ^%DT K %DT Q:Y<0 W ! D DATECK G:FBFL ASKDT S ENDDATE=Y+.9
|
|---|
| 6 | QUE S VAR="BEGDATE^ENDDATE^FBFY",VAL=BEGDATE_"^"_ENDDATE_"^"_FBFY,PGM="START^FBAAPAY" D ZIS^FBAAUTL G END:FBPOP
|
|---|
| 7 | ;
|
|---|
| 8 | START K ^TMP($J) S (CNT,PAY)="",%DT="X",X="TODAY" D ^%DT S FBRUN=Y_"^"_BEGDATE_"^"_ENDDATE,FBFY=FBFY+1700
|
|---|
| 9 | ;
|
|---|
| 10 | RD F I=0:0 S I=$O(^FBAAC(I)) Q:I'>0 F J=0:0 S J=$O(^FBAAC(I,1,J)) Q:J'>0 I $D(^(J,0)) F K=0:0 S K=$O(^FBAAC(I,1,J,1,K)) Q:K'>0 I $D(^(K,0)) D RD1
|
|---|
| 11 | S I=0 F S I=$O(^TMP($J,I)) Q:I="" I +^(I)>7 S VARR=+^(I) D SET,80
|
|---|
| 12 | S ^FBAA(163.99,"AC",FBFY,FBFY)="" D START^FBAASOUT
|
|---|
| 13 | ;
|
|---|
| 14 | END K AC,AP,%DT("A"),FBCPT,FBAAFY,FBEDT,FBRUN,PGM,Q,QQ,VAL,FBFL,FBFY,VARR,CNT,NUM,NUM1,PAY,I,II,J,K,L,NOD,VAR,X,Y,ZZ,BEGDATE,ENDDATE ;,^TMP($J),FBDESC,FBI
|
|---|
| 15 | K FBMODLE
|
|---|
| 16 | D CLOSE^FBAAUTL Q
|
|---|
| 17 | ;
|
|---|
| 18 | SET S FBI=$O(^FBAA(163.99,"B",I,0)) D:'FBI
|
|---|
| 19 | .S X=I,DIC(0)="L",DIC="^FBAA(163.99,"
|
|---|
| 20 | .K DD,DO D FILE^DICN Q:Y<0 S FBI=+Y K DIC,DD,DO
|
|---|
| 21 | Q:'$G(FBI)
|
|---|
| 22 | S:'$D(^FBAA(163.99,FBI,"FY",0)) ^FBAA(163.99,FBI,"FY",0)="^163.991A^^"
|
|---|
| 23 | S Y(2)=^FBAA(163.99,FBI,"FY",0),$P(Y(2),"^",3)=FBFY,$P(Y(2),"^",4)=$P(Y(2),"^",4)+1,^FBAA(163.99,FBI,"FY",0)=Y(2)
|
|---|
| 24 | S ^FBAA(163.99,FBI,"FY",FBFY,0)=FBFY_"^"_VARR
|
|---|
| 25 | Q
|
|---|
| 26 | RD1 I +^FBAAC(I,1,J,1,K,0)>BEGDATE&(+^FBAAC(I,1,J,1,K,0)<ENDDATE) F L=0:0 S L=$O(^FBAAC(I,1,J,1,K,1,L)) Q:L'>0 I $D(^(L,0)) D LOOK
|
|---|
| 27 | Q
|
|---|
| 28 | LOOK N FBUNITS
|
|---|
| 29 | S Y(1)=^FBAAC(I,1,J,1,K,1,L,0)
|
|---|
| 30 | S FBMODLE=$$MODL^FBAAUTL4("^FBAAC(I,1,J,1,K,1,L,""M"")","E")
|
|---|
| 31 | ; file 163.99 supports upto 18 modifiers
|
|---|
| 32 | I $L(FBMODLE,",")>18 S FBMODLE=$P(FBMODLE,",",1,18) ; truncate mods
|
|---|
| 33 | S II=$$CPT^FBAAUTL4($P(Y(1),U))_$S($G(FBMODLE)]"":"-"_FBMODLE,1:"")
|
|---|
| 34 | Q:II=""
|
|---|
| 35 | S AC=$P(Y(1),"^",2),AP=$P(Y(1),"^",3) S:'$D(^TMP($J,II)) ^TMP($J,II)=0
|
|---|
| 36 | I AP>0 D
|
|---|
| 37 | . ; skip if beginning date not after October 2003
|
|---|
| 38 | . I BEGDATE>3030930 D
|
|---|
| 39 | . . S FBUNITS=$P($G(^FBAAC(I,1,J,1,K,1,L,2)),U,14)
|
|---|
| 40 | . . ; skip if units paid not more than one
|
|---|
| 41 | . . Q:$G(FBUNITS)'>1
|
|---|
| 42 | . . ; divide amount claimed by units and round it to cents
|
|---|
| 43 | . . S AC=$J(AC/FBUNITS,"",2)
|
|---|
| 44 | . . ; divide amount paid by units and round it to cents
|
|---|
| 45 | . . S AP=$J(AP/FBUNITS,"",2)
|
|---|
| 46 | . S Y=^TMP($J,II),$P(^(II),"^",1)=$P(Y,"^",1)+1,$P(^(II),"^",2)=$P(Y,"^",2)+AC,$P(^(II),"^",3)=$P(Y,"^",3)+AP,CNT=CNT+1,^TMP($J,II,+AC,+AP,CNT)=""
|
|---|
| 47 | Q
|
|---|
| 48 | FILE F J=0:0 S J=$O(^TMP($J,I,J)) Q:J'>0 F K=0:0 S K=$O(^TMP($J,I,J,K)) Q:K'>0 F L=0:0 S L=$O(^TMP($J,I,J,K,L)) Q:L'>0 S CNT=CNT+1 S:CNT=VAR $P(^FBAA(163.99,FBI,"FY",FBFY,0),"^",NOD)=J,$P(^(0),"^",6,8)=FBRUN
|
|---|
| 49 | K FBI Q
|
|---|
| 50 | ;
|
|---|
| 51 | 80 Q:'$G(FBI)
|
|---|
| 52 | S VAR=VARR*.75,VAR=$S($P(VAR,".",2)>5:$P(VAR,".",1)+1,1:$P(VAR,".",1)) S (CNT,NUM,NUM1,PAY)=0,NOD=5 D FILE Q
|
|---|
| 53 | ;
|
|---|
| 54 | FYCK S FBFY=$E(Y,1,3),BEGDATE=(FBFY-1_"1000"),ENDDATE=(FBFY_"0930") G QUE
|
|---|
| 55 | ;
|
|---|
| 56 | DATECK S FBFY=$S($E(BEGDATE,4,5)>9:($E(BEGDATE,1,3)+1),1:$E(BEGDATE,1,3)) I Y>(FBFY_"1001") W !,*7," Dates must be within a fiscal year. " S FBFL=1 Q
|
|---|
| 57 | Q
|
|---|
