RMPRCDP ;PHX/DWL,HNB-PURGE FILE 664 ;8/29/1994
;;3.0;PROSTHETICS;**3,173**;Feb 09, 1996;Build 29
;
;RMPR*3.0*173 Added purge for file 664 to remove aged orders that are
; no longer defined in IFCAP file 442. The purge will be
; controlled to ONLY allow orders for a fiscal year greater
; than 6 years ago to be entered and should be run AFTER
; the IFCAP annual purging process and use the same fiscal
; year that purge process used.
;
EN1 ;Purge 664, Canceled Transactions
D DIV4^RMPRSIT Q:$D(X)
EN4 K IOP,ZTIO,%ZIS S %ZIS="MQ",%ZIS("B")="" D ^%ZIS G:POP END
;I IOST["C-" W !,$C(7),"YOU MAY NOT SELECT YOUR TERMINAL" G EN4
I $D(IO("Q")) D
.S ZTRTN="EN11^RMPRCDP"
.S ZTDESC="CANCEL TRANSACTIONS IN FILE 664 FOR A STATION/DIVISION"
.F RD="I","RMPRIEN","RMPRDT","RMPRSITE","RMPR(" S ZTSAVE(RD)=""
I $D(IO("Q")) K IO("Q") D ^%ZTLOAD W !,$S($D(ZTSK):"<REQUEST QUEUED!>",1:"<REQUEST NOT QUEUED!>") G END
EN11 S (I,RMPRIEN)=0,RMPRDT=$P(^RMPR(669.9,RMPRSITE,0),U,10) G:RMPRDT'>89 END
S X1=DT,X2=-RMPRDT D C^%DTC S RMPRDT=X D NOW^%DTC S Y=% X ^DD("DD")
U IO W !!,"Purge Canceled Prosthetic Purchasing Transactions For: ",!,$P(^RMPR(669.9,RMPRSITE,0),U,1)," On ",Y,!!
F S RMPRIEN=$O(^RMPR(664,RMPRIEN)) Q:RMPRIEN'>0 D
.;quit if it is a purchase card transaction, non get purged
.Q:$D(^RMPR(664,RMPRIEN,4))
.I ($P(^RMPR(664,RMPRIEN,0),U,5))&($P(^(0),U,5)<RMPRDT&($P(^(0),U,14)=RMPR("STA"))) D
..S DA=RMPRIEN,DIC="^RMPR(664," D EN^DIQ
..S DA=RMPRIEN,DIK=DIC D ^DIK W "Deleted...",! S RDEL=1
I '$D(RDEL) S $P(L,"-",IOM)="" W !,L,!,?5,"NO CANCELED PURCHASING TRANSACTIONS DELETED"
G END
EN ;PURGE 664 FILE OF ENTRIES CLOSED OUT FOR A STATION/DIVISION
D DIV4^RMPRSIT Q:$D(X)
EN5 K IOP,%ZIS,ZTIO S %ZIS="MQ",%ZIS("B")="" D ^%ZIS G:POP END
;I IOST["C-" W !,$C(7),"YOU MAY NOT SELECT YOUR OWN TERMINAL" G EN5
I $D(IO("Q")) S ZTRTN="EN2^RMPRCDP",ZTDESC="PURGE 664 OF CLOSED OUT ENTRIES" F RD="I","RMPRIEN","RMPRDT","RMPRSITE","RMPR(" S ZTSAVE(RD)=""
I $D(IO("Q")) K IO("Q") D ^%ZTLOAD W !,$S($D(ZTSK):"<REQUEST QUEUED!>",1:"<REQUEST NOT QUEUED>") G END
EN2 S (I,RMPRIEN)=0,RMPRDT=$P(^RMPR(669.9,RMPRSITE,0),U,9) G:RMPRDT'>89 END
S X1=DT,X2=-RMPRDT D C^%DTC S RMPRDT=X D NOW^%DTC S Y=% X ^DD("DD")
U IO W !!,"Purge Closed Prosthetic Purchasing Transactions For",!,$P(^RMPR(669.9,RMPRSITE,0),U,1)," On ",Y,!!
F S RMPRIEN=$O(^RMPR(664,RMPRIEN)) Q:RMPRIEN'>0 D
.;quit if it is a purchase card transaction, non get purged
.Q:$D(^RMPR(664,RMPRIEN,4))
.I ($P(^RMPR(664,RMPRIEN,0),U,8))&($P(^(0),U,8)<RMPRDT&($P(^(0),U,14)=RMPR("STA"))) D
..S DA=RMPRIEN,DIC="^RMPR(664," D EN^DIQ
..S DA=RMPRIEN,DIK=DIC D ^DIK W "Deleted",! S RDEL=1
I '$D(RDEL) S $P(L,"-",IOM)="" W !,L,!,?5,"NO CLOSED PURCHASING TRANSACTIONS DELETED",!
END K I,RD,RMPRIEN,RMPRDT,RMPR,DIR,DIK,DA,DIC,X1,X2,L,RDEL,ZTSK D ^%ZISC
Q
EN3 ;Purge Non-Obligated Transactions
;IF C.P. and Reference Number missing, transaction not obligated to IFCAP
D DIV4^RMPRSIT Q:$D(X)
K IOP,%ZIS,ZTIO S %ZIS="MQ",%ZIS("B")="" D ^%ZIS G:POP END
I $D(IO("Q")) S ZTRTN="EN3A^RMPRCDP",ZTDESC="Purge Non-Obligated Transactions For Station # "_RMPR("STA"),ZTSAVE("RMPR*")=""
I $D(IO("Q")) K IO("Q") D ^%ZTLOAD W !,$S($D(ZTSK):"<REQUEST QUEUED!>",1:"<REQUEST NOT QUEUED>")
G END
EN3A ;
S RMPRA=0 F S RMPRA=$O(^RMPR(664,RMPRA)) Q:RMPRA'>0 D
.;quit if this is a purchase card transaction, non should be purged
.Q:$D(^RMPR(664,RMPRA,4))
.I '$P(^RMPR(664,RMPRA,0),U,6)&('$P(^(0),U,7))&($P(^(0),U,14)=RMPR("STA")) D
..S DA=RMPRA,DIC="^RMPR(664," D EN^DIQ
..S DA=RMPRA,DIK=DIC D ^DIK W "Deleted...",! S RDEL=1
I $G(RDEL)'=1 W !!,"No Non-Obligated Transactions deleted."
K RMPRA,DIK,DA,I,DIC D ^%ZISC
Q
;
;RMPR*3.0*173 File 664 Aged Order Purge
EN20 ;Purge 664, Aged order transactions based on file 442 purge history for closed/cancelled orders
S DIR("?")="Enter 'YES' or 'Y' to continue processing."
S DIR(0)="Y",DIR("A")="Purge MUST follow the IFCAP annual purge process, OK to continue? ",DIR("B")="NO" D ^DIR I $D(DIRUT)!($D(DTOUT))!(+Y'=1) Q
D DIV4^RMPRSIT G END1:$D(X)
EN21 ;Select Fiscal Year
D:'$D(DT) DT^DICRW
S RMPRFYT=1700+$E(DT,1,3)+$E(DT,4),RMPRFY=RMPRFYT
S DIR("?")="Fiscal year. Should be same year (or prior) as used in IFCAP annual purge."
S DIR("A")="Enter FISCAL YEAR (YYYY) to purge",DIR(0)="N^1990:2100",DIR("B")=RMPRFYT-8 D ^DIR K DIR G END1:$D(DIRUT) S RMPRFY=Y
I RMPRFY>(RMPRFYT-8) W " You CANNOT purge Prosthetics order data for a fiscal year LESS than 8 years ago!!" G EN21
S DIR("?")="Enter 'YES' or 'Y' to continue processing."
S DIR(0)="Y",DIR("A")="Purging closed PROS orders prior to FY end 09/30/"_RMPRFY_", OK? ",DIR("B")="NO" D ^DIR G:$D(DIRUT)!($D(DTOUT)) EN21 I +Y'=1 Q
S RMPRFYDT=(RMPRFY-1700)_1001
EN25 K IOP,ZTIO,%ZIS S %ZIS="MQ",%ZIS("B")="" D ^%ZIS G:POP END1
;I IOST["C-" W !,$C(7),"YOU MAY NOT SELECT YOUR TERMINAL" G EN4
I $D(IO("Q")) D
.S ZTRTN="EN26^RMPRCDP"
.S ZTDESC="PURGE ALL ORDERS IN FILE 664 FOR A STATION/DIVISION THAT ARE SAME/PRIOR TO CURRENT IFCAP PURGE YEAR"
.S ZTSAVE("RMPR*")=""
I $D(IO("Q")) K IO("Q") D ^%ZTLOAD W !,$S($D(ZTSK):"<REQUEST QUEUED!>",1:"<REQUEST NOT QUEUED!>") G END1
EN26 S (I,RMPRIEN,RMPRTOTD)=0
D NOW^%DTC S Y=% X ^DD("DD")
U IO W !!,"Purge Prosthetic Purchasing Transactions For: ",RMPRFY," On ",Y,!!
F S RMPRIEN=$O(^RMPR(664,RMPRIEN)) Q:RMPRIEN'>0 D
. S RMPRDEL=0,RMPRODT=$P(^RMPR(664,RMPRIEN,0),U),RMPROSIT=$P(^RMPR(664,RMPRIEN,0),U,14),RMPRORD=$P($G(^RMPR(664,RMPRIEN,4)),U,5),RMPROIEN=$P($G(^RMPR(664,RMPRIEN,4)),U,6)
. I RMPRODT<RMPRFYDT,(RMPROSIT=RMPR("STA")!(RMPROSIT="")) D
..I RMPRORD=""!(RMPROIEN="") S RMPRDEL=1
.. I RMPRDEL=0,'$D(^PRC(442,"B",RMPROSIT_"-"_RMPRORD,RMPROIEN)) S RMPRDEL=1
.. I RMPRDEL=1 D
... S DA=RMPRIEN,DIC="^RMPR(664," D EN^DIQ
... S DIK=DIC D ^DIK K DIK,DIC
... W !,"Deleted...",! S RMPRTOTD=RMPRTOTD+1
S $P(RMPRL,"-",IOM)="" W !!,RMPRL,!!,?5,"TOTAL PROSTHETICS PURCHASING TRANSACTIONS DELETED: ",RMPRTOTD,!
END1 K I,RD,RMPRIEN,RMPRDT,RMPR,DIR,DIK,DA,DIC,X,X1,X2,RMPRL,RMPRTOTD,ZTSK,RMPRFYT,RMPRDEL,RMPRFY,RMPRFYDT,RMPRODT,RMPROSIT,RMPRORD,RMPROIEN,DIRUT,DTOUT D ^%ZISC
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRCDP 6257 printed Dec 13, 2024@02:34:01 Page 2
RMPRCDP ;PHX/DWL,HNB-PURGE FILE 664 ;8/29/1994
+1 ;;3.0;PROSTHETICS;**3,173**;Feb 09, 1996;Build 29
+2 ;
+3 ;RMPR*3.0*173 Added purge for file 664 to remove aged orders that are
+4 ; no longer defined in IFCAP file 442. The purge will be
+5 ; controlled to ONLY allow orders for a fiscal year greater
+6 ; than 6 years ago to be entered and should be run AFTER
+7 ; the IFCAP annual purging process and use the same fiscal
+8 ; year that purge process used.
+9 ;
EN1 ;Purge 664, Canceled Transactions
+1 DO DIV4^RMPRSIT
if $DATA(X)
QUIT
EN4 KILL IOP,ZTIO,%ZIS
SET %ZIS="MQ"
SET %ZIS("B")=""
DO ^%ZIS
if POP
GOTO END
+1 ;I IOST["C-" W !,$C(7),"YOU MAY NOT SELECT YOUR TERMINAL" G EN4
+2 IF $DATA(IO("Q"))
Begin DoDot:1
+3 SET ZTRTN="EN11^RMPRCDP"
+4 SET ZTDESC="CANCEL TRANSACTIONS IN FILE 664 FOR A STATION/DIVISION"
+5 FOR RD="I","RMPRIEN","RMPRDT","RMPRSITE","RMPR("
SET ZTSAVE(RD)=""
End DoDot:1
+6 IF $DATA(IO("Q"))
KILL IO("Q")
DO ^%ZTLOAD
WRITE !,$SELECT($DATA(ZTSK):"<REQUEST QUEUED!>",1:"<REQUEST NOT QUEUED!>")
GOTO END
EN11 SET (I,RMPRIEN)=0
SET RMPRDT=$PIECE(^RMPR(669.9,RMPRSITE,0),U,10)
if RMPRDT'>89
GOTO END
+1 SET X1=DT
SET X2=-RMPRDT
DO C^%DTC
SET RMPRDT=X
DO NOW^%DTC
SET Y=%
XECUTE ^DD("DD")
+2 USE IO
WRITE !!,"Purge Canceled Prosthetic Purchasing Transactions For: ",!,$PIECE(^RMPR(669.9,RMPRSITE,0),U,1)," On ",Y,!!
+3 FOR
SET RMPRIEN=$ORDER(^RMPR(664,RMPRIEN))
if RMPRIEN'>0
QUIT
Begin DoDot:1
+4 ;quit if it is a purchase card transaction, non get purged
+5 if $DATA(^RMPR(664,RMPRIEN,4))
QUIT
+6 IF ($PIECE(^RMPR(664,RMPRIEN,0),U,5))&($PIECE(^(0),U,5)<RMPRDT&($PIECE(^(0),U,14)=RMPR("STA")))
Begin DoDot:2
+7 SET DA=RMPRIEN
SET DIC="^RMPR(664,"
DO EN^DIQ
+8 SET DA=RMPRIEN
SET DIK=DIC
DO ^DIK
WRITE "Deleted...",!
SET RDEL=1
End DoDot:2
End DoDot:1
+9 IF '$DATA(RDEL)
SET $PIECE(L,"-",IOM)=""
WRITE !,L,!,?5,"NO CANCELED PURCHASING TRANSACTIONS DELETED"
+10 GOTO END
EN ;PURGE 664 FILE OF ENTRIES CLOSED OUT FOR A STATION/DIVISION
+1 DO DIV4^RMPRSIT
if $DATA(X)
QUIT
EN5 KILL IOP,%ZIS,ZTIO
SET %ZIS="MQ"
SET %ZIS("B")=""
DO ^%ZIS
if POP
GOTO END
+1 ;I IOST["C-" W !,$C(7),"YOU MAY NOT SELECT YOUR OWN TERMINAL" G EN5
+2 IF $DATA(IO("Q"))
SET ZTRTN="EN2^RMPRCDP"
SET ZTDESC="PURGE 664 OF CLOSED OUT ENTRIES"
FOR RD="I","RMPRIEN","RMPRDT","RMPRSITE","RMPR("
SET ZTSAVE(RD)=""
+3 IF $DATA(IO("Q"))
KILL IO("Q")
DO ^%ZTLOAD
WRITE !,$SELECT($DATA(ZTSK):"<REQUEST QUEUED!>",1:"<REQUEST NOT QUEUED>")
GOTO END
EN2 SET (I,RMPRIEN)=0
SET RMPRDT=$PIECE(^RMPR(669.9,RMPRSITE,0),U,9)
if RMPRDT'>89
GOTO END
+1 SET X1=DT
SET X2=-RMPRDT
DO C^%DTC
SET RMPRDT=X
DO NOW^%DTC
SET Y=%
XECUTE ^DD("DD")
+2 USE IO
WRITE !!,"Purge Closed Prosthetic Purchasing Transactions For",!,$PIECE(^RMPR(669.9,RMPRSITE,0),U,1)," On ",Y,!!
+3 FOR
SET RMPRIEN=$ORDER(^RMPR(664,RMPRIEN))
if RMPRIEN'>0
QUIT
Begin DoDot:1
+4 ;quit if it is a purchase card transaction, non get purged
+5 if $DATA(^RMPR(664,RMPRIEN,4))
QUIT
+6 IF ($PIECE(^RMPR(664,RMPRIEN,0),U,8))&($PIECE(^(0),U,8)<RMPRDT&($PIECE(^(0),U,14)=RMPR("STA")))
Begin DoDot:2
+7 SET DA=RMPRIEN
SET DIC="^RMPR(664,"
DO EN^DIQ
+8 SET DA=RMPRIEN
SET DIK=DIC
DO ^DIK
WRITE "Deleted",!
SET RDEL=1
End DoDot:2
End DoDot:1
+9 IF '$DATA(RDEL)
SET $PIECE(L,"-",IOM)=""
WRITE !,L,!,?5,"NO CLOSED PURCHASING TRANSACTIONS DELETED",!
END KILL I,RD,RMPRIEN,RMPRDT,RMPR,DIR,DIK,DA,DIC,X1,X2,L,RDEL,ZTSK
DO ^%ZISC
+1 QUIT
EN3 ;Purge Non-Obligated Transactions
+1 ;IF C.P. and Reference Number missing, transaction not obligated to IFCAP
+2 DO DIV4^RMPRSIT
if $DATA(X)
QUIT
+3 KILL IOP,%ZIS,ZTIO
SET %ZIS="MQ"
SET %ZIS("B")=""
DO ^%ZIS
if POP
GOTO END
+4 IF $DATA(IO("Q"))
SET ZTRTN="EN3A^RMPRCDP"
SET ZTDESC="Purge Non-Obligated Transactions For Station # "_RMPR("STA")
SET ZTSAVE("RMPR*")=""
+5 IF $DATA(IO("Q"))
KILL IO("Q")
DO ^%ZTLOAD
WRITE !,$SELECT($DATA(ZTSK):"<REQUEST QUEUED!>",1:"<REQUEST NOT QUEUED>")
+6 GOTO END
EN3A ;
+1 SET RMPRA=0
FOR
SET RMPRA=$ORDER(^RMPR(664,RMPRA))
if RMPRA'>0
QUIT
Begin DoDot:1
+2 ;quit if this is a purchase card transaction, non should be purged
+3 if $DATA(^RMPR(664,RMPRA,4))
QUIT
+4 IF '$PIECE(^RMPR(664,RMPRA,0),U,6)&('$PIECE(^(0),U,7))&($PIECE(^(0),U,14)=RMPR("STA"))
Begin DoDot:2
+5 SET DA=RMPRA
SET DIC="^RMPR(664,"
DO EN^DIQ
+6 SET DA=RMPRA
SET DIK=DIC
DO ^DIK
WRITE "Deleted...",!
SET RDEL=1
End DoDot:2
End DoDot:1
+7 IF $GET(RDEL)'=1
WRITE !!,"No Non-Obligated Transactions deleted."
+8 KILL RMPRA,DIK,DA,I,DIC
DO ^%ZISC
+9 QUIT
+10 ;
+11 ;RMPR*3.0*173 File 664 Aged Order Purge
EN20 ;Purge 664, Aged order transactions based on file 442 purge history for closed/cancelled orders
+1 SET DIR("?")="Enter 'YES' or 'Y' to continue processing."
+2 SET DIR(0)="Y"
SET DIR("A")="Purge MUST follow the IFCAP annual purge process, OK to continue? "
SET DIR("B")="NO"
DO ^DIR
IF $DATA(DIRUT)!($DATA(DTOUT))!(+Y'=1)
QUIT
+3 DO DIV4^RMPRSIT
if $DATA(X)
GOTO END1
EN21 ;Select Fiscal Year
+1 if '$DATA(DT)
DO DT^DICRW
+2 SET RMPRFYT=1700+$EXTRACT(DT,1,3)+$EXTRACT(DT,4)
SET RMPRFY=RMPRFYT
+3 SET DIR("?")="Fiscal year. Should be same year (or prior) as used in IFCAP annual purge."
+4 SET DIR("A")="Enter FISCAL YEAR (YYYY) to purge"
SET DIR(0)="N^1990:2100"
SET DIR("B")=RMPRFYT-8
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO END1
SET RMPRFY=Y
+5 IF RMPRFY>(RMPRFYT-8)
WRITE " You CANNOT purge Prosthetics order data for a fiscal year LESS than 8 years ago!!"
GOTO EN21
+6 SET DIR("?")="Enter 'YES' or 'Y' to continue processing."
+7 SET DIR(0)="Y"
SET DIR("A")="Purging closed PROS orders prior to FY end 09/30/"_RMPRFY_", OK? "
SET DIR("B")="NO"
DO ^DIR
if $DATA(DIRUT)!($DATA(DTOUT))
GOTO EN21
IF +Y'=1
QUIT
+8 SET RMPRFYDT=(RMPRFY-1700)_1001
EN25 KILL IOP,ZTIO,%ZIS
SET %ZIS="MQ"
SET %ZIS("B")=""
DO ^%ZIS
if POP
GOTO END1
+1 ;I IOST["C-" W !,$C(7),"YOU MAY NOT SELECT YOUR TERMINAL" G EN4
+2 IF $DATA(IO("Q"))
Begin DoDot:1
+3 SET ZTRTN="EN26^RMPRCDP"
+4 SET ZTDESC="PURGE ALL ORDERS IN FILE 664 FOR A STATION/DIVISION THAT ARE SAME/PRIOR TO CURRENT IFCAP PURGE YEAR"
+5 SET ZTSAVE("RMPR*")=""
End DoDot:1
+6 IF $DATA(IO("Q"))
KILL IO("Q")
DO ^%ZTLOAD
WRITE !,$SELECT($DATA(ZTSK):"<REQUEST QUEUED!>",1:"<REQUEST NOT QUEUED!>")
GOTO END1
EN26 SET (I,RMPRIEN,RMPRTOTD)=0
+1 DO NOW^%DTC
SET Y=%
XECUTE ^DD("DD")
+2 USE IO
WRITE !!,"Purge Prosthetic Purchasing Transactions For: ",RMPRFY," On ",Y,!!
+3 FOR
SET RMPRIEN=$ORDER(^RMPR(664,RMPRIEN))
if RMPRIEN'>0
QUIT
Begin DoDot:1
+4 SET RMPRDEL=0
SET RMPRODT=$PIECE(^RMPR(664,RMPRIEN,0),U)
SET RMPROSIT=$PIECE(^RMPR(664,RMPRIEN,0),U,14)
SET RMPRORD=$PIECE($GET(^RMPR(664,RMPRIEN,4)),U,5)
SET RMPROIEN=$PIECE($GET(^RMPR(664,RMPRIEN,4)),U,6)
+5 IF RMPRODT<RMPRFYDT
IF (RMPROSIT=RMPR("STA")!(RMPROSIT=""))
Begin DoDot:2
+6 IF RMPRORD=""!(RMPROIEN="")
SET RMPRDEL=1
+7 IF RMPRDEL=0
IF '$DATA(^PRC(442,"B",RMPROSIT_"-"_RMPRORD,RMPROIEN))
SET RMPRDEL=1
+8 IF RMPRDEL=1
Begin DoDot:3
+9 SET DA=RMPRIEN
SET DIC="^RMPR(664,"
DO EN^DIQ
+10 SET DIK=DIC
DO ^DIK
KILL DIK,DIC
+11 WRITE !,"Deleted...",!
SET RMPRTOTD=RMPRTOTD+1
End DoDot:3
End DoDot:2
End DoDot:1
+12 SET $PIECE(RMPRL,"-",IOM)=""
WRITE !!,RMPRL,!!,?5,"TOTAL PROSTHETICS PURCHASING TRANSACTIONS DELETED: ",RMPRTOTD,!
END1 KILL I,RD,RMPRIEN,RMPRDT,RMPR,DIR,DIK,DA,DIC,X,X1,X2,RMPRL,RMPRTOTD,ZTSK,RMPRFYT,RMPRDEL,RMPRFY,RMPRFYDT,RMPRODT,RMPROSIT,RMPRORD,RMPROIEN,DIRUT,DTOUT
DO ^%ZISC
+1 QUIT
