source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCD1B.m@ 623

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

initial load of WorldVistAEHR

File size: 2.6 KB
Line 
1PRCD1B ;WISC/PLT-LOAD STANDARD DICTIONARY ; 02/16/94 2:12 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 ;
6EN N PRCDD,PRCDR,PRCRI,PRCAED,PRCQT,PRCA,PRCU,PRCX,A,B,X,Y S PRCU="^"
7 F D EN^DDIOL(" ") D Q:PRCQT=1
8 . S PRCDD=420.19,PRCQT=""
9 . S X("S")="I $$STATUS^PRC0B=""A"""
10 . S DA="" D LOOKUP^PRC0B(.X,.Y,PRCDD,"AEMOQS","Select Standard Dictionary: ")
11 . I Y<0!(X="") S PRCQT=1 QUIT
12 . K X
13 . S PRCRI(420.19)=+Y
14 . D PIECE^PRC0B("420.19;;"_PRCRI(420.19),"1;3;5","I","A")
15 . S PRCDD=$G(A(420.19,PRCRI(420.19),3,"I")),PRCA=$G(A(420.19,PRCRI(420.19),1,"I"))
16 . S PRCX=$G(A(420.19,PRCRI(420.19),5,"I")) K A
17 . Q:PRCDD=""
18 . F D EN^DDIOL(" ") D Q:PRCQT=1
19 .. S PRCQT=""
20 .. D LKUP Q:PRCQT
21 .. S PRCLOCK=$$DICGL^PRC0B1(PRCDD)_PRCRI(PRCDD)_",",Y=3 D ICLOCK^PRC0B(PRCLOCK,.Y)
22 .. I 'Y D EN^DDIOL("File is in use, please try later!") QUIT
23 .. D EDIT
24 .. D DCLOCK^PRC0B(PRCLOCK)
25 .. QUIT
26 . QUIT
27 QUIT
28 ;
29LKUP ;lookup prcdd
30 S X("W")="W:$X<30 ?30,$P(^(0),U,2)"
31 S DA="" D LOOKUP^PRC0B(.X,.Y,PRCDD,"AEMOQLS","Select "_PRCA_": ")
32 I Y<0!(X="") S PRCQT=1 QUIT
33 S PRCRI(PRCDD)=+Y,PRCAED=$P(Y,"^",3) K X
34 QUIT
35 ;
36EDIT ;edit prcdd
37 S PRCDR=".01;1;2;" S:$P(PRCX,PRCU)="Y" PRCDR=PRCDR_"3;" S PRCDR=PRCDR_"4:9999",C=PRCDR
38ED1 D EDIT^PRC0B(.X,PRCDD_";;"_PRCRI(PRCDD),C) I X=0 S PRCQT=2 QUIT
39 I X=-1,PRCAED=1 D Q:PRCQT
40 . D YN^PRC0A(.X,.Y,"Delete this NEW entry","","No")
41 . I Y=1 D DELETE I PRCAED=-1 D EN^DDIOL(" **** NEW ENTRY DELETED ****") S PRCQT=3 QUIT
42 . D EN^DDIOL(" **** NEW ENTRY IS NOT DELETED ****")
43 .QUIT
44 ;require fileds check
45 S C="1;2;"
46EDA D PIECE^PRC0B(PRCDD_";;"_PRCRI(PRCDD),C,"I","A")
47 S C="" F A=1,2 I $G(A(PRCDD,PRCRI(PRCDD),A,"I"))="" S C=C_A_";"
48 K A I C]"" D EN^DDIOL(" **** Missing Required Field(s) ****") S C=C_"S Y=0;"_PRCDR G ED1
49 QUIT
50 ;
51DELETE ;delete prcdd
52 D DELETE^PRC0B1(.X,PRCDD_";^PRCD("_PRCDD_",;"_PRCRI(PRCDD))
53 S:X=1 PRCAED=-1
54 QUIT
55 ;
56EN1 ;standard dictionary list
57 N PRCDD,PRCRI,PRCAED,PRCQT,PRCA,PRCU,PRCX,A,B,X,Y
58 F D EN^DDIOL(" ") D Q:PRCQT=1
59 . S PRCDD=420.19,PRCQT=""
60 . D LOOKUP^PRC0B(.X,.Y,PRCDD,"AEMOQS","Select Standard Dictionary: ")
61 . I Y<0!(X="") S PRCQT=1 QUIT
62 . S PRCRI(420.19)=+Y
63 . D PIECE^PRC0B("420.19;;"_PRCRI(420.19),".01;1;3","I","A")
64 . S PRCDD=$G(A(420.19,PRCRI(420.19),3,"I")),PRCA=$G(A(420.19,PRCRI(420.19),.01,"I"))_"-"_$G(A(420.19,PRCRI(420.19),1,"I"))
65 . K A
66 . Q:PRCDD=""
67 . D EN1A(PRCDD,PRCA)
68 . QUIT
69 QUIT
70 ;
71 ;start printing
72EN1A(PRCDD,PRCA) N L,DIC,FLDS,BY,FR,TO,DHD
73 S DIC=PRCDD,DHD=$G(PRCA)_" List" K:DHD="" DHD
74 S L=0,FLDS="[PRC SD PRINT]"
75 S BY="@.01",FR="@",TO="~"
76 D EN1^DIP
77 QUIT
78 ;
Note: See TracBrowser for help on using the repository browser.