- 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 Feb 19, 2025@00:00:29 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
