- 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 Feb 18, 2025@23:09:47 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 ;