PRCD1D.m

PRCD1D ;WISC/PLT-DOCUMENT REQUIRED DATA ELEMENT ; 02/17/94  9:12 AM

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

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

 QUIT  ;invalid entry

 ;

 ;enter/edit document required data element

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

 N PRCUQ,PRCK,PRCK01,PRCK1,PRCK2

 F  D EN^DDIOL("Enter/Edit Budget/Document Required Data"_$TR($J("",10)," ","-")) D  Q:PRCQT=1

 . S PRCQT=""

 . D PTR^PRC0A(.X,.Y,"Select Fund","O^420.14:EMOQS","")

 . I Y=-1!(Y?1"^".E) S PRCQT=1 QUIT

 . S PRCRI(420.14)=+Y,PRCHE=$$NP^PRC0B("^PRCD(420.14,+Y,",0,1)

 . D PTR^PRC0A(.X,.Y,"Select Document Type","O^420.16:EMOQS","")

 . I Y=-1!(Y?1"^".E) QUIT

 . S PRCRI(420.16)=+Y,PRCHE=PRCHE_" / "_$$NP^PRC0B("^PRCD(420.16,+Y,",0,2)

 . F  D EN^DDIOL(PRCHE_$TR($J("",10)," ","-")) D  Q:PRCQT=2

 .. S PRCQT=""

 .. D PTR^PRC0A(.X,.Y,"Select Data Element","O^420.17:EMOQS","")

 .. I Y=-1!(Y?1"^".E) S PRCQT=2 QUIT

 .. S PRCRI(420.17)=+Y

 .. S PRCDD=420.18,PRCQT=""

 .. S (PRCUQ,PRCK01,PRCK1,PRCK2)=""

 .. 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:PRCAED'=1 KEY

 .. D EDIT

 .. D DCLOCK^PRC0B(PRCLOCK)

 .. QUIT

 . QUIT

 QUIT

 ;

LKUP ;lookup prcdd=420.18

 S DA="",Y=$O(^PRCD(420.18,"UNQ",PRCRI(420.14),PRCRI(420.16),PRCRI(420.17),""))

 I 'Y D

 . S X=PRCRI(420.14),X("DR")="1////"_PRCRI(420.16)_";2////"_PRCRI(420.17)

 . D ADD^PRC0B1(.X,.Y,"420.18;^PRCD(420.18,")

 . QUIT

 K X I Y<0 S PRCQT=2 QUIT

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

 QUIT

 ;

EDIT ;edit prcdd=420.18

 S PRCDR=3,C=PRCDR

ED1 D EDIT^PRC0B(.X,PRCDD_";;"_PRCRI(PRCDD),C) I X=0 S PRCQT=3 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

 ;delete entry if nil

 S C=3

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

 I $G(A(PRCDD,PRCRI(PRCDD),3,"I"))="" D DELETE

 QUIT

 ;

DELETE ;delete prcdd=420.18

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

 S:X=1 PRCAED=-1

 QUIT

 ;

KEY ;initial key values

 N A

 S A=$G(^PRCD(420.18,DA,0))

 S PRCK01=$P(A,"^",1),PRCK1=$P(A,"^",2),PRCK2=$P(A,"^",3)

 QUIT

 ;

 ;not in use

UNQCHK(PRCK01,PRCK1,PRCK2) ;check uniqueness from ^dd(420.18)

 S PRCK=","""_$G(PRCK01)_""","""_$G(PRCK1)_""","""_$G(PRCK2)_""","

 I PRCK'[",""""," S @("PRCUQ=$O(^PRCD(420.18,""UNQ"""_PRCK_"0))") I PRCUQ,PRCUQ-DA D UNQMES K X

 QUIT

 ;

