DGBTOA6 ;ALB/SCK - DGBT BENE TRAVEL PAYABLE CLAIMS REPORT ; 6/29/93 7/16/93
;;1.0;Beneficiary Travel;;September 25, 2001
ACCTS ;
U IO
N Y
K ^TMP("BT",$J)
F ACTCDE=4,5 D
. S Y=$$GETACT(ACTCDE)
D KVAR^VADPT
D REPORT
K DGBTBEG,DGBTBG,DGBTEND,CDATE,CURACT,ACTCDE,DIV,ERR,^TMP("BT",$J)
ACCTSQ Q
;
GETACT(ACTNUM) ;
N Y S Y=1
S CDATE=DGBTBG F S CDATE=$O(^DGBT(392,"ACTP",ACTNUM,CDATE)) Q:'CDATE!(CDATE>DGBTEND) D
. N BTCLAIM
. Q:'$D(^DGBT(392,CDATE,0))
. S BTCLAIM=^DGBT(392,CDATE,0)
. S BTCLAIM("M")=$G(^DGBT(392,CDATE,"M")) ; reference node "M" of bene travel claim file (#392)
. S BTCLAIM("R")=$G(^DGBT(392,CDATE,"R")) ; reference node "R" of bene travel claim file ( #392)
. S DIV=$P($G(BTCLAIM),U,11)
. S DFN=$P($G(BTCLAIM),U,2)
. D PID^VADPT6 Q:VAERR
. S ^TMP("BT",$J,ACTNUM,DIV,$P($G(^DPT(DFN,0)),U),VA("PID"),CDATE)=$P(BTCLAIM("M"),U,3)_"^"_$P(BTCLAIM,U,9)_"^"_$P(BTCLAIM,U,10)_"^"_$P(BTCLAIM("R"),U)
Q (Y)
;
REPORT ;
N BTFIN,PDIV,NDIV
I '$D(^TMP("BT",$J)) D NOREP Q
S ERR=$$SETVAR()
S CURACT="",CURACT=$O(^TMP("BT",$J,CURACT)),PRVACT=CURACT
Q:$$HEADR()
S CURACT="" F S CURACT=$O(^TMP("BT",$J,CURACT)) Q:CURACT="" D Q:BTFIN
. I CURACT'=PRVACT D SUBS S BTFIN=$$HEADR,PRVACT=CURACT I PDIV]"" S ERR=$$DIVSN(NDIV)
. S NDIV="" F S NDIV=$O(^TMP("BT",$J,CURACT,NDIV)) Q:NDIV']"" S:PDIV'=NDIV PDIV=$$DIVSN(NDIV) D Q:BTFIN
.. S CURNAME="" F S CURNAME=$O(^TMP("BT",$J,CURACT,NDIV,CURNAME)) Q:CURNAME="" D Q:BTFIN
... S CURID="" F S CURID=$O(^TMP("BT",$J,CURACT,NDIV,CURNAME,CURID)) Q:CURID="" D Q:BTFIN
.... S CDATE="" F S CDATE=$O(^TMP("BT",$J,CURACT,NDIV,CURNAME,CURID,CDATE)) Q:CDATE="" S BTFIN=$$PRTOUT() Q:BTFIN
D TOTL
Q
;
PRTOUT() ;
N Y
S BTCLAIM=^TMP("BT",$J,CURACT,NDIV,CURNAME,CURID,CDATE)
I $Y+5>IOSL S Y=$$HEADR() G:Y PRTOUTQ
W !,$E(CURNAME,1,21),?23,CURID,?37,$$EXDATE(CDATE),?61,$FN($P(BTCLAIM,U,1),"",2),?70,$FN($P(BTCLAIM,U,2),"",2),?78,$FN($P(BTCLAIM,U,3),"",2),?86,$E($P(BTCLAIM,U,4),1,50)
S COUNT=COUNT+1,MILES=MILES+$P(BTCLAIM,U,1),DEDCT=DEDCT+$P(BTCLAIM,U,2),PAY=PAY+$P(BTCLAIM,U,3)
PRTOUTQ Q (Y)
;
EXDATE(CDOUT) ;
S Y=CDOUT D DD^%DT
Q (Y)
;
DIVSN(NDIV) ;
I $G(NDIV)]"" D
. W !!,"Division: ",$P($G(^DG(40.8,NDIV,0)),"^")
. W !,"========="
Q (NDIV)
;
NOREP ;
S CURACT=4,PAGE=0
I $$HEADR() G NOREPQ
W !!,"No data found for accounts 'ALL OTHER' or 'C&P'"
NOREPQ Q
;
HEADR() ;
N QFLAG S QFLAG=0
I $E(IOST,1,2)="C-" K DIR S DIR(0)="E" D ^DIR S QFLAG='Y G:QFLAG HEADRQ W @IOF
S PAGE=PAGE+1
I $E(IOST,1,2)'="C-" W @IOF
W !,"Payable Claims Report"
W ?(IOM-40),"Report Date: ",$P($$NOW^VALM1,"@"),?(IOM-10),"Page: ",PAGE
W !,"Inclusion Dates: ",$P($$FMTE^XLFDT(DGBTBEG,1),"@")," to ",$P($$FMTE^XLFDT(DGBTEND,1),"@")
W !,"For ACCOUNT TYPE: ",$S(CURACT=4:"ALL OTHER",CURACT=5:"C&P EXAMINATIONS")
W !!?61,"Mileage",?70,"Amount",?78,"Amount"
W !,"Patient Name",?23,"Patient ID",?37,"Claim DATE/TME",?61,"Amount",?70,"Deduct",?78,"Payable",?86,"Remarks"
W !,"----------------",?23,"------------",?37,"------------------",?61,"------",?70,"------",?78,"-------",?86,"-----------------"
HEADRQ Q (QFLAG)
;
TOTL ;
D SUBS
W !!?61,"------",?70,"------",?78,"-------"
W !,"TOTALS",?61,$FN(TMILES,"",2),?70,$FN(TDEDCT,"",2),?78,$FN(TPAY,"",2)
W !,"TOTAL CLAIMS: ",TCOUNT
Q
;
SUBS ;
N Y
W !!?61,"------",?70,"------",?78,"-------"
W !,"Subtotals",?61,$FN(MILES,"",2),?70,$FN(DEDCT,"",2),?78,$FN(PAY,"",2)
W !,"Subtotal Count of Claims: ",COUNT
S TCOUNT=TCOUNT+COUNT,TMILES=TMILES+MILES,TDEDCT=TDEDCT+DEDCT,TPAY=TPAY+PAY
S (MILES,DEDCT,PAY,COUNT)=0
Q
;
SETVAR() ;
N Y S Y=0
S (PAGE,COUNT,MILES,DEDCT,PAY,TCOUNT,TPAY,TDEDCT,TMILES,BTFIN)=0
S PDIV=""
;
Q (Y)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGBTOA6 3750 printed Nov 22, 2024@16:51:06 Page 2
DGBTOA6 ;ALB/SCK - DGBT BENE TRAVEL PAYABLE CLAIMS REPORT ; 6/29/93 7/16/93
+1 ;;1.0;Beneficiary Travel;;September 25, 2001
ACCTS ;
+1 USE IO
+2 NEW Y
+3 KILL ^TMP("BT",$JOB)
+4 FOR ACTCDE=4,5
Begin DoDot:1
+5 SET Y=$$GETACT(ACTCDE)
End DoDot:1
+6 DO KVAR^VADPT
+7 DO REPORT
+8 KILL DGBTBEG,DGBTBG,DGBTEND,CDATE,CURACT,ACTCDE,DIV,ERR,^TMP("BT",$JOB)
ACCTSQ QUIT
+1 ;
GETACT(ACTNUM) ;
+1 NEW Y
SET Y=1
+2 SET CDATE=DGBTBG
FOR
SET CDATE=$ORDER(^DGBT(392,"ACTP",ACTNUM,CDATE))
if 'CDATE!(CDATE>DGBTEND)
QUIT
Begin DoDot:1
+3 NEW BTCLAIM
+4 if '$DATA(^DGBT(392,CDATE,0))
QUIT
+5 SET BTCLAIM=^DGBT(392,CDATE,0)
+6 ; reference node "M" of bene travel claim file (#392)
SET BTCLAIM("M")=$GET(^DGBT(392,CDATE,"M"))
+7 ; reference node "R" of bene travel claim file ( #392)
SET BTCLAIM("R")=$GET(^DGBT(392,CDATE,"R"))
+8 SET DIV=$PIECE($GET(BTCLAIM),U,11)
+9 SET DFN=$PIECE($GET(BTCLAIM),U,2)
+10 DO PID^VADPT6
if VAERR
QUIT
+11 SET ^TMP("BT",$JOB,ACTNUM,DIV,$PIECE($GET(^DPT(DFN,0)),U),VA("PID"),CDATE)=$PIECE(BTCLAIM("M"),U,3)_"^"_$PIECE(BTCLAIM,U,9)_"^"_$PIECE(BTCLAIM,U,10)_"^"_$PIECE(BTCLAIM("R"),U)
End DoDot:1
+12 QUIT (Y)
+13 ;
REPORT ;
+1 NEW BTFIN,PDIV,NDIV
+2 IF '$DATA(^TMP("BT",$JOB))
DO NOREP
QUIT
+3 SET ERR=$$SETVAR()
+4 SET CURACT=""
SET CURACT=$ORDER(^TMP("BT",$JOB,CURACT))
SET PRVACT=CURACT
+5 if $$HEADR()
QUIT
+6 SET CURACT=""
FOR
SET CURACT=$ORDER(^TMP("BT",$JOB,CURACT))
if CURACT=""
QUIT
Begin DoDot:1
+7 IF CURACT'=PRVACT
DO SUBS
SET BTFIN=$$HEADR
SET PRVACT=CURACT
IF PDIV]""
SET ERR=$$DIVSN(NDIV)
+8 SET NDIV=""
FOR
SET NDIV=$ORDER(^TMP("BT",$JOB,CURACT,NDIV))
if NDIV']""
QUIT
if PDIV'=NDIV
SET PDIV=$$DIVSN(NDIV)
Begin DoDot:2
+9 SET CURNAME=""
FOR
SET CURNAME=$ORDER(^TMP("BT",$JOB,CURACT,NDIV,CURNAME))
if CURNAME=""
QUIT
Begin DoDot:3
+10 SET CURID=""
FOR
SET CURID=$ORDER(^TMP("BT",$JOB,CURACT,NDIV,CURNAME,CURID))
if CURID=""
QUIT
Begin DoDot:4
+11 SET CDATE=""
FOR
SET CDATE=$ORDER(^TMP("BT",$JOB,CURACT,NDIV,CURNAME,CURID,CDATE))
if CDATE=""
QUIT
SET BTFIN=$$PRTOUT()
if BTFIN
QUIT
End DoDot:4
if BTFIN
QUIT
End DoDot:3
if BTFIN
QUIT
End DoDot:2
if BTFIN
QUIT
End DoDot:1
if BTFIN
QUIT
+12 DO TOTL
+13 QUIT
+14 ;
PRTOUT() ;
+1 NEW Y
+2 SET BTCLAIM=^TMP("BT",$JOB,CURACT,NDIV,CURNAME,CURID,CDATE)
+3 IF $Y+5>IOSL
SET Y=$$HEADR()
if Y
GOTO PRTOUTQ
+4 WRITE !,$EXTRACT(CURNAME,1,21),?23,CURID,?37,$$EXDATE(CDATE),?61,$FNUMBER($PIECE(BTCLAIM,U,1),"",2),?70,$FNUMBER($PIECE(BTCLAIM,U,2),"",2),?78,$FNUMBER($PIECE(BTCLAIM,U,3),"",2),?86,$EXTRACT($PIECE(BTCLAIM,U,4),1,50)
+5 SET COUNT=COUNT+1
SET MILES=MILES+$PIECE(BTCLAIM,U,1)
SET DEDCT=DEDCT+$PIECE(BTCLAIM,U,2)
SET PAY=PAY+$PIECE(BTCLAIM,U,3)
PRTOUTQ QUIT (Y)
+1 ;
EXDATE(CDOUT) ;
+1 SET Y=CDOUT
DO DD^%DT
+2 QUIT (Y)
+3 ;
DIVSN(NDIV) ;
+1 IF $GET(NDIV)]""
Begin DoDot:1
+2 WRITE !!,"Division: ",$PIECE($GET(^DG(40.8,NDIV,0)),"^")
+3 WRITE !,"========="
End DoDot:1
+4 QUIT (NDIV)
+5 ;
NOREP ;
+1 SET CURACT=4
SET PAGE=0
+2 IF $$HEADR()
GOTO NOREPQ
+3 WRITE !!,"No data found for accounts 'ALL OTHER' or 'C&P'"
NOREPQ QUIT
+1 ;
HEADR() ;
+1 NEW QFLAG
SET QFLAG=0
+2 IF $EXTRACT(IOST,1,2)="C-"
KILL DIR
SET DIR(0)="E"
DO ^DIR
SET QFLAG='Y
if QFLAG
GOTO HEADRQ
WRITE @IOF
+3 SET PAGE=PAGE+1
+4 IF $EXTRACT(IOST,1,2)'="C-"
WRITE @IOF
+5 WRITE !,"Payable Claims Report"
+6 WRITE ?(IOM-40),"Report Date: ",$PIECE($$NOW^VALM1,"@"),?(IOM-10),"Page: ",PAGE
+7 WRITE !,"Inclusion Dates: ",$PIECE($$FMTE^XLFDT(DGBTBEG,1),"@")," to ",$PIECE($$FMTE^XLFDT(DGBTEND,1),"@")
+8 WRITE !,"For ACCOUNT TYPE: ",$SELECT(CURACT=4:"ALL OTHER",CURACT=5:"C&P EXAMINATIONS")
+9 WRITE !!?61,"Mileage",?70,"Amount",?78,"Amount"
+10 WRITE !,"Patient Name",?23,"Patient ID",?37,"Claim DATE/TME",?61,"Amount",?70,"Deduct",?78,"Payable",?86,"Remarks"
+11 WRITE !,"----------------",?23,"------------",?37,"------------------",?61,"------",?70,"------",?78,"-------",?86,"-----------------"
HEADRQ QUIT (QFLAG)
+1 ;
TOTL ;
+1 DO SUBS
+2 WRITE !!?61,"------",?70,"------",?78,"-------"
+3 WRITE !,"TOTALS",?61,$FNUMBER(TMILES,"",2),?70,$FNUMBER(TDEDCT,"",2),?78,$FNUMBER(TPAY,"",2)
+4 WRITE !,"TOTAL CLAIMS: ",TCOUNT
+5 QUIT
+6 ;
SUBS ;
+1 NEW Y
+2 WRITE !!?61,"------",?70,"------",?78,"-------"
+3 WRITE !,"Subtotals",?61,$FNUMBER(MILES,"",2),?70,$FNUMBER(DEDCT,"",2),?78,$FNUMBER(PAY,"",2)
+4 WRITE !,"Subtotal Count of Claims: ",COUNT
+5 SET TCOUNT=TCOUNT+COUNT
SET TMILES=TMILES+MILES
SET TDEDCT=TDEDCT+DEDCT
SET TPAY=TPAY+PAY
+6 SET (MILES,DEDCT,PAY,COUNT)=0
+7 QUIT
+8 ;
SETVAR() ;
+1 NEW Y
SET Y=0
+2 SET (PAGE,COUNT,MILES,DEDCT,PAY,TCOUNT,TPAY,TDEDCT,TMILES,BTFIN)=0
+3 SET PDIV=""
+4 ;
+5 QUIT (Y)
