- 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 Feb 18, 2025@23:13:17 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