- 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 Mar 13, 2025@21:00:38 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
