FBAABPG ;AISC/DMK - PURGE BATCH FILE ;11/15/2010
;;3.5;FEE BASIS;**117**;JAN 30, 1995;Build 9
;;Per VHA Directive 2004-038, this routine should not be modified.
I $S('($D(DUZ)#2):1,'($D(DUZ(0))#2):1,'DUZ:1,1:0) W *7,!!,"DUZ and DUZ(0) must be defined as a valid user to run the batch purge.",!! Q
I DUZ(0)'="@" W *7,!!,"You must have programmer access (DUZ(0)='@') before running the batch purge.",!! Q
D DT^DICRW S Y=DT D PDF^FBAAUTL S FBPGDT=Y
I '$D(^FBAA(161.7,"AF")) W !,*7,?7,"There are no batches finalized !!" Q
RD W !,"This option is used to purge Fee Basis batch numbers that were"
W !,"finalized before a specified date (at least 18 months ago)."
SETDT W ! S %DT="AEP",%DT(0)=("-"_$$FMADD^XLFDT(DT,-549)) ; IA #10103
S %DT("A")="Purge batch #'s PRIOR to date : "
D ^%DT G:Y<0 END K %DT S PDAT=Y
;
S DIR(0)="Y",DIR("A")="Do you want to continue",DIR("B")="NO"
S DIR("?")="Answer ""Yes"" if you wish to proceed with Fee Basis batch number purging!"
D ^DIR K DIR I 'Y!$D(DIRUT) G END
;
S VAR="PDAT^FBPGDT",VAL=PDAT_"^"_FBPGDT,PGM="START^FBAABPG" D ZIS^FBAAUTL G:FBPOP END
START U IO W:$E(IOST,1,2)="C-" @IOF W ?15,"*** BEGIN FEE BASIS BATCH NUMBER PURGE ***",!!! S CNT=0
F PD=0:0 S PD=$O(^FBAA(161.7,"AF",PD)) Q:PD'>0!(PD'<PDAT) F I=0:0 S I=$O(^FBAA(161.7,"AF",PD,I)) Q:I'>0 I $D(^FBAA(161.7,I,0)) D MORE
G PRT
MORE S Y(0)=^FBAA(161.7,I,0),B=$P(Y(0),"^",1),FBTYPE=$P(Y(0),"^",3),FBDUZ=$P(Y(0),"^",5) D MEDP:FBTYPE="B3",TRAVP:FBTYPE="B2",RPHP:FBTYPE="B5",CHP:FBTYPE="B9"
Q
MEDP F J=0:0 S J=$O(^FBAAC("AC",I,J)) Q:J'>0 F K=0:0 S K=$O(^FBAAC("AC",I,J,K)) Q:K'>0 F L=0:0 S L=$O(^FBAAC("AC",I,J,K,L)) Q:L'>0 F M=0:0 S M=$O(^FBAAC("AC",I,J,K,L,M)) Q:M'>0 I $D(^FBAAC(J,1,K,1,L,1,M,0)) S $P(^(0),"^",8)=""
K ^FBAAC("AC",I) D GOT Q
TRAVP F J=0:0 S J=$O(^FBAAC("AD",I,J)) Q:J'>0 F K=0:0 S K=$O(^FBAAC("AD",I,J,K)) Q:K'>0 I $D(^FBAAC(J,3,K,0)) S $P(^(0),"^",2)=""
K ^FBAAC("AD",I) D GOT Q
RPHP F J=0:0 S J=$O(^FBAA(162.1,"AE",I,J)) Q:J'>0 F K=0:0 S K=$O(^FBAA(162.1,"AE",I,J,K)) Q:K'>0 I $D(^FBAA(162.1,J,"RX",K,0)) S $P(^(0),"^",17)=""
K ^FBAA(162.1,"AE",I),^FBAA(162.1,"AJ",I) D GOT Q
GOT S CNT=CNT+1 W "." S DIK="^FBAA(161.7,",DA=I D ^DIK Q
PRT I CNT=0 W !!,?10,"There are no batch numbers to purge for this time frame !! " G END
W:CNT>0 !!,?10,"This option has purged ",CNT," batch numbers",!!,?16,"finalized prior to ",$E(PDAT,4,5)_"/"_$E(PDAT,6,7)_"/"_$E(PDAT,2,3)," ."
S ^FBAA(161.4,1,"PURGE")=DT
W !!!!,?15,"*** FEE BASIS BATCH NUMBER PURGE FINISHED ***"
S XMB(1)=$S($D(^VA(200,DUZ,0)):$P(^(0),"^",1),1:"Unknown User"),XMB(2)=FBPGDT,Y=PDAT D PDF^FBAAUTL S XMB(3)=Y,XMB(4)=CNT,XMB="FBAA BATCH PURGE" D ^XMB
END K I,J,K,L,M,Y,DA,D0,D1,CNT,DIC,DIRUT,DIW,DIWL,DIWT,DN,X,DIK,PDAT,VAR,VAL,FBPGDT,FBTYPE,B,PD,PGM,FBDUZ,XM1,XMA,XMDT,XMM,XMB D CLOSE^FBAAUTL Q
CHP F J=0:0 S J=$O(^FBAAI("AC",I,J)) Q:J'>0 I $D(^FBAAI(J,0)),'$D(^("FBREJ")) S $P(^FBAAI(J,0),"^",17)=""
K ^FBAAI("AC",I),^FBAAI("AE",I) D GOT Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAABPG 2981 printed Apr 09, 2024@21:06:20 Page 2
FBAABPG ;AISC/DMK - PURGE BATCH FILE ;11/15/2010
+1 ;;3.5;FEE BASIS;**117**;JAN 30, 1995;Build 9
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 IF $SELECT('($DATA(DUZ)#2):1,'($DATA(DUZ(0))#2):1,'DUZ:1,1:0)
WRITE *7,!!,"DUZ and DUZ(0) must be defined as a valid user to run the batch purge.",!!
QUIT
+4 IF DUZ(0)'="@"
WRITE *7,!!,"You must have programmer access (DUZ(0)='@') before running the batch purge.",!!
QUIT
+5 DO DT^DICRW
SET Y=DT
DO PDF^FBAAUTL
SET FBPGDT=Y
+6 IF '$DATA(^FBAA(161.7,"AF"))
WRITE !,*7,?7,"There are no batches finalized !!"
QUIT
RD WRITE !,"This option is used to purge Fee Basis batch numbers that were"
+1 WRITE !,"finalized before a specified date (at least 18 months ago)."
SETDT ; IA #10103
WRITE !
SET %DT="AEP"
SET %DT(0)=("-"_$$FMADD^XLFDT(DT,-549))
+1 SET %DT("A")="Purge batch #'s PRIOR to date : "
+2 DO ^%DT
if Y<0
GOTO END
KILL %DT
SET PDAT=Y
+3 ;
+4 SET DIR(0)="Y"
SET DIR("A")="Do you want to continue"
SET DIR("B")="NO"
+5 SET DIR("?")="Answer ""Yes"" if you wish to proceed with Fee Basis batch number purging!"
+6 DO ^DIR
KILL DIR
IF 'Y!$DATA(DIRUT)
GOTO END
+7 ;
+8 SET VAR="PDAT^FBPGDT"
SET VAL=PDAT_"^"_FBPGDT
SET PGM="START^FBAABPG"
DO ZIS^FBAAUTL
if FBPOP
GOTO END
START USE IO
if $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
WRITE ?15,"*** BEGIN FEE BASIS BATCH NUMBER PURGE ***",!!!
SET CNT=0
+1 FOR PD=0:0
SET PD=$ORDER(^FBAA(161.7,"AF",PD))
if PD'>0!(PD'<PDAT)
QUIT
FOR I=0:0
SET I=$ORDER(^FBAA(161.7,"AF",PD,I))
if I'>0
QUIT
IF $DATA(^FBAA(161.7,I,0))
DO MORE
+2 GOTO PRT
MORE SET Y(0)=^FBAA(161.7,I,0)
SET B=$PIECE(Y(0),"^",1)
SET FBTYPE=$PIECE(Y(0),"^",3)
SET FBDUZ=$PIECE(Y(0),"^",5)
if FBTYPE="B3"
DO MEDP
if FBTYPE="B2"
DO TRAVP
if FBTYPE="B5"
DO RPHP
if FBTYPE="B9"
DO CHP
+1 QUIT
MEDP FOR J=0:0
SET J=$ORDER(^FBAAC("AC",I,J))
if J'>0
QUIT
FOR K=0:0
SET K=$ORDER(^FBAAC("AC",I,J,K))
if K'>0
QUIT
FOR L=0:0
SET L=$ORDER(^FBAAC("AC",I,J,K,L))
if L'>0
QUIT
FOR M=0:0
SET M=$ORDER(^FBAAC("AC",I,J,K,L,M))
if M'>0
QUIT
IF $DATA(^FBAAC(J,1,K,1,L,1,M,0))
SET $PIECE(^(0),"^",8)=""
+1 KILL ^FBAAC("AC",I)
DO GOT
QUIT
TRAVP FOR J=0:0
SET J=$ORDER(^FBAAC("AD",I,J))
if J'>0
QUIT
FOR K=0:0
SET K=$ORDER(^FBAAC("AD",I,J,K))
if K'>0
QUIT
IF $DATA(^FBAAC(J,3,K,0))
SET $PIECE(^(0),"^",2)=""
+1 KILL ^FBAAC("AD",I)
DO GOT
QUIT
RPHP FOR J=0:0
SET J=$ORDER(^FBAA(162.1,"AE",I,J))
if J'>0
QUIT
FOR K=0:0
SET K=$ORDER(^FBAA(162.1,"AE",I,J,K))
if K'>0
QUIT
IF $DATA(^FBAA(162.1,J,"RX",K,0))
SET $PIECE(^(0),"^",17)=""
+1 KILL ^FBAA(162.1,"AE",I),^FBAA(162.1,"AJ",I)
DO GOT
QUIT
GOT SET CNT=CNT+1
WRITE "."
SET DIK="^FBAA(161.7,"
SET DA=I
DO ^DIK
QUIT
PRT IF CNT=0
WRITE !!,?10,"There are no batch numbers to purge for this time frame !! "
GOTO END
+1 if CNT>0
WRITE !!,?10,"This option has purged ",CNT," batch numbers",!!,?16,"finalized prior to ",$EXTRACT(PDAT,4,5)_"/"_$EXTRACT(PDAT,6,7)_"/"_$EXTRACT(PDAT,2,3)," ."
+2 SET ^FBAA(161.4,1,"PURGE")=DT
+3 WRITE !!!!,?15,"*** FEE BASIS BATCH NUMBER PURGE FINISHED ***"
+4 SET XMB(1)=$SELECT($DATA(^VA(200,DUZ,0)):$PIECE(^(0),"^",1),1:"Unknown User")
SET XMB(2)=FBPGDT
SET Y=PDAT
DO PDF^FBAAUTL
SET XMB(3)=Y
SET XMB(4)=CNT
SET XMB="FBAA BATCH PURGE"
DO ^XMB
END KILL I,J,K,L,M,Y,DA,D0,D1,CNT,DIC,DIRUT,DIW,DIWL,DIWT,DN,X,DIK,PDAT,VAR,VAL,FBPGDT,FBTYPE,B,PD,PGM,FBDUZ,XM1,XMA,XMDT,XMM,XMB
DO CLOSE^FBAAUTL
QUIT
CHP FOR J=0:0
SET J=$ORDER(^FBAAI("AC",I,J))
if J'>0
QUIT
IF $DATA(^FBAAI(J,0))
IF '$DATA(^("FBREJ"))
SET $PIECE(^FBAAI(J,0),"^",17)=""
+1 KILL ^FBAAI("AC",I),^FBAAI("AE",I)
DO GOT
QUIT
