- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCFMOBR.m
r613 r623 1 RCFMOBR ;WASH-ISC@ALTOONA,PA/RWT-BILL RECONCILIATIONS LIST ;11/20/96 2:30 PM 2 V ;;4.5;Accounts Receivable;**2,20,40,53,249**;Mar 20, 1995;Build 2 3 ;;Per VHA Directive 10-93-142, this routine should not be modified. 4 EN ;Creates report from OBR data in file 423.6 5 ; 6 ; OBR Data Structure used by this routine 7 ; ^TMP("OBR",$J,SITE,"NOT IN AR")=NextRec^TotalItems^TotalFMSAmt 8 ; ^TMP("OBR",$J,SITE,"NOT IN FMS")=NextRec^TotalItems^TotalARAmt 9 ; ^TMP("OBR",$J,SITE,"DISCREPANCY")=NextRec^TotalItems^TotalFMSAmt^TotalARAmt 10 ; ^TMP("OBR",$J,"BN",BILLNUMBER)=[423.6 rec] <-- x-ref of FMS Bills 11 ; ^TMP("OBR",$J,"REPORT","1")="LINE 1" 12 ; ^TMP("OBR",$J","REPORT,"2")="LINE 2" 13 ; 14 ; Descriptions of modules: 15 ; PROCFMS - loop through FMS bills (^PRCF(423.6)) updating 16 ; global ^TMP("OBR",$J,"BN") while also checking 17 ; for invalid AR bills 18 ; PROCAR - loop through all Active AR Bills comparing amounts 19 ; and looking for Detail bills not found in FMS 20 ; BUILDRPT - Prepares report in global ^TMP("OBR",$J,"REPORT") 21 ; 22 N X,Y,OBR,A0,ERR 23 K ^TMP("OBR",$J) 24 ; 25 I $G(PRCADA) D PROCESS(PRCADA) G Q1 26 S OBR="OBR-",ERR=-1 27 F S OBR=$O(^PRCF(423.6,"B",OBR)) Q:OBR=""!(OBR'["OBR-") D 28 .I $O(^PRCF(423.6,"B",OBR))'["OBR-" D Q 29 ..S A0=$O(^PRCF(423.6,"B",OBR,0)) 30 ..S ERR=0 D PROCESS(A0) 31 I ERR D PROCESS(ERR) 32 Q1 K ^TMP("OBR",$J) 33 Q 34 PROCESS(A0) N X,X1,X2,Y,SN,PARENT,XMTEXT,XMSUB,XMSENDER,XMDUZ,ERR,DATE,FMSDATE 35 S ERR=0 D 36 .I '$D(^PRCF(423.6,A0,0)) S ERR=-1 Q 37 .I $E(^PRCF(423.6,A0,0),1,3)'["OBR" S ERR=-1 Q 38 .S X=$P(^PRCF(423.6,A0,0),"-",2) 39 .S X=$E(X,5,6)_"-"_$E(X,7,8)_"-"_$E(X,1,4) D ^%DT ;Y is defined 40 .S PARENT=$P($P(^PRCF(423.6,A0,0),"-",5),U) 41 .; 42 .D PROCFMS^RCFMOBR1(A0) 43 .D PROCAR^RCFMOBR1(A0) 44 .D BUILDRPT^RCFMOBR2(PARENT) 45 ; 46 I '$D(PARENT) S PARENT=$$SITE^RCMSITE 47 S PARENT=$P(^DIC(4,+$O(^DIC(4,"D",PARENT,0)),0),U) 48 ; 49 I '$D(Y) S Y=DT ;Y may be defined from %DT call above 50 S X1=Y,X2=($E(Y,6,7)+1)*-1 D C^%DTC,YX^%DTC 51 S FMSDATE=$P(Y,"@"),FMSDATE=$E(FMSDATE,1,4)_$E(FMSDATE,9,12) 52 D NOW^%DTC S DATE=$E(X,4,5)_"-"_$E(X,6,7)_"-"_$E(X,2,3) 53 ; - Transmits report via e-mail to FMS mail group 54 S XMSUB="FMS "_FMSDATE_" RECONCILIATION ("_DATE_") " 55 S XMSUB=XMSUB_PARENT 56 I ERR D 57 .S ^TMP("OBR",$J,"REPORT",1)="Date of Report: "_DATE 58 .S ^TMP("OBR",$J,"REPORT",2)="NOTE: This report compares your current A/R records with data received from" 59 .S ^TMP("OBR",$J,"REPORT",3)=" FMS on the last day of the previous accounting period." 60 .S ^TMP("OBR",$J,"REPORT",4)="" 61 .S ^TMP("OBR",$J,"REPORT",5)="No FMS data exists to reconcile!" 62 S XMTEXT="^TMP(""OBR"",$J,""REPORT""," 63 S XMDUZ="Accounts Receivable Package",XMY("G.FMS")="",XMY(DUZ)="" D ^XMD 64 Q 65 EN2 ;Entry point from Regenerate Prior Month OBRs option 66 N DIR,PRCADA,Y 67 W !!,"This option will transmit the OBR report(s) to you and members" 68 W !,"of the G.FMS mail group." 69 W !!,"NOTE: Depending on the number of active AR bills in your system," 70 W !," this may take awhile to run.",! 71 S DIR(0)="YO",DIR("A")="Are you sure you want to do this",DIR("B")="NO" 72 D ^DIR Q:Y'=1 S ZTRTN="EN^RCFMOBR",ZTDESC="Prior Month OBRs" 73 S ZTIO="" D ^%ZTLOAD Q 74 ; 75 EN3 ;Deletes OBRs over 60 days old 76 N A0,A1,A2,DA,DIK,X,X1,X2 77 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 78 .S X1=DT,X2=$$RCDT(A1) D ^%DTC I X>60 S DIK="^PRCF(423.6,",DA=A2 D ^DIK 79 Q 80 RCDT(A1) ;Convert yyyymmdd to FM date 81 N X,Y 82 S X=A1,X=$E(X,5,6)_" "_$E(X,7,8)_", "_$E(X,1,4) 83 D ^%DT 84 Q Y 85 PURGE ;purge unprocessed document file 86 N DIR,Y,X,X1,X2,RCDT 87 S DIR("A")="How many days worth of DATA do you want to retain" 88 S DIR(0)="N",DIR("?")="This is the number of days entries will remain in the file." 89 D ^DIR 90 I +Y<0!(Y="")!($E(Y,1)="^") G POUT 91 S X1=DT,X2=-(+Y) D C^%DTC S RCDT=X 92 S ZTRTN="QPURGE^RCFMOBR",ZTSAVE("RCDT")="",ZTDESC="Purge unprocessed document list",ZTIO="" D ^%ZTLOAD 93 POUT K DIRUT,DIROUT,DTOUT,DUOUT Q 94 ; 95 QPURGE N DA,DIK 96 S DIK="^RC(347," 97 Q:'$D(^RC(347)) 98 S DA=0 F S DA=$O(^RC(347,DA)) Q:'DA I $P(^(DA,0),U,5)<RCDT D ^DIK 99 K RCDT 100 Q 1 RCFMOBR ;WASH-ISC@ALTOONA,PA/RWT-BILL RECONCILIATIONS LIST ;11/20/96 2:30 PM 2 V ;;4.5;Accounts Receivable;**2,20,40,53**;Mar 20, 1995 3 ;;Per VHA Directive 10-93-142, this routine should not be modified. 4 EN ;Creates report from OBR data in file 423.6 5 ; 6 ; OBR Data Structure used by this routine 7 ; ^TMP("OBR",$J,SITE,"NOT IN AR")=NextRec^TotalItems^TotalFMSAmt 8 ; ^TMP("OBR",$J,SITE,"NOT IN FMS")=NextRec^TotalItems^TotalARAmt 9 ; ^TMP("OBR",$J,SITE,"DISCREPANCY")=NextRec^TotalItems^TotalFMSAmt^TotalARAmt 10 ; ^TMP("OBR",$J,"BN",BILLNUMBER)=[423.6 rec] <-- x-ref of FMS Bills 11 ; ^TMP("OBR",$J,"REPORT","1")="LINE 1" 12 ; ^TMP("OBR",$J","REPORT,"2")="LINE 2" 13 ; 14 ; Descriptions of modules: 15 ; PROCFMS - loop through FMS bills (^PRCF(423.6)) updating 16 ; global ^TMP("OBR",$J,"BN") while also checking 17 ; for invalid AR bills 18 ; PROCAR - loop through all Active AR Bills comparing amounts 19 ; and looking for Detail bills not found in FMS 20 ; BUILDRPT - Prepares report in global ^TMP("OBR",$J,"REPORT") 21 ; 22 N X,Y,OBR,A0,ERR 23 K ^TMP("OBR",$J) 24 ; 25 I $G(PRCADA) D PROCESS(PRCADA) G Q1 26 S OBR="OBR-",ERR=-1 27 F S OBR=$O(^PRCF(423.6,"B",OBR)) Q:OBR=""!(OBR'["OBR-") D 28 .I $O(^PRCF(423.6,"B",OBR))'["OBR-" D Q 29 ..S A0=$O(^PRCF(423.6,"B",OBR,0)) 30 ..S ERR=0 D PROCESS(A0) 31 I ERR D PROCESS(ERR) 32 Q1 K ^TMP("OBR",$J) 33 Q 34 PROCESS(A0) N X,X1,X2,Y,SN,PARENT,XMTEXT,XMSUB,XMSENDER,XMDUZ,ERR,DATE,FMSDATE 35 S ERR=0 D 36 .I '$D(^PRCF(423.6,A0,0)) S ERR=-1 Q 37 .I $E(^PRCF(423.6,A0,0),1,3)'["OBR" S ERR=-1 Q 38 .S X=$P(^PRCF(423.6,A0,0),"-",2) 39 .S X=$E(X,5,6)_"-"_$E(X,7,8)_"-"_$E(X,1,4) D ^%DT ;Y is defined 40 .S PARENT=$P($P(^PRCF(423.6,A0,0),"-",5),U) 41 .; 42 .D PROCFMS^RCFMOBR1(A0) 43 .D PROCAR^RCFMOBR1(A0) 44 .D BUILDRPT^RCFMOBR2(PARENT) 45 ; 46 I '$D(PARENT) S PARENT=$$SITE^RCMSITE 47 S PARENT=$P(^DIC(4,+$O(^DIC(4,"D",PARENT,0)),0),U) 48 ; 49 I '$D(Y) S Y=DT ;Y may be defined from %DT call above 50 S X1=Y,X2=($E(Y,6,7)+1)*-1 D C^%DTC,YX^%DTC 51 S FMSDATE=$P(Y,"@"),FMSDATE=$E(FMSDATE,1,4)_$E(FMSDATE,9,12) 52 D NOW^%DTC S DATE=$E(X,4,5)_"-"_$E(X,6,7)_"-"_$E(X,2,3) 53 ; - Transmits report via e-mail to FMS mail group 54 S XMSUB="FMS "_FMSDATE_" RECONCILIATION ("_DATE_") " 55 S XMSUB=XMSUB_PARENT 56 I ERR D 57 .S ^TMP("OBR",$J,"REPORT",1)="Date of Report: "_DATE 58 .S ^TMP("OBR",$J,"REPORT",2)="NOTE: This report compares your current A/R records with data received from" 59 .S ^TMP("OBR",$J,"REPORT",3)=" FMS on the last day of the previous accounting period." 60 .S ^TMP("OBR",$J,"REPORT",4)="" 61 .S ^TMP("OBR",$J,"REPORT",5)="No FMS data exists to reconcile!" 62 S XMTEXT="^TMP(""OBR"",$J,""REPORT""," 63 S XMDUZ="Accounts Receivable Package",XMY("G.FMS")="",XMY(DUZ)="" D ^XMD 64 Q 65 EN2 ;Entry point from Regenerate Prior Month OBRs option 66 N DIR,PRCADA,Y 67 W !!,"This option will transmit the OBR report(s) to you and members" 68 W !,"of the G.FMS mail group." 69 W !!,"NOTE: Depending on the number of active AR bills in your system," 70 W !," this may take awhile to run.",! 71 S DIR(0)="YO",DIR("A")="Are you sure you want to do this",DIR("B")="NO" 72 D ^DIR Q:Y'=1 S ZTRTN="EN^RCFMOBR",ZTDESC="Prior Month OBRs" 73 S ZTIO="" D ^%ZTLOAD Q 74 ; 75 EN3 ;Deletes OBRs over 60 days old 76 N A0,A1,A2,DA,DIK,X,X1,X2 77 S A0="OBR-" F S A0=$O(^PRCF(423.6,"B",A0)) Q:A0=""!(A0'["OBR-") S A1=2_$E($P(A0,"-",2),3,8),A2=0 F S A2=$O(^PRCF(423.6,"B",A0,A2)) Q:+A2=0 D 78 .S X1=DT,X2=A1 D ^%DTC I X>60 S DIK="^PRCF(423.6,",DA=A2 D ^DIK 79 Q 80 PURGE ;purge unprocessed document file 81 N DIR,Y,X,X1,X2,RCDT 82 S DIR("A")="How many days worth of DATA do you want to retain" 83 S DIR(0)="N",DIR("?")="This is the number of days entries will remain in the file." 84 D ^DIR 85 I +Y<0!(Y="")!($E(Y,1)="^") G POUT 86 S X1=DT,X2=-(+Y) D C^%DTC S RCDT=X 87 S ZTRTN="QPURGE^RCFMOBR",ZTSAVE("RCDT")="",ZTDESC="Purge unprocessed document list",ZTIO="" D ^%ZTLOAD 88 POUT K DIRUT,DIROUT,DTOUT,DUOUT Q 89 ; 90 QPURGE N DA,DIK 91 S DIK="^RC(347," 92 Q:'$D(^RC(347)) 93 S DA=0 F S DA=$O(^RC(347,DA)) Q:'DA I $P(^(DA,0),U,5)<RCDT D ^DIK 94 K RCDT 95 Q
Note:
See TracChangeset
for help on using the changeset viewer.
