Routine: PRCD1A

PRCD1A ;WISC/PLT-DEFINE/PRINT DEFINED STANDARD DICTIONARY ; 02/16/94  11:30 AM

V ;;5.1;IFCAP;;Oct 20, 2000

 ;Per VHA Directive 10-93-142, this routine should not be modified.

 QUIT  ;invalid entry

 ;define standard dictionary

EN N PRCDD,PRCDR,PRCRI,PRCAED,PRCQT,PRCU,A,B,X,Y S PRCU="^"

 F  D EN^DDIOL(" ") D  Q:PRCQT=1

 . S PRCDD=420.19,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

LKUP ;lookup prcdd=420.19

 S DA="" D LOOKUP^PRC0B(.X,.Y,PRCDD,"AEMOQLS","Select Standard Dictionary: ")

 I Y<0!(X="") S PRCQT=1 QUIT

 S PRCRI(PRCDD)=+Y,PRCAED=$P(Y,"^",3)

 QUIT

EDIT ;edit prcdd=420.19

 S PRCDR=".01:99999999",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="2;3;4;5;"

EDA D PIECE^PRC0B(PRCDD_";;"_PRCRI(PRCDD),C,"I","A")

 S C="" F A=2,3,4,5 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=420.19

 D DELETE^PRC0B1(.X,PRCDD_";^PRCD(420.19,;"_PRCRI(PRCDD))

 S:X=1 PRCAED=-1

 QUIT

EN1 ;print defined standard dictionary

 N L,DIC,FLDS,BY,FR,TO,DHD,PRCDD

 S PRCDD=420.19

 S L=0,DIC=PRCDD,FLDS="[PRCD LIST]"

 S BY="@.01",FR="@",TO="~"

 D EN1^DIP

 QUIT

INIDIC ;initial dictionary files

 N X,Y

 S (X,Y)=""

 D YN^PRC0A(.X,.Y,"Initial Standard Dic","No")

 Q:Y=0

 F I=420.13,420.131,420.14,420.15,420.16,420.17,420.19 D

 . S X=^PRCD(I,0) K ^PRCD(I) S $P(X,"^",3,4)="",^PRCD(I,0)=X

 . QUIT

  W !,"ALL DONE!"

 QUIT

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCD1A   1962     printed  Feb 18, 2025@23:27:23                                                                                                                                                                                                      Page 2

PRCD1A    ;WISC/PLT-DEFINE/PRINT DEFINED STANDARD DICTIONARY ; 02/16/94  11:30 AM

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       ;

 +4       ;define standard dictionary

EN         NEW PRCDD,PRCDR,PRCRI,PRCAED,PRCQT,PRCU,A,B,X,Y

           SET PRCU="^"

 +1        FOR

               DO EN^DDIOL(" ")

               Begin DoDot:1

 +2                SET PRCDD=420.19

                   SET PRCQT=""

 +3                DO LKUP

                   if PRCQT

                       QUIT

 +4                SET PRCLOCK=$$DICGL^PRC0B1(PRCDD)_PRCRI(PRCDD)_","

                   SET Y=3

                   DO ICLOCK^PRC0B(PRCLOCK,.Y)

 +5                IF 'Y

                       DO EN^DDIOL("File is in use, please try later!")

                       QUIT

 +6                DO EDIT

 +7                DO DCLOCK^PRC0B(PRCLOCK)

 +8                QUIT

               End DoDot:1

               if PRCQT=1

                   QUIT

 +9        QUIT

 +10      ;

LKUP      ;lookup prcdd=420.19

 +1        SET DA=""

           DO LOOKUP^PRC0B(.X,.Y,PRCDD,"AEMOQLS","Select Standard Dictionary: ")

 +2        IF Y<0!(X="")

               SET PRCQT=1

               QUIT

 +3        SET PRCRI(PRCDD)=+Y

           SET PRCAED=$PIECE(Y,"^",3)

 +4        QUIT

 +5       ;

EDIT      ;edit prcdd=420.19

 +1        SET PRCDR=".01:99999999"

           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="2;3;4;5;"

EDA        DO PIECE^PRC0B(PRCDD_";;"_PRCRI(PRCDD),C,"I","A")

 +1        SET C=""

           FOR A=2,3,4,5

               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=420.19

 +1        DO DELETE^PRC0B1(.X,PRCDD_";^PRCD(420.19,;"_PRCRI(PRCDD))

 +2        if X=1

               SET PRCAED=-1

 +3        QUIT

 +4       ;

EN1       ;print defined standard dictionary

 +1        NEW L,DIC,FLDS,BY,FR,TO,DHD,PRCDD

 +2        SET PRCDD=420.19

 +3        SET L=0

           SET DIC=PRCDD

           SET FLDS="[PRCD LIST]"

 +4        SET BY="@.01"

           SET FR="@"

           SET TO="~"

 +5        DO EN1^DIP

 +6        QUIT

 +7       ;

INIDIC    ;initial dictionary files

 +1        NEW X,Y

 +2        SET (X,Y)=""

 +3        DO YN^PRC0A(.X,.Y,"Initial Standard Dic","No")

 +4        if Y=0

               QUIT

 +5        FOR I=420.13,420.131,420.14,420.15,420.16,420.17,420.19

               Begin DoDot:1

 +6                SET X=^PRCD(I,0)

                   KILL ^PRCD(I)

                   SET $PIECE(X,"^",3,4)=""

                   SET ^PRCD(I,0)=X

 +7                QUIT

               End DoDot:1

 +8        WRITE !,"ALL DONE!"

 +9        QUIT

 +10      ;

PRCD1A.m