source: FOIAVistA/trunk/r/INTERIM_MANAGEMENT_SUPPORT-ECT/ECTP13.m@ 1607

Last change on this file since 1607 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 1.6 KB
Line 
1ECTP13 ;B'ham ISC/PTD - Patch Routine to Update the National Service File ;11/02/93 08:00
2V ;;1.05;INTERIM MANAGEMENT SUPPORT;**13**;
3 I '$O(^ECC(730,0)) W !,"National Service File - #730 does not exist on your system.",!,"This routine is unable to update the file!" G EXIT
4 W !!,"This routine will update your National Service File - #730.",!,"The following changes will be made:"
5 W !!,"BUILDING MANAGEMENT will be changed to ENVIRONMENTAL MANAGEMENT.",!,"LABORATORY will be changed to PATHOLOGY & LABORATORY MEDICINE."
6 W !,"PERSONNEL will be changed to HUMAN RESOURCES MANAGEMENT.",!,"REHABILITATION MEDICINE will be changed to PHYSICAL MEDICINE & REHABILITATION."
7 S DIR(0)="Y",DIR("A")="Do you wish to continue?",DIR("B")="NO" D ^DIR I Y'=1 W !!,"No change has been made to File 730!",! G EXIT
8 L +^ECC(730) W ! F JJ=1:1 S ECTSRV=$P($T(TEXT+JJ),";;",2) Q:ECTSRV="" D LOOP
9 L -^ECC(730) K ^ECC(730,"B") S DIK="^ECC(730,",DIK(1)=".01^B" D ENALL^DIK
10EXIT K DA,DIC,DIK,DIR,DTOUT,DUOUT,DIRUT,DIROUT,ECTDA,ECTNEW,ECTOLD,ECTSRV,JJ,X,Y
11 Q
12 ;
13LOOP ;Make change to individual file entry.
14 S ECTDA=$P(ECTSRV,"^"),ECTOLD=$P(ECTSRV,"^",2),ECTNEW=$P(ECTSRV,"^",3)
15 I $D(^ECC(730,ECTDA,0)),$P(^(0),"^")=ECTNEW Q ;Entry previously converted.
16 S $P(^ECC(730,ECTDA,0),"^")=ECTNEW W !,ECTOLD," has been changed to ",ECTNEW,"."
17 Q
18 ;
19TEXT ;Services to be updated: Internal DA#^Old Service Name^New Service Name
20 ;;6^BUILDING MANAGEMENT^ENVIRONMENTAL MANAGEMENT
21 ;;20^LABORATORY^PATHOLOGY & LABORATORY MEDICINE
22 ;;29^PERSONNEL^HUMAN RESOURCES MANAGEMENT
23 ;;39^REHABILITATION MEDICINE^PHYSICAL MEDICINE & REHABILITATION
Note: See TracBrowser for help on using the repository browser.