- PRCB1E1 ;WISC/PLT/BGJ-PRCB1E continue ;1/8/97 12:55
- V ;;5.1;IFCAP;**145**;Oct 20, 2000;Build 3
- ;Per VHA Directive 2004-038, this routine should not be modified.
- QUIT ;invalid entry
- ;
- ;prcduz - user id #
- ;prcopt data ^1=option #, ^2=yyyy-q, ^3=station #, ^4=cp ri
- ;prcdes = description
- TMEN ;carry forward
- N PRCA,PRCB,PRCD,PRCE,PRCDI,PRCRICB,PRCLOCK,PRCRI
- N A,B,C
- I $D(ZTQUEUED) D KILL^%ZTLOAD
- ;from quarter, prcopt data ^5=from qtr bd, ^6=to qtr bd, ^7=to fy (yyyy)-qtr
- I $P(PRCOPT,"^",2)'?4N1"-"1N D EN^DDIOL("CARRY FORWARD FAILS WITH WRONG YEAR FORMAT.") QUIT
- S A=$P(PRCOPT,"^",2),A=$$QTRDATE^PRC0D(+A,$P(A,"-",2))
- S $P(PRCOPT,"^",5)=$P(A,"^",7)
- ;to quarter
- S A=$$DATE^PRC0C($P(A,"^",8)+100,"H"),A=$$QTRDATE^PRC0D(+A,$P(A,"^",2))
- S $P(PRCOPT,"^",6)=$P(A,"^",7),$P(PRCOPT,"^",7)=$P(A,"^")_"-"_$P(A,"^",2)
- S PRCDES=PRCDES_" to "_$E($P(PRCOPT,"^",7),3,999)
- D EN^DDIOL(PRCDES)
- S A=$$DATE^PRC0C("T","E"),A=$P(A,"^",4)_"/"_$P(A,"^",5)_"/"_$P(A,"^",3)
- S PRC("SITE")=$P(PRCOPT,"^",3)
- D EN^DDIOL("Station: "_PRC("SITE")_" Printed on "_A)
- S B=3 D ICLOCK^PRC0B("^PRCS(410,"""_PRCOPT_""",",.B)
- I 'B D EN^DDIOL(" Another Carry Forward job is running, try later!") QUIT
- I $P(PRCOPT,"^")=3 D FCPBAL(PRCOPT,$P(PRCOPT,"^",4)),CPBAL^PRCB1E2(PRCOPT,$P(PRCOPT,"^",4)) I 1
- E I $P(PRCOPT,"^")=1,$P(PRCOPT,"^",2)["-4",$P(^PRC(411,PRC("SITE"),0),"^",25)'="Y" D EN^DDIOL("The outstanding requests are not carried forward to the new fiscal year.") I 1
- E S PRCRI(420.01)=0 F S PRCRI(420.01)=$O(^PRC(420,+PRC("SITE"),1,PRCRI(420.01))) Q:PRCRI(420.01)>9998!'PRCRI(420.01) S PRCD=$G(^(PRCRI(420.01),0)) I PRCD]"",'$P(PRCD,"^",19) D
- . D:"1"[$P(PRCOPT,"^") FCPUOB(PRCOPT,+PRCD)
- . D:"2"[$P(PRCOPT,"^") FCPBAL(PRCOPT,+PRCD),CPBAL^PRCB1E2(PRCOPT,+PRCD)
- . QUIT
- I "1"[$P(PRCOPT,"^"),$P(^PRC(420,+PRC("SITE"),0),"^",9)<$P(PRCOPT,"^",6) D EDIT^PRC0B(.X,"420;^PRC(420,;"_(+PRC("SITE")),"9////"_$P(PRCOPT,"^",6),"SL")
- D DCLOCK^PRC0B("^PRCS(410,"""_PRCOPT_""",")
- D EN^DDIOL("End of Report at "_$$NOW^PRC5A)
- EXIT QUIT
- ;
- ;prca = prcopt, prcb=fund control point ri
- FCPUOB(PRCA,PRCB) ;carry forward all unobligated request to new quarte and
- N PRC,PRCRI,PRCC,PRCD,PRCE,PRCF,PRCG
- N A,B,C,X,Y
- S PRC("SITE")=$P(PRCA,"^",3),PRCRI(420)=+PRC("SITE"),PRCRI(420.01)=+PRCB
- S PRC("CP")=$P($G(^PRC(420,PRCRI(420),1,PRCRI(420.01),0)),"^")
- S PRCC=$$QTRDT^PRC0G(PRCRI(420)_"^"_PRCRI(420.01)_"^"_+$P(PRCA,"^",2)_"^"_"F")
- QUIT:$P(PRCA,"^",5)'<$P(PRCC,"^",2) ;last qtr always open
- S PRCD=$P(PRCA,"^",5)_"-"_PRC("SITE")_"-"_$P(PRC("CP")," ")_"-",PRCE=PRCD_"~"
- F S PRCD=$O(^PRCS(410,"RB",PRCD)),PRCRI(410)=0 QUIT:PRCD]PRCE!'PRCD D
- . F S PRCRI(410)=$O(^PRCS(410,"RB",PRCD,PRCRI(410))) Q:'PRCRI(410) D
- .. S PRCF=$G(^PRCS(410,PRCRI(410),0)),PRCG=$P(PRCF,"^",12),PRCH=-$P($G(^(4)),"^",8)
- .. ;credit back the approved requests committed charge
- .. I PRCG="A" S B=$P(PRCA,"^",2) D EBAL^PRCSEZ(PRCRI(420)_"^"_PRCRI(420.01)_"^"_$E(B,3,4)_"^"_$P(B,"-",2)_"^"_PRCH,"C")
- .. I "EA"[PRCG D EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"449////"_$P(PRCA,"^",6),"LS")
- .. ;if approved charge to new quarter
- .. I PRCG="A" S B=$P(PRCA,"^",7) D EBAL^PRCSEZ(PRCRI(420)_"^"_PRCRI(420.01)_"^"_$E(B,3,4)_"^"_$P(B,"-",2)_"^"_-PRCH,"C")
- .. I "EA"[PRCG W !,$P(PRCF,"^",1),?20,$S(PRCG="E":"ENTERED",1:"APPROVED")
- .. QUIT
- QUIT
- ;
- ;prca = prcopt, prcb=fund control point ri
- FCPBAL(PRCA,PRCB) ;carry forward cp ballance
- N PRC,PRCRI,PRCC,PRCD,PRCCOM,PRCOBL
- N A,B,C,X,Y,Z,DA
- S PRC("SITE")=$P(PRCA,"^",3),PRCRI(420)=+PRC("SITE"),PRCRI(420.01)=+PRCB
- S PRC("CP")=$P($G(^PRC(420,PRCRI(420),1,PRCRI(420.01),0)),"^")
- S PRCC=$$QTRDT^PRC0G(PRCRI(420)_"^"_PRCRI(420.01)_"^"_+$P(PRCA,"^",2)_"^"_"F")
- QUIT:$P(PRCA,"^",5)'<$P(PRCC,"^",2) ;last qtr always open
- S A=$P(PRCOPT,"^",2),PRC("FY")=$E(A,3,4),PRC("QTR")=$P(A,"-",2)
- L +^PRC(420,PRCRI(420),1,PRCRI(420.01),4,PRC("FY"),0):5
- E S PRC("MSG")="Note: Carry forward from "_$P(PRC("CP")," ")_" failed. File locked by another user." D EN^DDIOL(PRC("MSG")) QUIT
- S A=$G(^PRC(420,PRCRI(420),1,PRCRI(420.01),4,PRC("FY"),0))
- L -^PRC(420,PRCRI(420),1,PRCRI(420.01),4,PRC("FY"),0)
- QUIT:A=""
- S PRCCOM=-$P(A,"^",1+PRC("QTR")),PRCOBL=-$P(A,"^",5+PRC("QTR"))
- I +PRCOBL=0 S PRC("MSG")=PRC("CP")_" Qtr "_$E($P(PRCOPT,"^",2),3,999)_" closed. $"_$J(PRCOBL,0,2)_" carried forward."
- ;zero out from quarte balances
- S A=$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),PRC("CP"),1)
- S X=PRC("SITE")_"-"_PRC("FY")_"-"_$P(PRC("CP")," ")
- S Z=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$P(PRC("CP")," ")
- D EN1^PRCSUT3 S PRC("TXNTO")=X D EN2^PRCSUT3 S PRCRI(410)=$G(DA)
- I 'PRCRI(410) S PRC("MSG")="Note: Carry forward 'to' fails for "_$P(PRC("CP")," ")_" $"_$J(PRCOBL,10,2) D EN^DDIOL(PRC("MSG")) G MM
- S A="1///C;40////^S X=PRCDUZ;42////^S X=PRCDUZ;449////"_$P(PRCA,"^",5)_";450////O;35////"_PRCOBL_";24////"_"TO "_$E($P(PRCA,"^",7),3,999)
- D EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),A)
- ;carry forward from qtr balances to new quarter
- S PRCOBL=-PRCOBL
- S A=$P(PRCOPT,"^",7),PRC("FY")=$E(A,3,4),PRC("QTR")=$P(A,"-",2)
- S A=$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),PRC("CP"),1)
- S X=PRC("SITE")_"-"_PRC("FY")_"-"_$P(PRC("CP")," ")
- S Z=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$P(PRC("CP")," ")
- D EN1^PRCSUT3 S PRC("TXNFR")=X D EN2^PRCSUT3 S PRCRI(410)=$G(DA)
- I 'PRCRI(410) S PRC("MSG")="Note: Carry forward 'from' fails for "_$P(PRC("CP")," ")_" $"_$J(PRCOBL,10,2) D EN^DDIOL(PRC("MSG")) G MM
- S A="1///C;40////^S X=PRCDUZ;42////^S X=PRCDUZ;449////"_$P(PRCA,"^",6)_";450////O;35////"_PRCOBL_";24////"_"FROM "_$E($P(PRCA,"^",2),3,999)
- D EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),A)
- S PRC("MSG")=PRC("CP")_" Qtr "_$E($P(PRCOPT,"^",2),3,999)_" closed. $"_$J(PRCOBL,0,2)_" carried forward."
- MM D EN^DDIOL($J($P(PRC("CP")," "),8)_" "_$E($P(PRC("CP")," ",2,999)_$J("",40),1,40)_" (CEI) $"_$J(PRCOBL,0,2)) D:+PRCOBL'=0
- . N A,B,X,Y,XMY
- . D NAMES^PRCBBUL
- . S X(1)=PRC("MSG")
- . D:$O(XMY("")) MM^PRC0B2(PRCDES,"X(",.XMY)
- . QUIT
- QUIT
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCB1E1 6041 printed Feb 18, 2025@23:26:43 Page 2
- PRCB1E1 ;WISC/PLT/BGJ-PRCB1E continue ;1/8/97 12:55
- V ;;5.1;IFCAP;**145**;Oct 20, 2000;Build 3
- +1 ;Per VHA Directive 2004-038, this routine should not be modified.
- +2 ;invalid entry
- QUIT
- +3 ;
- +4 ;prcduz - user id #
- +5 ;prcopt data ^1=option #, ^2=yyyy-q, ^3=station #, ^4=cp ri
- +6 ;prcdes = description
- TMEN ;carry forward
- +1 NEW PRCA,PRCB,PRCD,PRCE,PRCDI,PRCRICB,PRCLOCK,PRCRI
- +2 NEW A,B,C
- +3 IF $DATA(ZTQUEUED)
- DO KILL^%ZTLOAD
- +4 ;from quarter, prcopt data ^5=from qtr bd, ^6=to qtr bd, ^7=to fy (yyyy)-qtr
- +5 IF $PIECE(PRCOPT,"^",2)'?4N1"-"1N
- DO EN^DDIOL("CARRY FORWARD FAILS WITH WRONG YEAR FORMAT.")
- QUIT
- +6 SET A=$PIECE(PRCOPT,"^",2)
- SET A=$$QTRDATE^PRC0D(+A,$PIECE(A,"-",2))
- +7 SET $PIECE(PRCOPT,"^",5)=$PIECE(A,"^",7)
- +8 ;to quarter
- +9 SET A=$$DATE^PRC0C($PIECE(A,"^",8)+100,"H")
- SET A=$$QTRDATE^PRC0D(+A,$PIECE(A,"^",2))
- +10 SET $PIECE(PRCOPT,"^",6)=$PIECE(A,"^",7)
- SET $PIECE(PRCOPT,"^",7)=$PIECE(A,"^")_"-"_$PIECE(A,"^",2)
- +11 SET PRCDES=PRCDES_" to "_$EXTRACT($PIECE(PRCOPT,"^",7),3,999)
- +12 DO EN^DDIOL(PRCDES)
- +13 SET A=$$DATE^PRC0C("T","E")
- SET A=$PIECE(A,"^",4)_"/"_$PIECE(A,"^",5)_"/"_$PIECE(A,"^",3)
- +14 SET PRC("SITE")=$PIECE(PRCOPT,"^",3)
- +15 DO EN^DDIOL("Station: "_PRC("SITE")_" Printed on "_A)
- +16 SET B=3
- DO ICLOCK^PRC0B("^PRCS(410,"""_PRCOPT_""",",.B)
- +17 IF 'B
- DO EN^DDIOL(" Another Carry Forward job is running, try later!")
- QUIT
- +18 IF $PIECE(PRCOPT,"^")=3
- DO FCPBAL(PRCOPT,$PIECE(PRCOPT,"^",4))
- DO CPBAL^PRCB1E2(PRCOPT,$PIECE(PRCOPT,"^",4))
- IF 1
- +19 IF '$TEST
- IF $PIECE(PRCOPT,"^")=1
- IF $PIECE(PRCOPT,"^",2)["-4"
- IF $PIECE(^PRC(411,PRC("SITE"),0),"^",25)'="Y"
- DO EN^DDIOL("The outstanding requests are not carried forward to the new fiscal year.")
- IF 1
- +20 IF '$TEST
- SET PRCRI(420.01)=0
- FOR
- SET PRCRI(420.01)=$ORDER(^PRC(420,+PRC("SITE"),1,PRCRI(420.01)))
- if PRCRI(420.01)>9998!'PRCRI(420.01)
- QUIT
- SET PRCD=$GET(^(PRCRI(420.01),0))
- IF PRCD]""
- IF '$PIECE(PRCD,"^",19)
- Begin DoDot:1
- +21 if "1"[$PIECE(PRCOPT,"^")
- DO FCPUOB(PRCOPT,+PRCD)
- +22 if "2"[$PIECE(PRCOPT,"^")
- DO FCPBAL(PRCOPT,+PRCD)
- DO CPBAL^PRCB1E2(PRCOPT,+PRCD)
- +23 QUIT
- End DoDot:1
- +24 IF "1"[$PIECE(PRCOPT,"^")
- IF $PIECE(^PRC(420,+PRC("SITE"),0),"^",9)<$PIECE(PRCOPT,"^",6)
- DO EDIT^PRC0B(.X,"420;^PRC(420,;"_(+PRC("SITE")),"9////"_$PIECE(PRCOPT,"^",6),"SL")
- +25 DO DCLOCK^PRC0B("^PRCS(410,"""_PRCOPT_""",")
- +26 DO EN^DDIOL("End of Report at "_$$NOW^PRC5A)
- EXIT QUIT
- +1 ;
- +2 ;prca = prcopt, prcb=fund control point ri
- FCPUOB(PRCA,PRCB) ;carry forward all unobligated request to new quarte and
- +1 NEW PRC,PRCRI,PRCC,PRCD,PRCE,PRCF,PRCG
- +2 NEW A,B,C,X,Y
- +3 SET PRC("SITE")=$PIECE(PRCA,"^",3)
- SET PRCRI(420)=+PRC("SITE")
- SET PRCRI(420.01)=+PRCB
- +4 SET PRC("CP")=$PIECE($GET(^PRC(420,PRCRI(420),1,PRCRI(420.01),0)),"^")
- +5 SET PRCC=$$QTRDT^PRC0G(PRCRI(420)_"^"_PRCRI(420.01)_"^"_+$PIECE(PRCA,"^",2)_"^"_"F")
- +6 ;last qtr always open
- if $PIECE(PRCA,"^",5)'<$PIECE(PRCC,"^",2)
- QUIT
- +7 SET PRCD=$PIECE(PRCA,"^",5)_"-"_PRC("SITE")_"-"_$PIECE(PRC("CP")," ")_"-"
- SET PRCE=PRCD_"~"
- +8 FOR
- SET PRCD=$ORDER(^PRCS(410,"RB",PRCD))
- SET PRCRI(410)=0
- if PRCD]PRCE!'PRCD
- QUIT
- Begin DoDot:1
- +9 FOR
- SET PRCRI(410)=$ORDER(^PRCS(410,"RB",PRCD,PRCRI(410)))
- if 'PRCRI(410)
- QUIT
- Begin DoDot:2
- +10 SET PRCF=$GET(^PRCS(410,PRCRI(410),0))
- SET PRCG=$PIECE(PRCF,"^",12)
- SET PRCH=-$PIECE($GET(^(4)),"^",8)
- +11 ;credit back the approved requests committed charge
- +12 IF PRCG="A"
- SET B=$PIECE(PRCA,"^",2)
- DO EBAL^PRCSEZ(PRCRI(420)_"^"_PRCRI(420.01)_"^"_$EXTRACT(B,3,4)_"^"_$PIECE(B,"-",2)_"^"_PRCH,"C")
- +13 IF "EA"[PRCG
- DO EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"449////"_$PIECE(PRCA,"^",6),"LS")
- +14 ;if approved charge to new quarter
- +15 IF PRCG="A"
- SET B=$PIECE(PRCA,"^",7)
- DO EBAL^PRCSEZ(PRCRI(420)_"^"_PRCRI(420.01)_"^"_$EXTRACT(B,3,4)_"^"_$PIECE(B,"-",2)_"^"_-PRCH,"C")
- +16 IF "EA"[PRCG
- WRITE !,$PIECE(PRCF,"^",1),?20,$SELECT(PRCG="E":"ENTERED",1:"APPROVED")
- +17 QUIT
- End DoDot:2
- End DoDot:1
- +18 QUIT
- +19 ;
- +20 ;prca = prcopt, prcb=fund control point ri
- FCPBAL(PRCA,PRCB) ;carry forward cp ballance
- +1 NEW PRC,PRCRI,PRCC,PRCD,PRCCOM,PRCOBL
- +2 NEW A,B,C,X,Y,Z,DA
- +3 SET PRC("SITE")=$PIECE(PRCA,"^",3)
- SET PRCRI(420)=+PRC("SITE")
- SET PRCRI(420.01)=+PRCB
- +4 SET PRC("CP")=$PIECE($GET(^PRC(420,PRCRI(420),1,PRCRI(420.01),0)),"^")
- +5 SET PRCC=$$QTRDT^PRC0G(PRCRI(420)_"^"_PRCRI(420.01)_"^"_+$PIECE(PRCA,"^",2)_"^"_"F")
- +6 ;last qtr always open
- if $PIECE(PRCA,"^",5)'<$PIECE(PRCC,"^",2)
- QUIT
- +7 SET A=$PIECE(PRCOPT,"^",2)
- SET PRC("FY")=$EXTRACT(A,3,4)
- SET PRC("QTR")=$PIECE(A,"-",2)
- +8 LOCK +^PRC(420,PRCRI(420),1,PRCRI(420.01),4,PRC("FY"),0):5
- +9 IF '$TEST
- SET PRC("MSG")="Note: Carry forward from "_$PIECE(PRC("CP")," ")_" failed. File locked by another user."
- DO EN^DDIOL(PRC("MSG"))
- QUIT
- +10 SET A=$GET(^PRC(420,PRCRI(420),1,PRCRI(420.01),4,PRC("FY"),0))
- +11 LOCK -^PRC(420,PRCRI(420),1,PRCRI(420.01),4,PRC("FY"),0)
- +12 if A=""
- QUIT
- +13 SET PRCCOM=-$PIECE(A,"^",1+PRC("QTR"))
- SET PRCOBL=-$PIECE(A,"^",5+PRC("QTR"))
- +14 IF +PRCOBL=0
- SET PRC("MSG")=PRC("CP")_" Qtr "_$EXTRACT($PIECE(PRCOPT,"^",2),3,999)_" closed. $"_$JUSTIFY(PRCOBL,0,2)_" carried forward."
- +15 ;zero out from quarte balances
- +16 SET A=$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),PRC("CP"),1)
- +17 SET X=PRC("SITE")_"-"_PRC("FY")_"-"_$PIECE(PRC("CP")," ")
- +18 SET Z=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$PIECE(PRC("CP")," ")
- +19 DO EN1^PRCSUT3
- SET PRC("TXNTO")=X
- DO EN2^PRCSUT3
- SET PRCRI(410)=$GET(DA)
- +20 IF 'PRCRI(410)
- SET PRC("MSG")="Note: Carry forward 'to' fails for "_$PIECE(PRC("CP")," ")_" $"_$JUSTIFY(PRCOBL,10,2)
- DO EN^DDIOL(PRC("MSG"))
- GOTO MM
- +21 SET A="1///C;40////^S X=PRCDUZ;42////^S X=PRCDUZ;449////"_$PIECE(PRCA,"^",5)_";450////O;35////"_PRCOBL_";24////"_"TO "_$EXTRACT($PIECE(PRCA,"^",7),3,999)
- +22 DO EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),A)
- +23 ;carry forward from qtr balances to new quarter
- +24 SET PRCOBL=-PRCOBL
- +25 SET A=$PIECE(PRCOPT,"^",7)
- SET PRC("FY")=$EXTRACT(A,3,4)
- SET PRC("QTR")=$PIECE(A,"-",2)
- +26 SET A=$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),PRC("CP"),1)
- +27 SET X=PRC("SITE")_"-"_PRC("FY")_"-"_$PIECE(PRC("CP")," ")
- +28 SET Z=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$PIECE(PRC("CP")," ")
- +29 DO EN1^PRCSUT3
- SET PRC("TXNFR")=X
- DO EN2^PRCSUT3
- SET PRCRI(410)=$GET(DA)
- +30 IF 'PRCRI(410)
- SET PRC("MSG")="Note: Carry forward 'from' fails for "_$PIECE(PRC("CP")," ")_" $"_$JUSTIFY(PRCOBL,10,2)
- DO EN^DDIOL(PRC("MSG"))
- GOTO MM
- +31 SET A="1///C;40////^S X=PRCDUZ;42////^S X=PRCDUZ;449////"_$PIECE(PRCA,"^",6)_";450////O;35////"_PRCOBL_";24////"_"FROM "_$EXTRACT($PIECE(PRCA,"^",2),3,999)
- +32 DO EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),A)
- +33 SET PRC("MSG")=PRC("CP")_" Qtr "_$EXTRACT($PIECE(PRCOPT,"^",2),3,999)_" closed. $"_$JUSTIFY(PRCOBL,0,2)_" carried forward."
- MM DO EN^DDIOL($JUSTIFY($PIECE(PRC("CP")," "),8)_" "_$EXTRACT($PIECE(PRC("CP")," ",2,999)_$JUSTIFY("",40),1,40)_" (CEI) $"_$JUSTIFY(PRCOBL,0,2))
- if +PRCOBL'=0
- Begin DoDot:1
- +1 NEW A,B,X,Y,XMY
- +2 DO NAMES^PRCBBUL
- +3 SET X(1)=PRC("MSG")
- +4 if $ORDER(XMY(""))
- DO MM^PRC0B2(PRCDES,"X(",.XMY)
- +5 QUIT
- End DoDot:1
- +6 QUIT