| 1 | FBAABPG ;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
|
|---|
| 8 | RD 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
|
|---|
| 10 | SETDT 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
|
|---|
| 12 | START 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
|
|---|
| 15 | 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"
|
|---|
| 16 | Q
|
|---|
| 17 | 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)=""
|
|---|
| 18 | K ^FBAAC("AC",I) D GOT Q
|
|---|
| 19 | 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)=""
|
|---|
| 20 | K ^FBAAC("AD",I) D GOT Q
|
|---|
| 21 | 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)=""
|
|---|
| 22 | K ^FBAA(162.1,"AE",I),^FBAA(162.1,"AJ",I) D GOT Q
|
|---|
| 23 | GOT S CNT=CNT+1 W "." S DIK="^FBAA(161.7,",DA=I D ^DIK Q
|
|---|
| 24 | PRT 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
|
|---|
| 29 | 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
|
|---|
| 30 | 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)=""
|
|---|
| 31 | K ^FBAAI("AC",I),^FBAAI("AE",I) D GOT Q
|
|---|
