- 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 Mar 13, 2025@21:05:02 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
