- PRCFACPS ;WISC@ALTOONA/CTB/DL-PURGE CODE SHEET CONTINUATION ;1/29/98 1300
- V ;;5.1;IFCAP;**114,116**;Oct 20, 2000;Build 8
- ;Per VHA Directive 2004-038, this routine should not be modified.
- DQ ;;PURGE CODE SHEETS AND TRANSMISSION RECORDS
- D:$D(ZTQUEUED) KILL^%ZTLOAD
- S PRCFNAME=$S(PRCFASYS["ALL":"All Codes, Receiving Reports & LOG",PRCFASYS["CLMCLIRRLOG":"FEE/FEN, Receiving Reports & LOG",PRCFASYS["CLM":"FEE/FEN",PRCFASYS["ISM":"ISM",PRCFASYS["IRS":"IRS",1:"LOG")
- L +^PRCF(423,0):5 I '$T S X="Code Sheet file unavailable - File lock timeout.*" D MSG^PRCFQ Q
- W:$D(IOF) @IOF W PRCFNAME_" CODE SHEET & TRANSMISSION RECORD DELETION TRANSCRIPT" D NOW^PRCFQ W ?IOM-$L(%X),%X
- S $P(LINE,"-",IOM-2)="" W !,LINE,!!,"Option queued by: ",$S($D(DUZ):$P(^VA(200,DUZ,0),"^"),1:"Menu Manager"),!,"Date/Time queued: ",PRCFA("QTIME"),!,"From Device: ",PRCFA("QION")
- W !!!,PRCFNAME_" code sheet deletion has begun for station ",PRC("SITE"),!,"I am deleting all "_PRCFNAME_" code sheets created or transmitted on or before ",PRCFA("DATE"),".",!
- S (DA,J)=0,U="^" F K=1:1 S DA=$O(^PRCF(423,DA)) Q:'DA D KILLCS
- W !!,"Done - deleted ",J," ",PRCFNAME," code sheets. ",$P(^PRCF(423,0),"^",4)," code sheets remaining."
- W !!,"I will now begin cleaning up the Log Transmission Record file.",!,"I will delete all "_PRCFNAME_" batches and transmission records created on or before ",PRCFA("DATE"),!
- S (DA,JX)=0,DIK="^PRCF(421.2," F K=1:1 S DA=$O(^PRCF(421.2,DA)) Q:'DA I $D(^(DA,0)) S X=^(0) I +$P(X,"-",2)>0!(PRCFASYS[$P(X,"-",2)),$P(X,"^",10)<PRCFA("KDATE"),(+X=PRC("SITE")!(+X="")) D ^DIK S JX=JX+1 W:JX#50=0 "."
- W !!,"Done - Deleted ",JX," Batch and Transmission records. ",$P(^PRCF(421.2,0),"^",4)," transmission/batch records remaining.",!!
- XREF ;CLEAN UP OF XREF'S IN FILE 423
- S XREF="A" F ZI=1:1 S XREF=$O(^PRCF(423,XREF)) Q:XREF="" S VAL="" F ZJ=1:1 S VAL=$O(^PRCF(423,XREF,VAL)) Q:VAL="" S DA=0 F ZK=1:1 S DA=$O(^PRCF(423,XREF,VAL,DA)) Q:DA="" K:'$D(^PRCF(423,DA)) ^PRCF(423,XREF,VAL,DA)
- ;S XREF="C",VAL="" F ZJ=1:1 S VAL=$O(^PRCF(423,XREF,VAL)) Q:VAL="" I VAL["^" S DA=0,VAL1=$P(VAL,"^") F ZK=1:1 S DA=$O(^PRCF(423,XREF,VAL,DA)) Q:DA="" K ^PRCF(423,XREF,VAL,DA) S ^PRCF(423,XREF,VAL1,DA)=""
- K XREF,VAL,DA,ZI,ZJ,ZK
- Q
- KILLCS S ZERO=$S($D(^PRCF(423,DA,0)):^(0),1:""),TRANS=$S($D(^("TRANS")):^("TRANS"),1:""),ZLOG=$S($D(^(300)):^(300),1:""),ONE=$S($D(^(1)):^(1),1:"")
- I ZERO="",TRANS="",ZLOG="",ONE G K
- I $P(ZERO,"^",2)'=PRC("SITE"),$P(ZERO,"^",2)]"" Q
- I PRCFASYS'[$P(ZERO,"^",10),$P(ZERO,"^",10)]"" Q
- I +$P(TRANS,U,3)>PRCFA("KDATE")!(+$P(TRANS,U,9)>PRCFA("KDATE")) Q
- S J=J+1 W:J#50=0 "."
- I $P(ZERO,U,6)'="" K ^PRCF(423,"C",$P(ZERO,U,6),DA)
- K:$P(ZERO,U,1)'="" ^PRCF(423,"B",$P(ZERO,U),DA)
- K:$P(TRANS,U,5)'="" ^PRCF(423,"AD",$P(TRANS,U,5),DA)
- K:$P(TRANS,U,6)]"" ^PRCF(423,"AE",$P(TRANS,U,6),DA)
- K:$P(ZLOG,U,24)]"" ^PRCF(423,"D",$P(ZLOG,U,24),DA)
- K:$P(ZLOG,U,25)]"" ^PRCF(423,"AN",$P(ZLOG,U,25),DA)
- K:$P(ONE,U,29)]"" ^PRCF(423,"AI",$P(ONE,U,29),DA)
- K K ONE,ZERO,TRANS,ZLOG,^PRCF(423,"AC","N",DA),^PRCF(423,"AC","I",DA)
- F ZX="AJ","AK","AL","AM" K ^PRCF(423,ZX,"Y",DA)
- K ^PRCF(423,DA),ZX S:$P(^PRCF(423,0),"^",4)>0 $P(^(0),U,4)=$P(^(0),U,4)-1 Q
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFACPS 3198 printed Feb 18, 2025@23:28:30 Page 2
- PRCFACPS ;WISC@ALTOONA/CTB/DL-PURGE CODE SHEET CONTINUATION ;1/29/98 1300
- V ;;5.1;IFCAP;**114,116**;Oct 20, 2000;Build 8
- +1 ;Per VHA Directive 2004-038, this routine should not be modified.
- DQ ;;PURGE CODE SHEETS AND TRANSMISSION RECORDS
- +1 if $DATA(ZTQUEUED)
- DO KILL^%ZTLOAD
- +2 SET PRCFNAME=$SELECT(PRCFASYS["ALL":"All Codes, Receiving Reports & LOG",PRCFASYS["CLMCLIRRLOG":"FEE/FEN, Receiving Reports & LOG",PRCFASYS["CLM":"FEE/FEN",PRCFASYS["ISM":"ISM",PRCFASYS["IRS":"IRS",1:"LOG")
- +3 LOCK +^PRCF(423,0):5
- IF '$TEST
- SET X="Code Sheet file unavailable - File lock timeout.*"
- DO MSG^PRCFQ
- QUIT
- +4 if $DATA(IOF)
- WRITE @IOF
- WRITE PRCFNAME_" CODE SHEET & TRANSMISSION RECORD DELETION TRANSCRIPT"
- DO NOW^PRCFQ
- WRITE ?IOM-$LENGTH(%X),%X
- +5 SET $PIECE(LINE,"-",IOM-2)=""
- WRITE !,LINE,!!,"Option queued by: ",$SELECT($DATA(DUZ):$PIECE(^VA(200,DUZ,0),"^"),1:"Menu Manager"),!,"Date/Time queued: ",PRCFA("QTIME"),!,"From Device: ",PRCFA("QION")
- +6 WRITE !!!,PRCFNAME_" code sheet deletion has begun for station ",PRC("SITE"),!,"I am deleting all "_PRCFNAME_" code sheets created or transmitted on or before ",PRCFA("DATE"),".",!
- +7 SET (DA,J)=0
- SET U="^"
- FOR K=1:1
- SET DA=$ORDER(^PRCF(423,DA))
- if 'DA
- QUIT
- DO KILLCS
- +8 WRITE !!,"Done - deleted ",J," ",PRCFNAME," code sheets. ",$PIECE(^PRCF(423,0),"^",4)," code sheets remaining."
- +9 WRITE !!,"I will now begin cleaning up the Log Transmission Record file.",!,"I will delete all "_PRCFNAME_" batches and transmission records created on or before ",PRCFA("DATE"),!
- +10 SET (DA,JX)=0
- SET DIK="^PRCF(421.2,"
- FOR K=1:1
- SET DA=$ORDER(^PRCF(421.2,DA))
- if 'DA
- QUIT
- IF $DATA(^(DA,0))
- SET X=^(0)
- IF +$PIECE(X,"-",2)>0!(PRCFASYS[$PIECE(X,"-",2))
- IF $PIECE(X,"^",10)<PRCFA("KDATE")
- IF (+X=PRC("SITE")!(+X=""))
- DO ^DIK
- SET JX=JX+1
- if JX#50=0
- WRITE "."
- +11 WRITE !!,"Done - Deleted ",JX," Batch and Transmission records. ",$PIECE(^PRCF(421.2,0),"^",4)," transmission/batch records remaining.",!!
- XREF ;CLEAN UP OF XREF'S IN FILE 423
- +1 SET XREF="A"
- FOR ZI=1:1
- SET XREF=$ORDER(^PRCF(423,XREF))
- if XREF=""
- QUIT
- SET VAL=""
- FOR ZJ=1:1
- SET VAL=$ORDER(^PRCF(423,XREF,VAL))
- if VAL=""
- QUIT
- SET DA=0
- FOR ZK=1:1
- SET DA=$ORDER(^PRCF(423,XREF,VAL,DA))
- if DA=""
- QUIT
- if '$DATA(^PRCF(423,DA))
- KILL ^PRCF(423,XREF,VAL,DA)
- +2 ;S XREF="C",VAL="" F ZJ=1:1 S VAL=$O(^PRCF(423,XREF,VAL)) Q:VAL="" I VAL["^" S DA=0,VAL1=$P(VAL,"^") F ZK=1:1 S DA=$O(^PRCF(423,XREF,VAL,DA)) Q:DA="" K ^PRCF(423,XREF,VAL,DA) S ^PRCF(423,XREF,VAL1,DA)=""
- +3 KILL XREF,VAL,DA,ZI,ZJ,ZK
- +4 QUIT
- KILLCS SET ZERO=$SELECT($DATA(^PRCF(423,DA,0)):^(0),1:"")
- SET TRANS=$SELECT($DATA(^("TRANS")):^("TRANS"),1:"")
- SET ZLOG=$SELECT($DATA(^(300)):^(300),1:"")
- SET ONE=$SELECT($DATA(^(1)):^(1),1:"")
- +1 IF ZERO=""
- IF TRANS=""
- IF ZLOG=""
- IF ONE
- GOTO K
- +2 IF $PIECE(ZERO,"^",2)'=PRC("SITE")
- IF $PIECE(ZERO,"^",2)]""
- QUIT
- +3 IF PRCFASYS'[$PIECE(ZERO,"^",10)
- IF $PIECE(ZERO,"^",10)]""
- QUIT
- +4 IF +$PIECE(TRANS,U,3)>PRCFA("KDATE")!(+$PIECE(TRANS,U,9)>PRCFA("KDATE"))
- QUIT
- +5 SET J=J+1
- if J#50=0
- WRITE "."
- +6 IF $PIECE(ZERO,U,6)'=""
- KILL ^PRCF(423,"C",$PIECE(ZERO,U,6),DA)
- +7 if $PIECE(ZERO,U,1)'=""
- KILL ^PRCF(423,"B",$PIECE(ZERO,U),DA)
- +8 if $PIECE(TRANS,U,5)'=""
- KILL ^PRCF(423,"AD",$PIECE(TRANS,U,5),DA)
- +9 if $PIECE(TRANS,U,6)]""
- KILL ^PRCF(423,"AE",$PIECE(TRANS,U,6),DA)
- +10 if $PIECE(ZLOG,U,24)]""
- KILL ^PRCF(423,"D",$PIECE(ZLOG,U,24),DA)
- +11 if $PIECE(ZLOG,U,25)]""
- KILL ^PRCF(423,"AN",$PIECE(ZLOG,U,25),DA)
- +12 if $PIECE(ONE,U,29)]""
- KILL ^PRCF(423,"AI",$PIECE(ONE,U,29),DA)
- K KILL ONE,ZERO,TRANS,ZLOG,^PRCF(423,"AC","N",DA),^PRCF(423,"AC","I",DA)
- +1 FOR ZX="AJ","AK","AL","AM"
- KILL ^PRCF(423,ZX,"Y",DA)
- +2 KILL ^PRCF(423,DA),ZX
- if $PIECE(^PRCF(423,0),"^",4)>0
- SET $PIECE(^(0),U,4)=$PIECE(^(0),U,4)-1
- QUIT
- +3 QUIT