PRCD1C ;WISC/PLT-FUND ENTER/EDIT ; 02/08/94 12:06 PM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
QUIT ;invalid entry
;
;enter/edit fund
EN N PRCDD,PRCDR,PRCRI,PRCAED,PRCQT,PRCU,A,B,X,Y S PRCU="^"
N PRCUQ,PRCK,PRCK01,PRCK2,PRCK3
F D EN^DDIOL($TR($J("",78)," ","-")) D Q:PRCQT=1
. S PRCDD=420.14,PRCQT=""
. S (PRCUQ,PRCK01,PRCK2,PRCK3)=""
. D LKUP Q:PRCQT
. S PRCLOCK=$$DICGL^PRC0B1(PRCDD)_PRCRI(PRCDD)_",",Y=3 D ICLOCK^PRC0B(PRCLOCK,.Y)
. I 'Y D EN^DDIOL("File is in use, please try later!") QUIT
. D:PRCAED'=1 KEY
. D EDIT
. D DCLOCK^PRC0B(PRCLOCK)
. QUIT
QUIT
;
LKUP ;lookup prcdd=420.14
S DA="" D LOOKUP^PRC0B(.X,.Y,PRCDD,"AEMOQLS","Select Fund: ")
I Y<0!(X="") S PRCQT=1 QUIT
S DA=+Y,PRCRI(PRCDD)=+Y,PRCAED=$P(Y,"^",3)
QUIT
;
EDIT ;edit prcdd=420.14
S PRCDR=".01:99999999",C=PRCDR
ED1 D EDIT^PRC0B(.X,PRCDD_";;"_PRCRI(PRCDD),C) I X=0 S PRCQT=2 QUIT
I X=-1,PRCAED=1 D Q:PRCQT
. D YN^PRC0A(.X,.Y,"Delete this NEW entry","","No")
. I Y=1 D DELETE I PRCAED=-1 D EN^DDIOL(" **** NEW ENTRY DELETED ****") S PRCQT=3 QUIT
. D EN^DDIOL(" **** NEW ENTRY IS NOT DELETED ****")
.QUIT
;require fileds check
S C="1;2;3;4.5;5;"
EDA K A D PIECE^PRC0B(PRCDD_";;"_PRCRI(PRCDD),C,"I","A")
S C="" F A=2,3,4.5,5 I $G(A(PRCDD,PRCRI(PRCDD),A,"I"))="" S C=C_A_";"
K A I C]"" D EN^DDIOL(" **** Missing Required Field(s) ****") S C=C_"S Y=0;"_PRCDR G ED1
QUIT
;
DELETE ;delete prcdd=420.14
D DELETE^PRC0B1(.X,PRCDD_";^PRCD(420.14,;"_PRCRI(PRCDD))
S:X=1 PRCAED=-1
QUIT
;
KEY ;initial key values
N A
S A=$G(^PRCD(420.14,DA,0))
S PRCK01=$P(A,"^",1),PRCK2=$P(A,"^",3),PRCK3=$P(A,"^",4)
QUIT
;
;called from file 420.14 input transform for unique check
UNQCHK(PRCK01,PRCK2,PRCK3) ;check uniqueness from ^dd(420.14)
S PRCK=","""_$G(PRCK01)_""","""_$G(PRCK2)_""","""_$G(PRCK3)_""","
I PRCK'[",""""," S @("PRCUQ=$O(^PRCD(420.14,""UNQ"""_PRCK_"0))") I PRCUQ,PRCUQ-DA D UNQMES K X
QUIT
;
UNQCRS ;set unique cross reference called from ^dd(420.14)
S PRCK=","""_$G(PRCK01)_""","""_$G(PRCK2)_""","""_$G(PRCK3)_""","
I PRCK'[",""""," S @("^PRCD(420.14,""UNQ"""_PRCK_"DA)=""""")
QUIT
;
UNQCRK ;kill unique cross reference called from ^dd(420.14)
S PRCK=","""_$G(PRCK01)_""","""_$G(PRCK2)_""","""_$G(PRCK3)_""","
I PRCK'[",""""," K @("^PRCD(420.14,""UNQ"""_PRCK_"DA)")
QUIT
;
;
UNQMES D EN^DDIOL(" NOT UNIQUE for fund, beginning fiscal year, or ending fiscal year!")
QUIT
;
EN1 ;print fund
N L,DIC,FLDS,BY,FR,TO,DHD,PRCDD
S PRCDD=420.14
S L=0,DIC=PRCDD,FLDS="[PRCD FUND]"
S BY="@.01",FR="@",TO="~"
D EN1^DIP
QUIT
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCD1C 2677 printed Sep 23, 2025@19:37:06 Page 2
PRCD1C ;WISC/PLT-FUND ENTER/EDIT ; 02/08/94 12:06 PM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;invalid entry
QUIT
+3 ;
+4 ;enter/edit fund
EN NEW PRCDD,PRCDR,PRCRI,PRCAED,PRCQT,PRCU,A,B,X,Y
SET PRCU="^"
+1 NEW PRCUQ,PRCK,PRCK01,PRCK2,PRCK3
+2 FOR
DO EN^DDIOL($TRANSLATE($JUSTIFY("",78)," ","-"))
Begin DoDot:1
+3 SET PRCDD=420.14
SET PRCQT=""
+4 SET (PRCUQ,PRCK01,PRCK2,PRCK3)=""
+5 DO LKUP
if PRCQT
QUIT
+6 SET PRCLOCK=$$DICGL^PRC0B1(PRCDD)_PRCRI(PRCDD)_","
SET Y=3
DO ICLOCK^PRC0B(PRCLOCK,.Y)
+7 IF 'Y
DO EN^DDIOL("File is in use, please try later!")
QUIT
+8 if PRCAED'=1
DO KEY
+9 DO EDIT
+10 DO DCLOCK^PRC0B(PRCLOCK)
+11 QUIT
End DoDot:1
if PRCQT=1
QUIT
+12 QUIT
+13 ;
LKUP ;lookup prcdd=420.14
+1 SET DA=""
DO LOOKUP^PRC0B(.X,.Y,PRCDD,"AEMOQLS","Select Fund: ")
+2 IF Y<0!(X="")
SET PRCQT=1
QUIT
+3 SET DA=+Y
SET PRCRI(PRCDD)=+Y
SET PRCAED=$PIECE(Y,"^",3)
+4 QUIT
+5 ;
EDIT ;edit prcdd=420.14
+1 SET PRCDR=".01:99999999"
SET C=PRCDR
ED1 DO EDIT^PRC0B(.X,PRCDD_";;"_PRCRI(PRCDD),C)
IF X=0
SET PRCQT=2
QUIT
+1 IF X=-1
IF PRCAED=1
Begin DoDot:1
+2 DO YN^PRC0A(.X,.Y,"Delete this NEW entry","","No")
+3 IF Y=1
DO DELETE
IF PRCAED=-1
DO EN^DDIOL(" **** NEW ENTRY DELETED ****")
SET PRCQT=3
QUIT
+4 DO EN^DDIOL(" **** NEW ENTRY IS NOT DELETED ****")
+5 QUIT
End DoDot:1
if PRCQT
QUIT
+6 ;require fileds check
+7 SET C="1;2;3;4.5;5;"
EDA KILL A
DO PIECE^PRC0B(PRCDD_";;"_PRCRI(PRCDD),C,"I","A")
+1 SET C=""
FOR A=2,3,4.5,5
IF $GET(A(PRCDD,PRCRI(PRCDD),A,"I"))=""
SET C=C_A_";"
+2 KILL A
IF C]""
DO EN^DDIOL(" **** Missing Required Field(s) ****")
SET C=C_"S Y=0;"_PRCDR
GOTO ED1
+3 QUIT
+4 ;
DELETE ;delete prcdd=420.14
+1 DO DELETE^PRC0B1(.X,PRCDD_";^PRCD(420.14,;"_PRCRI(PRCDD))
+2 if X=1
SET PRCAED=-1
+3 QUIT
+4 ;
KEY ;initial key values
+1 NEW A
+2 SET A=$GET(^PRCD(420.14,DA,0))
+3 SET PRCK01=$PIECE(A,"^",1)
SET PRCK2=$PIECE(A,"^",3)
SET PRCK3=$PIECE(A,"^",4)
+4 QUIT
+5 ;
+6 ;called from file 420.14 input transform for unique check
UNQCHK(PRCK01,PRCK2,PRCK3) ;check uniqueness from ^dd(420.14)
+1 SET PRCK=","""_$GET(PRCK01)_""","""_$GET(PRCK2)_""","""_$GET(PRCK3)_""","
+2 IF PRCK'[","""","
SET @("PRCUQ=$O(^PRCD(420.14,""UNQ"""_PRCK_"0))")
IF PRCUQ
IF PRCUQ-DA
DO UNQMES
KILL X
+3 QUIT
+4 ;
UNQCRS ;set unique cross reference called from ^dd(420.14)
+1 SET PRCK=","""_$GET(PRCK01)_""","""_$GET(PRCK2)_""","""_$GET(PRCK3)_""","
+2 IF PRCK'[","""","
SET @("^PRCD(420.14,""UNQ"""_PRCK_"DA)=""""")
+3 QUIT
+4 ;
UNQCRK ;kill unique cross reference called from ^dd(420.14)
+1 SET PRCK=","""_$GET(PRCK01)_""","""_$GET(PRCK2)_""","""_$GET(PRCK3)_""","
+2 IF PRCK'[","""","
KILL @("^PRCD(420.14,""UNQ"""_PRCK_"DA)")
+3 QUIT
+4 ;
+5 ;
UNQMES DO EN^DDIOL(" NOT UNIQUE for fund, beginning fiscal year, or ending fiscal year!")
+1 QUIT
+2 ;
EN1 ;print fund
+1 NEW L,DIC,FLDS,BY,FR,TO,DHD,PRCDD
+2 SET PRCDD=420.14
+3 SET L=0
SET DIC=PRCDD
SET FLDS="[PRCD FUND]"
+4 SET BY="@.01"
SET FR="@"
SET TO="~"
+5 DO EN1^DIP
+6 QUIT
+7 ;