UNQCRS ;set unique cross reference called from ^dd(420.18)

 S PRCK=","""_$G(PRCK01)_""","""_$G(PRCK1)_""","""_$G(PRCK2)_""","

 I PRCK'[",""""," S @("^PRCD(420.18,""UNQ"""_PRCK_"DA)=""""")

 QUIT

 ;

UNQCRK ;kill unique cross reference called from ^dd(420.18)

 S PRCK=","""_$G(PRCK01)_""","""_$G(PRCK1)_""","""_$G(PRCK2)_""","

 I PRCK'[",""""," K @("^PRCD(420.18,""UNQ"""_PRCK_"DA)")

 QUIT

 ;

 ;

UNQMES D EN^DDIOL(" NOT UNIQUE for document data element, fund, document type!")

 QUIT

 ;

EN1 ;print document required fields

 N L,DIC,FLDS,BY,FR,TO,DHD,DISTOP,PRCDD,PRCOPT,PRCRI,PRCQT

Q20 D SC^PRC0A(.X,.Y,"Select: ","O^1:ALL;2:SELECT FOR FUND","")

 G EXIT1:Y=""!(Y["^")

 S PRCOPT=+Y,PRCQT=""

Q20A I PRCOPT=2 D  G Q20:PRCQT=1

  . D PTR^PRC0A(.X,.Y,"Select Fund","O^420.14:EMOQS","")

 . I Y=-1!(Y?1"^".E)!(Y="") S PRCQT=1 QUIT

 . S PRCRI(420.14)=+Y

 . QUIT

 D PRINT G EXIT1:PRCOPT=1,Q20A

PRINT S PRCDD=420.18

 S L=0,DIC=PRCDD,FLDS="[PRCD PRINT]",BY="[PRCD BY FUND,DOC TYPE,DATA ELE]",(FR,TO)=""

 I PRCOPT=2 S BY="@INTERNAL(FUND),DOCUMENT TYPE,DATA ELEMENT",FR=PRCRI(420.14),TO=FR,DISTOP=1

 D EN1^DIP

EXIT1 QUIT

 ;

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PRCD1D   3773     printed  Feb 18, 2025@23:27:26                                                                                                                                                                                                      Page 2

PRCD1D    ;WISC/PLT-DOCUMENT REQUIRED DATA ELEMENT ; 02/17/94  9:12 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       ;enter/edit document required data element

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

           SET PRCU="^"

 +1        NEW PRCUQ,PRCK,PRCK01,PRCK1,PRCK2

 +2        FOR 

               DO EN^DDIOL("Enter/Edit Budget/Document Required Data"_$TRANSLATE($JUSTIFY("",10)," ","-"))

               Begin DoDot:1

 +3                SET PRCQT=""

 +4                DO PTR^PRC0A(.X,.Y,"Select Fund","O^420.14:EMOQS","")

 +5                IF Y=-1!(Y?1"^".E)

                       SET PRCQT=1

                       QUIT 

 +6                SET PRCRI(420.14)=+Y

                   SET PRCHE=$$NP^PRC0B("^PRCD(420.14,+Y,",0,1)

 +7                DO PTR^PRC0A(.X,.Y,"Select Document Type","O^420.16:EMOQS","")

 +8                IF Y=-1!(Y?1"^".E)

                       QUIT 

 +9                SET PRCRI(420.16)=+Y

                   SET PRCHE=PRCHE_" / "_$$NP^PRC0B("^PRCD(420.16,+Y,",0,2)

 +10               FOR 

                       DO EN^DDIOL(PRCHE_$TRANSLATE($JUSTIFY("",10)," ","-"))

                       Begin DoDot:2

 +11                       SET PRCQT=""

 +12                       DO PTR^PRC0A(.X,.Y,"Select Data Element","O^420.17:EMOQS","")

 +13                       IF Y=-1!(Y?1"^".E)

                               SET PRCQT=2

                               QUIT 

 +14                       SET PRCRI(420.17)=+Y

 +15                       SET PRCDD=420.18

                           SET PRCQT=""

 +16                       SET (PRCUQ,PRCK01,PRCK1,PRCK2)=""

 +17                       DO LKUP

                           if PRCQT

                               QUIT 

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

                           SET Y=3

                           DO ICLOCK^PRC0B(PRCLOCK,.Y)

 +19                       IF 'Y

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

                               QUIT 

 +20                       if PRCAED'=1

                               DO KEY

 +21                       DO EDIT

 +22                       DO DCLOCK^PRC0B(PRCLOCK)

 +23                       QUIT 

                       End DoDot:2

                       if PRCQT=2

                           QUIT 

 +24               QUIT 

               End DoDot:1

               if PRCQT=1

                   QUIT 

 +25       QUIT 

 +26      ;

LKUP      ;lookup prcdd=420.18

 +1        SET DA=""

           SET Y=$ORDER(^PRCD(420.18,"UNQ",PRCRI(420.14),PRCRI(420.16),PRCRI(420.17),""))

 +2        IF 'Y

               Begin DoDot:1

 +3                SET X=PRCRI(420.14)

                   SET X("DR")="1////"_PRCRI(420.16)_";2////"_PRCRI(420.17)

 +4                DO ADD^PRC0B1(.X,.Y,"420.18;^PRCD(420.18,")

 +5                QUIT 

               End DoDot:1

 +6        KILL X

           IF Y<0

               SET PRCQT=2

               QUIT 

 +7        SET DA=+Y

           SET PRCRI(PRCDD)=+Y

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

 +8        QUIT 

 +9       ;

EDIT      ;edit prcdd=420.18

 +1        SET PRCDR=3

           SET C=PRCDR

ED1        DO EDIT^PRC0B(.X,PRCDD_";;"_PRCRI(PRCDD),C)

           IF X=0

               SET PRCQT=3

               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       ;delete entry if nil

 +7        SET C=3

EDA        KILL A

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

 +1        IF $GET(A(PRCDD,PRCRI(PRCDD),3,"I"))=""

               DO DELETE

 +2        QUIT 

 +3       ;

DELETE    ;delete prcdd=420.18

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

 +2        if X=1

               SET PRCAED=-1

 +3        QUIT 

 +4       ;

KEY       ;initial key values

 +1        NEW A

 +2        SET A=$GET(^PRCD(420.18,DA,0))

 +3        SET PRCK01=$PIECE(A,"^",1)

           SET PRCK1=$PIECE(A,"^",2)

           SET PRCK2=$PIECE(A,"^",3)

 +4        QUIT 

 +5       ;

 +6       ;not in use

UNQCHK(PRCK01,PRCK1,PRCK2) ;check uniqueness from ^dd(420.18)

 +1        SET PRCK=","""_$GET(PRCK01)_""","""_$GET(PRCK1)_""","""_$GET(PRCK2)_""","

 +2        IF PRCK'[","""","

               SET @("PRCUQ=$O(^PRCD(420.18,""UNQ"""_PRCK_"0))")

               IF PRCUQ

                   IF PRCUQ-DA

                       DO UNQMES

                       KILL X

 +3        QUIT 

 +4       ;

UNQCRS    ;set unique cross reference called from ^dd(420.18)

 +1        SET PRCK=","""_$GET(PRCK01)_""","""_$GET(PRCK1)_""","""_$GET(PRCK2)_""","

 +2        IF PRCK'[","""","

               SET @("^PRCD(420.18,""UNQ"""_PRCK_"DA)=""""")

 +3        QUIT 

 +4       ;

UNQCRK    ;kill unique cross reference called from ^dd(420.18)

 +1        SET PRCK=","""_$GET(PRCK01)_""","""_$GET(PRCK1)_""","""_$GET(PRCK2)_""","

 +2        IF PRCK'[","""","

               KILL @("^PRCD(420.18,""UNQ"""_PRCK_"DA)")

 +3        QUIT 

 +4       ;

 +5       ;

UNQMES     DO EN^DDIOL(" NOT UNIQUE for document data element, fund, document type!")

 +1        QUIT 

 +2       ;

EN1       ;print document required fields

 +1        NEW L,DIC,FLDS,BY,FR,TO,DHD,DISTOP,PRCDD,PRCOPT,PRCRI,PRCQT

Q20        DO SC^PRC0A(.X,.Y,"Select: ","O^1:ALL;2:SELECT FOR FUND","")

 +1        if Y=""!(Y["^")

               GOTO EXIT1

 +2        SET PRCOPT=+Y

           SET PRCQT=""

Q20A       IF PRCOPT=2

               Begin DoDot:1

 +1                DO PTR^PRC0A(.X,.Y,"Select Fund","O^420.14:EMOQS","")

 +2                IF Y=-1!(Y?1"^".E)!(Y="")

                       SET PRCQT=1

                       QUIT 

 +3                SET PRCRI(420.14)=+Y

 +4                QUIT 

               End DoDot:1

               if PRCQT=1

                   GOTO Q20

 +5        DO PRINT

           if PRCOPT=1

               GOTO EXIT1

           GOTO Q20A

PRINT      SET PRCDD=420.18

 +1        SET L=0

           SET DIC=PRCDD

           SET FLDS="[PRCD PRINT]"

           SET BY="[PRCD BY FUND,DOC TYPE,DATA ELE]"

           SET (FR,TO)=""

 +2        IF PRCOPT=2

               SET BY="@INTERNAL(FUND),DOCUMENT TYPE,DATA ELEMENT"

               SET FR=PRCRI(420.14)

               SET TO=FR

               SET DISTOP=1

 +3        DO EN1^DIP

EXIT1      QUIT 

 +1       ;