RCXVDC1 ;DAOU/ALA-AR Data Extraction Data Creation ;02-JUL-03
;;4.5;Accounts Receivable;**201,227,228**;Mar 20, 1995
;
Q
EN ; Entry Point
K ^TMP($J)
D430 ; Get #430 data given RCXVBLN
N RCXVD,RCXVD1,RCXVD2,RCXVD3,RCXVD4,RCXVD5,RCXVP1,RCXVP2
N RCXVDA,RCXVDB,RCXVDC,RCXVVP1,RCXVVP,RCXVX,RCXVY
S RCXVD1=$G(^PRCA(430,RCXVBLN,0))
S RCXVD2=$G(^PRCA(430,RCXVBLN,6))
S RCXVD3=$G(^PRCA(430,RCXVBLN,7))
S RCXVD4=$G(^PRCA(430,RCXVBLN,11))
S RCXVD5=$G(^PRCA(430,RCXVBLN,13))
S RCXVBLNA=$P(RCXVD1,U,1)
S RCXVBLNB=$P(RCXVBLNA,"-",1)_"-"
S RCXVDA=RCXVBLNA ; Bill #
S RCXVP1=$P(RCXVD1,U,2),RCXVP2=""
I RCXVP1'="" S RCXVP2=$P($G(^PRCA(430.2,RCXVP1,0)),U,1)
S RCXVDA=RCXVDA_RCXVU_RCXVP2 ; Cat (P)
S RCXVDA=RCXVDA_RCXVU_$P(RCXVD1,U,3) ; Orig Amt
S RCXVDA=RCXVDA_RCXVU_$P(RCXVD1,U,4) ; GL #
S RCXVP1=$P(RCXVD1,U,8),RCXVP2=""
I RCXVP1'="" S RCXVP2=$P($G(^PRCA(430.3,RCXVP1,0)),U,1)
S RCXVDA=RCXVDA_RCXVU_RCXVP2 ; Cur Stat (P)
S RCXVDBN=$$GET1^DIQ(430,RCXVBLN_",",9,"I")
I RCXVDBN'="" S RCXVDBN=$P($G(^RCD(340,RCXVDBN,0)),U,1) I RCXVDBN="" D
. NEW CT
. S CT=$G(^TMP("RCXVBREC",$J,0))+1,^TMP("RCXVBREC",$J,0)=CT
. S ^TMP("RCXVBREC",$J,CT,0)="Bill # "_$P(^PRCA(430,RCXVBLN,0),"^",1)_" has a bad debtor record."
I RCXVDBN["DPT",DFN="" S DFN=$P(RCXVDBN,";",1)
S RCXVVP1=$S(RCXVDBN["DPT":"PATIENT",1:$$GET1^DIQ(430,RCXVBLN_",",9,"E"))
S RCXVDA=RCXVDA_RCXVU_RCXVVP1 ; Debtor (P)
S RCXVDT=$P(RCXVD1,U,10)
S RCXVDA=RCXVDA_RCXVU_$E($$HLDATE^HLFNC(RCXVDT),1,8) ; DT Bill Preprd
S RCXVY(430,11,1)=$G(^PRCA(430,RCXVBLN,7)) ; Cur Bal - Comp
S RCXVX=$P(RCXVY(430,11,1),U,1)+$P(RCXVY(430,11,1),U,2)+$P(RCXVY(430,11,1),U,3)+$P(RCXVY(430,11,1),U,4)+$P(RCXVY(430,11,1),U,5) S RCXVX=$J(RCXVX,0,2)
S RCXVDA=RCXVDA_RCXVU_RCXVX ; Cur. Bal. - computed
S RCXVDT=$P(RCXVD1,U,14)
S RCXVDA=RCXVDA_RCXVU_$E($$HLDATE^HLFNC(RCXVDT),1,8) ; DT Stat Upd
S RCXVDT=$P($P(RCXVD2,U,21),".",1)
S RCXVDB=$$HLDATE^HLFNC(RCXVDT) ; DT acct actd
S RCXVDT=$P(RCXVD2,U,1)
S RCXVDB=RCXVDB_RCXVU_$E($$HLDATE^HLFNC(RCXVDT),1,8) ; Letter 1 (DT)
S RCXVDT=$P(RCXVD2,U,4)
S RCXVDB=RCXVDB_RCXVU_$E($$HLDATE^HLFNC(RCXVDT),1,8) ; Ref DT
S RCXVDB=RCXVDB_RCXVU_$P(RCXVD2,U,5) ; RF code
S RCXVDB=RCXVDB_RCXVU_$P(RCXVD2,U,6) ; RF amt
S RCXVDT=$P(RCXVD2,U,10)
S RCXVDB=RCXVDB_RCXVU_$E($$HLDATE^HLFNC(RCXVDT),1,8) ; RF DT
S RCXVDT=$P(RCXVD2,U,11)
S RCXVDB=RCXVDB_RCXVU_$E($$HLDATE^HLFNC(RCXVDT),1,8) ; Rtrn DT
S RCXVDT=$P(RCXVD2,U,12)
S RCXVDB=RCXVDB_RCXVU_$E($$HLDATE^HLFNC(RCXVDT),1,8) ; RF DT to COWC
S RCXVDB=RCXVDB_RCXVU_$P(RCXVD2,U,13) ; RF amt to COWC
S RCXVDB=RCXVDB_RCXVU_$P(RCXVD4,U,23) ; RSC
S RCXVDB=RCXVDB_RCXVU_$P(RCXVD3,U,1) ; PRIN BAL
S RCXVDC=$P(RCXVD3,U,2) ; INT BAL
S RCXVDC=RCXVDC_RCXVU_$P(RCXVD3,U,3) ; ADMIN COST BAL
S RCXVDC=RCXVDC_RCXVU_$P(RCXVD3,U,7) ; TOT PAID PRINC
S RCXVDC=RCXVDC_RCXVU_$P(RCXVD3,U,8) ; TOT PAID INT
S RCXVDC=RCXVDC_RCXVU_$P(RCXVD3,U,9) ; TOT PAID ADMIN
S RCXVDC=RCXVDC_RCXVU_$P(RCXVD3,U,10) ; TOT PAID MARSHAL FEE
S RCXVDC=RCXVDC_RCXVU_$P(RCXVD4,U,17) ; FUND
S RCXVP1=$P(RCXVD4,U,6),RCXVP2=""
I RCXVP1'="" S RCXVP2=$P($G(^RC(347.3,RCXVP1,0)),U,1)
S RCXVDC=RCXVDC_RCXVU_RCXVP2 ; REV SRCE (P)
S RCXVDT=$$DFP^RCXVUTIL(RCXVBLN)
S RCXVDC=RCXVDC_RCXVU_$E($$HLDATE^HLFNC(RCXVDT),1,8) ; DT 1ST PAYMNT
S RCXVDC=RCXVDC_RCXVU_$P(RCXVD5,U) ;MEDICARE CONTRACT ADJUSTMENT AMT
S RCXVDC=RCXVDC_RCXVU_$P(RCXVD5,U,2) ;MEDICARE UNREIMBURSABLE AMOUNT
S RCXVDC=RCXVDC_RCXVU_$P(RCXVD3,U,18) ;REFUNDED AMOUNT
S RCXVDT=$P(RCXVD3,U,19)
S RCXVDC=RCXVDC_RCXVU_$E($$HLDATE^HLFNC(RCXVDT),1,8) ;REFUNDED DATE
;
S ^TMP($J,RCXVBLN,"1-430A")=RCXVDA
S ^TMP($J,RCXVBLN,"1-430B")=RCXVDB
S ^TMP($J,RCXVBLN,"1-430C")=RCXVDC
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCXVDC1 3716 printed Nov 22, 2024@16:59:42 Page 2
RCXVDC1 ;DAOU/ALA-AR Data Extraction Data Creation ;02-JUL-03
+1 ;;4.5;Accounts Receivable;**201,227,228**;Mar 20, 1995
+2 ;
+3 QUIT
EN ; Entry Point
+1 KILL ^TMP($JOB)
D430 ; Get #430 data given RCXVBLN
+1 NEW RCXVD,RCXVD1,RCXVD2,RCXVD3,RCXVD4,RCXVD5,RCXVP1,RCXVP2
+2 NEW RCXVDA,RCXVDB,RCXVDC,RCXVVP1,RCXVVP,RCXVX,RCXVY
+3 SET RCXVD1=$GET(^PRCA(430,RCXVBLN,0))
+4 SET RCXVD2=$GET(^PRCA(430,RCXVBLN,6))
+5 SET RCXVD3=$GET(^PRCA(430,RCXVBLN,7))
+6 SET RCXVD4=$GET(^PRCA(430,RCXVBLN,11))
+7 SET RCXVD5=$GET(^PRCA(430,RCXVBLN,13))
+8 SET RCXVBLNA=$PIECE(RCXVD1,U,1)
+9 SET RCXVBLNB=$PIECE(RCXVBLNA,"-",1)_"-"
+10 ; Bill #
SET RCXVDA=RCXVBLNA
+11 SET RCXVP1=$PIECE(RCXVD1,U,2)
SET RCXVP2=""
+12 IF RCXVP1'=""
SET RCXVP2=$PIECE($GET(^PRCA(430.2,RCXVP1,0)),U,1)
+13 ; Cat (P)
SET RCXVDA=RCXVDA_RCXVU_RCXVP2
+14 ; Orig Amt
SET RCXVDA=RCXVDA_RCXVU_$PIECE(RCXVD1,U,3)
+15 ; GL #
SET RCXVDA=RCXVDA_RCXVU_$PIECE(RCXVD1,U,4)
+16 SET RCXVP1=$PIECE(RCXVD1,U,8)
SET RCXVP2=""
+17 IF RCXVP1'=""
SET RCXVP2=$PIECE($GET(^PRCA(430.3,RCXVP1,0)),U,1)
+18 ; Cur Stat (P)
SET RCXVDA=RCXVDA_RCXVU_RCXVP2
+19 SET RCXVDBN=$$GET1^DIQ(430,RCXVBLN_",",9,"I")
+20 IF RCXVDBN'=""
SET RCXVDBN=$PIECE($GET(^RCD(340,RCXVDBN,0)),U,1)
IF RCXVDBN=""
Begin DoDot:1
+21 NEW CT
+22 SET CT=$GET(^TMP("RCXVBREC",$JOB,0))+1
SET ^TMP("RCXVBREC",$JOB,0)=CT
+23 SET ^TMP("RCXVBREC",$JOB,CT,0)="Bill # "_$PIECE(^PRCA(430,RCXVBLN,0),"^",1)_" has a bad debtor record."
End DoDot:1
+24 IF RCXVDBN["DPT"
IF DFN=""
SET DFN=$PIECE(RCXVDBN,";",1)
+25 SET RCXVVP1=$SELECT(RCXVDBN["DPT":"PATIENT",1:$$GET1^DIQ(430,RCXVBLN_",",9,"E"))
+26 ; Debtor (P)
SET RCXVDA=RCXVDA_RCXVU_RCXVVP1
+27 SET RCXVDT=$PIECE(RCXVD1,U,10)
+28 ; DT Bill Preprd
SET RCXVDA=RCXVDA_RCXVU_$EXTRACT($$HLDATE^HLFNC(RCXVDT),1,8)
+29 ; Cur Bal - Comp
SET RCXVY(430,11,1)=$GET(^PRCA(430,RCXVBLN,7))
+30 SET RCXVX=$PIECE(RCXVY(430,11,1),U,1)+$PIECE(RCXVY(430,11,1),U,2)+$PIECE(RCXVY(430,11,1),U,3)+$PIECE(RCXVY(430,11,1),U,4)+$PIECE(RCXVY(430,11,1),U,5)
SET RCXVX=$JUSTIFY(RCXVX,0,2)
+31 ; Cur. Bal. - computed
SET RCXVDA=RCXVDA_RCXVU_RCXVX
+32 SET RCXVDT=$PIECE(RCXVD1,U,14)
+33 ; DT Stat Upd
SET RCXVDA=RCXVDA_RCXVU_$EXTRACT($$HLDATE^HLFNC(RCXVDT),1,8)
+34 SET RCXVDT=$PIECE($PIECE(RCXVD2,U,21),".",1)
+35 ; DT acct actd
SET RCXVDB=$$HLDATE^HLFNC(RCXVDT)
+36 SET RCXVDT=$PIECE(RCXVD2,U,1)
+37 ; Letter 1 (DT)
SET RCXVDB=RCXVDB_RCXVU_$EXTRACT($$HLDATE^HLFNC(RCXVDT),1,8)
+38 SET RCXVDT=$PIECE(RCXVD2,U,4)
+39 ; Ref DT
SET RCXVDB=RCXVDB_RCXVU_$EXTRACT($$HLDATE^HLFNC(RCXVDT),1,8)
+40 ; RF code
SET RCXVDB=RCXVDB_RCXVU_$PIECE(RCXVD2,U,5)
+41 ; RF amt
SET RCXVDB=RCXVDB_RCXVU_$PIECE(RCXVD2,U,6)
+42 SET RCXVDT=$PIECE(RCXVD2,U,10)
+43 ; RF DT
SET RCXVDB=RCXVDB_RCXVU_$EXTRACT($$HLDATE^HLFNC(RCXVDT),1,8)
+44 SET RCXVDT=$PIECE(RCXVD2,U,11)
+45 ; Rtrn DT
SET RCXVDB=RCXVDB_RCXVU_$EXTRACT($$HLDATE^HLFNC(RCXVDT),1,8)
+46 SET RCXVDT=$PIECE(RCXVD2,U,12)
+47 ; RF DT to COWC
SET RCXVDB=RCXVDB_RCXVU_$EXTRACT($$HLDATE^HLFNC(RCXVDT),1,8)
+48 ; RF amt to COWC
SET RCXVDB=RCXVDB_RCXVU_$PIECE(RCXVD2,U,13)
+49 ; RSC
SET RCXVDB=RCXVDB_RCXVU_$PIECE(RCXVD4,U,23)
+50 ; PRIN BAL
SET RCXVDB=RCXVDB_RCXVU_$PIECE(RCXVD3,U,1)
+51 ; INT BAL
SET RCXVDC=$PIECE(RCXVD3,U,2)
+52 ; ADMIN COST BAL
SET RCXVDC=RCXVDC_RCXVU_$PIECE(RCXVD3,U,3)
+53 ; TOT PAID PRINC
SET RCXVDC=RCXVDC_RCXVU_$PIECE(RCXVD3,U,7)
+54 ; TOT PAID INT
SET RCXVDC=RCXVDC_RCXVU_$PIECE(RCXVD3,U,8)
+55 ; TOT PAID ADMIN
SET RCXVDC=RCXVDC_RCXVU_$PIECE(RCXVD3,U,9)
+56 ; TOT PAID MARSHAL FEE
SET RCXVDC=RCXVDC_RCXVU_$PIECE(RCXVD3,U,10)
+57 ; FUND
SET RCXVDC=RCXVDC_RCXVU_$PIECE(RCXVD4,U,17)
+58 SET RCXVP1=$PIECE(RCXVD4,U,6)
SET RCXVP2=""
+59 IF RCXVP1'=""
SET RCXVP2=$PIECE($GET(^RC(347.3,RCXVP1,0)),U,1)
+60 ; REV SRCE (P)
SET RCXVDC=RCXVDC_RCXVU_RCXVP2
+61 SET RCXVDT=$$DFP^RCXVUTIL(RCXVBLN)
+62 ; DT 1ST PAYMNT
SET RCXVDC=RCXVDC_RCXVU_$EXTRACT($$HLDATE^HLFNC(RCXVDT),1,8)
+63 ;MEDICARE CONTRACT ADJUSTMENT AMT
SET RCXVDC=RCXVDC_RCXVU_$PIECE(RCXVD5,U)
+64 ;MEDICARE UNREIMBURSABLE AMOUNT
SET RCXVDC=RCXVDC_RCXVU_$PIECE(RCXVD5,U,2)
+65 ;REFUNDED AMOUNT
SET RCXVDC=RCXVDC_RCXVU_$PIECE(RCXVD3,U,18)
+66 SET RCXVDT=$PIECE(RCXVD3,U,19)
+67 ;REFUNDED DATE
SET RCXVDC=RCXVDC_RCXVU_$EXTRACT($$HLDATE^HLFNC(RCXVDT),1,8)
+68 ;
+69 SET ^TMP($JOB,RCXVBLN,"1-430A")=RCXVDA
+70 SET ^TMP($JOB,RCXVBLN,"1-430B")=RCXVDB
+71 SET ^TMP($JOB,RCXVBLN,"1-430C")=RCXVDC
+72 QUIT
+73 ;
