source: FOIAVistA/trunk/r/FEE_BASIS-FB/FBAABPG.m@ 1274

Last change on this file since 1274 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 2.8 KB
Line 
1FBAABPG ;AISC/DMK-PURGE BATCH FILE ;01SEP89
2 ;;3.5;FEE BASIS;;JAN 30, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 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
5 I DUZ(0)'="@" W *7,!!,"You must have programmer access (DUZ(0)='@') before running the batch purge.",!! Q
6 D DT^DICRW S Y=DT D PDF^FBAAUTL S FBPGDT=Y
7 I '$D(^FBAA(161.7,"AF")) W !,*7,?7,"There are no batches finalized !!" Q
8RD S DIR(0)="Y",DIR("A")="This option is used to purge Fee Basis batch numbers for a time frame in the past. Do you want to continue",DIR("B")="NO",DIR("?")="Answer ""Yes"" if you wish to proceed with Fee Basis batch number purging!"
9 D ^DIR K DIR I 'Y!$D(DIRUT) G END
10SETDT W !! S %DT="AEP",%DT(0)=-DT,%DT("A")="Purge batch #'s PRIOR to date : " D ^%DT G:Y<0 END K %DT S PDAT=Y
11 S VAR="PDAT^FBPGDT",VAL=PDAT_"^"_FBPGDT,PGM="START^FBAABPG" D ZIS^FBAAUTL G:FBPOP END
12START U IO W:$E(IOST,1,2)="C-" @IOF W ?15,"*** BEGIN FEE BASIS BATCH NUMBER PURGE ***",!!! S CNT=0
13 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
14 G PRT
15MORE 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"
16 Q
17MEDP 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)=""
18 K ^FBAAC("AC",I) D GOT Q
19TRAVP 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)=""
20 K ^FBAAC("AD",I) D GOT Q
21RPHP 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)=""
22 K ^FBAA(162.1,"AE",I),^FBAA(162.1,"AJ",I) D GOT Q
23GOT S CNT=CNT+1 W "." S DIK="^FBAA(161.7,",DA=I D ^DIK Q
24PRT I CNT=0 W !!,?10,"There are no batch numbers to purge for this time frame !! " G END
25 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)," ."
26 S ^FBAA(161.4,1,"PURGE")=DT
27 W !!!!,?15,"*** FEE BASIS BATCH NUMBER PURGE FINISHED ***"
28 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
29END 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
30CHP 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)=""
31 K ^FBAAI("AC",I),^FBAAI("AE",I) D GOT Q
Note: See TracBrowser for help on using the repository browser.