PRCD1B ;WISC/PLT-LOAD STANDARD DICTIONARY ; 02/16/94 2:12 PM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
QUIT ;invalid entry
;
EN N PRCDD,PRCDR,PRCRI,PRCAED,PRCQT,PRCA,PRCU,PRCX,A,B,X,Y S PRCU="^"
F D EN^DDIOL(" ") D Q:PRCQT=1
. S PRCDD=420.19,PRCQT=""
. S X("S")="I $$STATUS^PRC0B=""A"""
. S DA="" D LOOKUP^PRC0B(.X,.Y,PRCDD,"AEMOQS","Select Standard Dictionary: ")
. I Y<0!(X="") S PRCQT=1 QUIT
. K X
. S PRCRI(420.19)=+Y
. D PIECE^PRC0B("420.19;;"_PRCRI(420.19),"1;3;5","I","A")
. S PRCDD=$G(A(420.19,PRCRI(420.19),3,"I")),PRCA=$G(A(420.19,PRCRI(420.19),1,"I"))
. S PRCX=$G(A(420.19,PRCRI(420.19),5,"I")) K A
. Q:PRCDD=""
. F D EN^DDIOL(" ") D Q:PRCQT=1
.. S PRCQT=""
.. 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 EDIT
.. D DCLOCK^PRC0B(PRCLOCK)
.. QUIT
. QUIT
QUIT
;
LKUP ;lookup prcdd
S X("W")="W:$X<30 ?30,$P(^(0),U,2)"
S DA="" D LOOKUP^PRC0B(.X,.Y,PRCDD,"AEMOQLS","Select "_PRCA_": ")
I Y<0!(X="") S PRCQT=1 QUIT
S PRCRI(PRCDD)=+Y,PRCAED=$P(Y,"^",3) K X
QUIT
;
EDIT ;edit prcdd
S PRCDR=".01;1;2;" S:$P(PRCX,PRCU)="Y" PRCDR=PRCDR_"3;" S PRCDR=PRCDR_"4:9999",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;"
EDA D PIECE^PRC0B(PRCDD_";;"_PRCRI(PRCDD),C,"I","A")
S C="" F A=1,2 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
D DELETE^PRC0B1(.X,PRCDD_";^PRCD("_PRCDD_",;"_PRCRI(PRCDD))
S:X=1 PRCAED=-1
QUIT
;
EN1 ;standard dictionary list
N PRCDD,PRCRI,PRCAED,PRCQT,PRCA,PRCU,PRCX,A,B,X,Y
F D EN^DDIOL(" ") D Q:PRCQT=1
. S PRCDD=420.19,PRCQT=""
. D LOOKUP^PRC0B(.X,.Y,PRCDD,"AEMOQS","Select Standard Dictionary: ")
. I Y<0!(X="") S PRCQT=1 QUIT
. S PRCRI(420.19)=+Y
. D PIECE^PRC0B("420.19;;"_PRCRI(420.19),".01;1;3","I","A")
. 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"))
. K A
. Q:PRCDD=""
. D EN1A(PRCDD,PRCA)
. QUIT
QUIT
;
;start printing
EN1A(PRCDD,PRCA) N L,DIC,FLDS,BY,FR,TO,DHD
S DIC=PRCDD,DHD=$G(PRCA)_" List" K:DHD="" DHD
S L=0,FLDS="[PRC SD PRINT]"
S BY="@.01",FR="@",TO="~"
D EN1^DIP
QUIT
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCD1B 2710 printed Sep 23, 2025@19:37:05 Page 2
PRCD1B ;WISC/PLT-LOAD STANDARD DICTIONARY ; 02/16/94 2:12 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 ;
EN NEW PRCDD,PRCDR,PRCRI,PRCAED,PRCQT,PRCA,PRCU,PRCX,A,B,X,Y
SET PRCU="^"
+1 FOR
DO EN^DDIOL(" ")
Begin DoDot:1
+2 SET PRCDD=420.19
SET PRCQT=""
+3 SET X("S")="I $$STATUS^PRC0B=""A"""
+4 SET DA=""
DO LOOKUP^PRC0B(.X,.Y,PRCDD,"AEMOQS","Select Standard Dictionary: ")
+5 IF Y<0!(X="")
SET PRCQT=1
QUIT
+6 KILL X
+7 SET PRCRI(420.19)=+Y
+8 DO PIECE^PRC0B("420.19;;"_PRCRI(420.19),"1;3;5","I","A")
+9 SET PRCDD=$GET(A(420.19,PRCRI(420.19),3,"I"))
SET PRCA=$GET(A(420.19,PRCRI(420.19),1,"I"))
+10 SET PRCX=$GET(A(420.19,PRCRI(420.19),5,"I"))
KILL A
+11 if PRCDD=""
QUIT
+12 FOR
DO EN^DDIOL(" ")
Begin DoDot:2
+13 SET PRCQT=""
+14 DO LKUP
if PRCQT
QUIT
+15 SET PRCLOCK=$$DICGL^PRC0B1(PRCDD)_PRCRI(PRCDD)_","
SET Y=3
DO ICLOCK^PRC0B(PRCLOCK,.Y)
+16 IF 'Y
DO EN^DDIOL("File is in use, please try later!")
QUIT
+17 DO EDIT
+18 DO DCLOCK^PRC0B(PRCLOCK)
+19 QUIT
End DoDot:2
if PRCQT=1
QUIT
+20 QUIT
End DoDot:1
if PRCQT=1
QUIT
+21 QUIT
+22 ;
LKUP ;lookup prcdd
+1 SET X("W")="W:$X<30 ?30,$P(^(0),U,2)"
+2 SET DA=""
DO LOOKUP^PRC0B(.X,.Y,PRCDD,"AEMOQLS","Select "_PRCA_": ")
+3 IF Y<0!(X="")
SET PRCQT=1
QUIT
+4 SET PRCRI(PRCDD)=+Y
SET PRCAED=$PIECE(Y,"^",3)
KILL X
+5 QUIT
+6 ;
EDIT ;edit prcdd
+1 SET PRCDR=".01;1;2;"
if $PIECE(PRCX,PRCU)="Y"
SET PRCDR=PRCDR_"3;"
SET PRCDR=PRCDR_"4:9999"
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;"
EDA DO PIECE^PRC0B(PRCDD_";;"_PRCRI(PRCDD),C,"I","A")
+1 SET C=""
FOR A=1,2
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
+1 DO DELETE^PRC0B1(.X,PRCDD_";^PRCD("_PRCDD_",;"_PRCRI(PRCDD))
+2 if X=1
SET PRCAED=-1
+3 QUIT
+4 ;
EN1 ;standard dictionary list
+1 NEW PRCDD,PRCRI,PRCAED,PRCQT,PRCA,PRCU,PRCX,A,B,X,Y
+2 FOR
DO EN^DDIOL(" ")
Begin DoDot:1
+3 SET PRCDD=420.19
SET PRCQT=""
+4 DO LOOKUP^PRC0B(.X,.Y,PRCDD,"AEMOQS","Select Standard Dictionary: ")
+5 IF Y<0!(X="")
SET PRCQT=1
QUIT
+6 SET PRCRI(420.19)=+Y
+7 DO PIECE^PRC0B("420.19;;"_PRCRI(420.19),".01;1;3","I","A")
+8 SET PRCDD=$GET(A(420.19,PRCRI(420.19),3,"I"))
SET PRCA=$GET(A(420.19,PRCRI(420.19),.01,"I"))_"-"_$GET(A(420.19,PRCRI(420.19),1,"I"))
+9 KILL A
+10 if PRCDD=""
QUIT
+11 DO EN1A(PRCDD,PRCA)
+12 QUIT
End DoDot:1
if PRCQT=1
QUIT
+13 QUIT
+14 ;
+15 ;start printing
EN1A(PRCDD,PRCA) NEW L,DIC,FLDS,BY,FR,TO,DHD
+1 SET DIC=PRCDD
SET DHD=$GET(PRCA)_" List"
if DHD=""
KILL DHD
+2 SET L=0
SET FLDS="[PRC SD PRINT]"
+3 SET BY="@.01"
SET FR="@"
SET TO="~"
+4 DO EN1^DIP
+5 QUIT
+6 ;
