- 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 Jan 18, 2025@03:02:13 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 ;