- 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 Feb 18, 2025@23:21:23 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