- PRCPXTRA ;WISC/RFJ-purge transaction register ;10 Feb 92
- ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- D ^PRCPUSEL Q:'$G(PRCP("I"))
- N %,%H,%I,DATE,NOWDT,STOPDATE,X,Y
- D NOW^%DTC S NOWDT=$E(X,1,5)_"01",X1=$E(X,1,5)_"15",X2=-395 D C^%DTC S (Y,STOPDATE)=$E(X,1,5)_"01" D DD^%DT S DATE=Y
- W ! F %=1:1 S X=$P($T(OPTION+%),";",3,99) Q:X="" S:X["DATE" X=$P(X,"DATE")_DATE_$P(X,"DATE",2) W !,X
- W ! S XP="ARE YOU SURE",XH="ENTER 'YES' TO START THE PURGE, 'NO' OR '^' TO EXIT."
- I $$YN^PRCPUYN(2)'=1 Q
- W !!,"<*> please wait <*>"
- DQ ; automatic purge starts here
- N D,DA,DIC,DIK,ITEMDA,TRANDA
- S TRANDA=0 F S TRANDA=$O(^PRCP(445.2,"B",PRCP("I"),TRANDA)) Q:'TRANDA S D=$P($G(^PRCP(445.2,TRANDA,0)),"^",17) I D<STOPDATE D
- . W "." S DIK="^PRCP(445.2,",DA=TRANDA D ^DIK K DIK,DA
- S ITEMDA=0 F S ITEMDA=$O(^PRCP(445.2,"ABEG",PRCP("I"),ITEMDA)) Q:'ITEMDA S D=0 F S D=$O(^PRCP(445.2,"ABEG",PRCP("I"),ITEMDA,D)) Q:'D I D<$E(STOPDATE,1,5) K ^PRCP(445.2,"ABEG",PRCP("I"),ITEMDA,D)
- W:'$G(PRCPZTSK) " Finished!" S $P(^PRCP(445,PRCP("I"),0),"^",18)=NOWDT Q
- ;
- OPTION ;;display entry text
- ;;This option will purge the register of all transactions that affect the
- ;;inventory point up to date DATE.
- ;;
- ;;The transaction register for and after DATE will NOT be purged.
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPXTRA 1357 printed Jan 18, 2025@03:18:06 Page 2
- PRCPXTRA ;WISC/RFJ-purge transaction register ;10 Feb 92
- +1 ;;5.1;IFCAP;;Oct 20, 2000
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 DO ^PRCPUSEL
- if '$GET(PRCP("I"))
- QUIT
- +4 NEW %,%H,%I,DATE,NOWDT,STOPDATE,X,Y
- +5 DO NOW^%DTC
- SET NOWDT=$EXTRACT(X,1,5)_"01"
- SET X1=$EXTRACT(X,1,5)_"15"
- SET X2=-395
- DO C^%DTC
- SET (Y,STOPDATE)=$EXTRACT(X,1,5)_"01"
- DO DD^%DT
- SET DATE=Y
- +6 WRITE !
- FOR %=1:1
- SET X=$PIECE($TEXT(OPTION+%),";",3,99)
- if X=""
- QUIT
- if X["DATE"
- SET X=$PIECE(X,"DATE")_DATE_$PIECE(X,"DATE",2)
- WRITE !,X
- +7 WRITE !
- SET XP="ARE YOU SURE"
- SET XH="ENTER 'YES' TO START THE PURGE, 'NO' OR '^' TO EXIT."
- +8 IF $$YN^PRCPUYN(2)'=1
- QUIT
- +9 WRITE !!,"<*> please wait <*>"
- DQ ; automatic purge starts here
- +1 NEW D,DA,DIC,DIK,ITEMDA,TRANDA
- +2 SET TRANDA=0
- FOR
- SET TRANDA=$ORDER(^PRCP(445.2,"B",PRCP("I"),TRANDA))
- if 'TRANDA
- QUIT
- SET D=$PIECE($GET(^PRCP(445.2,TRANDA,0)),"^",17)
- IF D<STOPDATE
- Begin DoDot:1
- +3 WRITE "."
- SET DIK="^PRCP(445.2,"
- SET DA=TRANDA
- DO ^DIK
- KILL DIK,DA
- End DoDot:1
- +4 SET ITEMDA=0
- FOR
- SET ITEMDA=$ORDER(^PRCP(445.2,"ABEG",PRCP("I"),ITEMDA))
- if 'ITEMDA
- QUIT
- SET D=0
- FOR
- SET D=$ORDER(^PRCP(445.2,"ABEG",PRCP("I"),ITEMDA,D))
- if 'D
- QUIT
- IF D<$EXTRACT(STOPDATE,1,5)
- KILL ^PRCP(445.2,"ABEG",PRCP("I"),ITEMDA,D)
- +5 if '$GET(PRCPZTSK)
- WRITE " Finished!"
- SET $PIECE(^PRCP(445,PRCP("I"),0),"^",18)=NOWDT
- QUIT
- +6 ;
- OPTION ;;display entry text
- +1 ;;This option will purge the register of all transactions that affect the
- +2 ;;inventory point up to date DATE.
- +3 ;;
- +4 ;;The transaction register for and after DATE will NOT be purged.