RCFMOBR ;WASH-ISC@ALTOONA,PA/RWT-BILL RECONCILIATIONS LIST ;11/20/96 2:30 PM
V ;;4.5;Accounts Receivable;**2,20,40,53,249**;Mar 20, 1995;Build 2
;;Per VHA Directive 10-93-142, this routine should not be modified.
EN ;Creates report from OBR data in file 423.6
;
; 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"
;
; Descriptions of 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
; BUILDRPT - Prepares report in global ^TMP("OBR",$J,"REPORT")
;
N X,Y,OBR,A0,ERR
K ^TMP("OBR",$J)
;
I $G(PRCADA) D PROCESS(PRCADA) G Q1
S OBR="OBR-",ERR=-1
F S OBR=$O(^PRCF(423.6,"B",OBR)) Q:OBR=""!(OBR'["OBR-") D
.I $O(^PRCF(423.6,"B",OBR))'["OBR-" D Q
..S A0=$O(^PRCF(423.6,"B",OBR,0))
..S ERR=0 D PROCESS(A0)
I ERR D PROCESS(ERR)
Q1 K ^TMP("OBR",$J)
Q
PROCESS(A0) N X,X1,X2,Y,SN,PARENT,XMTEXT,XMSUB,XMSENDER,XMDUZ,ERR,DATE,FMSDATE
S ERR=0 D
.I '$D(^PRCF(423.6,A0,0)) S ERR=-1 Q
.I $E(^PRCF(423.6,A0,0),1,3)'["OBR" S ERR=-1 Q
.S X=$P(^PRCF(423.6,A0,0),"-",2)
.S X=$E(X,5,6)_"-"_$E(X,7,8)_"-"_$E(X,1,4) D ^%DT ;Y is defined
.S PARENT=$P($P(^PRCF(423.6,A0,0),"-",5),U)
.;
.D PROCFMS^RCFMOBR1(A0)
.D PROCAR^RCFMOBR1(A0)
.D BUILDRPT^RCFMOBR2(PARENT)
;
I '$D(PARENT) S PARENT=$$SITE^RCMSITE
S PARENT=$P(^DIC(4,+$O(^DIC(4,"D",PARENT,0)),0),U)
;
I '$D(Y) S Y=DT ;Y may be defined from %DT call above
S X1=Y,X2=($E(Y,6,7)+1)*-1 D C^%DTC,YX^%DTC
S FMSDATE=$P(Y,"@"),FMSDATE=$E(FMSDATE,1,4)_$E(FMSDATE,9,12)
D NOW^%DTC S DATE=$E(X,4,5)_"-"_$E(X,6,7)_"-"_$E(X,2,3)
; - Transmits report via e-mail to FMS mail group
S XMSUB="FMS "_FMSDATE_" RECONCILIATION ("_DATE_") "
S XMSUB=XMSUB_PARENT
I ERR D
.S ^TMP("OBR",$J,"REPORT",1)="Date of Report: "_DATE
.S ^TMP("OBR",$J,"REPORT",2)="NOTE: This report compares your current A/R records with data received from"
.S ^TMP("OBR",$J,"REPORT",3)=" FMS on the last day of the previous accounting period."
.S ^TMP("OBR",$J,"REPORT",4)=""
.S ^TMP("OBR",$J,"REPORT",5)="No FMS data exists to reconcile!"
S XMTEXT="^TMP(""OBR"",$J,""REPORT"","
S XMDUZ="Accounts Receivable Package",XMY("G.FMS")="",XMY(DUZ)="" D ^XMD
Q
EN2 ;Entry point from Regenerate Prior Month OBRs option
N DIR,PRCADA,Y
W !!,"This option will transmit the OBR report(s) to you and members"
W !,"of the G.FMS mail group."
W !!,"NOTE: Depending on the number of active AR bills in your system,"
W !," this may take awhile to run.",!
S DIR(0)="YO",DIR("A")="Are you sure you want to do this",DIR("B")="NO"
D ^DIR Q:Y'=1 S ZTRTN="EN^RCFMOBR",ZTDESC="Prior Month OBRs"
S ZTIO="" D ^%ZTLOAD Q
;
EN3 ;Deletes OBRs over 60 days old
N A0,A1,A2,DA,DIK,X,X1,X2
S A0="OBR-" F S A0=$O(^PRCF(423.6,"B",A0)) Q:A0=""!(A0'["OBR-") S A1=$E($P(A0,"-",2),1,8),A2=0 F S A2=$O(^PRCF(423.6,"B",A0,A2)) Q:+A2=0 D
.S X1=DT,X2=$$RCDT(A1) D ^%DTC I X>60 S DIK="^PRCF(423.6,",DA=A2 D ^DIK
Q
RCDT(A1) ;Convert yyyymmdd to FM date
N X,Y
S X=A1,X=$E(X,5,6)_" "_$E(X,7,8)_", "_$E(X,1,4)
D ^%DT
Q Y
PURGE ;purge unprocessed document file
N DIR,Y,X,X1,X2,RCDT
S DIR("A")="How many days worth of DATA do you want to retain"
S DIR(0)="N",DIR("?")="This is the number of days entries will remain in the file."
D ^DIR
I +Y<0!(Y="")!($E(Y,1)="^") G POUT
S X1=DT,X2=-(+Y) D C^%DTC S RCDT=X
S ZTRTN="QPURGE^RCFMOBR",ZTSAVE("RCDT")="",ZTDESC="Purge unprocessed document list",ZTIO="" D ^%ZTLOAD
POUT K DIRUT,DIROUT,DTOUT,DUOUT Q
;
QPURGE N DA,DIK
S DIK="^RC(347,"
Q:'$D(^RC(347))
S DA=0 F S DA=$O(^RC(347,DA)) Q:'DA I $P(^(DA,0),U,5)<RCDT D ^DIK
K RCDT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCFMOBR 4258 printed Dec 13, 2024@01:46:54 Page 2
RCFMOBR ;WASH-ISC@ALTOONA,PA/RWT-BILL RECONCILIATIONS LIST ;11/20/96 2:30 PM
V ;;4.5;Accounts Receivable;**2,20,40,53,249**;Mar 20, 1995;Build 2
+1 ;;Per VHA Directive 10-93-142, this routine should not be modified.
EN ;Creates report from OBR data in file 423.6
+1 ;
+2 ; OBR Data Structure used by this routine
+3 ; ^TMP("OBR",$J,SITE,"NOT IN AR")=NextRec^TotalItems^TotalFMSAmt
+4 ; ^TMP("OBR",$J,SITE,"NOT IN FMS")=NextRec^TotalItems^TotalARAmt
+5 ; ^TMP("OBR",$J,SITE,"DISCREPANCY")=NextRec^TotalItems^TotalFMSAmt^TotalARAmt
+6 ; ^TMP("OBR",$J,"BN",BILLNUMBER)=[423.6 rec] <-- x-ref of FMS Bills
+7 ; ^TMP("OBR",$J,"REPORT","1")="LINE 1"
+8 ; ^TMP("OBR",$J","REPORT,"2")="LINE 2"
+9 ;
+10 ; Descriptions of 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 ; BUILDRPT - Prepares report in global ^TMP("OBR",$J,"REPORT")
+17 ;
+18 NEW X,Y,OBR,A0,ERR
+19 KILL ^TMP("OBR",$JOB)
+20 ;
+21 IF $GET(PRCADA)
DO PROCESS(PRCADA)
GOTO Q1
+22 SET OBR="OBR-"
SET ERR=-1
+23 FOR
SET OBR=$ORDER(^PRCF(423.6,"B",OBR))
if OBR=""!(OBR'["OBR-")
QUIT
Begin DoDot:1
+24 IF $ORDER(^PRCF(423.6,"B",OBR))'["OBR-"
Begin DoDot:2
+25 SET A0=$ORDER(^PRCF(423.6,"B",OBR,0))
+26 SET ERR=0
DO PROCESS(A0)
End DoDot:2
QUIT
End DoDot:1
+27 IF ERR
DO PROCESS(ERR)
Q1 KILL ^TMP("OBR",$JOB)
+1 QUIT
PROCESS(A0) NEW X,X1,X2,Y,SN,PARENT,XMTEXT,XMSUB,XMSENDER,XMDUZ,ERR,DATE,FMSDATE
+1 SET ERR=0
Begin DoDot:1
+2 IF '$DATA(^PRCF(423.6,A0,0))
SET ERR=-1
QUIT
+3 IF $EXTRACT(^PRCF(423.6,A0,0),1,3)'["OBR"
SET ERR=-1
QUIT
+4 SET X=$PIECE(^PRCF(423.6,A0,0),"-",2)
+5 ;Y is defined
SET X=$EXTRACT(X,5,6)_"-"_$EXTRACT(X,7,8)_"-"_$EXTRACT(X,1,4)
DO ^%DT
+6 SET PARENT=$PIECE($PIECE(^PRCF(423.6,A0,0),"-",5),U)
+7 ;
+8 DO PROCFMS^RCFMOBR1(A0)
+9 DO PROCAR^RCFMOBR1(A0)
+10 DO BUILDRPT^RCFMOBR2(PARENT)
End DoDot:1
+11 ;
+12 IF '$DATA(PARENT)
SET PARENT=$$SITE^RCMSITE
+13 SET PARENT=$PIECE(^DIC(4,+$ORDER(^DIC(4,"D",PARENT,0)),0),U)
+14 ;
+15 ;Y may be defined from %DT call above
IF '$DATA(Y)
SET Y=DT
+16 SET X1=Y
SET X2=($EXTRACT(Y,6,7)+1)*-1
DO C^%DTC
DO YX^%DTC
+17 SET FMSDATE=$PIECE(Y,"@")
SET FMSDATE=$EXTRACT(FMSDATE,1,4)_$EXTRACT(FMSDATE,9,12)
+18 DO NOW^%DTC
SET DATE=$EXTRACT(X,4,5)_"-"_$EXTRACT(X,6,7)_"-"_$EXTRACT(X,2,3)
+19 ; - Transmits report via e-mail to FMS mail group
+20 SET XMSUB="FMS "_FMSDATE_" RECONCILIATION ("_DATE_") "
+21 SET XMSUB=XMSUB_PARENT
+22 IF ERR
Begin DoDot:1
+23 SET ^TMP("OBR",$JOB,"REPORT",1)="Date of Report: "_DATE
+24 SET ^TMP("OBR",$JOB,"REPORT",2)="NOTE: This report compares your current A/R records with data received from"
+25 SET ^TMP("OBR",$JOB,"REPORT",3)=" FMS on the last day of the previous accounting period."
+26 SET ^TMP("OBR",$JOB,"REPORT",4)=""
+27 SET ^TMP("OBR",$JOB,"REPORT",5)="No FMS data exists to reconcile!"
End DoDot:1
+28 SET XMTEXT="^TMP(""OBR"",$J,""REPORT"","
+29 SET XMDUZ="Accounts Receivable Package"
SET XMY("G.FMS")=""
SET XMY(DUZ)=""
DO ^XMD
+30 QUIT
EN2 ;Entry point from Regenerate Prior Month OBRs option
+1 NEW DIR,PRCADA,Y
+2 WRITE !!,"This option will transmit the OBR report(s) to you and members"
+3 WRITE !,"of the G.FMS mail group."
+4 WRITE !!,"NOTE: Depending on the number of active AR bills in your system,"
+5 WRITE !," this may take awhile to run.",!
+6 SET DIR(0)="YO"
SET DIR("A")="Are you sure you want to do this"
SET DIR("B")="NO"
+7 DO ^DIR
if Y'=1
QUIT
SET ZTRTN="EN^RCFMOBR"
SET ZTDESC="Prior Month OBRs"
+8 SET ZTIO=""
DO ^%ZTLOAD
QUIT
+9 ;
EN3 ;Deletes OBRs over 60 days old
+1 NEW A0,A1,A2,DA,DIK,X,X1,X2
+2 SET A0="OBR-"
FOR
SET A0=$ORDER(^PRCF(423.6,"B",A0))
if A0=""!(A0'["OBR-")
QUIT
SET A1=$EXTRACT($PIECE(A0,"-",2),1,8)
SET A2=0
FOR
SET A2=$ORDER(^PRCF(423.6,"B",A0,A2))
if +A2=0
QUIT
Begin DoDot:1
+3 SET X1=DT
SET X2=$$RCDT(A1)
DO ^%DTC
IF X>60
SET DIK="^PRCF(423.6,"
SET DA=A2
DO ^DIK
End DoDot:1
+4 QUIT
RCDT(A1) ;Convert yyyymmdd to FM date
+1 NEW X,Y
+2 SET X=A1
SET X=$EXTRACT(X,5,6)_" "_$EXTRACT(X,7,8)_", "_$EXTRACT(X,1,4)
+3 DO ^%DT
+4 QUIT Y
PURGE ;purge unprocessed document file
+1 NEW DIR,Y,X,X1,X2,RCDT
+2 SET DIR("A")="How many days worth of DATA do you want to retain"
+3 SET DIR(0)="N"
SET DIR("?")="This is the number of days entries will remain in the file."
+4 DO ^DIR
+5 IF +Y<0!(Y="")!($EXTRACT(Y,1)="^")
GOTO POUT
+6 SET X1=DT
SET X2=-(+Y)
DO C^%DTC
SET RCDT=X
+7 SET ZTRTN="QPURGE^RCFMOBR"
SET ZTSAVE("RCDT")=""
SET ZTDESC="Purge unprocessed document list"
SET ZTIO=""
DO ^%ZTLOAD
POUT KILL DIRUT,DIROUT,DTOUT,DUOUT
QUIT
+1 ;
QPURGE NEW DA,DIK
+1 SET DIK="^RC(347,"
+2 if '$DATA(^RC(347))
QUIT
+3 SET DA=0
FOR
SET DA=$ORDER(^RC(347,DA))
if 'DA
QUIT
IF $PIECE(^(DA,0),U,5)<RCDT
DO ^DIK
+4 KILL RCDT
+5 QUIT
