PSXCSTPG ;BIR/JMB-Purges Cost Data/One Day Compile/Recompile Cost Data ;[ 04/08/97 2:06 PM ]
;;2.0;CMOP;;11 Apr 97
I '$D(^XUSEC("PSXCOST",DUZ)) W !,"You are not authorized to use this option!" Q
;If no data in file, print error msg.
S PSXBDT=$O(^PSX(552.5,"AD",0)) I '$D(PSXBDT) W !!,"There is no data in the cost file." K PSXBDT Q
;Determine 3 month back.
S X1=DT,X2=-(93+$E(DT,6,7)) D C^%DTC S PSXDT90=$E(X,1,5)_"00"
;If beginning date is not 3 months ago, display error msg.
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
S Y=PSXBDT D DD^%DT S PSXBDTR=Y,Y=PSXDT90 D DD^%DT S PSXDT90R=Y
PDT ;Get & validate purge date range
W !!,"Data for three complete months must remain in the cost file.",!?10,PSXBDTR_" through "_PSXDT90R_" can be purged.",!
S %DT="EPA",%DT(0)=PSXBDT,%DT("A")="Purge data from "_PSXBDTR_" through: " D ^%DT G:"^"[X END^PSXCSUTL G:Y<0 PDT
I PSXDT90<Y!($E(Y,1,5)>$E(PSXDT90,1,5)) W " Invalid month." G PDT
S PSXEDT=Y D DD^%DT W !!,"Purge from "_PSXBDTR_" to "_Y,!
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))
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
;Looks for active task working on this date range's data.
S PSXCOM=0 D CHECK^PSXCSLOG G:$G(PSXERR) PDT
;Queue job
S PSXSTART=9999999.999999-$E($$HTFM^XLFDT($H),1,14),PSXJOB="P"
W ! S ZTDTH="",ZTRTN="P^PSXCSTPG",ZTDESC="CMOP Cost Data Purge",ZTIO="" F PSXG="PSXBDT","PSXEDT","PSXSTART" S:$D(@PSXG) ZTSAVE(PSXG)=""
D ^%ZTLOAD W:$D(ZTSK) !!,"Task Queued!",!
S PSXEDT=$E(PSXEDT,1,5)_"00" D QUE^PSXCSLG1 S:$D(ZTQUEUED) ZTREQ="@"
G END^PSXCSUTL
P ;Queued entry point
D RUN^PSXCSLG1 ;Updates cost task log
;Loops thru date range & deletes drug data nodes
F DA=(PSXBDT-1):0 S DA=$O(^PSX(552.5,"AD",DA)) Q:'DA!(DA>PSXEDT) D
.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
P2 ;Deletes sub-file nodes if no drug data nodes
K DA F DA(1)=0:0 S DA(1)=$O(^PSX(552.5,"B",DA(1))) Q:'DA(1) D
.S PSXDIV="" F S PSXDIV=$O(^PSX(552.5,DA(1),1,"B",PSXDIV)) Q:PSXDIV="" D
..F DA=0:0 S DA=$O(^PSX(552.5,DA(1),1,"B",PSXDIV,DA)) Q:'DA D
...I '$O(^PSX(552.5,DA(1),1,DA,1,0)) S DIK="^PSX(552.5,"_DA(1)_",1," D ^DIK K DIK
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
D END^PSXCSLG1 ;Updates cost task log
G END^PSXCSUTL
DAY ;Entry point for One Day Compile/Recompile Cost Data
I '$D(^XUSEC("PSXCOST",DUZ)) W !,"You are not authorized to use this option!" Q
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
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
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
W ! D QUE^PSXCST,END^PSXCSUTL
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSXCSTPG 3363 printed Sep 23, 2025@19:19:55 Page 2
PSXCSTPG ;BIR/JMB-Purges Cost Data/One Day Compile/Recompile Cost Data ;[ 04/08/97 2:06 PM ]
+1 ;;2.0;CMOP;;11 Apr 97
+2 IF '$DATA(^XUSEC("PSXCOST",DUZ))
WRITE !,"You are not authorized to use this option!"
QUIT
+3 ;If no data in file, print error msg.
+4 SET PSXBDT=$ORDER(^PSX(552.5,"AD",0))
IF '$DATA(PSXBDT)
WRITE !!,"There is no data in the cost file."
KILL PSXBDT
QUIT
+5 ;Determine 3 month back.
+6 SET X1=DT
SET X2=-(93+$EXTRACT(DT,6,7))
DO C^%DTC
SET PSXDT90=$EXTRACT(X,1,5)_"00"
+7 ;If beginning date is not 3 months ago, display error msg.
+8 IF PSXBDT'<PSXDT90
SET Y=PSXBDT
DO DD^%DT
WRITE !!,"The cost file contains data beginning with ",Y,".",!!,"Data for three complete months must remain",!,"in the cost file. No data can be purged.",!
QUIT
+9 SET Y=PSXBDT
DO DD^%DT
SET PSXBDTR=Y
SET Y=PSXDT90
DO DD^%DT
SET PSXDT90R=Y
PDT ;Get & validate purge date range
+1 WRITE !!,"Data for three complete months must remain in the cost file.",!?10,PSXBDTR_" through "_PSXDT90R_" can be purged.",!
+2 SET %DT="EPA"
SET %DT(0)=PSXBDT
SET %DT("A")="Purge data from "_PSXBDTR_" through: "
DO ^%DT
if "^"[X
GOTO END^PSXCSUTL
if Y<0
GOTO PDT
+3 IF PSXDT90<Y!($EXTRACT(Y,1,5)>$EXTRACT(PSXDT90,1,5))
WRITE " Invalid month."
GOTO PDT
+4 SET PSXEDT=Y
DO DD^%DT
WRITE !!,"Purge from "_PSXBDTR_" to "_Y,!
+5 IF PSXEDT'=PSXDT90
IF $EXTRACT(PSXEDT,6,7)="00"
SET PSXEDT=$EXTRACT(PSXEDT,1,5)_$PIECE("31^29^31^30^31^30^31^31^30^31^30^31","^",$EXTRACT(PSXEDT,4,5))
+6 SET DIR("A")="Are you sure"
SET DIR(0)="Y"
SET DIR("B")="N"
DO ^DIR
KILL DIR
IF $GET(DIRUT)!('Y)
WRITE !!,"No data has been purged."
GOTO END^PSXCSUTL
+7 ;Looks for active task working on this date range's data.
+8 SET PSXCOM=0
DO CHECK^PSXCSLOG
if $GET(PSXERR)
GOTO PDT
+9 ;Queue job
+10 SET PSXSTART=9999999.999999-$EXTRACT($$HTFM^XLFDT($HOROLOG),1,14)
SET PSXJOB="P"
+11 WRITE !
SET ZTDTH=""
SET ZTRTN="P^PSXCSTPG"
SET ZTDESC="CMOP Cost Data Purge"
SET ZTIO=""
FOR PSXG="PSXBDT","PSXEDT","PSXSTART"
if $DATA(@PSXG)
SET ZTSAVE(PSXG)=""
+12 DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !!,"Task Queued!",!
+13 SET PSXEDT=$EXTRACT(PSXEDT,1,5)_"00"
DO QUE^PSXCSLG1
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+14 GOTO END^PSXCSUTL
P ;Queued entry point
+1 ;Updates cost task log
DO RUN^PSXCSLG1
+2 ;Loops thru date range & deletes drug data nodes
+3 FOR DA=(PSXBDT-1):0
SET DA=$ORDER(^PSX(552.5,"AD",DA))
if 'DA!(DA>PSXEDT)
QUIT
Begin DoDot:1
+4 FOR DA(2)=0:0
SET DA(2)=$ORDER(^PSX(552.5,"AD",DA,DA(2)))
if '+DA(2)
QUIT
FOR DA(1)=0:0
SET DA(1)=$ORDER(^PSX(552.5,"AD",DA,DA(2),DA(1)))
if '+DA(1)
QUIT
SET DIK="^PSX(552.5,"_DA(2)_",1,"_DA(1)_",1,"
DO ^DIK
End DoDot:1
P2 ;Deletes sub-file nodes if no drug data nodes
+1 KILL DA
FOR DA(1)=0:0
SET DA(1)=$ORDER(^PSX(552.5,"B",DA(1)))
if 'DA(1)
QUIT
Begin DoDot:1
+2 SET PSXDIV=""
FOR
SET PSXDIV=$ORDER(^PSX(552.5,DA(1),1,"B",PSXDIV))
if PSXDIV=""
QUIT
Begin DoDot:2
+3 FOR DA=0:0
SET DA=$ORDER(^PSX(552.5,DA(1),1,"B",PSXDIV,DA))
if 'DA
QUIT
Begin DoDot:3
+4 IF '$ORDER(^PSX(552.5,DA(1),1,DA,1,0))
SET DIK="^PSX(552.5,"_DA(1)_",1,"
DO ^DIK
KILL DIK
End DoDot:3
End DoDot:2
End DoDot:1
+5 KILL DA
FOR DA=0:0
SET DA=$ORDER(^PSX(552.5,"B",DA))
if 'DA
QUIT
IF '$ORDER(^PSX(552.5,DA,1,0))
SET DIK="^PSX(552.5,"
DO ^DIK
KILL DIK
+6 ;Updates cost task log
DO END^PSXCSLG1
+7 GOTO END^PSXCSUTL
DAY ;Entry point for One Day Compile/Recompile Cost Data
+1 IF '$DATA(^XUSEC("PSXCOST",DUZ))
WRITE !,"You are not authorized to use this option!"
QUIT
+2 WRITE !
SET %DT(0)=-DT
SET %DT("A")="Date: "
SET %DT="EPXA"
DO ^%DT
if "^"[X
GOTO END^PSXCSUTL
if 'Y
GOTO DAY
SET (PSXBDT,PSXEDT)=Y
KILL %DT(0)
SET PSXCOM=1
+3 SET PSXFND=$ORDER(^PSX(552.4,"AD",PSXBDT-1))
IF PSXFND>PSXEDT!(+PSXFND=0)
SET Y=PSXBDT
XECUTE ^DD("DD")
SET PSXSDATE=Y
WRITE !!?5,"There is no prescription data for "_PSXSDATE_".",!
GOTO END^PSXCSUTL
+4 WRITE !
SET DIR("A")="Are you sure"
SET DIR(0)="Y"
SET DIR("B")="N"
DO ^DIR
KILL DIR
IF $GET(DIRUT)!('Y)
WRITE !!,"No data has been compiled/recompiled."
GOTO DAY
+5 WRITE !
DO QUE^PSXCST
DO END^PSXCSUTL
+6 QUIT
