PRCEN ;WISC/CLH - ENTER/EDIT 1358 ;9/2/2010
V ;;5.1;IFCAP;**23,148,150,196,204,209**;Oct 20, 2000;Build 3
;Per VA Directive 6402, this routine should not be modified.
;
;PRC*5.1*150 RGB 4/23/12 Control the node 0 counter for file 410
;kill call since DIK call does not handle descending file logic
;
;PRC*5.1*196 Check Committed Date for 1358 against FY requested
; to insure date is within the FY range.
;
EN ;new 1358 request
N PRC,X,X1,DIC,DIE,DR,PRCS2,PRCSL,PRCSIP,DIR,DIRUT,PRCS,PRCSCP,PRCSN
N PRCST,PRCST1,PRCSTT,PRC410,PRCUA,PRCAUTH,PRCAUTHS,PRCQ,PRCVEN,PRCONT
EN0 K PRC,X,X1,DIC,DIE,DR,PRCS2,PRCSL,PRCSIP,DIR,DIRUT,PRCS,PRCSCP,PRCSN
K PRCST,PRCST1,PRCSTT,PRCAED,PRC410,PRCUA,PRCAUTHS
D EN^PRCSUT I '$D(PRC("SITE")) W !!,"You are not an authorized control point user.",!,"Contact your control point official." H 3 Q
Q:'$D(PRC("QTR"))!(Y<0)
;
; warn CP official, allow to quit
Q:$$Q1358(PRC("SITE"),PRC("CP"))
;
; ask for 1358 Authority (need to preserve variables)
S PRCQ=0 D
. N X,Y,DTOUT,DUOUT,DIC
. S DIC="^PRCS(410.9,",DIC(0)="AEMQ",DIC("S")="I Y<100,('$P(^(0),U,4)!($P(^(0),U,4)>DT))",DIC("A")="Select AUTHORITY OF REQUEST: " D ^DIC S PRCAUTH=+Y I Y<1 S PRCQ=1 Q
. I $D(^PRCS(410.9,"AC",PRCAUTH)) S DIC("S")="I $P(^(0),U,3)=PRCAUTH,('$P(^(0),U,4)!($P(^(0),U,4)>DT))",DIC("A")="Select SUB-AUTHORITY OF REQUEST: " D ^DIC S PRCAUTHS=+Y I Y<1 S PRCQ=1
Q:PRCQ
D EN1^PRCSUT3 Q:'X
S X1=X D EN2^PRCSUT3 Q:'$D(X1) S X=X1 W !!,"This transaction is assigned Transaction number: ",X
S PRC410=DA
D G:'$D(DA) EN0
. L +^PRCS(410,DA):$S($D(DILOCKTM):DILOCKTM,1:3)
. E D EN^DDIOL("Transaction is being accessed by another user!") K DA
. Q
I $D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)) S:$P(^(0),"^",11)="Y" PRCS2=1
S DIC(0)="AEMQ",DIE=DIC,DR="3///1"_$S($D(PRCSIP):";4////"_PRCSIP,1:"")_";19////^S X=PRCAUTH"_$S($G(PRCAUTHS):";19.1////^S X=PRCAUTHS",1:""),X4=1 D ^DIE
S PRCAED=1,PRCUA=""
; define if fields need to be required or not
S PRCVEN=^PRCS(410.9,$S($G(PRCAUTHS):PRCAUTHS,1:PRCAUTH),0),PRCONT=$P(PRCVEN,"^",6),PRCVEN=$P(PRCVEN,"^",5)
S DR="[PRCE NEW 1358]" D ^DIE
I $D(Y)#10 S PRCUA=1 D YN^PRC0A(.X,.Y,"Delete this NEW entry","","No") I Y=1 D
. S PRCIENCT=$P(^PRCS(410,0),"^",3)+1 ;PRC*5.1*150
. D DELETE^PRC0B1(.X,"410;^PRCS(410,;"_DA) S:X=1 PRCAED=-1
. I X=1 S $P(^PRCS(410,0),"^",3)=PRCIENCT ;PRC*5.1*150
. K PRCIENCT ;PRC*5.1*150
. D EN^DDIOL(" **** NEW ENTRY IS "_$S(X=1:"",1:"NOT ")_"DELETED ****")
. QUIT
I PRCAED'=-1 D
. D:$O(^PRCS(410,DA,12,0)) SCPC0^PRCSED
. K PRCSF
. D W1^PRCSEB
. I $D(PRCS2),+^PRCS(410,DA,0),'PRCUA,$$CHECK(PRC410) D
.. D W6^PRCSEB
.. Q
. Q
L -^PRCS(410,PRC410)
S DIR("B")="NO",DIR(0)="Y",DIR("A")="Do you want to enter another NEW request" D ^DIR Q:'Y!($D(DIRUT))
W !! K PRCS2 G EN0
Q
ED ;edit 1358
N PRC410,PRC442,PRCHQ,PRCSDR,PRCSN,PRCST,PRCST1,Y,PRC,PRCS,TT,DIE,DA,DIC
N DR,DIR,PRCSY,PRCSL,X,X1,T,T1,Z,PRCSDA,DTOUT,PRCVEN,PRCONT
ED0 K PRCHQ,PRCSDR,PRCSN,PRCST,PRCST1,Y,PRC,PRCS,TT,DIE,DA,DIC,DR,DIR,PRCSY
K PRCSL,X,X1,T,T1,Z,PRCSDA
D EN3^PRCSUT I '$D(PRC("SITE")) W !!,"You are not an authorized control point user.",!,"Contact your control point official." H 3 Q
Q:Y<0
S DIC="^PRCS(410,",DIE=DIC,DIC(0)="AEQM",DIC("S")="I $P(^(0),U,4)=1,+$P(^(0),U)'=0,$D(^(3)),+^(3)=+PRC(""CP""),$P(^(0),""^"",5)=PRC(""SITE"") I $D(^PRC(420,""A"",DUZ,PRC(""SITE""),+PRC(""CP""),1))!($D(^(2)))"
D ^PRCSDIC Q:Y<0 K DIC("S") S (DA,PRCSY,PRCSDA)=+Y ;D LOCK^PRCSUT G ED0:PRCSL=0
D G:'$D(DA) ED0
. L +^PRCS(410,DA):$S($D(DILOCKTM):DILOCKTM,1:3)
. E D EN^DDIOL("Another user is editing this transaction! Try Later") K DA
. Q
D NODE^PRCS58OB(DA,.TRNODE) S PRC410=DA
S X=^PRCS(410,DA,0) S:+X PRC("FY")=$P(X,"-",2),PRC("QTR")=+$P(X,"-",3),TT=$P(X,"^",2)
D EN2B^PRCSUT3
I $D(^PRCS(410,DA,7)),$P(^(7),U,6)]"" D SCPE G OUT ;if obligated
ED1 I TT="CA" S DR="[PRCSENCT]",DIE=DIC D ^DIE S DA=PRCSY L -^PRCS(410,PRCSY) G ED0
; warn CP offical and allow to quit
I $$Q1358(PRC("SITE"),PRC("CP"),$G(TT),$G(DA)) L -^PRCS(410,PRCSY) G ED0
;
; patch 23, fix problem of not able to exit with "^"
I TT'="O" S DR="[PRCSENA 1358]" S DIE=DIC D ^DIE L:$D(Y)>9 -^PRCS(410,PRCSY) G:$D(Y)>9 ED0 S DA=PRCSY
I TT="A" S PRC442=$P($G(^PRCS(410,PRC410,10)),U,3) I PRC442 G:$$EN1^PRCE0A(PRC410,PRC442,1) ED1
I TT="A",$P(^PRCS(410,DA,0),U,4)=1 S X=$P(^(4),U,6),X1=$P(^(3),U,7) I $J(X,0,2)'=$J(X1,0,2)!('X)!('X1) W $C(7),!,"Adj $ Amt does not equal the total of BOC $ Amts.",!,"Please correct the error.",! K DR G ED1
D:TT="A"&($O(^PRCS(410,PRCSY,12,0))) SCPC0^PRCSED
I TT="A" D REV D:$$CHECK(PRC410) W6^PRCSEB G OUT
;
S DR="[PRCE NEW 1358]" D ^DIE,REV D:$$CHECK(PRC410) W6^PRCSEB
S DIR(0)="Y",DIR("B")="NO",DIR("A")="Do you want to edit another request" D ^DIR G OUT:'Y!($D(DIRUT))
L -^PRCS(410,PRCSDA)
G ED0
SCPE ;sub control point edit
S DR="[PRCSEDS]" D ^DIE
REV W !!,"Would you like to review this request" S %=2 D YN^DICN G REV:%=0 Q:%'=1 S (N,PRCSZ)=DA,PRCSF=1 D PRF1^PRCSP1 S DA=PRCSZ K X,PRCSF,PRCSZ Q
OUT L -^PRCS(410,PRCSDA) Q
;
CHECK(PRC410) ; - Check out a 1358 410 entry for required fields
N PRCX,PRC0,PRC11,PRCER,PRC3,PRC1
Q:'$G(PRC410) -1
;
; get data
F PRCX=0,1,3,11 S @("PRC"_PRCX)=$G(^PRCS(410,PRC410,PRCX))
S PRCX=$G(^PRCS(410.9,$S(+$P(PRC11,"^",5):+$P(PRC11,"^",5),1:+$P(PRC11,"^",4)),0))
S PRCER=0
;
; make sure I have a 1358
I $P(PRC0,"^",4)'=1 Q 1
;
; start checking out data
I '$D(^PRCS(410,PRC410,8,1,0)) D CKER("PURPOSE is Missing")
;
; done checking if not an obligation
I $P(PRC0,"^",2)'="O" G CKEX
;
; continue checking
I '$P(PRC11,"^",4) D CKER("AUTHORITY is Missing")
I $P(PRC11,"^",5),'$D(^PRCS(410.9,"AC",$P(PRC11,"^",4),$P(PRC11,"^",5))) D CKER("SUB-AUTHORITY does not correspond to AUTHORITY")
I '$P(PRC11,"^",5),$O(^PRCS(410.9,"AC",+$P(PRC11,"^",4),0)) D CKER("SUB-AUTHORITY is Missing")
I $P(PRCX,"^",5),'$P(PRC3,"^",4) D CKER("VENDOR is Missing")
I $P(PRCX,"^",6),'$L($P(PRC3,"^",10)) D CKER("CONTRACT is Missing")
I '$P(PRC1,"^",6) D CKER("Service Start Date is Missing")
I '$P(PRC1,"^",7) D CKER("Service End Date is Missing")
;
CKEX I PRCER S PRCER=0 F S PRCER=$O(PRCER(PRCER)) Q:'PRCER W !?5,PRCER(PRCER),"!!!"
Q $S($O(PRCER(0)):0,1:1)
;
CKER(X) ;
S PRCER=PRCER+1
S PRCER(PRCER)=X
Q
;
Q1358(PRCSTA,PRCFCP,PRCTT,PRCDA) ; Quit 1358 Process
; This API warns a control point offical that they will be set as
; the requestor on the 1358 and thus cannot also approve it.
; The API will return 1 (true) if the user decided to quit the
; current process before being set as the requestor.
;
; inputs
; PRCSTA - station number
; PRCFCP - fund control point
; PRCTT - (optional) transaction type, pass "A" for adjustment
; PRCDA - (optional) file 410 ien of 1358 when editing 1358
; returns boolean value (0 or 1)
; = 0 to proceed with process
; = 1 to quit process
;
N RET
S RET=0 ; init value to return
;
; if user is control point official for input station and FCP
I $G(PRCSTA)]"",$G(PRCFCP)]"",$D(^PRC(420,"A",DUZ,PRCSTA,+PRCFCP,1)) D
. N DA,DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
. ;
. ; don't warn when editing a 1358 if user is already the requestor
. I $G(PRCDA),$P($G(^PRCS(410,PRCDA,7)),"^")=DUZ Q
. ;
. I $G(PRCTT)'="A" D
. . W !,"WARNING: The system will assign you as the CP Clerk (Requestor) of this 1358."
. . W !,"You will be unable to approve a 1358 on which you are the REQUESTOR due to"
. . W !,"segregation of duties."
. I $G(PRCTT)="A" D
. . W !,"WARNING: The system will assign you as the CP Clerk (Requestor) of this 1358"
. . W !,"Adjustment. You will be unable to approve a 1358 Adjustment on which you"
. . W !,"are the REQUESTOR due to segregation of duties."
. ;
. S DIR(0)="Y",DIR("A")="Do you want to proceed (Y/N)",DIR("B")="NO"
. D ^DIR K DIR I $D(DIRUT)!'Y S RET=1
. W !
;
Q RET
COMCHK ;Check Committed Date to insure it is within the FY/FQ range during option entry for 'NEW 1358' ;PRC*5.1*196
N PRCDT,PRCDT1,PRCTAPPR
S PRCTAPPR=$P($G(^PRC(420,PRC("SITE"),1,+PRC("CP"),4,+PRC("FY"),2)),"^",9) ;PRC*5.1*209 use appropriation code from node 4, check both X and x
I $G(PRCBBMY) S PRCCKERR=0 Q
I '$D(PRC("BBFY"))!(+$P(^PRC(420,PRC("SITE"),1,+PRC("CP"),0),"^",12)>0)!(PRCTAPPR["X")!(PRCTAPPR["x") S PRC("BBFY")=PRC("FY")+2000
S PRCCKERR=0,PRCDT=(PRC("BBFY")-1701)_$P("10:01:04:07",":",PRC("QTR"))_"01",PRCDT1=(PRC("BBFY")-1700)_"0930"
I PRCCOMDT<PRCDT!(PRCCOMDT>PRCDT1) D
. S PRCCKERR=1
. W !!," ** Date Committed must be specified for time **",!," ** period covered by fiscal year ",PRC("BBFY")," **",!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCEN 8747 printed Oct 16, 2024@18:02:16 Page 2
PRCEN ;WISC/CLH - ENTER/EDIT 1358 ;9/2/2010
V ;;5.1;IFCAP;**23,148,150,196,204,209**;Oct 20, 2000;Build 3
+1 ;Per VA Directive 6402, this routine should not be modified.
+2 ;
+3 ;PRC*5.1*150 RGB 4/23/12 Control the node 0 counter for file 410
+4 ;kill call since DIK call does not handle descending file logic
+5 ;
+6 ;PRC*5.1*196 Check Committed Date for 1358 against FY requested
+7 ; to insure date is within the FY range.
+8 ;
EN ;new 1358 request
+1 NEW PRC,X,X1,DIC,DIE,DR,PRCS2,PRCSL,PRCSIP,DIR,DIRUT,PRCS,PRCSCP,PRCSN
+2 NEW PRCST,PRCST1,PRCSTT,PRC410,PRCUA,PRCAUTH,PRCAUTHS,PRCQ,PRCVEN,PRCONT
EN0 KILL PRC,X,X1,DIC,DIE,DR,PRCS2,PRCSL,PRCSIP,DIR,DIRUT,PRCS,PRCSCP,PRCSN
+1 KILL PRCST,PRCST1,PRCSTT,PRCAED,PRC410,PRCUA,PRCAUTHS
+2 DO EN^PRCSUT
IF '$DATA(PRC("SITE"))
WRITE !!,"You are not an authorized control point user.",!,"Contact your control point official."
HANG 3
QUIT
+3 if '$DATA(PRC("QTR"))!(Y<0)
QUIT
+4 ;
+5 ; warn CP official, allow to quit
+6 if $$Q1358(PRC("SITE"),PRC("CP"))
QUIT
+7 ;
+8 ; ask for 1358 Authority (need to preserve variables)
+9 SET PRCQ=0
Begin DoDot:1
+10 NEW X,Y,DTOUT,DUOUT,DIC
+11 SET DIC="^PRCS(410.9,"
SET DIC(0)="AEMQ"
SET DIC("S")="I Y<100,('$P(^(0),U,4)!($P(^(0),U,4)>DT))"
SET DIC("A")="Select AUTHORITY OF REQUEST: "
DO ^DIC
SET PRCAUTH=+Y
IF Y<1
SET PRCQ=1
QUIT
+12 IF $DATA(^PRCS(410.9,"AC",PRCAUTH))
SET DIC("S")="I $P(^(0),U,3)=PRCAUTH,('$P(^(0),U,4)!($P(^(0),U,4)>DT))"
SET DIC("A")="Select SUB-AUTHORITY OF REQUEST: "
DO ^DIC
SET PRCAUTHS=+Y
IF Y<1
SET PRCQ=1
End DoDot:1
+13 if PRCQ
QUIT
+14 DO EN1^PRCSUT3
if 'X
QUIT
+15 SET X1=X
DO EN2^PRCSUT3
if '$DATA(X1)
QUIT
SET X=X1
WRITE !!,"This transaction is assigned Transaction number: ",X
+16 SET PRC410=DA
+17 Begin DoDot:1
+18 LOCK +^PRCS(410,DA):$SELECT($DATA(DILOCKTM):DILOCKTM,1:3)
+19 IF '$TEST
DO EN^DDIOL("Transaction is being accessed by another user!")
KILL DA
+20 QUIT
End DoDot:1
if '$DATA(DA)
GOTO EN0
+21 IF $DATA(^PRC(420,PRC("SITE"),1,+PRC("CP"),0))
if $PIECE(^(0),"^",11)="Y"
SET PRCS2=1
+22 SET DIC(0)="AEMQ"
SET DIE=DIC
SET DR="3///1"_$SELECT($DATA(PRCSIP):";4////"_PRCSIP,1:"")_";19////^S X=PRCAUTH"_$SELECT($GET(PRCAUTHS):";19.1////^S X=PRCAUTHS",1:"")
SET X4=1
DO ^DIE
+23 SET PRCAED=1
SET PRCUA=""
+24 ; define if fields need to be required or not
+25 SET PRCVEN=^PRCS(410.9,$SELECT($GET(PRCAUTHS):PRCAUTHS,1:PRCAUTH),0)
SET PRCONT=$PIECE(PRCVEN,"^",6)
SET PRCVEN=$PIECE(PRCVEN,"^",5)
+26 SET DR="[PRCE NEW 1358]"
DO ^DIE
+27 IF $DATA(Y)#10
SET PRCUA=1
DO YN^PRC0A(.X,.Y,"Delete this NEW entry","","No")
IF Y=1
Begin DoDot:1
+28 ;PRC*5.1*150
SET PRCIENCT=$PIECE(^PRCS(410,0),"^",3)+1
+29 DO DELETE^PRC0B1(.X,"410;^PRCS(410,;"_DA)
if X=1
SET PRCAED=-1
+30 ;PRC*5.1*150
IF X=1
SET $PIECE(^PRCS(410,0),"^",3)=PRCIENCT
+31 ;PRC*5.1*150
KILL PRCIENCT
+32 DO EN^DDIOL(" **** NEW ENTRY IS "_$SELECT(X=1:"",1:"NOT ")_"DELETED ****")
+33 QUIT
End DoDot:1
+34 IF PRCAED'=-1
Begin DoDot:1
+35 if $ORDER(^PRCS(410,DA,12,0))
DO SCPC0^PRCSED
+36 KILL PRCSF
+37 DO W1^PRCSEB
+38 IF $DATA(PRCS2)
IF +^PRCS(410,DA,0)
IF 'PRCUA
IF $$CHECK(PRC410)
Begin DoDot:2
+39 DO W6^PRCSEB
+40 QUIT
End DoDot:2
+41 QUIT
End DoDot:1
+42 LOCK -^PRCS(410,PRC410)
+43 SET DIR("B")="NO"
SET DIR(0)="Y"
SET DIR("A")="Do you want to enter another NEW request"
DO ^DIR
if 'Y!($DATA(DIRUT))
QUIT
+44 WRITE !!
KILL PRCS2
GOTO EN0
+45 QUIT
ED ;edit 1358
+1 NEW PRC410,PRC442,PRCHQ,PRCSDR,PRCSN,PRCST,PRCST1,Y,PRC,PRCS,TT,DIE,DA,DIC
+2 NEW DR,DIR,PRCSY,PRCSL,X,X1,T,T1,Z,PRCSDA,DTOUT,PRCVEN,PRCONT
ED0 KILL PRCHQ,PRCSDR,PRCSN,PRCST,PRCST1,Y,PRC,PRCS,TT,DIE,DA,DIC,DR,DIR,PRCSY
+1 KILL PRCSL,X,X1,T,T1,Z,PRCSDA
+2 DO EN3^PRCSUT
IF '$DATA(PRC("SITE"))
WRITE !!,"You are not an authorized control point user.",!,"Contact your control point official."
HANG 3
QUIT
+3 if Y<0
QUIT
+4 SET DIC="^PRCS(410,"
SET DIE=DIC
SET DIC(0)="AEQM"
SET DIC("S")="I $P(^(0),U,4)=1,+$P(^(0),U)'=0,$D(^(3)),+^(3)=+PRC(""CP""),$P(^(0),""^"",5)=PRC(""SITE"") I $D(^PRC(420,""A"",DUZ,PRC(""SITE""),+PRC(""CP""),1))!($D(^(2)))"
+5 ;D LOCK^PRCSUT G ED0:PRCSL=0
DO ^PRCSDIC
if Y<0
QUIT
KILL DIC("S")
SET (DA,PRCSY,PRCSDA)=+Y
+6 Begin DoDot:1
+7 LOCK +^PRCS(410,DA):$SELECT($DATA(DILOCKTM):DILOCKTM,1:3)
+8 IF '$TEST
DO EN^DDIOL("Another user is editing this transaction! Try Later")
KILL DA
+9 QUIT
End DoDot:1
if '$DATA(DA)
GOTO ED0
+10 DO NODE^PRCS58OB(DA,.TRNODE)
SET PRC410=DA
+11 SET X=^PRCS(410,DA,0)
if +X
SET PRC("FY")=$PIECE(X,"-",2)
SET PRC("QTR")=+$PIECE(X,"-",3)
SET TT=$PIECE(X,"^",2)
+12 DO EN2B^PRCSUT3
+13 ;if obligated
IF $DATA(^PRCS(410,DA,7))
IF $PIECE(^(7),U,6)]""
DO SCPE
GOTO OUT
ED1 IF TT="CA"
SET DR="[PRCSENCT]"
SET DIE=DIC
DO ^DIE
SET DA=PRCSY
LOCK -^PRCS(410,PRCSY)
GOTO ED0
+1 ; warn CP offical and allow to quit
+2 IF $$Q1358(PRC("SITE"),PRC("CP"),$GET(TT),$GET(DA))
LOCK -^PRCS(410,PRCSY)
GOTO ED0
+3 ;
+4 ; patch 23, fix problem of not able to exit with "^"
+5 IF TT'="O"
SET DR="[PRCSENA 1358]"
SET DIE=DIC
DO ^DIE
if $DATA(Y)>9
LOCK -^PRCS(410,PRCSY)
if $DATA(Y)>9
GOTO ED0
SET DA=PRCSY
+6 IF TT="A"
SET PRC442=$PIECE($GET(^PRCS(410,PRC410,10)),U,3)
IF PRC442
if $$EN1^PRCE0A(PRC410,PRC442,1)
GOTO ED1
+7 IF TT="A"
IF $PIECE(^PRCS(410,DA,0),U,4)=1
SET X=$PIECE(^(4),U,6)
SET X1=$PIECE(^(3),U,7)
IF $JUSTIFY(X,0,2)'=$JUSTIFY(X1,0,2)!('X)!('X1)
WRITE $CHAR(7),!,"Adj $ Amt does not equal the total of BOC $ Amts.",!,"Please correct the error.",!
KILL DR
GOTO ED1
+8 if TT="A"&($ORDER(^PRCS(410,PRCSY,12,0)))
DO SCPC0^PRCSED
+9 IF TT="A"
DO REV
if $$CHECK(PRC410)
DO W6^PRCSEB
GOTO OUT
+10 ;
+11 SET DR="[PRCE NEW 1358]"
DO ^DIE
DO REV
if $$CHECK(PRC410)
DO W6^PRCSEB
+12 SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("A")="Do you want to edit another request"
DO ^DIR
if 'Y!($DATA(DIRUT))
GOTO OUT
+13 LOCK -^PRCS(410,PRCSDA)
+14 GOTO ED0
SCPE ;sub control point edit
+1 SET DR="[PRCSEDS]"
DO ^DIE
REV WRITE !!,"Would you like to review this request"
SET %=2
DO YN^DICN
if %=0
GOTO REV
if %'=1
QUIT
SET (N,PRCSZ)=DA
SET PRCSF=1
DO PRF1^PRCSP1
SET DA=PRCSZ
KILL X,PRCSF,PRCSZ
QUIT
OUT LOCK -^PRCS(410,PRCSDA)
QUIT
+1 ;
CHECK(PRC410) ; - Check out a 1358 410 entry for required fields
+1 NEW PRCX,PRC0,PRC11,PRCER,PRC3,PRC1
+2 if '$GET(PRC410)
QUIT -1
+3 ;
+4 ; get data
+5 FOR PRCX=0,1,3,11
SET @("PRC"_PRCX)=$GET(^PRCS(410,PRC410,PRCX))
+6 SET PRCX=$GET(^PRCS(410.9,$SELECT(+$PIECE(PRC11,"^",5):+$PIECE(PRC11,"^",5),1:+$PIECE(PRC11,"^",4)),0))
+7 SET PRCER=0
+8 ;
+9 ; make sure I have a 1358
+10 IF $PIECE(PRC0,"^",4)'=1
QUIT 1
+11 ;
+12 ; start checking out data
+13 IF '$DATA(^PRCS(410,PRC410,8,1,0))
DO CKER("PURPOSE is Missing")
+14 ;
+15 ; done checking if not an obligation
+16 IF $PIECE(PRC0,"^",2)'="O"
GOTO CKEX
+17 ;
+18 ; continue checking
+19 IF '$PIECE(PRC11,"^",4)
DO CKER("AUTHORITY is Missing")
+20 IF $PIECE(PRC11,"^",5)
IF '$DATA(^PRCS(410.9,"AC",$PIECE(PRC11,"^",4),$PIECE(PRC11,"^",5)))
DO CKER("SUB-AUTHORITY does not correspond to AUTHORITY")
+21 IF '$PIECE(PRC11,"^",5)
IF $ORDER(^PRCS(410.9,"AC",+$PIECE(PRC11,"^",4),0))
DO CKER("SUB-AUTHORITY is Missing")
+22 IF $PIECE(PRCX,"^",5)
IF '$PIECE(PRC3,"^",4)
DO CKER("VENDOR is Missing")
+23 IF $PIECE(PRCX,"^",6)
IF '$LENGTH($PIECE(PRC3,"^",10))
DO CKER("CONTRACT is Missing")
+24 IF '$PIECE(PRC1,"^",6)
DO CKER("Service Start Date is Missing")
+25 IF '$PIECE(PRC1,"^",7)
DO CKER("Service End Date is Missing")
+26 ;
CKEX IF PRCER
SET PRCER=0
FOR
SET PRCER=$ORDER(PRCER(PRCER))
if 'PRCER
QUIT
WRITE !?5,PRCER(PRCER),"!!!"
+1 QUIT $SELECT($ORDER(PRCER(0)):0,1:1)
+2 ;
CKER(X) ;
+1 SET PRCER=PRCER+1
+2 SET PRCER(PRCER)=X
+3 QUIT
+4 ;
Q1358(PRCSTA,PRCFCP,PRCTT,PRCDA) ; Quit 1358 Process
+1 ; This API warns a control point offical that they will be set as
+2 ; the requestor on the 1358 and thus cannot also approve it.
+3 ; The API will return 1 (true) if the user decided to quit the
+4 ; current process before being set as the requestor.
+5 ;
+6 ; inputs
+7 ; PRCSTA - station number
+8 ; PRCFCP - fund control point
+9 ; PRCTT - (optional) transaction type, pass "A" for adjustment
+10 ; PRCDA - (optional) file 410 ien of 1358 when editing 1358
+11 ; returns boolean value (0 or 1)
+12 ; = 0 to proceed with process
+13 ; = 1 to quit process
+14 ;
+15 NEW RET
+16 ; init value to return
SET RET=0
+17 ;
+18 ; if user is control point official for input station and FCP
+19 IF $GET(PRCSTA)]""
IF $GET(PRCFCP)]""
IF $DATA(^PRC(420,"A",DUZ,PRCSTA,+PRCFCP,1))
Begin DoDot:1
+20 NEW DA,DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+21 ;
+22 ; don't warn when editing a 1358 if user is already the requestor
+23 IF $GET(PRCDA)
IF $PIECE($GET(^PRCS(410,PRCDA,7)),"^")=DUZ
QUIT
+24 ;
+25 IF $GET(PRCTT)'="A"
Begin DoDot:2
+26 WRITE !,"WARNING: The system will assign you as the CP Clerk (Requestor) of this 1358."
+27 WRITE !,"You will be unable to approve a 1358 on which you are the REQUESTOR due to"
+28 WRITE !,"segregation of duties."
End DoDot:2
+29 IF $GET(PRCTT)="A"
Begin DoDot:2
+30 WRITE !,"WARNING: The system will assign you as the CP Clerk (Requestor) of this 1358"
+31 WRITE !,"Adjustment. You will be unable to approve a 1358 Adjustment on which you"
+32 WRITE !,"are the REQUESTOR due to segregation of duties."
End DoDot:2
+33 ;
+34 SET DIR(0)="Y"
SET DIR("A")="Do you want to proceed (Y/N)"
SET DIR("B")="NO"
+35 DO ^DIR
KILL DIR
IF $DATA(DIRUT)!'Y
SET RET=1
+36 WRITE !
End DoDot:1
+37 ;
+38 QUIT RET
COMCHK ;Check Committed Date to insure it is within the FY/FQ range during option entry for 'NEW 1358' ;PRC*5.1*196
+1 NEW PRCDT,PRCDT1,PRCTAPPR
+2 ;PRC*5.1*209 use appropriation code from node 4, check both X and x
SET PRCTAPPR=$PIECE($GET(^PRC(420,PRC("SITE"),1,+PRC("CP"),4,+PRC("FY"),2)),"^",9)
+3 IF $GET(PRCBBMY)
SET PRCCKERR=0
QUIT
+4 IF '$DATA(PRC("BBFY"))!(+$PIECE(^PRC(420,PRC("SITE"),1,+PRC("CP"),0),"^",12)>0)!(PRCTAPPR["X")!(PRCTAPPR["x")
SET PRC("BBFY")=PRC("FY")+2000
+5 SET PRCCKERR=0
SET PRCDT=(PRC("BBFY")-1701)_$PIECE("10:01:04:07",":",PRC("QTR"))_"01"
SET PRCDT1=(PRC("BBFY")-1700)_"0930"
+6 IF PRCCOMDT<PRCDT!(PRCCOMDT>PRCDT1)
Begin DoDot:1
+7 SET PRCCKERR=1
+8 WRITE !!," ** Date Committed must be specified for time **",!," ** period covered by fiscal year ",PRC("BBFY")," **",!
End DoDot:1
+9 QUIT
