source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCD1C.m@ 619

Last change on this file since 619 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.5 KB
Line 
1PRCD1C ;WISC/PLT-FUND ENTER/EDIT ; 02/08/94 12:06 PM
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 QUIT ;invalid entry
5 ;
6 ;enter/edit fund
7EN N PRCDD,PRCDR,PRCRI,PRCAED,PRCQT,PRCU,A,B,X,Y S PRCU="^"
8 N PRCUQ,PRCK,PRCK01,PRCK2,PRCK3
9 F D EN^DDIOL($TR($J("",78)," ","-")) D Q:PRCQT=1
10 . S PRCDD=420.14,PRCQT=""
11 . S (PRCUQ,PRCK01,PRCK2,PRCK3)=""
12 . D LKUP Q:PRCQT
13 . S PRCLOCK=$$DICGL^PRC0B1(PRCDD)_PRCRI(PRCDD)_",",Y=3 D ICLOCK^PRC0B(PRCLOCK,.Y)
14 . I 'Y D EN^DDIOL("File is in use, please try later!") QUIT
15 . D:PRCAED'=1 KEY
16 . D EDIT
17 . D DCLOCK^PRC0B(PRCLOCK)
18 . QUIT
19 QUIT
20 ;
21LKUP ;lookup prcdd=420.14
22 S DA="" D LOOKUP^PRC0B(.X,.Y,PRCDD,"AEMOQLS","Select Fund: ")
23 I Y<0!(X="") S PRCQT=1 QUIT
24 S DA=+Y,PRCRI(PRCDD)=+Y,PRCAED=$P(Y,"^",3)
25 QUIT
26 ;
27EDIT ;edit prcdd=420.14
28 S PRCDR=".01:99999999",C=PRCDR
29ED1 D EDIT^PRC0B(.X,PRCDD_";;"_PRCRI(PRCDD),C) I X=0 S PRCQT=2 QUIT
30 I X=-1,PRCAED=1 D Q:PRCQT
31 . D YN^PRC0A(.X,.Y,"Delete this NEW entry","","No")
32 . I Y=1 D DELETE I PRCAED=-1 D EN^DDIOL(" **** NEW ENTRY DELETED ****") S PRCQT=3 QUIT
33 . D EN^DDIOL(" **** NEW ENTRY IS NOT DELETED ****")
34 .QUIT
35 ;require fileds check
36 S C="1;2;3;4.5;5;"
37EDA K A D PIECE^PRC0B(PRCDD_";;"_PRCRI(PRCDD),C,"I","A")
38 S C="" F A=2,3,4.5,5 I $G(A(PRCDD,PRCRI(PRCDD),A,"I"))="" S C=C_A_";"
39 K A I C]"" D EN^DDIOL(" **** Missing Required Field(s) ****") S C=C_"S Y=0;"_PRCDR G ED1
40 QUIT
41 ;
42DELETE ;delete prcdd=420.14
43 D DELETE^PRC0B1(.X,PRCDD_";^PRCD(420.14,;"_PRCRI(PRCDD))
44 S:X=1 PRCAED=-1
45 QUIT
46 ;
47KEY ;initial key values
48 N A
49 S A=$G(^PRCD(420.14,DA,0))
50 S PRCK01=$P(A,"^",1),PRCK2=$P(A,"^",3),PRCK3=$P(A,"^",4)
51 QUIT
52 ;
53 ;called from file 420.14 input transform for unique check
54UNQCHK(PRCK01,PRCK2,PRCK3) ;check uniqueness from ^dd(420.14)
55 S PRCK=","""_$G(PRCK01)_""","""_$G(PRCK2)_""","""_$G(PRCK3)_""","
56 I PRCK'[",""""," S @("PRCUQ=$O(^PRCD(420.14,""UNQ"""_PRCK_"0))") I PRCUQ,PRCUQ-DA D UNQMES K X
57 QUIT
58 ;
59UNQCRS ;set unique cross reference called from ^dd(420.14)
60 S PRCK=","""_$G(PRCK01)_""","""_$G(PRCK2)_""","""_$G(PRCK3)_""","
61 I PRCK'[",""""," S @("^PRCD(420.14,""UNQ"""_PRCK_"DA)=""""")
62 QUIT
63 ;
64UNQCRK ;kill unique cross reference called from ^dd(420.14)
65 S PRCK=","""_$G(PRCK01)_""","""_$G(PRCK2)_""","""_$G(PRCK3)_""","
66 I PRCK'[",""""," K @("^PRCD(420.14,""UNQ"""_PRCK_"DA)")
67 QUIT
68 ;
69 ;
70UNQMES D EN^DDIOL(" NOT UNIQUE for fund, beginning fiscal year, or ending fiscal year!")
71 QUIT
72 ;
73EN1 ;print fund
74 N L,DIC,FLDS,BY,FR,TO,DHD,PRCDD
75 S PRCDD=420.14
76 S L=0,DIC=PRCDD,FLDS="[PRCD FUND]"
77 S BY="@.01",FR="@",TO="~"
78 D EN1^DIP
79 QUIT
80 ;
Note: See TracBrowser for help on using the repository browser.