- 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 Jan 18, 2025@03:18:23 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
- 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.