| 1 | RMPRPOST ;PHX/JLT,HNB-POST INIT / DELETE LOAN PROGRAM ;5/23/95
|
|---|
| 2 | ;;3.0;PROSTHETICS;;Feb 09, 1996
|
|---|
| 3 | ;POST INIT
|
|---|
| 4 | ;quit if prosthetics not in package file
|
|---|
| 5 | I '$D(^DIC(9.4,"B","PROSTHETICS")) W !,$C(7),?5,"PROSTHETICS PACKAGE NOT LOADED ON THIS SYSTEM!" Q
|
|---|
| 6 | G POST
|
|---|
| 7 | Q
|
|---|
| 8 | LOAN ;check if loan program has already been deleted
|
|---|
| 9 | I '$D(^RMPR(660.1)) W !,$C(7),?5,"LOAN PROGRAM HAS ALREADY BEEN DELETED!" Q
|
|---|
| 10 | ;ask to delete loan program, some sites may be using
|
|---|
| 11 | S DIR(0)="Y",DIR("A")="Ready to Delete the Loan Program"
|
|---|
| 12 | S DIR("B")="YES" D ^DIR Q:Y'=1
|
|---|
| 13 | W !!,?5,"Searching for and deleting Loan Cards" K RMPRFIND
|
|---|
| 14 | 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
|
|---|
| 15 | I '$D(RMPRFIND) W !!,?5," ** No Loan Cards have been entered on your system"
|
|---|
| 16 | I $D(RMPRFIND) W !!,?5," ** All Loan Card Entries have been Deleted"
|
|---|
| 17 | 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
|
|---|
| 18 | W !!,?5,"Removing Loan Card Fields from the 660.1 Data Dictionary"
|
|---|
| 19 | F DA=.05,6,7,8,9,12,19,21,22 S DA(1)="660.1",DIK="^DD(660.1," D ^DIK
|
|---|
| 20 | S DIU=660.18,DIU(0)="S" D EN^DIU2
|
|---|
| 21 | W !!,?5,"Re-indexing File 660.1"
|
|---|
| 22 | K DA,DIK S DIK="^RMPR(660.1," D IXALL^DIK
|
|---|
| 23 | W !!,?5,"Deleting File 660.2"
|
|---|
| 24 | S DIU="^RMPR(660.2,",DIU(0)="DS" D EN^DIU2 K DIU
|
|---|
| 25 | W !!,?5,"Deleting Loan Card Options"
|
|---|
| 26 | OPT ;delete options
|
|---|
| 27 | 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
|
|---|
| 28 | .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
|
|---|
| 29 | ;end of deleting loan progarm
|
|---|
| 30 | ;
|
|---|
| 31 | Q
|
|---|
| 32 | ;
|
|---|
| 33 | POST ;POST INIT FOR VERSION 3.0
|
|---|
| 34 | AR ;DELETE OLD LAB AMIS CODES FROM FILE 660
|
|---|
| 35 | W !!,"Deleting Expired Fields From File 660 "
|
|---|
| 36 | F DA=41,65,66,67 S DIK="^DD(660,",DA(1)=660 D ^DIK W "."
|
|---|
| 37 | ;
|
|---|
| 38 | PT ;DELETE EXPIRED FIELDS FROM FILE PROSTHETICS PATIENT FILE 665
|
|---|
| 39 | W !!,"Deleting Expired Fields From File 665 "
|
|---|
| 40 | 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 "."
|
|---|
| 41 | S DIU=665.011,DIU(0)="S" D EN^DIU2 K DA,DIU S DIU=665.029,DIU(0)="S" D EN^DIU2 W "."
|
|---|
| 42 | S DIU=665.5,DIU(0)="DST" D EN^DIU2 W "."
|
|---|
| 43 | S DIU=660.95,DIU(0)="DST" D EN^DIU2 W "."
|
|---|
| 44 | S DA=3,DA(1)=664.2,DIK="^DD(664.2," D ^DIK W "."
|
|---|
| 45 | S DIU=664.23,DIU(0)="S" D EN^DIU2 W "."
|
|---|
| 46 | W !!,"Setting New Cross References ..."
|
|---|
| 47 | S DIK="^RMPR(665.4,",DIK(1)="2^AH1" D ENALL^DIK
|
|---|
| 48 | S DIK="^RMPR(665.4,",DIK(1)="11^AH2" D ENALL^DIK
|
|---|
| 49 | W !!,"Removing Obsolete Keys ..."
|
|---|
| 50 | S RMPRKEY=0
|
|---|
| 51 | F RMPRKEYS="RMPR TEST","RMPRCC","RMPRSP","RMPR PRINT","RMPRCANCEL" D
|
|---|
| 52 | .S RMPRKEY=$O(^DIC(19.1,"B",RMPRKEYS,RMPRKEY))
|
|---|
| 53 | .D:RMPRKEY DEL^XPDKEY(RMPRKEY)
|
|---|
| 54 | .S RMPRKEY=0
|
|---|
| 55 | K RMPRKEY,RMPRKEYS
|
|---|
| 56 | ;MOVE THE SITE PARAMETER FILE OUT OF DIC
|
|---|
| 57 | I '$D(^RMPR(669.9)) D
|
|---|
| 58 | .W !!,"Moving the Site Parameter File Data"
|
|---|
| 59 | .;move the data first
|
|---|
| 60 | .S ^RMPR(669.9,0)=^DIC(669.9,0) W "."
|
|---|
| 61 | .;Loop to get multi-divisional sites
|
|---|
| 62 | .S RMPRB=0
|
|---|
| 63 | .F S RMPRB=$O(^DIC(669.9,RMPRB)) Q:RMPRB'>0 D
|
|---|
| 64 | ..M ^RMPR(669.9,RMPRB)=^DIC(669.9,RMPRB) W "."
|
|---|
| 65 | .;at one time DINUM was set to 1, this is no longer the case
|
|---|
| 66 | .;M ^RMPR(669.9,1)=^DIC(669.9,1) W "."
|
|---|
| 67 | .M ^RMPR(669.9,"AC")=^DIC(669.9,"AC") W "."
|
|---|
| 68 | .M ^RMPR(669.9,"B")=^DIC(669.9,"B") W "."
|
|---|
| 69 | .M ^RMPR(669.9,"C")=^DIC(669.9,"C") W "."
|
|---|
| 70 | .W !!,"Deleting the OLD Site Parameter File "
|
|---|
| 71 | .S DIU="^DIC(669.9,",DIU(0)="DT" D EN^DIU2 W "..."
|
|---|
| 72 | ;Close-out purchasing purge changed from 90 to 120 as min.
|
|---|
| 73 | ;Cancelation Purchasing Purge changed from 90 to 120 as min.
|
|---|
| 74 | ;Need to check values and reset in file 669.9
|
|---|
| 75 | W !!,"Checking Purge Parameters ...",!
|
|---|
| 76 | S RMPRB=0
|
|---|
| 77 | F S RMPRB=$O(^RMPR(669.9,RMPRB)) Q:RMPRB'>0 D
|
|---|
| 78 | .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),"."
|
|---|
| 79 | .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),"."
|
|---|
| 80 | ;
|
|---|
| 81 | ;If sites choose to they can run RMPRFRM, to reset the remarks in
|
|---|
| 82 | ;file 660. Purchasing, Line Item Remarks add to Close-out remarks.
|
|---|
| 83 | ;caution to sites, this routine will not take into consideration
|
|---|
| 84 | ;the remarks that were added via ED2 option, after the transaction
|
|---|
| 85 | ;closed. This will have to be a local decesion.
|
|---|
| 86 | ;RMPRFRM is not exported, must contact the developers for a copy.
|
|---|
| 87 | I $D(^DD(669.9)) W !!,?20,"THANK YOU, ALL DONE!"
|
|---|
| 88 | E W !!!,"Installation NOT COMPLETE, D ^RMPTINIT to Finish This Installation!"
|
|---|
| 89 | EXIT Q
|
|---|
