PRCSAPP1 ;WISC/KMB-CHECK 2237 BEFORE APPROVAL ;12/17/93
;;5.1;IFCAP;**148,174**;Oct 20, 2000;Build 23
;Per VHA Directive 2004-038, this routine should not be modified.
CHEC ;
I +$P(^PRCS(410,DA,0),"-")'=PRC("SITE") S SPENDCP=1 G EVAL
I +$P(^PRCS(410,DA,0),"-",4)'=PRC("CP") S SPENDCP=2 G EVAL
S D0=DA,DIC="^PRCS(410," L +^PRCS(410,DA):5 W @IOF D ^PRCST5 H 1
L -^PRCS(410,DA)
I $D(^PRCS(410,DA,7)),$P(^(7),U,6)'="" S SPENDCP=3 D EVAL Q
S:'$D(^PRCS(410,DA,11)) ^(11)="" I '$P(^(11),U,3) S SPENDCP=4 D EVAL Q
; PRC*5.1*148
I $P(^PRCS(410,DA,0),"^",11)="" D ERS410^PRC0G(DA)
S PRCSN=^PRCS(410,DA,0),PRCHQ=$P(PRCSN,"^",4),PRC("FY")=$P(PRCSN,"-",2),PRC("QTR")=$P(PRCSN,"-",3)
T1 ; this is the 'jump' entry point for the CP official
; to approve a request just after s/he creates it
I '$D(ALL) N JUMP,ALL S JUMP=1,ALL=0
N ESTSHP,CST S ESTSHP=$P($G(^PRCS(410,DA,9)),"^",4),CST=$P($G(^PRCS(410,DA,4)),"^",8)
S PRC("RBDT")=$P(^PRCS(410,DA,0),"^",11),PRCST1=$$DATE^PRC0C(PRC("RBDT"),"I")
S PRCST1=$S($D(^PRC(420,PRC("SITE"),1,+PRC("CP"),4,$E($P(PRCST1,"^"),3,4),0)):$P(^(0),U,$P(PRCST1,"^",2)+1),1:0),PRCST=$S($D(^PRCS(410,DA,4)):$P(^(4),U,8),1:0)
S PRCST=ESTSHP+CST I PRCST<0,$P(^PRCS(410,DA,0),"^",4)'=1 S SPENDCP=9 D EVAL Q
;Check for different costs
N PRCCOMCT,PRCBOCCT
S PRCCOMCT=$S($D(^PRCS(410,DA,4)):$P(^(4),"^"),1:0)
S PRCBOCCT=$S($D(^PRCS(410,DA,3)):$P(^(3),"^",7),1:0)
I $P(^PRCS(410,DA,0),"^",2)="O",$P(^(0),"^",4)=1,$J(PRCCOMCT,0,2)'=$J(PRCBOCCT,0,2) S SPENDCP=10 D EVAL Q
;
W !,"Current Control Point balance: $",$J(PRCST1,0,2),!,"Estimated cost of this request: $",$J(PRCST,0,2) H 1
T2 ;
;N ALLTOT,MINUS S ALLTOT=0 F Z=2:1:PRC("QTR")+1 S ALLTOT=ALLTOT+$P($G(^PRC(420,PRC("SITE"),1,+PRC("CP"),4,PRC("FY"),0)),"^",Z)
;S MINUS="" I ALLTOT<0 S ALLTOT=-ALLTOT,MINUS="-"
;W !,"Total uncommitted balance from current and prior quarters: ",MINUS,"$",$J(ALLTOT,0,2),!
Q:$D(REPORT2)
;S STRING=PRC("SITE")_"^"_PRC("CP")_"^"_PRC("FY")_"^"_PRC("QTR")
;S TEST=$$YEAR^PRC0C(PRC("FY"))'<$$DATE^PRC0C("N","E")
;I TEST S TEST=$$OVCOM^PRCS0A(STRING,PRCST,2) I TEST'=0 S SPENDCP=5 D EVAL Q
I $$OVCOM^PRCS0A(PRC("SITE")_"^"_PRC("CP")_"^"_$P($$DATE^PRC0C(PRC("RBDT"),"I"),"^",1,2),PRCST,2)'=0 S SPENDCP=5 D EVAL Q
I $P(PRCSN,"^",4)="" S SPENDCP=6 D EVAL Q
I $P(PRCSN,"^",4)>1,'$D(^PRCS(410,DA,"IT",0)) S SPENDCP=7 D EVAL Q
I +$P(^PRCS(410,DA,3),"^",3)=0 S SPENDCP=8 D EVAL Q
I '$$CHECK^PRCEN(DA) S SPENDCP=11 D EVAL Q
;*****PRC*5.1*174 start*****
N PRCHJFT,PRCFAIL
S PRCHJFT=$P(^PRCS(410,DA,0),"^",4) ;Form Type
;if 2237 transaction (Form Type IEN 2,3, or 4) DO block
I $G(PRCHJFT)>1&($G(PRCHJFT)<5) D
. ;if 2237 required fields are missing DO block
. N PRCWARN
. I '$$REQCHECK^PRCHJUTL(DA,.PRCWARN) D
. . S PRCFAIL=1
. . N PRCIDX S PRCIDX=0
. . W !!,"WARNING - Transaction "_$$GET1^DIQ(410,DA,.01)_" is missing required data!",*7
. . F S PRCIDX=$O(PRCWARN(PRCIDX)) Q:'PRCIDX D
. . . W !?2,">>> "_$G(PRCWARN(PRCIDX))
;if 2237 missing data, output msg to user and quit (don't allow approval)
I $G(PRCFAIL) S SPENDCP=12 D EVAL Q
;*****PRC*5.1*174 end*****
S OK=1 QUIT
EVAL ;
I SPENDCP'=0 W !,$P($T(MESSAGE+SPENDCP),";;",2) H 2 Q:$D(JUMP) R !!,"Press return to continue: ",X:DTIME I X["^" D
.I ALL=0 S STOP1=-1 Q
.S %=1 W !,"Continue looping through your control points" D YN^DICN I %=2 S STOP1=-1 Q
.I %=0 W !,"Enter yes or no. Continue" S %=1 D YN^DICN S:%<2 STOP1=-1
Q
MESSAGE ;
;;This transaction was not entered for your site
;;This transaction was not entered for your control point
;;This transaction has already been approved!
;;This transaction is not ready for approval
;;You do not have the funds to approve this request
;;This request does not have a form type
;;Requests without items cannot be approved
;;This transaction does not have a cost center
;;This request has a negative dollar amount
;;Committed Cost does not equal BOC $ Amount - Please re-edit.
;;Missing required data, request needs to be edited.
;;Missing required data, 2237 request needs to be edited prior to approval.
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSAPP1 4133 printed Apr 09, 2024@21:05:02 Page 2
PRCSAPP1 ;WISC/KMB-CHECK 2237 BEFORE APPROVAL ;12/17/93
+1 ;;5.1;IFCAP;**148,174**;Oct 20, 2000;Build 23
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
CHEC ;
+1 IF +$PIECE(^PRCS(410,DA,0),"-")'=PRC("SITE")
SET SPENDCP=1
GOTO EVAL
+2 IF +$PIECE(^PRCS(410,DA,0),"-",4)'=PRC("CP")
SET SPENDCP=2
GOTO EVAL
+3 SET D0=DA
SET DIC="^PRCS(410,"
LOCK +^PRCS(410,DA):5
WRITE @IOF
DO ^PRCST5
HANG 1
+4 LOCK -^PRCS(410,DA)
+5 IF $DATA(^PRCS(410,DA,7))
IF $PIECE(^(7),U,6)'=""
SET SPENDCP=3
DO EVAL
QUIT
+6 if '$DATA(^PRCS(410,DA,11))
SET ^(11)=""
IF '$PIECE(^(11),U,3)
SET SPENDCP=4
DO EVAL
QUIT
+7 ; PRC*5.1*148
+8 IF $PIECE(^PRCS(410,DA,0),"^",11)=""
DO ERS410^PRC0G(DA)
+9 SET PRCSN=^PRCS(410,DA,0)
SET PRCHQ=$PIECE(PRCSN,"^",4)
SET PRC("FY")=$PIECE(PRCSN,"-",2)
SET PRC("QTR")=$PIECE(PRCSN,"-",3)
T1 ; this is the 'jump' entry point for the CP official
+1 ; to approve a request just after s/he creates it
+2 IF '$DATA(ALL)
NEW JUMP,ALL
SET JUMP=1
SET ALL=0
+3 NEW ESTSHP,CST
SET ESTSHP=$PIECE($GET(^PRCS(410,DA,9)),"^",4)
SET CST=$PIECE($GET(^PRCS(410,DA,4)),"^",8)
+4 SET PRC("RBDT")=$PIECE(^PRCS(410,DA,0),"^",11)
SET PRCST1=$$DATE^PRC0C(PRC("RBDT"),"I")
+5 SET PRCST1=$SELECT($DATA(^PRC(420,PRC("SITE"),1,+PRC("CP"),4,$EXTRACT($PIECE(PRCST1,"^"),3,4),0)):$PIECE(^(0),U,$PIECE(PRCST1,"^",2)+1),1:0)
SET PRCST=$SELECT($DATA(^PRCS(410,DA,4)):$PIECE(^(4),U,8),1:0)
+6 SET PRCST=ESTSHP+CST
IF PRCST<0
IF $PIECE(^PRCS(410,DA,0),"^",4)'=1
SET SPENDCP=9
DO EVAL
QUIT
+7 ;Check for different costs
+8 NEW PRCCOMCT,PRCBOCCT
+9 SET PRCCOMCT=$SELECT($DATA(^PRCS(410,DA,4)):$PIECE(^(4),"^"),1:0)
+10 SET PRCBOCCT=$SELECT($DATA(^PRCS(410,DA,3)):$PIECE(^(3),"^",7),1:0)
+11 IF $PIECE(^PRCS(410,DA,0),"^",2)="O"
IF $PIECE(^(0),"^",4)=1
IF $JUSTIFY(PRCCOMCT,0,2)'=$JUSTIFY(PRCBOCCT,0,2)
SET SPENDCP=10
DO EVAL
QUIT
+12 ;
+13 WRITE !,"Current Control Point balance: $",$JUSTIFY(PRCST1,0,2),!,"Estimated cost of this request: $",$JUSTIFY(PRCST,0,2)
HANG 1
T2 ;
+1 ;N ALLTOT,MINUS S ALLTOT=0 F Z=2:1:PRC("QTR")+1 S ALLTOT=ALLTOT+$P($G(^PRC(420,PRC("SITE"),1,+PRC("CP"),4,PRC("FY"),0)),"^",Z)
+2 ;S MINUS="" I ALLTOT<0 S ALLTOT=-ALLTOT,MINUS="-"
+3 ;W !,"Total uncommitted balance from current and prior quarters: ",MINUS,"$",$J(ALLTOT,0,2),!
+4 if $DATA(REPORT2)
QUIT
+5 ;S STRING=PRC("SITE")_"^"_PRC("CP")_"^"_PRC("FY")_"^"_PRC("QTR")
+6 ;S TEST=$$YEAR^PRC0C(PRC("FY"))'<$$DATE^PRC0C("N","E")
+7 ;I TEST S TEST=$$OVCOM^PRCS0A(STRING,PRCST,2) I TEST'=0 S SPENDCP=5 D EVAL Q
+8 IF $$OVCOM^PRCS0A(PRC("SITE")_"^"_PRC("CP")_"^"_$PIECE($$DATE^PRC0C(PRC("RBDT"),"I"),"^",1,2),PRCST,2)'=0
SET SPENDCP=5
DO EVAL
QUIT
+9 IF $PIECE(PRCSN,"^",4)=""
SET SPENDCP=6
DO EVAL
QUIT
+10 IF $PIECE(PRCSN,"^",4)>1
IF '$DATA(^PRCS(410,DA,"IT",0))
SET SPENDCP=7
DO EVAL
QUIT
+11 IF +$PIECE(^PRCS(410,DA,3),"^",3)=0
SET SPENDCP=8
DO EVAL
QUIT
+12 IF '$$CHECK^PRCEN(DA)
SET SPENDCP=11
DO EVAL
QUIT
+13 ;*****PRC*5.1*174 start*****
+14 NEW PRCHJFT,PRCFAIL
+15 ;Form Type
SET PRCHJFT=$PIECE(^PRCS(410,DA,0),"^",4)
+16 ;if 2237 transaction (Form Type IEN 2,3, or 4) DO block
+17 IF $GET(PRCHJFT)>1&($GET(PRCHJFT)<5)
Begin DoDot:1
+18 ;if 2237 required fields are missing DO block
+19 NEW PRCWARN
+20 IF '$$REQCHECK^PRCHJUTL(DA,.PRCWARN)
Begin DoDot:2
+21 SET PRCFAIL=1
+22 NEW PRCIDX
SET PRCIDX=0
+23 WRITE !!,"WARNING - Transaction "_$$GET1^DIQ(410,DA,.01)_" is missing required data!",*7
+24 FOR
SET PRCIDX=$ORDER(PRCWARN(PRCIDX))
if 'PRCIDX
QUIT
Begin DoDot:3
+25 WRITE !?2,">>> "_$GET(PRCWARN(PRCIDX))
End DoDot:3
End DoDot:2
End DoDot:1
+26 ;if 2237 missing data, output msg to user and quit (don't allow approval)
+27 IF $GET(PRCFAIL)
SET SPENDCP=12
DO EVAL
QUIT
+28 ;*****PRC*5.1*174 end*****
+29 SET OK=1
QUIT
EVAL ;
+1 IF SPENDCP'=0
WRITE !,$PIECE($TEXT(MESSAGE+SPENDCP),";;",2)
HANG 2
if $DATA(JUMP)
QUIT
READ !!,"Press return to continue: ",X:DTIME
IF X["^"
Begin DoDot:1
+2 IF ALL=0
SET STOP1=-1
QUIT
+3 SET %=1
Press return to continue: WRITE !,"Continue looping through your control points"
DO YN^DICN
IF %=2
SET STOP1=-1
QUIT
+4 IF %=0
WRITE !,"Enter yes or no. Continue"
SET %=1
DO YN^DICN
if %<2
SET STOP1=-1
End DoDot:1
+5 QUIT
MESSAGE ;
+1 ;;This transaction was not entered for your site
+2 ;;This transaction was not entered for your control point
+3 ;;This transaction has already been approved!
+4 ;;This transaction is not ready for approval
+5 ;;You do not have the funds to approve this request
+6 ;;This request does not have a form type
+7 ;;Requests without items cannot be approved
+8 ;;This transaction does not have a cost center
+9 ;;This request has a negative dollar amount
+10 ;;Committed Cost does not equal BOC $ Amount - Please re-edit.
+11 ;;Missing required data, request needs to be edited.
+12 ;;Missing required data, 2237 request needs to be edited prior to approval.
