| 1 | PRCD1B ;WISC/PLT-LOAD STANDARD DICTIONARY ; 02/16/94 2:12 PM
|
|---|
| 2 | V ;;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 | EN 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 | ;
|
|---|
| 29 | LKUP ;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 | ;
|
|---|
| 36 | EDIT ;edit prcdd
|
|---|
| 37 | S PRCDR=".01;1;2;" S:$P(PRCX,PRCU)="Y" PRCDR=PRCDR_"3;" S PRCDR=PRCDR_"4:9999",C=PRCDR
|
|---|
| 38 | ED1 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;"
|
|---|
| 46 | EDA 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 | ;
|
|---|
| 51 | DELETE ;delete prcdd
|
|---|
| 52 | D DELETE^PRC0B1(.X,PRCDD_";^PRCD("_PRCDD_",;"_PRCRI(PRCDD))
|
|---|
| 53 | S:X=1 PRCAED=-1
|
|---|
| 54 | QUIT
|
|---|
| 55 | ;
|
|---|
| 56 | EN1 ;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
|
|---|
| 72 | EN1A(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 | ;
|
|---|
