- PRCAKS ;WASH-ISC@ALTOONA,PA/CMS-AR Remove Records-Mark as ARCHIVED ;6/4/93 11:05 AM
- V ;;4.5;Accounts Receivable;**67**;Mar 20, 1995
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- NEW BEG,DATE,FDT,ND,PAGE,X,X1,X2,Y,ZTDESC,ZTRTN,ZTSAVE,%DT
- W !!,"This option will change the status of the AR Bills in the",!,"Pending Archive status that were moved to temporary storage"
- W !,"to the ARCHIVED status. The bill data and corresponding",!,"transactions will be deleted."
- W !!,"The entries in the archival temporary storage file will be deleted."
- I $P(^PRCA(430.3,+$O(^PRCA(430.3,"AC",115,0)),0),U)'="ARCHIVED" W !!,"The ARCHIVED entry is not setup properly in File 430.3" G Q
- W !!,"Enter the Archive Date that is marked on the AR Archive Permanent Storage Label."
- W !,"This date will display when inquires are made to ARCHIVED bills.",!
- D NOW^%DTC S %DT="AEXP",%DT(0)=-%,%DT("A")="Enter the Archive Date: " D ^%DT G:+Y<1 Q S DATE=+Y
- W !!,"NOTE: You should have verified that the data in the temporary",!,"storage file is in a permanent storage place before you continue!"
- W !!,"Are you sure you want to Archive AR data records" S %=2 D YN^DICN I %'=1 Q
- W !,"Okay, I'll send you a mail message when I'm done.",!
- S ZTRTN="DQ^PRCAKS",ZTSAVE("DATE")="",ZTDESC="Archive AR Records",ZTIO="" D ^%ZTLOAD
- Q Q
- DQ ;
- NEW ARN,BN0,OSTAT,PRCABN,STAT
- L +^PRCAK("PRCAK"):1 I '$T D BUSY^PRCAKS("Remove AR Records") G END
- S OSTAT=$O(^PRCA(430.3,"AC",114,0))
- S STAT=$O(^PRCA(430.3,"AC",115,0))
- F ARN=0:0 S ARN=$O(^PRCAK(430.8,ARN)) Q:'ARN S BN0=$G(^PRCAK(430.8,ARN,0)) I BN0'="" S PRCABN=$O(^PRCA(430,"B",$P(BN0,"-",1,2),0)) I PRCABN D PUR
- D PUR^PRCAKTP
- D BULL
- L -^PRCAK("PRCAK")
- END Q
- PUR ;purge data records
- N DA,DIK,LN,TN
- I $P(^PRCA(430,PRCABN,0),U,8)'=OSTAT Q
- S DIK="^PRCA(433," F TN=0:0 S TN=$O(^PRCA(433,"C",PRCABN,TN)) Q:'TN D
- .I $G(^PRCA(433,TN,0))']"" K ^PRCA(430,"C",PRCABN,TN) Q
- .S PRCAEN=TN,PRCAARC=1,PRCANOPR=1 D DELETE^PRCAWO1
- S LN=^PRCA(430,PRCABN,0)
- S DIK="^PRCA(430,",DA=PRCABN D ^DIK
- S ^PRCA(430,PRCABN,0)=$P(LN,U,1),$P(^(0),U,8)=STAT,$P(^(0),U,10)=DATE
- S DA=PRCABN D IX1^DIK
- S $P(^PRCA(430,0),U,4)=$P(^PRCA(430,0),U,4)+1
- K PRCAARC,PRCAEN,PRCANOPR
- Q
- BULL ;Send total in bulletin
- N XMDUZ,XMSUB,XMTEXT,XMY
- S XMDUZ="AR ARCHIVE PACKAGE",XMSUB="AR ARCHIVE COMPLETION",XMY(+DUZ)="",XMTEXT="X1("
- S X1(1)=" The AR Archival of AR record data in the Accounts Receivable"
- S X1(2)=" File 430 and the corresponding AR Transactions in File 433"
- S X1(2)=" is complete. The records in the temporary storage file"
- S X1(3)=" (AR Archive 430.8) were purged."
- XM D ^XMD
- Q
- ;
- BUSY(ARH) ;
- NEW XMDUZ,XMSUB,XMTEXT,XMY,X1
- S XMDUZ="AR ARCHIVE PACKAGE",XMSUB="Failure to Run (Busy)",XMY(+DUZ)="",XMTEXT="X1("
- S X1(1)="You attempted to run the archive process: "_ARH
- S X1(2)="This processes failed because another AR archive process",X1(3)="was already in progress."
- D ^XMD
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCAKS 2971 printed Jan 18, 2025@02:41:28 Page 2
- PRCAKS ;WASH-ISC@ALTOONA,PA/CMS-AR Remove Records-Mark as ARCHIVED ;6/4/93 11:05 AM
- V ;;4.5;Accounts Receivable;**67**;Mar 20, 1995
- +1 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 NEW BEG,DATE,FDT,ND,PAGE,X,X1,X2,Y,ZTDESC,ZTRTN,ZTSAVE,%DT
- +3 WRITE !!,"This option will change the status of the AR Bills in the",!,"Pending Archive status that were moved to temporary storage"
- +4 WRITE !,"to the ARCHIVED status. The bill data and corresponding",!,"transactions will be deleted."
- +5 WRITE !!,"The entries in the archival temporary storage file will be deleted."
- +6 IF $PIECE(^PRCA(430.3,+$ORDER(^PRCA(430.3,"AC",115,0)),0),U)'="ARCHIVED"
- WRITE !!,"The ARCHIVED entry is not setup properly in File 430.3"
- GOTO Q
- +7 WRITE !!,"Enter the Archive Date that is marked on the AR Archive Permanent Storage Label."
- +8 WRITE !,"This date will display when inquires are made to ARCHIVED bills.",!
- +9 DO NOW^%DTC
- SET %DT="AEXP"
- SET %DT(0)=-%
- SET %DT("A")="Enter the Archive Date: "
- DO ^%DT
- if +Y<1
- GOTO Q
- SET DATE=+Y
- +10 WRITE !!,"NOTE: You should have verified that the data in the temporary",!,"storage file is in a permanent storage place before you continue!"
- +11 WRITE !!,"Are you sure you want to Archive AR data records"
- SET %=2
- DO YN^DICN
- IF %'=1
- QUIT
- +12 WRITE !,"Okay, I'll send you a mail message when I'm done.",!
- +13 SET ZTRTN="DQ^PRCAKS"
- SET ZTSAVE("DATE")=""
- SET ZTDESC="Archive AR Records"
- SET ZTIO=""
- DO ^%ZTLOAD
- Q QUIT
- DQ ;
- +1 NEW ARN,BN0,OSTAT,PRCABN,STAT
- +2 LOCK +^PRCAK("PRCAK"):1
- IF '$TEST
- DO BUSY^PRCAKS("Remove AR Records")
- GOTO END
- +3 SET OSTAT=$ORDER(^PRCA(430.3,"AC",114,0))
- +4 SET STAT=$ORDER(^PRCA(430.3,"AC",115,0))
- +5 FOR ARN=0:0
- SET ARN=$ORDER(^PRCAK(430.8,ARN))
- if 'ARN
- QUIT
- SET BN0=$GET(^PRCAK(430.8,ARN,0))
- IF BN0'=""
- SET PRCABN=$ORDER(^PRCA(430,"B",$PIECE(BN0,"-",1,2),0))
- IF PRCABN
- DO PUR
- +6 DO PUR^PRCAKTP
- +7 DO BULL
- +8 LOCK -^PRCAK("PRCAK")
- END QUIT
- PUR ;purge data records
- +1 NEW DA,DIK,LN,TN
- +2 IF $PIECE(^PRCA(430,PRCABN,0),U,8)'=OSTAT
- QUIT
- +3 SET DIK="^PRCA(433,"
- FOR TN=0:0
- SET TN=$ORDER(^PRCA(433,"C",PRCABN,TN))
- if 'TN
- QUIT
- Begin DoDot:1
- +4 IF $GET(^PRCA(433,TN,0))']""
- KILL ^PRCA(430,"C",PRCABN,TN)
- QUIT
- +5 SET PRCAEN=TN
- SET PRCAARC=1
- SET PRCANOPR=1
- DO DELETE^PRCAWO1
- End DoDot:1
- +6 SET LN=^PRCA(430,PRCABN,0)
- +7 SET DIK="^PRCA(430,"
- SET DA=PRCABN
- DO ^DIK
- +8 SET ^PRCA(430,PRCABN,0)=$PIECE(LN,U,1)
- SET $PIECE(^(0),U,8)=STAT
- SET $PIECE(^(0),U,10)=DATE
- +9 SET DA=PRCABN
- DO IX1^DIK
- +10 SET $PIECE(^PRCA(430,0),U,4)=$PIECE(^PRCA(430,0),U,4)+1
- +11 KILL PRCAARC,PRCAEN,PRCANOPR
- +12 QUIT
- BULL ;Send total in bulletin
- +1 NEW XMDUZ,XMSUB,XMTEXT,XMY
- +2 SET XMDUZ="AR ARCHIVE PACKAGE"
- SET XMSUB="AR ARCHIVE COMPLETION"
- SET XMY(+DUZ)=""
- SET XMTEXT="X1("
- +3 SET X1(1)=" The AR Archival of AR record data in the Accounts Receivable"
- +4 SET X1(2)=" File 430 and the corresponding AR Transactions in File 433"
- +5 SET X1(2)=" is complete. The records in the temporary storage file"
- +6 SET X1(3)=" (AR Archive 430.8) were purged."
- XM DO ^XMD
- +1 QUIT
- +2 ;
- BUSY(ARH) ;
- +1 NEW XMDUZ,XMSUB,XMTEXT,XMY,X1
- +2 SET XMDUZ="AR ARCHIVE PACKAGE"
- SET XMSUB="Failure to Run (Busy)"
- SET XMY(+DUZ)=""
- SET XMTEXT="X1("
- +3 SET X1(1)="You attempted to run the archive process: "_ARH
- +4 SET X1(2)="This processes failed because another AR archive process"
- SET X1(3)="was already in progress."
- +5 DO ^XMD
- +6 QUIT