PRCB1A ;WISC/PLT - CONTROL POINT ENTER/EDIT;12/10/97 1600
V ;;5.1;IFCAP;**209**;Oct 20, 2000;Build 3
;Per VA Directive 6402, this routine should not be modified.
QUIT ;invalid entry
;
EN N PRC,PRCDD,PRCDR,PRCDI,PRCRI,PRCPR,PRCAED,PRCQT,PRCU S PRCU="^"
N PRCK,PRCLOCK,PRCNO,PRCST,PRCUNQ
N DA,A,B,X,Y
N PRCUQ,PRCK1,PRCK26,PRCK28,PRCK29,PRCK25,PRCK25D5,PRCK27
N PRCF,PRCFA,PRCFUND,PRCBBFY,PRCRQ
S PRCF("X")="AS" D ^PRCFSITE G:$G(PRC("SITE"))="" EXIT
I '$D(^PRC(420,PRC("SITE"))) K X S X=PRC("SITE"),Y=""="" D ADD^PRC0B1(.X,.Y,"420;^PRC(420,",X) G:Y<0 EXIT
S PRCDD=420,PRCRI(420)=PRC("SITE"),PRCFA("ALL")=""
S PRCLOCK=$$DICGL^PRC0B1(PRCDD)_PRCRI(PRCDD)_",",Y=3 D ICLOCK^PRC0B(PRCLOCK,.Y)
I 'Y D EN^DDIOL("The station/fund control point data is in use, edit station data is not allowed.") G FCP
S PRCDR="2;3;10;11;3.1"
D EDIT^PRC0B(.X,PRCDD_";;"_PRCRI(PRCDD),PRCDR)
D DCLOCK^PRC0B(PRCLOCK)
FCP F D EN^DDIOL($TR($J("",78)," ","-")) D Q:PRCQT=1
. N PRCDD,PRCAED,PRCDI,PRCLOCK1
. S PRCDD=420.01,PRCQT=""
. S X("S")="I ^(0)-9999"
. D LKUP Q:PRCQT
. S PRCLOCK1=PRCLOCK_"1,"_PRCRI(PRCDD)_",",Y=3 D ICLOCK^PRC0B(PRCLOCK1,.Y)
. I 'Y D EN^DDIOL("The station/selected fund control point data is in use, please try later!") QUIT
. S Y=$$NODE^PRC0B("^PRC(420,PRCRI(420),1,PRCRI(420.01),",0)
. S PRCST=$P(Y,PRCU,19),PRCNM=$P(Y,PRCU),PRCNO=$P(PRCNM," "),PRCNM=$P(PRCNM," ",2,999)
. D KEY1
. D REQ1^PRCB1A1
. D EDIT
. D TUSER^PRCSEB1(PRCRI(PRCDD))
. D DCLOCK^PRC0B(PRCLOCK1)
. QUIT
EXIT QUIT
;
LKUP ;lookup prcdd=420.01
S PRCDI="420;^PRC(420,;"_PRCRI(420)_";1~420.01;^PRC(420,"_PRCRI(420)_",1,"
D LOOKUP^PRC0B(.X,.Y,PRCDI,"AEOQLS","Select Fund Control Point: ")
I Y<0!(X="") S PRCQT=1 K X QUIT
K X S PRCRI(PRCDD)=+Y,PRCAED=$P(Y,"^",3)
S PRCDI="420;^PRC(420,;"_PRCRI(420)_"~420.01;^PRC(420,"_PRCRI(420)_",1,;"_PRCRI(420.01)
QUIT
;
EDIT ;edit prcdd=420.01
I PRCST=1 D Q:PRCQT
. D EDIT^PRC0B(.X,PRCDI,"20Active/Inactive Control Point","") I X=0 S PRCQT=2
. K A D PIECE^PRC0B(PRCDI,"1~20","I","A")
. S X=$G(A(PRCDD,PRCRI(PRCDD),20,"I")) K A
. S X=$S(X=1:"23////^S X=DUZ;24///NOW",1:"23///^S X=""@"";24///^S X=""@""")
. D EDIT^PRC0B(.X,PRCDI,X)
D FT^PRC0A(.X,.Y,"Control Point Name","^1:25^K:X'?1AN.ANP X",PRCNM)
I X?1"^".E S:PRCAED'=1 PRCQT=99 D:PRCAED=1 DELQ^PRCB1A1 Q:PRCQT G EDIT
I X]"",X'=PRCNM S PRCNM=X,X=".01///"_PRCNO_" "_PRCNM D EDIT^PRC0B(.X,PRCDI,X)
S C=""
G ED0^PRCB1A1
;
KEY ;initial key values/func code/bbfy
S:$D(DA(1)) PRCRI(420)=DA(1) S:$D(DA) PRCRI(420.01)=DA
KEY1 F I=1,26,27,28,29 S @("PRCK"_I_"=""""")
S PRCK25D5=""
QUIT:'PRCRI(420)!'PRCRI(420.01)
S A=$G(^PRC(420,PRCRI(420),1,PRCRI(420.01),0)),PRCK1=$P(A,"^",2)
S A=$G(^PRC(420,PRCRI(420),1,PRCRI(420.01),5))
S PRCK25D5=$P(A,"^",5),PRCK26=$P(A,"^",2),PRCK27=$P(A,"^",3)
S PRCK28=$P(A,"^",4),PRCK29=$P(A,"^",6)
F I=26,27,28,29 I @("PRCK"_I_"=""""") S @("PRCK"_I_"="" """)
S:PRCK25D5="" PRCK25D5=" "
QUIT
;
UNQCHK(PRCK1,PRCK25D5,PRCK26,PRCK27,PRCK28,PRCK29) ;check uniqueness - modified in PRC*5.1*209 to check for multiple uniqueness
S PRCUNQ="",PRCUQ=0
F S PRCUQ=$O(^PRC(420,PRCRI(420),1,"UNQ",$G(PRCK1),$G(PRCK25D5),$G(PRCK26),$G(PRCK27),$G(PRCK28),$G(PRCK29),PRCUQ)) I (PRCUQ-PRCRI(420.01)=0)!(PRCUQ="") Q
I PRCUQ="" S PRCUQ=PRCRI(420.01) D UNQMES^PRCB1A1
QUIT
;
UNQCRS ;set unique cross reference
S PRCK=","_$G(PRCK1)_","""_$G(PRCK25D5)_""","""_$G(PRCK26)_""","""_$G(PRCK27)_""","""_$G(PRCK28)_""","""_$G(PRCK29)_""","
I PRCK'[",," S @("^PRC(420,PRCRI(420),1,""UNQ"""_PRCK_"DA)=""""")
QUIT
;
UNQCRK ;kill unique cross reference
S PRCK=","_$G(PRCK1)_","""_$G(PRCK25D5)_""","""_$G(PRCK26)_""","""_$G(PRCK27)_""","""_$G(PRCK28)_""","""_$G(PRCK29)_""","
I PRCK'[",," K @("^PRC(420,PRCRI(420),1,""UNQ"""_PRCK_"DA)")
QUIT
;
DINU ;call from ^dd(420.01,.01)
S DINUM=+X
QUIT
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCB1A 3891 printed Dec 13, 2024@02:00:10 Page 2
PRCB1A ;WISC/PLT - CONTROL POINT ENTER/EDIT;12/10/97 1600
V ;;5.1;IFCAP;**209**;Oct 20, 2000;Build 3
+1 ;Per VA Directive 6402, this routine should not be modified.
+2 ;invalid entry
QUIT
+3 ;
EN NEW PRC,PRCDD,PRCDR,PRCDI,PRCRI,PRCPR,PRCAED,PRCQT,PRCU
SET PRCU="^"
+1 NEW PRCK,PRCLOCK,PRCNO,PRCST,PRCUNQ
+2 NEW DA,A,B,X,Y
+3 NEW PRCUQ,PRCK1,PRCK26,PRCK28,PRCK29,PRCK25,PRCK25D5,PRCK27
+4 NEW PRCF,PRCFA,PRCFUND,PRCBBFY,PRCRQ
+5 SET PRCF("X")="AS"
DO ^PRCFSITE
if $GET(PRC("SITE"))=""
GOTO EXIT
+6 IF '$DATA(^PRC(420,PRC("SITE")))
KILL X
SET X=PRC("SITE")
SET Y=""=""
DO ADD^PRC0B1(.X,.Y,"420;^PRC(420,",X)
if Y<0
GOTO EXIT
+7 SET PRCDD=420
SET PRCRI(420)=PRC("SITE")
SET PRCFA("ALL")=""
+8 SET PRCLOCK=$$DICGL^PRC0B1(PRCDD)_PRCRI(PRCDD)_","
SET Y=3
DO ICLOCK^PRC0B(PRCLOCK,.Y)
+9 IF 'Y
DO EN^DDIOL("The station/fund control point data is in use, edit station data is not allowed.")
GOTO FCP
+10 SET PRCDR="2;3;10;11;3.1"
+11 DO EDIT^PRC0B(.X,PRCDD_";;"_PRCRI(PRCDD),PRCDR)
+12 DO DCLOCK^PRC0B(PRCLOCK)
FCP FOR
DO EN^DDIOL($TRANSLATE($JUSTIFY("",78)," ","-"))
Begin DoDot:1
+1 NEW PRCDD,PRCAED,PRCDI,PRCLOCK1
+2 SET PRCDD=420.01
SET PRCQT=""
+3 SET X("S")="I ^(0)-9999"
+4 DO LKUP
if PRCQT
QUIT
+5 SET PRCLOCK1=PRCLOCK_"1,"_PRCRI(PRCDD)_","
SET Y=3
DO ICLOCK^PRC0B(PRCLOCK1,.Y)
+6 IF 'Y
DO EN^DDIOL("The station/selected fund control point data is in use, please try later!")
QUIT
+7 SET Y=$$NODE^PRC0B("^PRC(420,PRCRI(420),1,PRCRI(420.01),",0)
+8 SET PRCST=$PIECE(Y,PRCU,19)
SET PRCNM=$PIECE(Y,PRCU)
SET PRCNO=$PIECE(PRCNM," ")
SET PRCNM=$PIECE(PRCNM," ",2,999)
+9 DO KEY1
+10 DO REQ1^PRCB1A1
+11 DO EDIT
+12 DO TUSER^PRCSEB1(PRCRI(PRCDD))
+13 DO DCLOCK^PRC0B(PRCLOCK1)
+14 QUIT
End DoDot:1
if PRCQT=1
QUIT
EXIT QUIT
+1 ;
LKUP ;lookup prcdd=420.01
+1 SET PRCDI="420;^PRC(420,;"_PRCRI(420)_";1~420.01;^PRC(420,"_PRCRI(420)_",1,"
+2 DO LOOKUP^PRC0B(.X,.Y,PRCDI,"AEOQLS","Select Fund Control Point: ")
+3 IF Y<0!(X="")
SET PRCQT=1
KILL X
QUIT
+4 KILL X
SET PRCRI(PRCDD)=+Y
SET PRCAED=$PIECE(Y,"^",3)
+5 SET PRCDI="420;^PRC(420,;"_PRCRI(420)_"~420.01;^PRC(420,"_PRCRI(420)_",1,;"_PRCRI(420.01)
+6 QUIT
+7 ;
EDIT ;edit prcdd=420.01
+1 IF PRCST=1
Begin DoDot:1
+2 DO EDIT^PRC0B(.X,PRCDI,"20Active/Inactive Control Point","")
IF X=0
SET PRCQT=2
+3 KILL A
DO PIECE^PRC0B(PRCDI,"1~20","I","A")
+4 SET X=$GET(A(PRCDD,PRCRI(PRCDD),20,"I"))
KILL A
+5 SET X=$SELECT(X=1:"23////^S X=DUZ;24///NOW",1:"23///^S X=""@"";24///^S X=""@""")
+6 DO EDIT^PRC0B(.X,PRCDI,X)
End DoDot:1
if PRCQT
QUIT
+7 DO FT^PRC0A(.X,.Y,"Control Point Name","^1:25^K:X'?1AN.ANP X",PRCNM)
+8 IF X?1"^".E
if PRCAED'=1
SET PRCQT=99
if PRCAED=1
DO DELQ^PRCB1A1
if PRCQT
QUIT
GOTO EDIT
+9 IF X]""
IF X'=PRCNM
SET PRCNM=X
SET X=".01///"_PRCNO_" "_PRCNM
DO EDIT^PRC0B(.X,PRCDI,X)
+10 SET C=""
+11 GOTO ED0^PRCB1A1
+12 ;
KEY ;initial key values/func code/bbfy
+1 if $DATA(DA(1))
SET PRCRI(420)=DA(1)
if $DATA(DA)
SET PRCRI(420.01)=DA
KEY1 FOR I=1,26,27,28,29
SET @("PRCK"_I_"=""""")
+1 SET PRCK25D5=""
+2 if 'PRCRI(420)!'PRCRI(420.01)
QUIT
+3 SET A=$GET(^PRC(420,PRCRI(420),1,PRCRI(420.01),0))
SET PRCK1=$PIECE(A,"^",2)
+4 SET A=$GET(^PRC(420,PRCRI(420),1,PRCRI(420.01),5))
+5 SET PRCK25D5=$PIECE(A,"^",5)
SET PRCK26=$PIECE(A,"^",2)
SET PRCK27=$PIECE(A,"^",3)
+6 SET PRCK28=$PIECE(A,"^",4)
SET PRCK29=$PIECE(A,"^",6)
+7 FOR I=26,27,28,29
IF @("PRCK"_I_"=""""")
SET @("PRCK"_I_"="" """)
+8 if PRCK25D5=""
SET PRCK25D5=" "
+9 QUIT
+10 ;
UNQCHK(PRCK1,PRCK25D5,PRCK26,PRCK27,PRCK28,PRCK29) ;check uniqueness - modified in PRC*5.1*209 to check for multiple uniqueness
+1 SET PRCUNQ=""
SET PRCUQ=0
+2 FOR
SET PRCUQ=$ORDER(^PRC(420,PRCRI(420),1,"UNQ",$GET(PRCK1),$GET(PRCK25D5),$GET(PRCK26),$GET(PRCK27),$GET(PRCK28),$GET(PRCK29),PRCUQ))
IF (PRCUQ-PRCRI(420.01)=0)!(PRCUQ="")
QUIT
+3 IF PRCUQ=""
SET PRCUQ=PRCRI(420.01)
DO UNQMES^PRCB1A1
+4 QUIT
+5 ;
UNQCRS ;set unique cross reference
+1 SET PRCK=","_$GET(PRCK1)_","""_$GET(PRCK25D5)_""","""_$GET(PRCK26)_""","""_$GET(PRCK27)_""","""_$GET(PRCK28)_""","""_$GET(PRCK29)_""","
+2 IF PRCK'[",,"
SET @("^PRC(420,PRCRI(420),1,""UNQ"""_PRCK_"DA)=""""")
+3 QUIT
+4 ;
UNQCRK ;kill unique cross reference
+1 SET PRCK=","_$GET(PRCK1)_","""_$GET(PRCK25D5)_""","""_$GET(PRCK26)_""","""_$GET(PRCK27)_""","""_$GET(PRCK28)_""","""_$GET(PRCK29)_""","
+2 IF PRCK'[",,"
KILL @("^PRC(420,PRCRI(420),1,""UNQ"""_PRCK_"DA)")
+3 QUIT
+4 ;
DINU ;call from ^dd(420.01,.01)
+1 SET DINUM=+X
+2 QUIT
+3 ;
