- PRCAKUN ;WASH-ISC@ALTOONA,PA/CMS-Unmark Pending Archive ;8/24/93 8:09 AM
- V ;;4.5;Accounts Receivable;**68**;Mar 20, 1995
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- EN1 ;Unmark records marked for archival entry point
- N %,DIC,DIR,DTOUT,DUOUT,PRCA,PRCABN,PRCATY,Y
- I $P($G(^PRCAK(430.8,0)),U,3)>0 W !!,"The PENDING ARCHIVE records were moved to temporary storage!",!,"You cannot unmark these records." G EN1Q
- S DIR("A")="Do you want to unmark ALL bills PENDING ARCHIVE",DIR("B")="NO",DIR(0)="Y",DIR("?")="Enter 'Y' to unmark all bills in this status for the same remarks" D ^DIR
- I $D(DTOUT)!$D(DUOUT) G EN1Q
- I Y=1 G ALL
- W ! S DIC("S")="I $P(^PRCA(430,+Y,0),U,8)=$O(^PRCA(430.3,""B"",""PENDING ARCHIVE"",0))",DIC(0)="AEQMZ",DIC="^PRCA(430," D ^DIC S PRCABN=+Y G:$G(PRCABN)'>0 EN1Q
- I '$P(^PRCA(430,PRCABN,9),U,6) W !!,"This bill does not have a previous status!" G EN1Q
- EN1A W !,"Change the status of this bill back to ",$P($G(^PRCA(430.3,+$P(^PRCA(430,PRCABN,9),U,6),0)),U,1) S %=2 D YN^DICN D:%=1 EN1S
- I %=0 W !!,"Enter YES if you want to change the status of the bill back to the",!,"previous status to prevent the bill from being archived!",! G EN1A
- EN1Q Q
- EN1S ;prompt user for change status data.
- N DA,DIE,DR,X
- S DR="8////^S X="_$S($P($G(^PRCA(430,PRCABN,9)),U,6):$P(^(9),U,6),1:15)_";15;17////^S X="_$G(DUZ),DIE="^PRCA(430,",DA=PRCABN D ^DIE
- Q
- ALL ;Loop on PENDING ARCHIVE status and reverse all bills
- N REM
- L +^PRCAK("PRCAK"):1 I '$T W *7,!!,"WARNING: Another AR Archive Process is still running!",!!
- L -^PRCAK("PRCAK")
- W !!,"Enter a Status Remark (3-45 characters) for all bills unmarked for archival."
- REM R !,"Status Remark: ",REM:DTIME I '$T!(REM["^") G EN1Q
- I $G(REM)]"",($L(REM)<3!($L(REM)>45)) W !,"Remark must be 3-45 characters in length" G REM
- I $O(^PRCA(430.3,"AC",114,0))="" W !!,*7,"Please contact your IRM. The Pending Archive status is not setup properly!",! Q
- I '$O(^PRCA(430,"AC",$O(^PRCA(430.3,"AC",114,0)),0)) W !!,*7,"Cannot find any bills in the Pending Archive status!",! Q
- S ZTRTN="DQ^PRCAKUN",ZTIO="",ZTSAVE("REM")="" D ^%ZTLOAD
- Q
- DQ ;
- NEW ST,PRCABN,X,DA,DIE,DR
- L +^PRCAK("PRCAK"):1 I '$T D BUSY^PRCAKS("Unmark ALL Pending Archive Records") G END
- S ST=$O(^PRCA(430.3,"AC",114,0)) I ST="" G END
- S PRCABN="" F S PRCABN=$O(^PRCA(430,"AC",ST,PRCABN)) Q:'PRCABN D
- .I '$D(^PRCA(430,PRCABN,0)) K ^PRCA(430,"AC",ST,PRCABN) Q
- .S DR="8////^S X="_$S($P($G(^PRCA(430,PRCABN,9)),U,6):$P(^(9),U,6),1:15)_";15////^S X=$G(REM);17////^S X=DUZ",DIE="^PRCA(430,",DA=PRCABN D ^DIE
- .Q
- END L -^PRCAK("PRCAK") Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCAKUN 2610 printed Jan 18, 2025@02:41:30 Page 2
- PRCAKUN ;WASH-ISC@ALTOONA,PA/CMS-Unmark Pending Archive ;8/24/93 8:09 AM
- V ;;4.5;Accounts Receivable;**68**;Mar 20, 1995
- +1 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- EN1 ;Unmark records marked for archival entry point
- +1 NEW %,DIC,DIR,DTOUT,DUOUT,PRCA,PRCABN,PRCATY,Y
- +2 IF $PIECE($GET(^PRCAK(430.8,0)),U,3)>0
- WRITE !!,"The PENDING ARCHIVE records were moved to temporary storage!",!,"You cannot unmark these records."
- GOTO EN1Q
- +3 SET DIR("A")="Do you want to unmark ALL bills PENDING ARCHIVE"
- SET DIR("B")="NO"
- SET DIR(0)="Y"
- SET DIR("?")="Enter 'Y' to unmark all bills in this status for the same remarks"
- DO ^DIR
- +4 IF $DATA(DTOUT)!$DATA(DUOUT)
- GOTO EN1Q
- +5 IF Y=1
- GOTO ALL
- +6 WRITE !
- SET DIC("S")="I $P(^PRCA(430,+Y,0),U,8)=$O(^PRCA(430.3,""B"",""PENDING ARCHIVE"",0))"
- SET DIC(0)="AEQMZ"
- SET DIC="^PRCA(430,"
- DO ^DIC
- SET PRCABN=+Y
- if $GET(PRCABN)'>0
- GOTO EN1Q
- +7 IF '$PIECE(^PRCA(430,PRCABN,9),U,6)
- WRITE !!,"This bill does not have a previous status!"
- GOTO EN1Q
- EN1A WRITE !,"Change the status of this bill back to ",$PIECE($GET(^PRCA(430.3,+$PIECE(^PRCA(430,PRCABN,9),U,6),0)),U,1)
- SET %=2
- DO YN^DICN
- if %=1
- DO EN1S
- +1 IF %=0
- WRITE !!,"Enter YES if you want to change the status of the bill back to the",!,"previous status to prevent the bill from being archived!",!
- GOTO EN1A
- EN1Q QUIT
- EN1S ;prompt user for change status data.
- +1 NEW DA,DIE,DR,X
- +2 SET DR="8////^S X="_$SELECT($PIECE($GET(^PRCA(430,PRCABN,9)),U,6):$PIECE(^(9),U,6),1:15)_";15;17////^S X="_$GET(DUZ)
- SET DIE="^PRCA(430,"
- SET DA=PRCABN
- DO ^DIE
- +3 QUIT
- ALL ;Loop on PENDING ARCHIVE status and reverse all bills
- +1 NEW REM
- +2 LOCK +^PRCAK("PRCAK"):1
- IF '$TEST
- WRITE *7,!!,"WARNING: Another AR Archive Process is still running!",!!
- +3 LOCK -^PRCAK("PRCAK")
- +4 WRITE !!,"Enter a Status Remark (3-45 characters) for all bills unmarked for archival."
- REM READ !,"Status Remark: ",REM:DTIME
- IF '$TEST!(REM["^")
- GOTO EN1Q
- +1 IF $GET(REM)]""
- IF ($LENGTH(REM)<3!($LENGTH(REM)>45))
- WRITE !,"Remark must be 3-45 characters in length"
- GOTO REM
- +2 IF $ORDER(^PRCA(430.3,"AC",114,0))=""
- WRITE !!,*7,"Please contact your IRM. The Pending Archive status is not setup properly!",!
- QUIT
- +3 IF '$ORDER(^PRCA(430,"AC",$ORDER(^PRCA(430.3,"AC",114,0)),0))
- WRITE !!,*7,"Cannot find any bills in the Pending Archive status!",!
- QUIT
- +4 SET ZTRTN="DQ^PRCAKUN"
- SET ZTIO=""
- SET ZTSAVE("REM")=""
- DO ^%ZTLOAD
- +5 QUIT
- DQ ;
- +1 NEW ST,PRCABN,X,DA,DIE,DR
- +2 LOCK +^PRCAK("PRCAK"):1
- IF '$TEST
- DO BUSY^PRCAKS("Unmark ALL Pending Archive Records")
- GOTO END
- +3 SET ST=$ORDER(^PRCA(430.3,"AC",114,0))
- IF ST=""
- GOTO END
- +4 SET PRCABN=""
- FOR
- SET PRCABN=$ORDER(^PRCA(430,"AC",ST,PRCABN))
- if 'PRCABN
- QUIT
- Begin DoDot:1
- +5 IF '$DATA(^PRCA(430,PRCABN,0))
- KILL ^PRCA(430,"AC",ST,PRCABN)
- QUIT
- +6 SET DR="8////^S X="_$SELECT($PIECE($GET(^PRCA(430,PRCABN,9)),U,6):$PIECE(^(9),U,6),1:15)_";15////^S X=$G(REM);17////^S X=DUZ"
- SET DIE="^PRCA(430,"
- SET DA=PRCABN
- DO ^DIE
- +7 QUIT
- End DoDot:1
- END LOCK -^PRCAK("PRCAK")
- QUIT