PRCB1A4 ;WOIFO/DWA-COPY FCP USERS TO NEW FCP ;3/8/04 2:22 PM
;;5.1;IFCAP;**76,201**;Oct 20, 2000;Build 1
;Per VA Directive 6402, this routine should not be modified.
;
V ; invalid entry
Q
;
; this routine will copy users from an existing Fund Control Point
; to an empty Fund Control Point.
;
EN ;
S PRCF("X")="AS" D ^PRCFSITE I '$G(PRC("SITE")) Q
S SITE=PRC("SITE")
;
;
N FCP1,FCP2,PRFL,DIC,DIR,I,X,Y,FLDS,BY,TO,FR,IOP,L,B,PRCNT,PRCLAST
;
FROM ; prompt for FCP to copy FROM
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
I $G(DIRUT) G QUIT
I 'Y G FROM
S FCP1=Y K X,Y
;
DISPLAY ; display the user profiles for the chosen FCP
W !!
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
I '$D(^PRC(420,SITE,1,FCP1,1)) W !,?15,"*** NO USERS FOUND ***",!! G FROM
I $P($G(^PRC(420,SITE,1,FCP1,1,0)),"^",3)="" W ! G FROM
I '$$CONFRM(FCP1,.X)
I X=1 G FROM
I X=0 G QUIT
I X=2 D
. S X="^PRC(420,SITE,1,FCP1,1,",B=3
. D ICLOCK^PRC0B(X,.B)
. I 'B W !,"Someone else is using that FCP, please try later."
. Q
I 'B G FROM
;
GETFCP ; get the FCP to copy TO
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
I X="^" D DCLOCK^PRC0B("^PRC(420,SITE,1,FCP1,1,") G QUIT
S FCP2=Y K X,Y
I '$$CONFRM2(FCP2,.X) D DCLOCK^PRC0B("^PRC(420,SITE,1,FCP1,1,") G QUIT
I X=1 G GETFCP
I $P($G(^PRC(420,SITE,1,FCP2,1,0)),"^",3)'="" D G QUIT
. W !!,"I cannot complete the copy, FCP ==> "_FCP2_" is not empty."
;
I X=2 S X="^PRC(420,SITE,1,FCP2,1,",B=3
D ICLOCK^PRC0B(X,.B)
I 'B W !,"Someone else is using that FCP, please try later." G GETFCP
;
XTRCT ;
S PRCNT=0,PRCLAST=0
S PRFL=0 F S PRFL=$O(^PRC(420,SITE,1,FCP1,1,PRFL)) Q:'PRFL D
. S DIC="^PRC(420,SITE,1,FCP1,1,",DIC(0)="V,Z",X=PRFL
. D ^DIC S PRFL(X)=Y(0,0)_"^"_Y(0)
. S PRCNT=$G(PRCNT)+1,PRCLAST=$P(PRFL(X),"^",2)
. Q
;
COPY ; copy records to new FCP, setup cross references as needed
S X=0 F S X=$O(PRFL(X)) Q:'X D
. S ^PRC(420,SITE,1,FCP2,1,X,0)=^PRC(420,SITE,1,FCP1,1,X,0)
. 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)
. I $P(PRFL(X),"^",3)]"" D
. . S ^PRC(420,"A",X,SITE,FCP2,$P(PRFL(X),"^",3))=""
. S ^PRC(420,"C",X,SITE,FCP2,X)=""
S $P(^PRC(420,SITE,1,FCP2,1,0),"^",2)="420.02IPA" ; define subfile
S $P(^PRC(420,SITE,1,FCP2,1,0),"^",4)=PRCNT ; keep users counted
S $P(^PRC(420,SITE,1,FCP2,1,0),"^",3)=PRCLAST ; last user added
W !!,"The FCP copy has been completed.",!
Q
;
UNLCK ; unlock
;Q:'$G(FCP1)
D DCLOCK^PRC0B("^PRC(420,SITE,1,FCP1,1,")
D DCLOCK^PRC0B("^PRC(420,SITE,1,FCP2,1,")
;
QUIT ;
K DLAYGO,DIC,X,Y,FCP1,FCP2,PRC,DIR,PRFL,PRCF,PRCNT,PRCLAST,SITE
Q
;
CONFRM(FCP,X) ; ask if these are the records that user wishes to copy
W !!,?10,"PLEASE NOTE: THE FCP 'TO COPY TO' MUST BE EMPTY."
W !!,"If you choose to use this option you must copy all users and their profiles."
W !!,"Are these the correct users to copy?"
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."
D ^DIR K DIR
I 'Y S X=1
I Y="^" S X=0
I Y S X=2
Q X
;
CONFRM2(FCP,X) ; confirm that the TO FCP is correct
W !!,"Copy users from "_FCP1_" to "_FCP_"?"
S DIR(0)="Y",DIR("B")="YES",DIR("?")="Answer YES to copy, NO to choose a different FCP, or ""^"" to QUIT."
D ^DIR K DIR
I 'Y S X=1
I Y="^" S X=0
I Y S X=2
Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCB1A4 3783 printed Apr 09, 2024@21:02:12 Page 2
PRCB1A4 ;WOIFO/DWA-COPY FCP USERS TO NEW FCP ;3/8/04 2:22 PM
+1 ;;5.1;IFCAP;**76,201**;Oct 20, 2000;Build 1
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
V ; invalid entry
+1 QUIT
+2 ;
+3 ; this routine will copy users from an existing Fund Control Point
+4 ; to an empty Fund Control Point.
+5 ;
EN ;
+1 SET PRCF("X")="AS"
DO ^PRCFSITE
IF '$GET(PRC("SITE"))
QUIT
+2 SET SITE=PRC("SITE")
+3 ;
+4 ;
+5 NEW FCP1,FCP2,PRFL,DIC,DIR,I,X,Y,FLDS,BY,TO,FR,IOP,L,B,PRCNT,PRCLAST
+6 ;
FROM ; prompt for FCP to copy FROM
+1 SET DIR(0)="NA^1:9999^I 'X!('$D(^PRC(420,SITE,1,Y))) K X"
SET DIR("A")="Select FCP to copy FROM: "
SET DIR("?")="Answer must be a valid 1-4 digit Fund Control Point number."
DO ^DIR
KILL DIR
+2 IF $GET(DIRUT)
GOTO QUIT
+3 IF 'Y
GOTO FROM
+4 SET FCP1=Y
KILL X,Y
+5 ;
DISPLAY ; display the user profiles for the chosen FCP
+1 WRITE !!
+2 SET L=0
SET DIC="^PRC(420,SITE,1,FCP1,1,"
SET FLDS=".01;L20,1;L23,2;C51,3;C68"
SET IOP=IO
SET BY=".01"
SET FR=","
SET TO=""
SET DHD="Control Point Users List "_FCP1
DO EN1^DIP
KILL DIC
+3 IF '$DATA(^PRC(420,SITE,1,FCP1,1))
WRITE !,?15,"*** NO USERS FOUND ***",!!
GOTO FROM
+4 IF $PIECE($GET(^PRC(420,SITE,1,FCP1,1,0)),"^",3)=""
WRITE !
GOTO FROM
+5 IF '$$CONFRM(FCP1,.X)
+6 IF X=1
GOTO FROM
+7 IF X=0
GOTO QUIT
+8 IF X=2
Begin DoDot:1
+9 SET X="^PRC(420,SITE,1,FCP1,1,"
SET B=3
+10 DO ICLOCK^PRC0B(X,.B)
+11 IF 'B
WRITE !,"Someone else is using that FCP, please try later."
+12 QUIT
End DoDot:1
+13 IF 'B
GOTO FROM
+14 ;
GETFCP ; get the FCP to copy TO
+1 SET DIR(0)="NA^1:9999^K:'$D(^PRC(420,SITE,1,Y))!('X) X"
SET DIR("A")="Select FCP to copy TO: "
SET DIR("?")="Answer must be a valid 1-4 digit Fund Control Point number."
DO ^DIR
KILL DIR
+2 IF X="^"
DO DCLOCK^PRC0B("^PRC(420,SITE,1,FCP1,1,")
GOTO QUIT
+3 SET FCP2=Y
KILL X,Y
+4 IF '$$CONFRM2(FCP2,.X)
DO DCLOCK^PRC0B("^PRC(420,SITE,1,FCP1,1,")
GOTO QUIT
+5 IF X=1
GOTO GETFCP
+6 IF $PIECE($GET(^PRC(420,SITE,1,FCP2,1,0)),"^",3)'=""
Begin DoDot:1
+7 WRITE !!,"I cannot complete the copy, FCP ==> "_FCP2_" is not empty."
End DoDot:1
GOTO QUIT
+8 ;
+9 IF X=2
SET X="^PRC(420,SITE,1,FCP2,1,"
SET B=3
+10 DO ICLOCK^PRC0B(X,.B)
+11 IF 'B
WRITE !,"Someone else is using that FCP, please try later."
GOTO GETFCP
+12 ;
XTRCT ;
+1 SET PRCNT=0
SET PRCLAST=0
+2 SET PRFL=0
FOR
SET PRFL=$ORDER(^PRC(420,SITE,1,FCP1,1,PRFL))
if 'PRFL
QUIT
Begin DoDot:1
+3 SET DIC="^PRC(420,SITE,1,FCP1,1,"
SET DIC(0)="V,Z"
SET X=PRFL
+4 DO ^DIC
SET PRFL(X)=Y(0,0)_"^"_Y(0)
+5 SET PRCNT=$GET(PRCNT)+1
SET PRCLAST=$PIECE(PRFL(X),"^",2)
+6 QUIT
End DoDot:1
+7 ;
COPY ; copy records to new FCP, setup cross references as needed
+1 SET X=0
FOR
SET X=$ORDER(PRFL(X))
if 'X
QUIT
Begin DoDot:1
+2 SET ^PRC(420,SITE,1,FCP2,1,X,0)=^PRC(420,SITE,1,FCP1,1,X,0)
+3 if $DATA(^PRC(420,SITE,1,FCP1,1,X,2))
SET ^PRC(420,SITE,1,FCP2,1,X,2)=^PRC(420,SITE,1,FCP1,1,X,2)
+4 IF $PIECE(PRFL(X),"^",3)]""
Begin DoDot:2
+5 SET ^PRC(420,"A",X,SITE,FCP2,$PIECE(PRFL(X),"^",3))=""
End DoDot:2
+6 SET ^PRC(420,"C",X,SITE,FCP2,X)=""
End DoDot:1
+7 ; define subfile
SET $PIECE(^PRC(420,SITE,1,FCP2,1,0),"^",2)="420.02IPA"
+8 ; keep users counted
SET $PIECE(^PRC(420,SITE,1,FCP2,1,0),"^",4)=PRCNT
+9 ; last user added
SET $PIECE(^PRC(420,SITE,1,FCP2,1,0),"^",3)=PRCLAST
+10 WRITE !!,"The FCP copy has been completed.",!
+11 QUIT
+12 ;
UNLCK ; unlock
+1 ;Q:'$G(FCP1)
+2 DO DCLOCK^PRC0B("^PRC(420,SITE,1,FCP1,1,")
+3 DO DCLOCK^PRC0B("^PRC(420,SITE,1,FCP2,1,")
+4 ;
QUIT ;
+1 KILL DLAYGO,DIC,X,Y,FCP1,FCP2,PRC,DIR,PRFL,PRCF,PRCNT,PRCLAST,SITE
+2 QUIT
+3 ;
CONFRM(FCP,X) ; ask if these are the records that user wishes to copy
+1 WRITE !!,?10,"PLEASE NOTE: THE FCP 'TO COPY TO' MUST BE EMPTY."
+2 WRITE !!,"If you choose to use this option you must copy all users and their profiles."
+3 WRITE !!,"Are these the correct users to copy?"
+4 SET DIR(0)="Y"
SET DIR("B")="YES"
SET DIR("?")="Answer YES if these are the correct users to copy, NO to choose a different FCP, or ""^"" to QUIT."
+5 DO ^DIR
KILL DIR
+6 IF 'Y
SET X=1
+7 IF Y="^"
SET X=0
+8 IF Y
SET X=2
+9 QUIT X
+10 ;
CONFRM2(FCP,X) ; confirm that the TO FCP is correct
+1 WRITE !!,"Copy users from "_FCP1_" to "_FCP_"?"
+2 SET DIR(0)="Y"
SET DIR("B")="YES"
SET DIR("?")="Answer YES to copy, NO to choose a different FCP, or ""^"" to QUIT."
+3 DO ^DIR
KILL DIR
+4 IF 'Y
SET X=1
+5 IF Y="^"
SET X=0
+6 IF Y
SET X=2
+7 QUIT X
