FBAAPAY ;AISC/DMK-COMPILE CPT CODE SCHEDULE ;6/14/1999
;;3.5;FEE BASIS;**4,69**;JAN 30, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
ASKDT S FBFL=0,FBFY="" W !!,?20,"*** DATE RANGE SELECTION ***",!!,?12,"Enter fiscal year or date range within fiscal year.",!!
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
QUE S VAR="BEGDATE^ENDDATE^FBFY",VAL=BEGDATE_"^"_ENDDATE_"^"_FBFY,PGM="START^FBAAPAY" D ZIS^FBAAUTL G END:FBPOP
;
START K ^TMP($J) S (CNT,PAY)="",%DT="X",X="TODAY" D ^%DT S FBRUN=Y_"^"_BEGDATE_"^"_ENDDATE,FBFY=FBFY+1700
;
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
S I=0 F S I=$O(^TMP($J,I)) Q:I="" I +^(I)>7 S VARR=+^(I) D SET,80
S ^FBAA(163.99,"AC",FBFY,FBFY)="" D START^FBAASOUT
;
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
K FBMODLE
D CLOSE^FBAAUTL Q
;
SET S FBI=$O(^FBAA(163.99,"B",I,0)) D:'FBI
.S X=I,DIC(0)="L",DIC="^FBAA(163.99,"
.K DD,DO D FILE^DICN Q:Y<0 S FBI=+Y K DIC,DD,DO
Q:'$G(FBI)
S:'$D(^FBAA(163.99,FBI,"FY",0)) ^FBAA(163.99,FBI,"FY",0)="^163.991A^^"
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)
S ^FBAA(163.99,FBI,"FY",FBFY,0)=FBFY_"^"_VARR
Q
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
Q
LOOK N FBUNITS
S Y(1)=^FBAAC(I,1,J,1,K,1,L,0)
S FBMODLE=$$MODL^FBAAUTL4("^FBAAC(I,1,J,1,K,1,L,""M"")","E")
; file 163.99 supports upto 18 modifiers
I $L(FBMODLE,",")>18 S FBMODLE=$P(FBMODLE,",",1,18) ; truncate mods
S II=$$CPT^FBAAUTL4($P(Y(1),U))_$S($G(FBMODLE)]"":"-"_FBMODLE,1:"")
Q:II=""
S AC=$P(Y(1),"^",2),AP=$P(Y(1),"^",3) S:'$D(^TMP($J,II)) ^TMP($J,II)=0
I AP>0 D
. ; skip if beginning date not after October 2003
. I BEGDATE>3030930 D
. . S FBUNITS=$P($G(^FBAAC(I,1,J,1,K,1,L,2)),U,14)
. . ; skip if units paid not more than one
. . Q:$G(FBUNITS)'>1
. . ; divide amount claimed by units and round it to cents
. . S AC=$J(AC/FBUNITS,"",2)
. . ; divide amount paid by units and round it to cents
. . S AP=$J(AP/FBUNITS,"",2)
. 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)=""
Q
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
K FBI Q
;
80 Q:'$G(FBI)
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
;
FYCK S FBFY=$E(Y,1,3),BEGDATE=(FBFY-1_"1000"),ENDDATE=(FBFY_"0930") G QUE
;
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
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAAPAY 3222 printed Dec 13, 2024@01:55:56 Page 2
FBAAPAY ;AISC/DMK-COMPILE CPT CODE SCHEDULE ;6/14/1999
+1 ;;3.5;FEE BASIS;**4,69**;JAN 30, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
ASKDT SET FBFL=0
SET FBFY=""
WRITE !!,?20,"*** DATE RANGE SELECTION ***",!!,?12,"Enter fiscal year or date range within fiscal year.",!!
+1 SET %DT="AE"
SET %DT("A")=" Beginning Date : "
DO ^%DT
if Y<0
QUIT
if '$EXTRACT(Y,4,7)
GOTO FYCK
SET BEGDATE=Y-.1
SET %DT(0)=Y
WRITE !
SET %DT("A")=" Ending Date : "
DO ^%DT
KILL %DT
if Y<0
QUIT
WRITE !
DO DATECK
if FBFL
GOTO ASKDT
SET ENDDATE=Y+.9
QUE SET VAR="BEGDATE^ENDDATE^FBFY"
SET VAL=BEGDATE_"^"_ENDDATE_"^"_FBFY
SET PGM="START^FBAAPAY"
DO ZIS^FBAAUTL
if FBPOP
GOTO END
+1 ;
START KILL ^TMP($JOB)
SET (CNT,PAY)=""
SET %DT="X"
SET X="TODAY"
DO ^%DT
SET FBRUN=Y_"^"_BEGDATE_"^"_ENDDATE
SET FBFY=FBFY+1700
+1 ;
RD FOR I=0:0
SET I=$ORDER(^FBAAC(I))
if I'>0
QUIT
FOR J=0:0
SET J=$ORDER(^FBAAC(I,1,J))
if J'>0
QUIT
IF $DATA(^(J,0))
FOR K=0:0
SET K=$ORDER(^FBAAC(I,1,J,1,K))
if K'>0
QUIT
IF $DATA(^(K,0))
DO RD1
+1 SET I=0
FOR
SET I=$ORDER(^TMP($JOB,I))
if I=""
QUIT
IF +^(I)>7
SET VARR=+^(I)
DO SET
DO 80
+2 SET ^FBAA(163.99,"AC",FBFY,FBFY)=""
DO START^FBAASOUT
+3 ;
END ;,^TMP($J),FBDESC,FBI
KILL 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
+1 KILL FBMODLE
+2 DO CLOSE^FBAAUTL
QUIT
+3 ;
SET SET FBI=$ORDER(^FBAA(163.99,"B",I,0))
if 'FBI
Begin DoDot:1
+1 SET X=I
SET DIC(0)="L"
SET DIC="^FBAA(163.99,"
+2 KILL DD,DO
DO FILE^DICN
if Y<0
QUIT
SET FBI=+Y
KILL DIC,DD,DO
End DoDot:1
+3 if '$GET(FBI)
QUIT
+4 if '$DATA(^FBAA(163.99,FBI,"FY",0))
SET ^FBAA(163.99,FBI,"FY",0)="^163.991A^^"
+5 SET Y(2)=^FBAA(163.99,FBI,"FY",0)
SET $PIECE(Y(2),"^",3)=FBFY
SET $PIECE(Y(2),"^",4)=$PIECE(Y(2),"^",4)+1
SET ^FBAA(163.99,FBI,"FY",0)=Y(2)
+6 SET ^FBAA(163.99,FBI,"FY",FBFY,0)=FBFY_"^"_VARR
+7 QUIT
RD1 IF +^FBAAC(I,1,J,1,K,0)>BEGDATE&(+^FBAAC(I,1,J,1,K,0)<ENDDATE)
FOR L=0:0
SET L=$ORDER(^FBAAC(I,1,J,1,K,1,L))
if L'>0
QUIT
IF $DATA(^(L,0))
DO LOOK
+1 QUIT
LOOK NEW FBUNITS
+1 SET Y(1)=^FBAAC(I,1,J,1,K,1,L,0)
+2 SET FBMODLE=$$MODL^FBAAUTL4("^FBAAC(I,1,J,1,K,1,L,""M"")","E")
+3 ; file 163.99 supports upto 18 modifiers
+4 ; truncate mods
IF $LENGTH(FBMODLE,",")>18
SET FBMODLE=$PIECE(FBMODLE,",",1,18)
+5 SET II=$$CPT^FBAAUTL4($PIECE(Y(1),U))_$SELECT($GET(FBMODLE)]"":"-"_FBMODLE,1:"")
+6 if II=""
QUIT
+7 SET AC=$PIECE(Y(1),"^",2)
SET AP=$PIECE(Y(1),"^",3)
if '$DATA(^TMP($JOB,II))
SET ^TMP($JOB,II)=0
+8 IF AP>0
Begin DoDot:1
+9 ; skip if beginning date not after October 2003
+10 IF BEGDATE>3030930
Begin DoDot:2
+11 SET FBUNITS=$PIECE($GET(^FBAAC(I,1,J,1,K,1,L,2)),U,14)
+12 ; skip if units paid not more than one
+13 if $GET(FBUNITS)'>1
QUIT
+14 ; divide amount claimed by units and round it to cents
+15 SET AC=$JUSTIFY(AC/FBUNITS,"",2)
+16 ; divide amount paid by units and round it to cents
+17 SET AP=$JUSTIFY(AP/FBUNITS,"",2)
End DoDot:2
+18 SET Y=^TMP($JOB,II)
SET $PIECE(^(II),"^",1)=$PIECE(Y,"^",1)+1
SET $PIECE(^(II),"^",2)=$PIECE(Y,"^",2)+AC
SET $PIECE(^(II),"^",3)=$PIECE(Y,"^",3)+AP
SET CNT=CNT+1
SET ^TMP($JOB,II,+AC,+AP,CNT)=""
End DoDot:1
+19 QUIT
FILE FOR J=0:0
SET J=$ORDER(^TMP($JOB,I,J))
if J'>0
QUIT
FOR K=0:0
SET K=$ORDER(^TMP($JOB,I,J,K))
if K'>0
QUIT
FOR L=0:0
SET L=$ORDER(^TMP($JOB,I,J,K,L))
if L'>0
QUIT
SET CNT=CNT+1
if CNT=VAR
SET $PIECE(^FBAA(163.99,FBI,"FY",FBFY,0),"^",NOD)=J
SET $PIECE(^(0),"^",6,8)=FBRUN
+1 KILL FBI
QUIT
+2 ;
80 if '$GET(FBI)
QUIT
+1 SET VAR=VARR*.75
SET VAR=$SELECT($PIECE(VAR,".",2)>5:$PIECE(VAR,".",1)+1,1:$PIECE(VAR,".",1))
SET (CNT,NUM,NUM1,PAY)=0
SET NOD=5
DO FILE
QUIT
+2 ;
FYCK SET FBFY=$EXTRACT(Y,1,3)
SET BEGDATE=(FBFY-1_"1000")
SET ENDDATE=(FBFY_"0930")
GOTO QUE
+1 ;
DATECK SET FBFY=$SELECT($EXTRACT(BEGDATE,4,5)>9:($EXTRACT(BEGDATE,1,3)+1),1:$EXTRACT(BEGDATE,1,3))
IF Y>(FBFY_"1001")
WRITE !,*7," Dates must be within a fiscal year. "
SET FBFL=1
QUIT
+1 QUIT
