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