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 Apr 09, 2024@20:51:52 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
