source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCD1D.m@ 1078

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

initial load of WorldVistAEHR

File size: 3.6 KB
Line 
1PRCD1D ;WISC/PLT-DOCUMENT REQUIRED DATA ELEMENT ; 02/17/94 9:12 AM
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 document required data element
7EN N PRCDD,PRCDR,PRCDI,PRCRI,PRCAED,PRCQT,PRCU,A,B,X,Y S PRCU="^"
8 N PRCUQ,PRCK,PRCK01,PRCK1,PRCK2
9 F D EN^DDIOL("Enter/Edit Budget/Document Required Data"_$TR($J("",10)," ","-")) D Q:PRCQT=1
10 . S PRCQT=""
11 . D PTR^PRC0A(.X,.Y,"Select Fund","O^420.14:EMOQS","")
12 . I Y=-1!(Y?1"^".E) S PRCQT=1 QUIT
13 . S PRCRI(420.14)=+Y,PRCHE=$$NP^PRC0B("^PRCD(420.14,+Y,",0,1)
14 . D PTR^PRC0A(.X,.Y,"Select Document Type","O^420.16:EMOQS","")
15 . I Y=-1!(Y?1"^".E) QUIT
16 . S PRCRI(420.16)=+Y,PRCHE=PRCHE_" / "_$$NP^PRC0B("^PRCD(420.16,+Y,",0,2)
17 . F D EN^DDIOL(PRCHE_$TR($J("",10)," ","-")) D Q:PRCQT=2
18 .. S PRCQT=""
19 .. D PTR^PRC0A(.X,.Y,"Select Data Element","O^420.17:EMOQS","")
20 .. I Y=-1!(Y?1"^".E) S PRCQT=2 QUIT
21 .. S PRCRI(420.17)=+Y
22 .. S PRCDD=420.18,PRCQT=""
23 .. S (PRCUQ,PRCK01,PRCK1,PRCK2)=""
24 .. D LKUP Q:PRCQT
25 .. S PRCLOCK=$$DICGL^PRC0B1(PRCDD)_PRCRI(PRCDD)_",",Y=3 D ICLOCK^PRC0B(PRCLOCK,.Y)
26 .. I 'Y D EN^DDIOL("File is in use, please try later!") QUIT
27 .. D:PRCAED'=1 KEY
28 .. D EDIT
29 .. D DCLOCK^PRC0B(PRCLOCK)
30 .. QUIT
31 . QUIT
32 QUIT
33 ;
34LKUP ;lookup prcdd=420.18
35 S DA="",Y=$O(^PRCD(420.18,"UNQ",PRCRI(420.14),PRCRI(420.16),PRCRI(420.17),""))
36 I 'Y D
37 . S X=PRCRI(420.14),X("DR")="1////"_PRCRI(420.16)_";2////"_PRCRI(420.17)
38 . D ADD^PRC0B1(.X,.Y,"420.18;^PRCD(420.18,")
39 . QUIT
40 K X I Y<0 S PRCQT=2 QUIT
41 S DA=+Y,PRCRI(PRCDD)=+Y,PRCAED=$P(Y,"^",3)
42 QUIT
43 ;
44EDIT ;edit prcdd=420.18
45 S PRCDR=3,C=PRCDR
46ED1 D EDIT^PRC0B(.X,PRCDD_";;"_PRCRI(PRCDD),C) I X=0 S PRCQT=3 QUIT
47 I X=-1,PRCAED=1 D Q:PRCQT
48 . D YN^PRC0A(.X,.Y,"Delete this NEW entry","","No")
49 . I Y=1 D DELETE I PRCAED=-1 D EN^DDIOL(" **** NEW ENTRY DELETED ****") S PRCQT=3 QUIT
50 . D EN^DDIOL(" **** NEW ENTRY IS NOT DELETED ****")
51 .QUIT
52 ;delete entry if nil
53 S C=3
54EDA K A D PIECE^PRC0B(PRCDD_";;"_PRCRI(PRCDD),C,"I","A")
55 I $G(A(PRCDD,PRCRI(PRCDD),3,"I"))="" D DELETE
56 QUIT
57 ;
58DELETE ;delete prcdd=420.18
59 D DELETE^PRC0B1(.X,PRCDD_";^PRCD(420.18,;"_PRCRI(PRCDD))
60 S:X=1 PRCAED=-1
61 QUIT
62 ;
63KEY ;initial key values
64 N A
65 S A=$G(^PRCD(420.18,DA,0))
66 S PRCK01=$P(A,"^",1),PRCK1=$P(A,"^",2),PRCK2=$P(A,"^",3)
67 QUIT
68 ;
69 ;not in use
70UNQCHK(PRCK01,PRCK1,PRCK2) ;check uniqueness from ^dd(420.18)
71 S PRCK=","""_$G(PRCK01)_""","""_$G(PRCK1)_""","""_$G(PRCK2)_""","
72 I PRCK'[",""""," S @("PRCUQ=$O(^PRCD(420.18,""UNQ"""_PRCK_"0))") I PRCUQ,PRCUQ-DA D UNQMES K X
73 QUIT
74 ;
75UNQCRS ;set unique cross reference called from ^dd(420.18)
76 S PRCK=","""_$G(PRCK01)_""","""_$G(PRCK1)_""","""_$G(PRCK2)_""","
77 I PRCK'[",""""," S @("^PRCD(420.18,""UNQ"""_PRCK_"DA)=""""")
78 QUIT
79 ;
80UNQCRK ;kill unique cross reference called from ^dd(420.18)
81 S PRCK=","""_$G(PRCK01)_""","""_$G(PRCK1)_""","""_$G(PRCK2)_""","
82 I PRCK'[",""""," K @("^PRCD(420.18,""UNQ"""_PRCK_"DA)")
83 QUIT
84 ;
85 ;
86UNQMES D EN^DDIOL(" NOT UNIQUE for document data element, fund, document type!")
87 QUIT
88 ;
89EN1 ;print document required fields
90 N L,DIC,FLDS,BY,FR,TO,DHD,DISTOP,PRCDD,PRCOPT,PRCRI,PRCQT
91Q20 D SC^PRC0A(.X,.Y,"Select: ","O^1:ALL;2:SELECT FOR FUND","")
92 G EXIT1:Y=""!(Y["^")
93 S PRCOPT=+Y,PRCQT=""
94Q20A I PRCOPT=2 D G Q20:PRCQT=1
95 . D PTR^PRC0A(.X,.Y,"Select Fund","O^420.14:EMOQS","")
96 . I Y=-1!(Y?1"^".E)!(Y="") S PRCQT=1 QUIT
97 . S PRCRI(420.14)=+Y
98 . QUIT
99 D PRINT G EXIT1:PRCOPT=1,Q20A
100PRINT S PRCDD=420.18
101 S L=0,DIC=PRCDD,FLDS="[PRCD PRINT]",BY="[PRCD BY FUND,DOC TYPE,DATA ELE]",(FR,TO)=""
102 I PRCOPT=2 S BY="@INTERNAL(FUND),DOCUMENT TYPE,DATA ELEMENT",FR=PRCRI(420.14),TO=FR,DISTOP=1
103 D EN1^DIP
104EXIT1 QUIT
105 ;
Note: See TracBrowser for help on using the repository browser.