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 ---[H[J[2J[HPRCD1D 3773 printed Apr 09, 2024@21:11:55 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 ;
