RMPRPOST ;PHX/JLT,HNB-POST INIT / DELETE LOAN PROGRAM ;5/23/95
;;3.0;PROSTHETICS;;Feb 09, 1996
;POST INIT
;quit if prosthetics not in package file
I '$D(^DIC(9.4,"B","PROSTHETICS")) W !,$C(7),?5,"PROSTHETICS PACKAGE NOT LOADED ON THIS SYSTEM!" Q
G POST
Q
LOAN ;check if loan program has already been deleted
I '$D(^RMPR(660.1)) W !,$C(7),?5,"LOAN PROGRAM HAS ALREADY BEEN DELETED!" Q
;ask to delete loan program, some sites may be using
S DIR(0)="Y",DIR("A")="Ready to Delete the Loan Program"
S DIR("B")="YES" D ^DIR Q:Y'=1
W !!,?5,"Searching for and deleting Loan Cards" K RMPRFIND
F RMPRL=0:0 S RMPRL=$O(^RMPR(660.1,RMPRL)) Q:RMPRL'>0 I $D(^RMPR(660.1,RMPRL,0)),$P(^(0),U,9)=1 S DIK="^RMPR(660.1,",DA=RMPRL D ^DIK W "." S RMPRFIND=1
I '$D(RMPRFIND) W !!,?5," ** No Loan Cards have been entered on your system"
I $D(RMPRFIND) W !!,?5," ** All Loan Card Entries have been Deleted"
K ^RMPR(660.1,"AF"),^RMPR(660.1,"AG"),^RMPR(660.1,"AC"),^RMPR(660.1,"AD"),^RMPR(660.1,"AP"),^RMPR(660.1,"AR"),DA,DIK
W !!,?5,"Removing Loan Card Fields from the 660.1 Data Dictionary"
F DA=.05,6,7,8,9,12,19,21,22 S DA(1)="660.1",DIK="^DD(660.1," D ^DIK
S DIU=660.18,DIU(0)="S" D EN^DIU2
W !!,?5,"Re-indexing File 660.1"
K DA,DIK S DIK="^RMPR(660.1," D IXALL^DIK
W !!,?5,"Deleting File 660.2"
S DIU="^RMPR(660.2,",DIU(0)="DS" D EN^DIU2 K DIU
W !!,?5,"Deleting Loan Card Options"
OPT ;delete options
F OPT="RMPR LOAN DEL","RMPR LOAN CREATE","RMPR LOAN RET","RMPR LOAN DISP","RMPR LOAN FOLLOW-UP","RMPR LOAN PRINT ALL","RMPR LOAN EDIT","RMPR LOAN STAT","RMPR LOAN MENU" D
.F REN=0:0 S REN=$O(^DIC(19,"B",OPT,REN)) Q:REN'>0 W !!,?5,"Deleting "_OPT_" Option" S DA=REN,DIK="^DIC(19," D ^DIK K DA,DIK
;end of deleting loan progarm
;
Q
;
POST ;POST INIT FOR VERSION 3.0
AR ;DELETE OLD LAB AMIS CODES FROM FILE 660
W !!,"Deleting Expired Fields From File 660 "
F DA=41,65,66,67 S DIK="^DD(660,",DA(1)=660 D ^DIK W "."
;
PT ;DELETE EXPIRED FIELDS FROM FILE PROSTHETICS PATIENT FILE 665
W !!,"Deleting Expired Fields From File 665 "
K DA,DIK F DA=3,4,5,6,7,8,9,11,17,24,25,29 S DIK="^DD(665,",DA(1)=665 D ^DIK W "."
S DIU=665.011,DIU(0)="S" D EN^DIU2 K DA,DIU S DIU=665.029,DIU(0)="S" D EN^DIU2 W "."
S DIU=665.5,DIU(0)="DST" D EN^DIU2 W "."
S DIU=660.95,DIU(0)="DST" D EN^DIU2 W "."
S DA=3,DA(1)=664.2,DIK="^DD(664.2," D ^DIK W "."
S DIU=664.23,DIU(0)="S" D EN^DIU2 W "."
W !!,"Setting New Cross References ..."
S DIK="^RMPR(665.4,",DIK(1)="2^AH1" D ENALL^DIK
S DIK="^RMPR(665.4,",DIK(1)="11^AH2" D ENALL^DIK
W !!,"Removing Obsolete Keys ..."
S RMPRKEY=0
F RMPRKEYS="RMPR TEST","RMPRCC","RMPRSP","RMPR PRINT","RMPRCANCEL" D
.S RMPRKEY=$O(^DIC(19.1,"B",RMPRKEYS,RMPRKEY))
.D:RMPRKEY DEL^XPDKEY(RMPRKEY)
.S RMPRKEY=0
K RMPRKEY,RMPRKEYS
;MOVE THE SITE PARAMETER FILE OUT OF DIC
I '$D(^RMPR(669.9)) D
.W !!,"Moving the Site Parameter File Data"
.;move the data first
.S ^RMPR(669.9,0)=^DIC(669.9,0) W "."
.;Loop to get multi-divisional sites
.S RMPRB=0
.F S RMPRB=$O(^DIC(669.9,RMPRB)) Q:RMPRB'>0 D
..M ^RMPR(669.9,RMPRB)=^DIC(669.9,RMPRB) W "."
.;at one time DINUM was set to 1, this is no longer the case
.;M ^RMPR(669.9,1)=^DIC(669.9,1) W "."
.M ^RMPR(669.9,"AC")=^DIC(669.9,"AC") W "."
.M ^RMPR(669.9,"B")=^DIC(669.9,"B") W "."
.M ^RMPR(669.9,"C")=^DIC(669.9,"C") W "."
.W !!,"Deleting the OLD Site Parameter File "
.S DIU="^DIC(669.9,",DIU(0)="DT" D EN^DIU2 W "..."
;Close-out purchasing purge changed from 90 to 120 as min.
;Cancelation Purchasing Purge changed from 90 to 120 as min.
;Need to check values and reset in file 669.9
W !!,"Checking Purge Parameters ...",!
S RMPRB=0
F S RMPRB=$O(^RMPR(669.9,RMPRB)) Q:RMPRB'>0 D
.I $P(^RMPR(669.9,RMPRB,0),U,9)<120 S $P(^(0),U,9)=120 W !,"Close-Out Purchasing Purge set to 120 Days for ",$P(^(0),U,1),"."
.I $P(^RMPR(669.9,RMPRB,0),U,10)<120 S $P(^(0),U,10)=120 W !,"Cancellation Purchasing Purge set to 120 Days for ",$P(^(0),U,1),"."
;
;If sites choose to they can run RMPRFRM, to reset the remarks in
;file 660. Purchasing, Line Item Remarks add to Close-out remarks.
;caution to sites, this routine will not take into consideration
;the remarks that were added via ED2 option, after the transaction
;closed. This will have to be a local decesion.
;RMPRFRM is not exported, must contact the developers for a copy.
I $D(^DD(669.9)) W !!,?20,"THANK YOU, ALL DONE!"
E W !!!,"Installation NOT COMPLETE, D ^RMPTINIT to Finish This Installation!"
EXIT Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPOST 4552 printed Sep 23, 2025@20:13:33 Page 2
RMPRPOST ;PHX/JLT,HNB-POST INIT / DELETE LOAN PROGRAM ;5/23/95
+1 ;;3.0;PROSTHETICS;;Feb 09, 1996
+2 ;POST INIT
+3 ;quit if prosthetics not in package file
+4 IF '$DATA(^DIC(9.4,"B","PROSTHETICS"))
WRITE !,$CHAR(7),?5,"PROSTHETICS PACKAGE NOT LOADED ON THIS SYSTEM!"
QUIT
+5 GOTO POST
+6 QUIT
LOAN ;check if loan program has already been deleted
+1 IF '$DATA(^RMPR(660.1))
WRITE !,$CHAR(7),?5,"LOAN PROGRAM HAS ALREADY BEEN DELETED!"
QUIT
+2 ;ask to delete loan program, some sites may be using
+3 SET DIR(0)="Y"
SET DIR("A")="Ready to Delete the Loan Program"
+4 SET DIR("B")="YES"
DO ^DIR
if Y'=1
QUIT
+5 WRITE !!,?5,"Searching for and deleting Loan Cards"
KILL RMPRFIND
+6 FOR RMPRL=0:0
SET RMPRL=$ORDER(^RMPR(660.1,RMPRL))
if RMPRL'>0
QUIT
IF $DATA(^RMPR(660.1,RMPRL,0))
IF $PIECE(^(0),U,9)=1
SET DIK="^RMPR(660.1,"
SET DA=RMPRL
DO ^DIK
WRITE "."
SET RMPRFIND=1
+7 IF '$DATA(RMPRFIND)
WRITE !!,?5," ** No Loan Cards have been entered on your system"
+8 IF $DATA(RMPRFIND)
WRITE !!,?5," ** All Loan Card Entries have been Deleted"
+9 KILL ^RMPR(660.1,"AF"),^RMPR(660.1,"AG"),^RMPR(660.1,"AC"),^RMPR(660.1,"AD"),^RMPR(660.1,"AP"),^RMPR(660.1,"AR"),DA,DIK
+10 WRITE !!,?5,"Removing Loan Card Fields from the 660.1 Data Dictionary"
+11 FOR DA=.05,6,7,8,9,12,19,21,22
SET DA(1)="660.1"
SET DIK="^DD(660.1,"
DO ^DIK
+12 SET DIU=660.18
SET DIU(0)="S"
DO EN^DIU2
+13 WRITE !!,?5,"Re-indexing File 660.1"
+14 KILL DA,DIK
SET DIK="^RMPR(660.1,"
DO IXALL^DIK
+15 WRITE !!,?5,"Deleting File 660.2"
+16 SET DIU="^RMPR(660.2,"
SET DIU(0)="DS"
DO EN^DIU2
KILL DIU
+17 WRITE !!,?5,"Deleting Loan Card Options"
OPT ;delete options
+1 FOR OPT="RMPR LOAN DEL","RMPR LOAN CREATE","RMPR LOAN RET","RMPR LOAN DISP","RMPR LOAN FOLLOW-UP","RMPR LOAN PRINT ALL","RMPR LOAN EDIT","RMPR LOAN STAT","RMPR LOAN MENU"
Begin DoDot:1
+2 FOR REN=0:0
SET REN=$ORDER(^DIC(19,"B",OPT,REN))
if REN'>0
QUIT
WRITE !!,?5,"Deleting "_OPT_" Option"
SET DA=REN
SET DIK="^DIC(19,"
DO ^DIK
KILL DA,DIK
End DoDot:1
+3 ;end of deleting loan progarm
+4 ;
+5 QUIT
+6 ;
POST ;POST INIT FOR VERSION 3.0
AR ;DELETE OLD LAB AMIS CODES FROM FILE 660
+1 WRITE !!,"Deleting Expired Fields From File 660 "
+2 FOR DA=41,65,66,67
SET DIK="^DD(660,"
SET DA(1)=660
DO ^DIK
WRITE "."
+3 ;
PT ;DELETE EXPIRED FIELDS FROM FILE PROSTHETICS PATIENT FILE 665
+1 WRITE !!,"Deleting Expired Fields From File 665 "
+2 KILL DA,DIK
FOR DA=3,4,5,6,7,8,9,11,17,24,25,29
SET DIK="^DD(665,"
SET DA(1)=665
DO ^DIK
WRITE "."
+3 SET DIU=665.011
SET DIU(0)="S"
DO EN^DIU2
KILL DA,DIU
SET DIU=665.029
SET DIU(0)="S"
DO EN^DIU2
WRITE "."
+4 SET DIU=665.5
SET DIU(0)="DST"
DO EN^DIU2
WRITE "."
+5 SET DIU=660.95
SET DIU(0)="DST"
DO EN^DIU2
WRITE "."
+6 SET DA=3
SET DA(1)=664.2
SET DIK="^DD(664.2,"
DO ^DIK
WRITE "."
+7 SET DIU=664.23
SET DIU(0)="S"
DO EN^DIU2
WRITE "."
+8 WRITE !!,"Setting New Cross References ..."
+9 SET DIK="^RMPR(665.4,"
SET DIK(1)="2^AH1"
DO ENALL^DIK
+10 SET DIK="^RMPR(665.4,"
SET DIK(1)="11^AH2"
DO ENALL^DIK
+11 WRITE !!,"Removing Obsolete Keys ..."
+12 SET RMPRKEY=0
+13 FOR RMPRKEYS="RMPR TEST","RMPRCC","RMPRSP","RMPR PRINT","RMPRCANCEL"
Begin DoDot:1
+14 SET RMPRKEY=$ORDER(^DIC(19.1,"B",RMPRKEYS,RMPRKEY))
+15 if RMPRKEY
DO DEL^XPDKEY(RMPRKEY)
+16 SET RMPRKEY=0
End DoDot:1
+17 KILL RMPRKEY,RMPRKEYS
+18 ;MOVE THE SITE PARAMETER FILE OUT OF DIC
+19 IF '$DATA(^RMPR(669.9))
Begin DoDot:1
+20 WRITE !!,"Moving the Site Parameter File Data"
+21 ;move the data first
+22 SET ^RMPR(669.9,0)=^DIC(669.9,0)
WRITE "."
+23 ;Loop to get multi-divisional sites
+24 SET RMPRB=0
+25 FOR
SET RMPRB=$ORDER(^DIC(669.9,RMPRB))
if RMPRB'>0
QUIT
Begin DoDot:2
+26 MERGE ^RMPR(669.9,RMPRB)=^DIC(669.9,RMPRB)
WRITE "."
End DoDot:2
+27 ;at one time DINUM was set to 1, this is no longer the case
+28 ;M ^RMPR(669.9,1)=^DIC(669.9,1) W "."
+29 MERGE ^RMPR(669.9,"AC")=^DIC(669.9,"AC")
WRITE "."
+30 MERGE ^RMPR(669.9,"B")=^DIC(669.9,"B")
WRITE "."
+31 MERGE ^RMPR(669.9,"C")=^DIC(669.9,"C")
WRITE "."
+32 WRITE !!,"Deleting the OLD Site Parameter File "
+33 SET DIU="^DIC(669.9,"
SET DIU(0)="DT"
DO EN^DIU2
WRITE "..."
End DoDot:1
+34 ;Close-out purchasing purge changed from 90 to 120 as min.
+35 ;Cancelation Purchasing Purge changed from 90 to 120 as min.
+36 ;Need to check values and reset in file 669.9
+37 WRITE !!,"Checking Purge Parameters ...",!
+38 SET RMPRB=0
+39 FOR
SET RMPRB=$ORDER(^RMPR(669.9,RMPRB))
if RMPRB'>0
QUIT
Begin DoDot:1
+40 IF $PIECE(^RMPR(669.9,RMPRB,0),U,9)<120
SET $PIECE(^(0),U,9)=120
WRITE !,"Close-Out Purchasing Purge set to 120 Days for ",$PIECE(^(0),U,1),"."
+41 IF $PIECE(^RMPR(669.9,RMPRB,0),U,10)<120
SET $PIECE(^(0),U,10)=120
WRITE !,"Cancellation Purchasing Purge set to 120 Days for ",$PIECE(^(0),U,1),"."
End DoDot:1
+42 ;
+43 ;If sites choose to they can run RMPRFRM, to reset the remarks in
+44 ;file 660. Purchasing, Line Item Remarks add to Close-out remarks.
+45 ;caution to sites, this routine will not take into consideration
+46 ;the remarks that were added via ED2 option, after the transaction
+47 ;closed. This will have to be a local decesion.
+48 ;RMPRFRM is not exported, must contact the developers for a copy.
+49 IF $DATA(^DD(669.9))
WRITE !!,?20,"THANK YOU, ALL DONE!"
+50 IF '$TEST
WRITE !!!,"Installation NOT COMPLETE, D ^RMPTINIT to Finish This Installation!"
EXIT QUIT
