source: FOIAVistA/tag/r/CMOP-PSX/PSXCSTPG.m@ 1104

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

initial load of FOIAVistA 6/30/08 version
File size: 3.2 KB
Line 
1PSXCSTPG ;BIR/JMB-Purges Cost Data/One Day Compile/Recompile Cost Data ;[ 04/08/97 2:06 PM ]
2 ;;2.0;CMOP;;11 Apr 97
3 I '$D(^XUSEC("PSXCOST",DUZ)) W !,"You are not authorized to use this option!" Q
4 ;If no data in file, print error msg.
5 S PSXBDT=$O(^PSX(552.5,"AD",0)) I '$D(PSXBDT) W !!,"There is no data in the cost file." K PSXBDT Q
6 ;Determine 3 month back.
7 S X1=DT,X2=-(93+$E(DT,6,7)) D C^%DTC S PSXDT90=$E(X,1,5)_"00"
8 ;If beginning date is not 3 months ago, display error msg.
9 I PSXBDT'<PSXDT90 S Y=PSXBDT D DD^%DT W !!,"The cost file contains data beginning with ",Y,".",!!,"Data for three complete months must remain",!,"in the cost file. No data can be purged.",! Q
10 S Y=PSXBDT D DD^%DT S PSXBDTR=Y,Y=PSXDT90 D DD^%DT S PSXDT90R=Y
11PDT ;Get & validate purge date range
12 W !!,"Data for three complete months must remain in the cost file.",!?10,PSXBDTR_" through "_PSXDT90R_" can be purged.",!
13 S %DT="EPA",%DT(0)=PSXBDT,%DT("A")="Purge data from "_PSXBDTR_" through: " D ^%DT G:"^"[X END^PSXCSUTL G:Y<0 PDT
14 I PSXDT90<Y!($E(Y,1,5)>$E(PSXDT90,1,5)) W " Invalid month." G PDT
15 S PSXEDT=Y D DD^%DT W !!,"Purge from "_PSXBDTR_" to "_Y,!
16 I PSXEDT'=PSXDT90,$E(PSXEDT,6,7)="00" S PSXEDT=$E(PSXEDT,1,5)_$P("31^29^31^30^31^30^31^31^30^31^30^31","^",$E(PSXEDT,4,5))
17 S DIR("A")="Are you sure",DIR(0)="Y",DIR("B")="N" D ^DIR K DIR I $G(DIRUT)!('Y) W !!,"No data has been purged." G END^PSXCSUTL
18 ;Looks for active task working on this date range's data.
19 S PSXCOM=0 D CHECK^PSXCSLOG G:$G(PSXERR) PDT
20 ;Queue job
21 S PSXSTART=9999999.999999-$E($$HTFM^XLFDT($H),1,14),PSXJOB="P"
22 W ! S ZTDTH="",ZTRTN="P^PSXCSTPG",ZTDESC="CMOP Cost Data Purge",ZTIO="" F PSXG="PSXBDT","PSXEDT","PSXSTART" S:$D(@PSXG) ZTSAVE(PSXG)=""
23 D ^%ZTLOAD W:$D(ZTSK) !!,"Task Queued!",!
24 S PSXEDT=$E(PSXEDT,1,5)_"00" D QUE^PSXCSLG1 S:$D(ZTQUEUED) ZTREQ="@"
25 G END^PSXCSUTL
26P ;Queued entry point
27 D RUN^PSXCSLG1 ;Updates cost task log
28 ;Loops thru date range & deletes drug data nodes
29 F DA=(PSXBDT-1):0 S DA=$O(^PSX(552.5,"AD",DA)) Q:'DA!(DA>PSXEDT) D
30 .F DA(2)=0:0 S DA(2)=$O(^PSX(552.5,"AD",DA,DA(2))) Q:'+DA(2) F DA(1)=0:0 S DA(1)=$O(^PSX(552.5,"AD",DA,DA(2),DA(1))) Q:'+DA(1) S DIK="^PSX(552.5,"_DA(2)_",1,"_DA(1)_",1," D ^DIK
31P2 ;Deletes sub-file nodes if no drug data nodes
32 K DA F DA(1)=0:0 S DA(1)=$O(^PSX(552.5,"B",DA(1))) Q:'DA(1) D
33 .S PSXDIV="" F S PSXDIV=$O(^PSX(552.5,DA(1),1,"B",PSXDIV)) Q:PSXDIV="" D
34 ..F DA=0:0 S DA=$O(^PSX(552.5,DA(1),1,"B",PSXDIV,DA)) Q:'DA D
35 ...I '$O(^PSX(552.5,DA(1),1,DA,1,0)) S DIK="^PSX(552.5,"_DA(1)_",1," D ^DIK K DIK
36 K DA F DA=0:0 S DA=$O(^PSX(552.5,"B",DA)) Q:'DA I '$O(^PSX(552.5,DA,1,0)) S DIK="^PSX(552.5," D ^DIK K DIK
37 D END^PSXCSLG1 ;Updates cost task log
38 G END^PSXCSUTL
39DAY ;Entry point for One Day Compile/Recompile Cost Data
40 I '$D(^XUSEC("PSXCOST",DUZ)) W !,"You are not authorized to use this option!" Q
41 W ! S %DT(0)=-DT,%DT("A")="Date: " S %DT="EPXA" D ^%DT G:"^"[X END^PSXCSUTL G DAY:'Y S (PSXBDT,PSXEDT)=Y K %DT(0) S PSXCOM=1
42 S PSXFND=$O(^PSX(552.4,"AD",PSXBDT-1)) I PSXFND>PSXEDT!(+PSXFND=0) S Y=PSXBDT X ^DD("DD") S PSXSDATE=Y W !!?5,"There is no prescription data for "_PSXSDATE_".",! G END^PSXCSUTL
43 W ! S DIR("A")="Are you sure",DIR(0)="Y",DIR("B")="N" D ^DIR K DIR I $G(DIRUT)!('Y) W !!,"No data has been compiled/recompiled." G DAY
44 W ! D QUE^PSXCST,END^PSXCSUTL
45 Q
Note: See TracBrowser for help on using the repository browser.