- RCBDXREF ;WISC/RFJ-fix cross references ;1 Jan 01
- ;;4.5;Accounts Receivable;**165**;Mar 20, 1995
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- Q
- ;
- ;
- FIXATD ; fix atd x-ref
- ;
- N DATE,DEBT,RCBILLDA,RCDATE,RCDEBTDA
- ;
- ; loop current x-refs and see if any should be removed
- S RCDEBTDA=0 F S RCDEBTDA=$O(^PRCA(430,"ATD",RCDEBTDA)) Q:'RCDEBTDA D
- . ;
- . ; not a first party account
- . I $P($G(^RCD(340,RCDEBTDA,0)),"^")'["DPT(" D Q
- . . W !,"Not a correct XREF. KILL ^PRCA(430,""ATD"",",RCDEBTDA,")"
- . . K ^PRCA(430,"ATD",RCDEBTDA)
- . ;
- . S RCDATE=0 F S RCDATE=$O(^PRCA(430,"ATD",RCDEBTDA,RCDATE)) Q:'RCDATE D
- . . S RCBILLDA=0 F S RCBILLDA=$O(^PRCA(430,"ATD",RCDEBTDA,RCDATE,RCBILLDA)) Q:'RCBILLDA D
- . . . S DATE=+$P($G(^PRCA(430,RCBILLDA,6)),"^",21)
- . . . S DEBT=+$P($G(^PRCA(430,RCBILLDA,0)),"^",9)
- . . . I RCDEBTDA'=DEBT!(RCDATE'=DATE) D
- . . . . W !,"Not a correct XREF. KILL ^PRCA(430,""ATD"",",RCDEBTDA,",",RCDATE,",",RCBILLDA,")"
- . . . . K ^PRCA(430,"ATD",RCDEBTDA,RCDATE,RCBILLDA)
- ;
- ; loop all bills and make sure x-ref is set
- S RCBILLDA=0 F S RCBILLDA=$O(^PRCA(430,RCBILLDA)) Q:'RCBILLDA D
- . S RCDATE=+$P($G(^PRCA(430,RCBILLDA,6)),"^",21) I 'RCDATE Q
- . S RCDEBTDA=+$P($G(^PRCA(430,RCBILLDA,0)),"^",9) I 'RCDEBTDA Q
- . ;
- . ; not a first party account
- . I $P($G(^RCD(340,RCDEBTDA,0)),"^")'["DPT(" Q
- . ;
- . I '$D(^PRCA(430,"ATD",RCDEBTDA,RCDATE,RCBILLDA)) D
- . . W !,"Missing XREF. SET ^PRCA(430,""ATD"",",RCDEBTDA,",",RCDATE,",",RCBILLDA,")"
- . . S ^PRCA(430,"ATD",RCDEBTDA,RCDATE,RCBILLDA)=""
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCBDXREF 1676 printed Feb 18, 2025@23:08:59 Page 2
- RCBDXREF ;WISC/RFJ-fix cross references ;1 Jan 01
- +1 ;;4.5;Accounts Receivable;**165**;Mar 20, 1995
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 QUIT
- +4 ;
- +5 ;
- FIXATD ; fix atd x-ref
- +1 ;
- +2 NEW DATE,DEBT,RCBILLDA,RCDATE,RCDEBTDA
- +3 ;
- +4 ; loop current x-refs and see if any should be removed
- +5 SET RCDEBTDA=0
- FOR
- SET RCDEBTDA=$ORDER(^PRCA(430,"ATD",RCDEBTDA))
- if 'RCDEBTDA
- QUIT
- Begin DoDot:1
- +6 ;
- +7 ; not a first party account
- +8 IF $PIECE($GET(^RCD(340,RCDEBTDA,0)),"^")'["DPT("
- Begin DoDot:2
- +9 WRITE !,"Not a correct XREF. KILL ^PRCA(430,""ATD"",",RCDEBTDA,")"
- +10 KILL ^PRCA(430,"ATD",RCDEBTDA)
- End DoDot:2
- QUIT
- +11 ;
- +12 SET RCDATE=0
- FOR
- SET RCDATE=$ORDER(^PRCA(430,"ATD",RCDEBTDA,RCDATE))
- if 'RCDATE
- QUIT
- Begin DoDot:2
- +13 SET RCBILLDA=0
- FOR
- SET RCBILLDA=$ORDER(^PRCA(430,"ATD",RCDEBTDA,RCDATE,RCBILLDA))
- if 'RCBILLDA
- QUIT
- Begin DoDot:3
- +14 SET DATE=+$PIECE($GET(^PRCA(430,RCBILLDA,6)),"^",21)
- +15 SET DEBT=+$PIECE($GET(^PRCA(430,RCBILLDA,0)),"^",9)
- +16 IF RCDEBTDA'=DEBT!(RCDATE'=DATE)
- Begin DoDot:4
- +17 WRITE !,"Not a correct XREF. KILL ^PRCA(430,""ATD"",",RCDEBTDA,",",RCDATE,",",RCBILLDA,")"
- +18 KILL ^PRCA(430,"ATD",RCDEBTDA,RCDATE,RCBILLDA)
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +19 ;
- +20 ; loop all bills and make sure x-ref is set
- +21 SET RCBILLDA=0
- FOR
- SET RCBILLDA=$ORDER(^PRCA(430,RCBILLDA))
- if 'RCBILLDA
- QUIT
- Begin DoDot:1
- +22 SET RCDATE=+$PIECE($GET(^PRCA(430,RCBILLDA,6)),"^",21)
- IF 'RCDATE
- QUIT
- +23 SET RCDEBTDA=+$PIECE($GET(^PRCA(430,RCBILLDA,0)),"^",9)
- IF 'RCDEBTDA
- QUIT
- +24 ;
- +25 ; not a first party account
- +26 IF $PIECE($GET(^RCD(340,RCDEBTDA,0)),"^")'["DPT("
- QUIT
- +27 ;
- +28 IF '$DATA(^PRCA(430,"ATD",RCDEBTDA,RCDATE,RCBILLDA))
- Begin DoDot:2
- +29 WRITE !,"Missing XREF. SET ^PRCA(430,""ATD"",",RCDEBTDA,",",RCDATE,",",RCBILLDA,")"
- +30 SET ^PRCA(430,"ATD",RCDEBTDA,RCDATE,RCBILLDA)=""
- End DoDot:2
- End DoDot:1
- +31 QUIT