source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCB1A4.m@ 975

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

initial load of WorldVistAEHR

File size: 3.6 KB
Line 
1PRCB1A4 ;WOIFO/DWA-COPY FCP USERS TO NEW FCP ;3/8/04 2:22 PM
2 ;;5.1;IFCAP;**76**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5V ; invalid entry
6 Q
7 ;
8 ; this routine will copy users from an existing Fund Control Point
9 ; to an empty Fund Control Point.
10 ;
11EN ;
12 S PRCF("X")="AS" D ^PRCFSITE I '$G(PRC("SITE")) Q
13 S SITE=PRC("SITE")
14 ;
15 ;
16 N FCP1,FCP2,PRFL,DIC,DIR,I,X,Y,FLDS,BY,TO,FR,IOP,L,B,PRCNT,PRCLAST
17 ;
18FROM ; prompt for FCP to copy FROM
19 S DIR(0)="NA^1:9999^I 'X!('$D(^PRC(420,SITE,1,Y))) K X",DIR("A")="Select FCP to copy FROM: ",DIR("?")="Answer must be a valid 1-4 digit Fund Control Point number." D ^DIR K DIR
20 I Y="^" G QUIT
21 I 'Y D FROM
22 S FCP1=Y K X,Y
23 ;
24DISPLAY ; display the user profiles for the chosen FCP
25 W !!
26 S L=0,DIC="^PRC(420,SITE,1,FCP1,1,",FLDS=".01;L20,1;L23,2;C51,3;C68",IOP=IO,BY=".01",FR=",",TO="",DHD="Control Point Users List "_FCP1 D EN1^DIP K DIC
27 I '$D(^PRC(420,SITE,1,FCP1,1)) W !,?15,"*** NO USERS FOUND ***",!! G FROM
28 I $P($G(^PRC(420,SITE,1,FCP1,1,0)),"^",3)="" W ! G FROM
29 I '$$CONFRM(FCP1,.X)
30 I X=1 G FROM
31 I X=0 G QUIT
32 I X=2 D
33 . S X="^PRC(420,SITE,1,FCP1,1,",B=3
34 . D ICLOCK^PRC0B(X,.B)
35 . I 'B W !,"Someone else is using that FCP, please try later."
36 . Q
37 I 'B G FROM
38 ;
39GETFCP ; get the FCP to copy TO
40 S DIR(0)="NA^1:9999^K:'$D(^PRC(420,SITE,1,Y))!('X) X",DIR("A")="Select FCP to copy TO: ",DIR("?")="Answer must be a valid 1-4 digit Fund Control Point number." D ^DIR K DIR
41 I X="^" D DCLOCK^PRC0B("^PRC(420,SITE,1,FCP1,1,") G QUIT
42 S FCP2=Y K X,Y
43 I '$$CONFRM2(FCP2,.X) D DCLOCK^PRC0B("^PRC(420,SITE,1,FCP1,1,") G QUIT
44 I X=1 G GETFCP
45 I $P($G(^PRC(420,SITE,1,FCP2,1,0)),"^",3)'="" D G QUIT
46 . W !!,"I cannot complete the copy, FCP ==> "_FCP2_" is not empty."
47 ;
48 I X=2 S X="^PRC(420,SITE,1,FCP2,1,",B=3
49 D ICLOCK^PRC0B(X,.B)
50 I 'B W !,"Someone else is using that FCP, please try later." G GETFCP
51 ;
52XTRCT ;
53 S PRCNT=0,PRCLAST=0
54 S PRFL=0 F S PRFL=$O(^PRC(420,SITE,1,FCP1,1,PRFL)) Q:'PRFL D
55 . S DIC="^PRC(420,SITE,1,FCP1,1,",DIC(0)="V,Z",X=PRFL
56 . D ^DIC S PRFL(X)=Y(0,0)_"^"_Y(0)
57 . S PRCNT=$G(PRCNT)+1,PRCLAST=$P(PRFL(X),"^",2)
58 . Q
59 ;
60COPY ; copy records to new FCP, setup cross references as needed
61 S X=0 F S X=$O(PRFL(X)) Q:'X D
62 . S ^PRC(420,SITE,1,FCP2,1,X,0)=^PRC(420,SITE,1,FCP1,1,X,0)
63 . S:$D(^PRC(420,SITE,1,FCP1,1,X,2)) ^PRC(420,SITE,1,FCP2,1,X,2)=^PRC(420,SITE,1,FCP1,1,X,2)
64 . I $P(PRFL(X),"^",3)]"" D
65 . . S ^PRC(420,"A",X,SITE,FCP2,$P(PRFL(X),"^",3))=""
66 . S ^PRC(420,"C",X,SITE,FCP2,X)=""
67 S $P(^PRC(420,SITE,1,FCP2,1,0),"^",2)="420.02IPA" ; define subfile
68 S $P(^PRC(420,SITE,1,FCP2,1,0),"^",4)=PRCNT ; keep users counted
69 S $P(^PRC(420,SITE,1,FCP2,1,0),"^",3)=PRCLAST ; last user added
70 W !!,"The FCP copy has been completed.",!
71 Q
72 ;
73UNLCK ; unlock
74 ;Q:'$G(FCP1)
75 D DCLOCK^PRC0B("^PRC(420,SITE,1,FCP1,1,")
76 D DCLOCK^PRC0B("^PRC(420,SITE,1,FCP2,1,")
77 ;
78QUIT ;
79 K DLAYGO,DIC,X,Y,FCP1,FCP2,PRC,DIR,PRFL,PRCF,PRCNT,PRCLAST,SITE
80 Q
81 ;
82CONFRM(FCP,X) ; ask if these are the records that user wishes to copy
83 W !!,?10,"PLEASE NOTE: THE FCP 'TO COPY TO' MUST BE EMPTY."
84 W !!,"If you choose to use this option you must copy all users and their profiles."
85 W !!,"Are these the correct users to copy?"
86 S DIR(0)="Y",DIR("B")="YES",DIR("?")="Answer YES if these are the correct users to copy, NO to choose a different FCP, or ""^"" to QUIT."
87 D ^DIR K DIR
88 I 'Y S X=1
89 I Y="^" S X=0
90 I Y S X=2
91 Q X
92 ;
93CONFRM2(FCP,X) ; confirm that the TO FCP is correct
94 W !!,"Copy users from "_FCP1_" to "_FCP_"?"
95 S DIR(0)="Y",DIR("B")="YES",DIR("?")="Answer YES to copy, NO to choose a different FCP, or ""^"" to QUIT."
96 D ^DIR K DIR
97 I 'Y S X=1
98 I Y="^" S X=0
99 I Y S X=2
100 Q X
Note: See TracBrowser for help on using the repository browser.