RCDMBWLA ;WISC/RFJ-diagnostic measures workload report (build it) (Cont.) ;1 Jan 01
;;4.5;Accounts Receivable;**167,171**;Mar 20, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
RECTYP ; screen on receivable type
I ($P(RCDATA2,"^",8)'="")&($P(RCDATA2,"^",8)'=5) D
. S RCIFSTAT=RCIFSTAT_"I RCRECTYP="_$P(RCDATA2,"^",8)_" "
. S RCIFDESC=RCIFDESC_"[RECEIVABLE TYPE equals "_$S($P(RCDATA2,"^",8)=1:"INPATIENT",$P(RCDATA2,"^",8)=2:"OUTPATIENT",$P(RCDATA2,"^",8)=3:"PROSTHETICS",$P(RCDATA2,"^",8)=4:"PHARMACY REFILL",$P(RCDATA2,"^",8)=5:"ALL RECEIVABLES")_"]"
Q
;
;
BUILDIF ; build if statement by clerk
S ^TMP("RCDMBWLR",$J,RCCLERK,RCASSIGN,"IF")=RCIFSTAT
S ^TMP("RCDMBWLR",$J,RCCLERK,RCASSIGN,"DESC")=RCIFDESC
Q
;
;
PAYDAYS(RCBILLDA) ; return number of days since last payment
N DATA1,DAYS,RCDATE,RCTRANDA
; loop all transactions in reverse order until you find last payment
S RCDATE=0
S RCTRANDA=99999999999 F S RCTRANDA=$O(^PRCA(433,"C",RCBILLDA,RCTRANDA),-1) Q:'RCTRANDA D I RCDATE Q
. S DATA1=$G(^PRCA(433,RCTRANDA,1))
. ; not a payment transaction
. I $P(DATA1,"^",2)'=2,$P(DATA1,"^",2)'=34 Q
. ; get the transaction date
. S RCDATE=+$P($P(DATA1,"^",9),".")
;
; if payment not found, use date bill activated
; if there is a problem with AR and the bill does not have an
; activation date, use default 1/1/1990
I 'RCDATE S RCDATE=+$P($P($G(^PRCA(430,RCBILLDA,6)),"^",21),".") I 'RCDATE S RCDATE=2900101
;
; calculate the number of days from today
S DAYS=$$FMDIFF^XLFDT(DT,RCDATE)
Q DAYS
;
;
TRANDAYS(RCBILLDA) ; return number of days since last transaction
N DAYS,RCDATE,RCTRANDA
; get the last transaction date
S RCTRANDA=+$O(^PRCA(433,"C",RCBILLDA,999999999999),-1)
; get the transaction date
S RCDATE=+$P($P($G(^PRCA(433,RCTRANDA,1)),"^",9),".")
;
; if transaction not found, use date bill activated
; if there is a problem with AR and the bill does not have an
; activation date, use default 1/1/1990
I 'RCDATE S RCDATE=+$P($P($G(^PRCA(430,RCBILLDA,6)),"^",21),".") I 'RCDATE S RCDATE=2900101
;
; calculate the number of days from today
S DAYS=$$FMDIFF^XLFDT(DT,RCDATE)
Q DAYS
;
PTNAM(RCBILLDA) ; return patient name if third party
S (RCPTNAM,RCSSN)=""
N IBFOTP,IBBCAT,IBZ
S IBBCAT=$P(RCDATA0,"^",2) Q:'IBBCAT "^"
S IBFOTP=$$CATTYP^IBJD1(IBBCAT)
I IBFOTP="T" D
. I '$D(^DGCR(399,RCBILLDA,0)) Q
. S IBZ=^DGCR(399,RCBILLDA,0),DFN=+$P(IBZ,"^",2)
. D DEM^VADPT S RCPTNAM=VADM(1),RCSSN=+VADM(2)
Q (RCPTNAM_"^"_RCSSN)
;
LOOP ; loop all active bills and put them into the assignment list
N RCPTNAM,RCSSN,RCX,RCRECTYP,RCY,RCCLDAT0
S RCBILLDA=0 F S RCBILLDA=$O(^PRCA(430,"AC",16,RCBILLDA)) Q:'RCBILLDA D
. ; get the data from the bill file
. S RCDATA0=$G(^PRCA(430,RCBILLDA,0)) I RCDATA0="" Q
. S RCDATA6=$G(^PRCA(430,RCBILLDA,6)) S RCRC=$P(RCDATA6,"^",4)
. S RCDATA7=$G(^PRCA(430,RCBILLDA,7))
. S RCBALANC=$P(RCDATA7,"^")+$P(RCDATA7,"^",2)+$P(RCDATA7,"^",3)+$P(RCDATA7,"^",4)+$P(RCDATA7,"^",5)
. ; get the data for the debtor
. K RCDPDATA
. D DIQ340^RCDPAPLM(+$P(RCDATA0,"^",9),.01)
. S RCNAME=$G(RCDPDATA(340,+$P(RCDATA0,"^",9),.01,"E")) I RCNAME="" S RCNAME=" "
. S RCDEBT=$G(RCDPDATA(340,+$P(RCDATA0,"^",9),.01,"I"))
. ; get the patient name and SSN if third party bill
. S RCY=$$PTNAM^RCDMBWLA(RCBILLDA)
. S RCPTNAM=$P(RCY,"^"),RCSSN=$P(RCY,"^",2)
. ; get the ssn-first party
. I $G(RCDPDATA(340,+$P(RCDATA0,"^",9),.01,"I"))["DPT" S RCSSN=$P($G(^DPT(+$G(RCDPDATA(340,+$P(RCDATA0,"^",9),.01,"I")),0)),"^",9)
. S RCSSN=$E($E(RCSSN,6,9)_" ",1,4)
. ; test for date of death
. S RCFDEATH=0
. I $G(RCDPDATA(340,+$P(RCDATA0,"^",9),.01,"I"))["DPT(",$G(^DPT(+$G(RCDPDATA(340,+$P(RCDATA0,"^",9),.01,"I")),.35)) S RCFDEATH=1
. ; get the receivable type
. S RCCLDAT0=$G(^DGCR(399,RCBILLDA,0))
. S RCX=$$BTYP^IBCOIVM1(RCBILLDA,RCCLDAT0)
. S RCRECTYP=$S(RCX="I":1,RCX="O":2,RCX="P":3,RCX="R":4,1:"")
. ;
. ; loop assignments and see if they should appear on the clerks list
. S RCCLERK=0 F S RCCLERK=$O(^TMP("RCDMBWLR",$J,RCCLERK)) Q:'RCCLERK D
. . S RCASSIGN=0 F S RCASSIGN=$O(^TMP("RCDMBWLR",$J,RCCLERK,RCASSIGN)) Q:'RCASSIGN D
. . . S RCIFSTAT=^TMP("RCDMBWLR",$J,RCCLERK,RCASSIGN,"IF")
. . . X RCIFSTAT
. . . I $T D
. . . . I $D(^TMP($J,RCCLERK,RCBILLDA)) Q
. . . . S RCDEBTDA=+$P(RCDATA0,"^",9)
. . . . S ^TMP("RCDMBWLR",$J,RCCLERK,RCASSIGN,"IF",$E(RCNAME,1,30),RCDEBTDA,RCBILLDA)=RCSSN_"^"_RCFDEATH_"^"_RCBALANC_"^"_RCPTNAM
. . . . S ^TMP($J,RCCLERK,RCBILLDA)=""
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCDMBWLA 4745 printed Sep 23, 2025@19:19:25 Page 2
RCDMBWLA ;WISC/RFJ-diagnostic measures workload report (build it) (Cont.) ;1 Jan 01
+1 ;;4.5;Accounts Receivable;**167,171**;Mar 20, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
RECTYP ; screen on receivable type
+1 IF ($PIECE(RCDATA2,"^",8)'="")&($PIECE(RCDATA2,"^",8)'=5)
Begin DoDot:1
+2 SET RCIFSTAT=RCIFSTAT_"I RCRECTYP="_$PIECE(RCDATA2,"^",8)_" "
+3 SET RCIFDESC=RCIFDESC_"[RECEIVABLE TYPE equals "_$SELECT($PIECE(RCDATA2,"^",8)=1:"INPATIENT",$PIECE(RCDATA2,"^",8)=2:"OUTPATIENT",$PIECE(RCDATA2,"^",8)=3:"PROSTHETICS",$PIECE(RCDATA2,"^",8)=4:"PHARMACY REFILL",...
... $PIECE(RCDATA2,"^",8)=5:"ALL RECEIVABLES")_"]"
End DoDot:1
+4 QUIT
+5 ;
+6 ;
BUILDIF ; build if statement by clerk
+1 SET ^TMP("RCDMBWLR",$JOB,RCCLERK,RCASSIGN,"IF")=RCIFSTAT
+2 SET ^TMP("RCDMBWLR",$JOB,RCCLERK,RCASSIGN,"DESC")=RCIFDESC
+3 QUIT
+4 ;
+5 ;
PAYDAYS(RCBILLDA) ; return number of days since last payment
+1 NEW DATA1,DAYS,RCDATE,RCTRANDA
+2 ; loop all transactions in reverse order until you find last payment
+3 SET RCDATE=0
+4 SET RCTRANDA=99999999999
FOR
SET RCTRANDA=$ORDER(^PRCA(433,"C",RCBILLDA,RCTRANDA),-1)
if 'RCTRANDA
QUIT
Begin DoDot:1
+5 SET DATA1=$GET(^PRCA(433,RCTRANDA,1))
+6 ; not a payment transaction
+7 IF $PIECE(DATA1,"^",2)'=2
IF $PIECE(DATA1,"^",2)'=34
QUIT
+8 ; get the transaction date
+9 SET RCDATE=+$PIECE($PIECE(DATA1,"^",9),".")
End DoDot:1
IF RCDATE
QUIT
+10 ;
+11 ; if payment not found, use date bill activated
+12 ; if there is a problem with AR and the bill does not have an
+13 ; activation date, use default 1/1/1990
+14 IF 'RCDATE
SET RCDATE=+$PIECE($PIECE($GET(^PRCA(430,RCBILLDA,6)),"^",21),".")
IF 'RCDATE
SET RCDATE=2900101
+15 ;
+16 ; calculate the number of days from today
+17 SET DAYS=$$FMDIFF^XLFDT(DT,RCDATE)
+18 QUIT DAYS
+19 ;
+20 ;
TRANDAYS(RCBILLDA) ; return number of days since last transaction
+1 NEW DAYS,RCDATE,RCTRANDA
+2 ; get the last transaction date
+3 SET RCTRANDA=+$ORDER(^PRCA(433,"C",RCBILLDA,999999999999),-1)
+4 ; get the transaction date
+5 SET RCDATE=+$PIECE($PIECE($GET(^PRCA(433,RCTRANDA,1)),"^",9),".")
+6 ;
+7 ; if transaction not found, use date bill activated
+8 ; if there is a problem with AR and the bill does not have an
+9 ; activation date, use default 1/1/1990
+10 IF 'RCDATE
SET RCDATE=+$PIECE($PIECE($GET(^PRCA(430,RCBILLDA,6)),"^",21),".")
IF 'RCDATE
SET RCDATE=2900101
+11 ;
+12 ; calculate the number of days from today
+13 SET DAYS=$$FMDIFF^XLFDT(DT,RCDATE)
+14 QUIT DAYS
+15 ;
PTNAM(RCBILLDA) ; return patient name if third party
+1 SET (RCPTNAM,RCSSN)=""
+2 NEW IBFOTP,IBBCAT,IBZ
+3 SET IBBCAT=$PIECE(RCDATA0,"^",2)
if 'IBBCAT
QUIT "^"
+4 SET IBFOTP=$$CATTYP^IBJD1(IBBCAT)
+5 IF IBFOTP="T"
Begin DoDot:1
+6 IF '$DATA(^DGCR(399,RCBILLDA,0))
QUIT
+7 SET IBZ=^DGCR(399,RCBILLDA,0)
SET DFN=+$PIECE(IBZ,"^",2)
+8 DO DEM^VADPT
SET RCPTNAM=VADM(1)
SET RCSSN=+VADM(2)
End DoDot:1
+9 QUIT (RCPTNAM_"^"_RCSSN)
+10 ;
LOOP ; loop all active bills and put them into the assignment list
+1 NEW RCPTNAM,RCSSN,RCX,RCRECTYP,RCY,RCCLDAT0
+2 SET RCBILLDA=0
FOR
SET RCBILLDA=$ORDER(^PRCA(430,"AC",16,RCBILLDA))
if 'RCBILLDA
QUIT
Begin DoDot:1
+3 ; get the data from the bill file
+4 SET RCDATA0=$GET(^PRCA(430,RCBILLDA,0))
IF RCDATA0=""
QUIT
+5 SET RCDATA6=$GET(^PRCA(430,RCBILLDA,6))
SET RCRC=$PIECE(RCDATA6,"^",4)
+6 SET RCDATA7=$GET(^PRCA(430,RCBILLDA,7))
+7 SET RCBALANC=$PIECE(RCDATA7,"^")+$PIECE(RCDATA7,"^",2)+$PIECE(RCDATA7,"^",3)+$PIECE(RCDATA7,"^",4)+$PIECE(RCDATA7,"^",5)
+8 ; get the data for the debtor
+9 KILL RCDPDATA
+10 DO DIQ340^RCDPAPLM(+$PIECE(RCDATA0,"^",9),.01)
+11 SET RCNAME=$GET(RCDPDATA(340,+$PIECE(RCDATA0,"^",9),.01,"E"))
IF RCNAME=""
SET RCNAME=" "
+12 SET RCDEBT=$GET(RCDPDATA(340,+$PIECE(RCDATA0,"^",9),.01,"I"))
+13 ; get the patient name and SSN if third party bill
+14 SET RCY=$$PTNAM^RCDMBWLA(RCBILLDA)
+15 SET RCPTNAM=$PIECE(RCY,"^")
SET RCSSN=$PIECE(RCY,"^",2)
+16 ; get the ssn-first party
+17 IF $GET(RCDPDATA(340,+$PIECE(RCDATA0,"^",9),.01,"I"))["DPT"
SET RCSSN=$PIECE($GET(^DPT(+$GET(RCDPDATA(340,+$PIECE(RCDATA0,"^",9),.01,"I")),0)),"^",9)
+18 SET RCSSN=$EXTRACT($EXTRACT(RCSSN,6,9)_" ",1,4)
+19 ; test for date of death
+20 SET RCFDEATH=0
+21 IF $GET(RCDPDATA(340,+$PIECE(RCDATA0,"^",9),.01,"I"))["DPT("
IF $GET(^DPT(+$GET(RCDPDATA(340,+$PIECE(RCDATA0,"^",9),.01,"I")),.35))
SET RCFDEATH=1
+22 ; get the receivable type
+23 SET RCCLDAT0=$GET(^DGCR(399,RCBILLDA,0))
+24 SET RCX=$$BTYP^IBCOIVM1(RCBILLDA,RCCLDAT0)
+25 SET RCRECTYP=$SELECT(RCX="I":1,RCX="O":2,RCX="P":3,RCX="R":4,1:"")
+26 ;
+27 ; loop assignments and see if they should appear on the clerks list
+28 SET RCCLERK=0
FOR
SET RCCLERK=$ORDER(^TMP("RCDMBWLR",$JOB,RCCLERK))
if 'RCCLERK
QUIT
Begin DoDot:2
+29 SET RCASSIGN=0
FOR
SET RCASSIGN=$ORDER(^TMP("RCDMBWLR",$JOB,RCCLERK,RCASSIGN))
if 'RCASSIGN
QUIT
Begin DoDot:3
+30 SET RCIFSTAT=^TMP("RCDMBWLR",$JOB,RCCLERK,RCASSIGN,"IF")
+31 XECUTE RCIFSTAT
+32 IF $TEST
Begin DoDot:4
+33 IF $DATA(^TMP($JOB,RCCLERK,RCBILLDA))
QUIT
+34 SET RCDEBTDA=+$PIECE(RCDATA0,"^",9)
+35 SET ^TMP("RCDMBWLR",$JOB,RCCLERK,RCASSIGN,"IF",$EXTRACT(RCNAME,1,30),RCDEBTDA,RCBILLDA)=RCSSN_"^"_RCFDEATH_"^"_RCBALANC_"^"_RCPTNAM
+36 SET ^TMP($JOB,RCCLERK,RCBILLDA)=""
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+37 QUIT
+38 ;
