PRCAKM ;WASH-ISC@ALTOONA,PA/CMS-AR Mark as PENDING ARCHIVE ;10/20/94 2:20 PM
V ;;4.5;Accounts Receivable;**104**;Mar 20, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
NEW BEG,FDT,ND,PAGE,X,X1,X2,Y,ZTDESC,ZTIO,ZTRTN,ZTSAVE,%DT
W !!,"This option will change the status of the AR Records whose Date of",!,"Last Activity is within the time frame selected to Pending Archive.",!
S X1=DT,X2=-3*365 D C^%DTC S (FDT,Y)=$E(X,1)_$$FY^RCFN01(X)_1001
;S (FDT,Y)=$E(DT,1)_($$FY^RCFN01(X))_1001
W !!,"NOTE: The Archive Ending Date must be before " D DD^%DT W Y,!
I $P(^PRCA(430.3,+$O(^PRCA(430.3,"AC",114,0)),0),U)'="PENDING ARCHIVE" W !!,"The PENDING ARCHIVE entry is not setup properly in File 430.3" G Q
BEG W !!,"IF you want to archive all valid records through the ending date,",!,"press return to take the default of NONE.",!
D NOW^%DTC S %DT(0)=-%,%DT="AEXP",%DT("A")="Archive Starting from Date: NONE//" D ^%DT S:X="" Y=2010101 G:Y<0 Q S BEG=Y
S %DT="AEXP",%DT("A")="Archive Ending through Date: " D ^%DT G:Y<0 Q S END=Y
I BEG>END W !!,*7,"*** Beginning date is greater than Ending date ***",! G BEG
I END'<FDT W !!,*7,"*** Ending date is after cut-off date ***",! G BEG
S X2=BEG,X1=END D ^%DTC I X>365 W !!,*7,"WARNING: The date range is greater than one year.",!,"This may cause a large amount of system activity during the Archive processes!",!
W !!,"Are you sure" S %=2 D YN^DICN I %'=1 Q
S ZTRTN="DQ^PRCAKM",ZTSAVE("BEG")="",ZTSAVE("END")="",ZTDESC="Mark AR Records for Archive",ZTIO="" D ^%ZTLOAD
Q Q
DQ ;
NEW CNT,DATE,PRCA,PRCABN,STAT
L +^PRCAK("PRCAK"):1 I '$T D BUSY^PRCAKS("Mark AR records for PENDING ARCHIVE") G END
S CNT=0,PRCA("STATUS")=$O(^PRCA(430.3,"AC",114,0)),PRCA("SDT")=DT
F PRCABN=0:0 S PRCABN=$O(^PRCA(430,PRCABN)) Q:'PRCABN D
.I $P($G(^PRCA(430,PRCABN,0)),U,8)=PRCA("STATUS") S CNT=CNT+1 Q
.Q:$P($G(^PRCA(430,PRCABN,0)),U,8)=49
.S DATE=$$PUR^PRCAFN(PRCABN) I DATE&(DATE'>END)&(DATE'<BEG)!(DATE=-2) D UPSTATS^PRCAUT2 S CNT=CNT+1
D BULL
L -^PRCAK("PRCAK")
END Q
BULL ;Send total in bulletin
N XMDUZ,XMSUB,XMTEXT,XMY
S XMDUZ="AR ARCHIVE PACKAGE",XMSUB="AR PENDING ARCHIVE TOTAL",XMY(+DUZ)="",XMTEXT="X1("
S X1(1)="The total number of bills marked as Pending Archive is "_CNT,X1(2)=" "
S X1(3)="Date Range selected: "_$S(BEG=2010101:"Beginning",1:$$SLH^RCFN01(BEG))_" thru "_$$SLH^RCFN01(END)
S X1(4)=" "
S X1(5)="Please forward this total to the IRM System Manager."
S X1(6)="This total will help IRM determine the amount of system activity",X1(7)="that will occur during the AR Archival processes."
S X1(8)=" ",X1(9)="NOTE: This total includes the number of bills, only!"
S X1(10)=" The number of archived records created will include the"
S X1(11)=" number of bills and all corresponding transactions."
XM D ^XMD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCAKM 2853 printed Apr 09, 2024@20:52:16 Page 2
PRCAKM ;WASH-ISC@ALTOONA,PA/CMS-AR Mark as PENDING ARCHIVE ;10/20/94 2:20 PM
V ;;4.5;Accounts Receivable;**104**;Mar 20, 1995
+1 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+2 NEW BEG,FDT,ND,PAGE,X,X1,X2,Y,ZTDESC,ZTIO,ZTRTN,ZTSAVE,%DT
+3 WRITE !!,"This option will change the status of the AR Records whose Date of",!,"Last Activity is within the time frame selected to Pending Archive.",!
+4 SET X1=DT
SET X2=-3*365
DO C^%DTC
SET (FDT,Y)=$EXTRACT(X,1)_$$FY^RCFN01(X)_1001
+5 ;S (FDT,Y)=$E(DT,1)_($$FY^RCFN01(X))_1001
+6 WRITE !!,"NOTE: The Archive Ending Date must be before "
DO DD^%DT
WRITE Y,!
+7 IF $PIECE(^PRCA(430.3,+$ORDER(^PRCA(430.3,"AC",114,0)),0),U)'="PENDING ARCHIVE"
WRITE !!,"The PENDING ARCHIVE entry is not setup properly in File 430.3"
GOTO Q
BEG WRITE !!,"IF you want to archive all valid records through the ending date,",!,"press return to take the default of NONE.",!
+1 DO NOW^%DTC
SET %DT(0)=-%
SET %DT="AEXP"
SET %DT("A")="Archive Starting from Date: NONE//"
DO ^%DT
if X=""
SET Y=2010101
if Y<0
GOTO Q
SET BEG=Y
+2 SET %DT="AEXP"
SET %DT("A")="Archive Ending through Date: "
DO ^%DT
if Y<0
GOTO Q
SET END=Y
+3 IF BEG>END
WRITE !!,*7,"*** Beginning date is greater than Ending date ***",!
GOTO BEG
+4 IF END'<FDT
WRITE !!,*7,"*** Ending date is after cut-off date ***",!
GOTO BEG
+5 SET X2=BEG
SET X1=END
DO ^%DTC
IF X>365
WRITE !!,*7,"WARNING: The date range is greater than one year.",!,"This may cause a large amount of system activity during the Archive processes!",!
+6 WRITE !!,"Are you sure"
SET %=2
DO YN^DICN
IF %'=1
QUIT
+7 SET ZTRTN="DQ^PRCAKM"
SET ZTSAVE("BEG")=""
SET ZTSAVE("END")=""
SET ZTDESC="Mark AR Records for Archive"
SET ZTIO=""
DO ^%ZTLOAD
Q QUIT
DQ ;
+1 NEW CNT,DATE,PRCA,PRCABN,STAT
+2 LOCK +^PRCAK("PRCAK"):1
IF '$TEST
DO BUSY^PRCAKS("Mark AR records for PENDING ARCHIVE")
GOTO END
+3 SET CNT=0
SET PRCA("STATUS")=$ORDER(^PRCA(430.3,"AC",114,0))
SET PRCA("SDT")=DT
+4 FOR PRCABN=0:0
SET PRCABN=$ORDER(^PRCA(430,PRCABN))
if 'PRCABN
QUIT
Begin DoDot:1
+5 IF $PIECE($GET(^PRCA(430,PRCABN,0)),U,8)=PRCA("STATUS")
SET CNT=CNT+1
QUIT
+6 if $PIECE($GET(^PRCA(430,PRCABN,0)),U,8)=49
QUIT
+7 SET DATE=$$PUR^PRCAFN(PRCABN)
IF DATE&(DATE'>END)&(DATE'<BEG)!(DATE=-2)
DO UPSTATS^PRCAUT2
SET CNT=CNT+1
End DoDot:1
+8 DO BULL
+9 LOCK -^PRCAK("PRCAK")
END QUIT
BULL ;Send total in bulletin
+1 NEW XMDUZ,XMSUB,XMTEXT,XMY
+2 SET XMDUZ="AR ARCHIVE PACKAGE"
SET XMSUB="AR PENDING ARCHIVE TOTAL"
SET XMY(+DUZ)=""
SET XMTEXT="X1("
+3 SET X1(1)="The total number of bills marked as Pending Archive is "_CNT
SET X1(2)=" "
+4 SET X1(3)="Date Range selected: "_$SELECT(BEG=2010101:"Beginning",1:$$SLH^RCFN01(BEG))_" thru "_$$SLH^RCFN01(END)
+5 SET X1(4)=" "
+6 SET X1(5)="Please forward this total to the IRM System Manager."
+7 SET X1(6)="This total will help IRM determine the amount of system activity"
SET X1(7)="that will occur during the AR Archival processes."
+8 SET X1(8)=" "
SET X1(9)="NOTE: This total includes the number of bills, only!"
+9 SET X1(10)=" The number of archived records created will include the"
+10 SET X1(11)=" number of bills and all corresponding transactions."
XM DO ^XMD
+1 QUIT
