RCFMOBR1 ;WASH-ISC@ALTOONA,PA/RWT-BILL RECONCILIATIONS LIST ;7/10/97 11:17 AM
;;4.5;Accounts Receivable;**53,73,90,203,220**;Mar 20, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
; OBR Data Structure used by this routine
; ^TMP("OBR",$J,SITE,"NOT IN AR")=NextRec^TotalItems^TotalFMSAmt
; ^TMP("OBR",$J,SITE,"NOT IN FMS")=NextRec^TotalItems^TotalARAmt
; ^TMP("OBR",$J,SITE,"DISCREPANCY")=NextRec^TotalItems^TotalFMSAmt^TotalARAmt
; ^TMP("OBR",$J,"BN",BILLNUMBER)=[423.6 rec] <-- x-ref of FMS Bills
; ^TMP("OBR",$J,"REPORT","1")="LINE 1"
; ^TMP("OBR",$J","REPORT,"2")="LINE 2"
; Modules:
; PROCFMS - loop through FMS bills (^PRCF(423.6)) updating
; global ^TMP("OBR",$J,"BN") while also checking
; for invalid AR bills
; PROCAR - loop through all Active AR Bills comparing amounts
; and looking for Detail bills not found in FMS
; SAVE - Saves the errors to tmp global ^TMP("OBR",site)
;
;
PROCFMS(A0) N NODE,FUND,RSC,SRSC,ND,BN,SN,A1
S A1=0 F S A1=$O(^PRCF(423.6,A0,1,A1)) Q:+A1=0 S ND=^(A1,0) D
.I $P(ND,U)="OBR" D Q
..; LIN Segment with OBR identifies FMS data
..S ND=^PRCF(423.6,A0,1,A1,0)
..S SN=$P(ND,U,2),FUND=$S($P(ND,U,7)'="~":$P(ND,U,7),1:""),RSC=$S($P(ND,U,8)'="~":$P(ND,U,8),1:""),SRSC=$S($P(ND,U,9)'="~":$P(ND,U,9),1:"")
..S BN=$P(ND,U,4) I $D(^TMP("OBR",$J,"BN",BN)) Q
..S ^TMP("OBR",$J,"BN",BN)=A1,EM=""
..S BN=$E($P(ND,U,4),1,3)_"-"_$E($P(ND,U,4),4,10)
..S A2=$O(^PRCA(430,"B",BN,0))
..I A2=""!('$D(^PRCA(430,+A2,0))) D Q:A2=""
...S AM1=+$P(ND,U,6)
...S AM2=0,DB="UNKNOWN"
...D SAVE(SN,BN,DB,AM1,AM2,"NOT IN AR")
..S NODE=$G(^PRCA(430,+A2,11)) Q:NODE=""
..I FUND'=$P(NODE,U,17) D SAVE(SN,BN,$P(NODE,U,17),FUND,0,"FUND MISMATCH")
..I RSC'=$P(NODE,U,6) D SAVE(SN,BN,$P(NODE,U,6),RSC,0,"RSC MISMATCH")
..I SRSC'=$P(NODE,U,7) D SAVE(SN,BN,$P(NODE,U,7),SRSC,0,"SUB RSC MISMATCH")
Q
PROCAR(A0) ;
; - Process all Active AR Bills
N A2,BN,AM1,AM2,AM3,DB,EM,ND,SN,FMSBN
S A2=0 F S A2=$O(^PRCA(430,"AC",16,A2)) Q:+A2=0 D
.I $D(^PRCA(430,A2,0)),$P(^(0),U,18)'="01610A1",'$$ACCK^PRCAACC(A2) D
..Q:$P(^PRCA(430,A2,0),"^",2)=29
..I $P(^PRCA(430,A2,0),"^",2)=6,$E($P(^(0),"^",18),1,4)=5287,$$PTACCT^PRCAACC($P(^(0),U,18)) Q
..I $P(^PRCA(430,A2,0),"^",2)=6,$P(^(0),"^",18)=5014 Q
..S BN=$P(^PRCA(430,A2,0),U),SN=$P(BN,"-") D
...S FMSBN=$P(BN,"-")_$P(BN,"-",2)
...S AM2=$S($D(^PRCA(430,A2,7)):+^(7),1:0)
...S DB=$E($$NAM^RCFN01(+$P(^PRCA(430,A2,0),U,9)),1,26)
...I '$D(^TMP("OBR",$J,"BN",FMSBN)) D Q
....S AM1=0
....D SAVE(SN,BN,DB,AM1,AM2,"NOT IN FMS")
...I $D(^TMP("OBR",$J,"BN",FMSBN)) D
....S ND=^PRCF(423.6,A0,1,^TMP("OBR",$J,"BN",FMSBN),0)
....S AM1=+$P(ND,U,6)
....I AM1'=AM2 D SAVE(SN,BN,DB,AM1,AM2,"DISCREPANCY")
Q
SAVE(SN,BILL,DEBTOR,FMSAMT,ARAMT,ERR) N S0,S1,S2,S3,N,DIFF
S S0="",$P(S0," ",(19-$L(BILL)))=""
S S1="",$P(S1," ",(15-$L(BILL)))=""
S S2="",$P(S2," ",(30-$L(DEBTOR)))=""
I ERR="NOT IN AR" D Q
.I '$D(^TMP("OBR",$J,SN,ERR)) S ^(ERR)="1^0^0"
.S N=^TMP("OBR",$J,SN,ERR)
.S ^TMP("OBR",$J,SN,ERR,+N)=BILL_S0_$J(FMSAMT,10,2)
.S $P(^TMP("OBR",$J,SN,ERR),U)=+N+1
.S $P(^TMP("OBR",$J,SN,ERR),U,2)=$P(N,U,2)+1
.S $P(^TMP("OBR",$J,SN,ERR),U,3)=$P(N,U,3)+FMSAMT
I ERR="NOT IN FMS" D Q
.I '$D(^TMP("OBR",$J,SN,ERR)) S ^(ERR)="1^0^0"
.S N=^TMP("OBR",$J,SN,ERR)
.S ^TMP("OBR",$J,SN,ERR,+N)=BILL_S1_DEBTOR_S2_$J(ARAMT,10,2)
.S $P(^TMP("OBR",$J,SN,ERR),U)=+N+1
.S $P(^TMP("OBR",$J,SN,ERR),U,2)=$P(N,U,2)+1
.S $P(^TMP("OBR",$J,SN,ERR),U,3)=$P(N,U,3)+ARAMT
I ERR="DISCREPANCY" D Q
.I '$D(^TMP("OBR",$J,SN,ERR)) S ^(ERR)="1^0^0^0"
.S N=^TMP("OBR",$J,SN,ERR)
.S DIFF=$S(FMSAMT>ARAMT:$J(FMSAMT-ARAMT,0,2),1:"+"_$J(ARAMT-FMSAMT,0,2))
.S S3="",$P(S3," ",11-$L(DIFF))="",DIFF=S3_DIFF
.S ^TMP("OBR",$J,SN,ERR,+N)=BILL_S1_DEBTOR_S2_$J(FMSAMT,10,2)_" "_$J(ARAMT,10,2)_" "_DIFF
.S $P(^TMP("OBR",$J,SN,ERR),U)=+N+1
.S $P(^TMP("OBR",$J,SN,ERR),U,2)=$P(N,U,2)+1
.S $P(^TMP("OBR",$J,SN,ERR),U,3)=$P(N,U,3)+FMSAMT
.S $P(^TMP("OBR",$J,SN,ERR),U,4)=$P(N,U,4)+ARAMT
I ERR="FUND MISMATCH" D Q
.I '$D(^TMP("OBR",$J,SN,ERR)) S ^(ERR)="1^0"
.S N=^TMP("OBR",$J,SN,ERR)
.S ^TMP("OBR",$J,SN,ERR,+N)=BILL_S2_DEBTOR_S2_FMSAMT
.S $P(^TMP("OBR",$J,SN,ERR),U)=+N+1
.S $P(^TMP("OBR",$J,SN,ERR),U,2)=$P(N,U,2)+1
I ERR="RSC MISMATCH" D Q
.I '$D(^TMP("OBR",$J,SN,ERR)) S ^(ERR)="1^0"
.S N=^TMP("OBR",$J,SN,ERR)
.S ^TMP("OBR",$J,SN,ERR,+N)=BILL_S2_DEBTOR_S2_FMSAMT
.S $P(^TMP("OBR",$J,SN,ERR),U)=+N+1
.S $P(^TMP("OBR",$J,SN,ERR),U,2)=$P(N,U,2)+1
I ERR="SUB RSC MISMATCH" D Q
.I '$D(^TMP("OBR",$J,SN,ERR)) S ^(ERR)="1^0"
.S N=^TMP("OBR",$J,SN,ERR)
.S ^TMP("OBR",$J,SN,ERR,+N)=BILL_S2_DEBTOR_S2_FMSAMT
.S $P(^TMP("OBR",$J,SN,ERR),U)=+N+1
.S $P(^TMP("OBR",$J,SN,ERR),U,2)=$P(N,U,2)+1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCFMOBR1 5115 printed Apr 09, 2024@20:51:15 Page 2
RCFMOBR1 ;WASH-ISC@ALTOONA,PA/RWT-BILL RECONCILIATIONS LIST ;7/10/97 11:17 AM
+1 ;;4.5;Accounts Receivable;**53,73,90,203,220**;Mar 20, 1995
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ; OBR Data Structure used by this routine
+4 ; ^TMP("OBR",$J,SITE,"NOT IN AR")=NextRec^TotalItems^TotalFMSAmt
+5 ; ^TMP("OBR",$J,SITE,"NOT IN FMS")=NextRec^TotalItems^TotalARAmt
+6 ; ^TMP("OBR",$J,SITE,"DISCREPANCY")=NextRec^TotalItems^TotalFMSAmt^TotalARAmt
+7 ; ^TMP("OBR",$J,"BN",BILLNUMBER)=[423.6 rec] <-- x-ref of FMS Bills
+8 ; ^TMP("OBR",$J,"REPORT","1")="LINE 1"
+9 ; ^TMP("OBR",$J","REPORT,"2")="LINE 2"
+10 ; Modules:
+11 ; PROCFMS - loop through FMS bills (^PRCF(423.6)) updating
+12 ; global ^TMP("OBR",$J,"BN") while also checking
+13 ; for invalid AR bills
+14 ; PROCAR - loop through all Active AR Bills comparing amounts
+15 ; and looking for Detail bills not found in FMS
+16 ; SAVE - Saves the errors to tmp global ^TMP("OBR",site)
+17 ;
+18 ;
PROCFMS(A0) NEW NODE,FUND,RSC,SRSC,ND,BN,SN,A1
+1 SET A1=0
FOR
SET A1=$ORDER(^PRCF(423.6,A0,1,A1))
if +A1=0
QUIT
SET ND=^(A1,0)
Begin DoDot:1
+2 IF $PIECE(ND,U)="OBR"
Begin DoDot:2
+3 ; LIN Segment with OBR identifies FMS data
+4 SET ND=^PRCF(423.6,A0,1,A1,0)
+5 SET SN=$PIECE(ND,U,2)
SET FUND=$SELECT($PIECE(ND,U,7)'="~":$PIECE(ND,U,7),1:"")
SET RSC=$SELECT($PIECE(ND,U,8)'="~":$PIECE(ND,U,8),1:"")
SET SRSC=$SELECT($PIECE(ND,U,9)'="~":$PIECE(ND,U,9),1:"")
+6 SET BN=$PIECE(ND,U,4)
IF $DATA(^TMP("OBR",$JOB,"BN",BN))
QUIT
+7 SET ^TMP("OBR",$JOB,"BN",BN)=A1
SET EM=""
+8 SET BN=$EXTRACT($PIECE(ND,U,4),1,3)_"-"_$EXTRACT($PIECE(ND,U,4),4,10)
+9 SET A2=$ORDER(^PRCA(430,"B",BN,0))
+10 IF A2=""!('$DATA(^PRCA(430,+A2,0)))
Begin DoDot:3
+11 SET AM1=+$PIECE(ND,U,6)
+12 SET AM2=0
SET DB="UNKNOWN"
+13 DO SAVE(SN,BN,DB,AM1,AM2,"NOT IN AR")
End DoDot:3
if A2=""
QUIT
+14 SET NODE=$GET(^PRCA(430,+A2,11))
if NODE=""
QUIT
+15 IF FUND'=$PIECE(NODE,U,17)
DO SAVE(SN,BN,$PIECE(NODE,U,17),FUND,0,"FUND MISMATCH")
+16 IF RSC'=$PIECE(NODE,U,6)
DO SAVE(SN,BN,$PIECE(NODE,U,6),RSC,0,"RSC MISMATCH")
+17 IF SRSC'=$PIECE(NODE,U,7)
DO SAVE(SN,BN,$PIECE(NODE,U,7),SRSC,0,"SUB RSC MISMATCH")
End DoDot:2
QUIT
End DoDot:1
+18 QUIT
PROCAR(A0) ;
+1 ; - Process all Active AR Bills
+2 NEW A2,BN,AM1,AM2,AM3,DB,EM,ND,SN,FMSBN
+3 SET A2=0
FOR
SET A2=$ORDER(^PRCA(430,"AC",16,A2))
if +A2=0
QUIT
Begin DoDot:1
+4 IF $DATA(^PRCA(430,A2,0))
IF $PIECE(^(0),U,18)'="01610A1"
IF '$$ACCK^PRCAACC(A2)
Begin DoDot:2
+5 if $PIECE(^PRCA(430,A2,0),"^",2)=29
QUIT
+6 IF $PIECE(^PRCA(430,A2,0),"^",2)=6
IF $EXTRACT($PIECE(^(0),"^",18),1,4)=5287
IF $$PTACCT^PRCAACC($PIECE(^(0),U,18))
QUIT
+7 IF $PIECE(^PRCA(430,A2,0),"^",2)=6
IF $PIECE(^(0),"^",18)=5014
QUIT
+8 SET BN=$PIECE(^PRCA(430,A2,0),U)
SET SN=$PIECE(BN,"-")
Begin DoDot:3
+9 SET FMSBN=$PIECE(BN,"-")_$PIECE(BN,"-",2)
+10 SET AM2=$SELECT($DATA(^PRCA(430,A2,7)):+^(7),1:0)
+11 SET DB=$EXTRACT($$NAM^RCFN01(+$PIECE(^PRCA(430,A2,0),U,9)),1,26)
+12 IF '$DATA(^TMP("OBR",$JOB,"BN",FMSBN))
Begin DoDot:4
+13 SET AM1=0
+14 DO SAVE(SN,BN,DB,AM1,AM2,"NOT IN FMS")
End DoDot:4
QUIT
+15 IF $DATA(^TMP("OBR",$JOB,"BN",FMSBN))
Begin DoDot:4
+16 SET ND=^PRCF(423.6,A0,1,^TMP("OBR",$JOB,"BN",FMSBN),0)
+17 SET AM1=+$PIECE(ND,U,6)
+18 IF AM1'=AM2
DO SAVE(SN,BN,DB,AM1,AM2,"DISCREPANCY")
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+19 QUIT
SAVE(SN,BILL,DEBTOR,FMSAMT,ARAMT,ERR) NEW S0,S1,S2,S3,N,DIFF
+1 SET S0=""
SET $PIECE(S0," ",(19-$LENGTH(BILL)))=""
+2 SET S1=""
SET $PIECE(S1," ",(15-$LENGTH(BILL)))=""
+3 SET S2=""
SET $PIECE(S2," ",(30-$LENGTH(DEBTOR)))=""
+4 IF ERR="NOT IN AR"
Begin DoDot:1
+5 IF '$DATA(^TMP("OBR",$JOB,SN,ERR))
SET ^(ERR)="1^0^0"
+6 SET N=^TMP("OBR",$JOB,SN,ERR)
+7 SET ^TMP("OBR",$JOB,SN,ERR,+N)=BILL_S0_$JUSTIFY(FMSAMT,10,2)
+8 SET $PIECE(^TMP("OBR",$JOB,SN,ERR),U)=+N+1
+9 SET $PIECE(^TMP("OBR",$JOB,SN,ERR),U,2)=$PIECE(N,U,2)+1
+10 SET $PIECE(^TMP("OBR",$JOB,SN,ERR),U,3)=$PIECE(N,U,3)+FMSAMT
End DoDot:1
QUIT
+11 IF ERR="NOT IN FMS"
Begin DoDot:1
+12 IF '$DATA(^TMP("OBR",$JOB,SN,ERR))
SET ^(ERR)="1^0^0"
+13 SET N=^TMP("OBR",$JOB,SN,ERR)
+14 SET ^TMP("OBR",$JOB,SN,ERR,+N)=BILL_S1_DEBTOR_S2_$JUSTIFY(ARAMT,10,2)
+15 SET $PIECE(^TMP("OBR",$JOB,SN,ERR),U)=+N+1
+16 SET $PIECE(^TMP("OBR",$JOB,SN,ERR),U,2)=$PIECE(N,U,2)+1
+17 SET $PIECE(^TMP("OBR",$JOB,SN,ERR),U,3)=$PIECE(N,U,3)+ARAMT
End DoDot:1
QUIT
+18 IF ERR="DISCREPANCY"
Begin DoDot:1
+19 IF '$DATA(^TMP("OBR",$JOB,SN,ERR))
SET ^(ERR)="1^0^0^0"
+20 SET N=^TMP("OBR",$JOB,SN,ERR)
+21 SET DIFF=$SELECT(FMSAMT>ARAMT:$JUSTIFY(FMSAMT-ARAMT,0,2),1:"+"_$JUSTIFY(ARAMT-FMSAMT,0,2))
+22 SET S3=""
SET $PIECE(S3," ",11-$LENGTH(DIFF))=""
SET DIFF=S3_DIFF
+23 SET ^TMP("OBR",$JOB,SN,ERR,+N)=BILL_S1_DEBTOR_S2_$JUSTIFY(FMSAMT,10,2)_" "_$JUSTIFY(ARAMT,10,2)_" "_DIFF
+24 SET $PIECE(^TMP("OBR",$JOB,SN,ERR),U)=+N+1
+25 SET $PIECE(^TMP("OBR",$JOB,SN,ERR),U,2)=$PIECE(N,U,2)+1
+26 SET $PIECE(^TMP("OBR",$JOB,SN,ERR),U,3)=$PIECE(N,U,3)+FMSAMT
+27 SET $PIECE(^TMP("OBR",$JOB,SN,ERR),U,4)=$PIECE(N,U,4)+ARAMT
End DoDot:1
QUIT
+28 IF ERR="FUND MISMATCH"
Begin DoDot:1
+29 IF '$DATA(^TMP("OBR",$JOB,SN,ERR))
SET ^(ERR)="1^0"
+30 SET N=^TMP("OBR",$JOB,SN,ERR)
+31 SET ^TMP("OBR",$JOB,SN,ERR,+N)=BILL_S2_DEBTOR_S2_FMSAMT
+32 SET $PIECE(^TMP("OBR",$JOB,SN,ERR),U)=+N+1
+33 SET $PIECE(^TMP("OBR",$JOB,SN,ERR),U,2)=$PIECE(N,U,2)+1
End DoDot:1
QUIT
+34 IF ERR="RSC MISMATCH"
Begin DoDot:1
+35 IF '$DATA(^TMP("OBR",$JOB,SN,ERR))
SET ^(ERR)="1^0"
+36 SET N=^TMP("OBR",$JOB,SN,ERR)
+37 SET ^TMP("OBR",$JOB,SN,ERR,+N)=BILL_S2_DEBTOR_S2_FMSAMT
+38 SET $PIECE(^TMP("OBR",$JOB,SN,ERR),U)=+N+1
+39 SET $PIECE(^TMP("OBR",$JOB,SN,ERR),U,2)=$PIECE(N,U,2)+1
End DoDot:1
QUIT
+40 IF ERR="SUB RSC MISMATCH"
Begin DoDot:1
+41 IF '$DATA(^TMP("OBR",$JOB,SN,ERR))
SET ^(ERR)="1^0"
+42 SET N=^TMP("OBR",$JOB,SN,ERR)
+43 SET ^TMP("OBR",$JOB,SN,ERR,+N)=BILL_S2_DEBTOR_S2_FMSAMT
+44 SET $PIECE(^TMP("OBR",$JOB,SN,ERR),U)=+N+1
+45 SET $PIECE(^TMP("OBR",$JOB,SN,ERR),U,2)=$PIECE(N,U,2)+1
End DoDot:1
QUIT
+46 QUIT
