- PRCSP1C1 ;SF/LJP-CONTROL POINT ACTIVITY PRINT OPTIONS CON'T ;4-26-94/3:45 PM
- V ;;5.1;IFCAP;**101**;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- SUB ;BUDGET OBJECT CODE TOTALS
- D EN1^PRCSUT G W1:'$D(PRC("SITE")),EXIT:Y<0 W ! S %ZIS="MQ" D ^%ZIS G EXIT:POP I $D(IO("Q")) S ZTRTN="SUB1^PRCSP1C1",ZTSAVE("DUZ")="",ZTSAVE("PRC*")="" D ^%ZTLOAD,EXIT,W2 G SUB
- SUB1 K T S (N,Z1)="",(T("COM"),T("OBL"),P)=0 D SUB2
- U IO D SUBHD W !,"BUDGET OBJECT CODE TOTALS",! S X="",$P(X,"-",18)="" W X S N=""
- S S=0 F I=0:1 S S=$O(T("S",S)) Q:S'>0 S PRC("SUB")=^PRCD(420.2,+S,0),PRC("SUB")=$P(PRC("SUB"),"^") W !,$E(PRC("SUB"),1,60),?70,$J(T("S",S),10,2) I IOSL-$Y<6 D HOLD Q:Z1[U D SUBHD
- G SUB:Z1[U I 'I W !!,"There are no transactions for this control point for the station and time frame",!,"you selected."
- I IOSL-($Y#IOSL)<6 D HOLD Q:Z1[U D SUBHD
- I I S X="",$P(X,"-",38)="" W !,X W !,"TOTAL OBLIGATED (ACTUAL) COST: ",?70,$J(T("OBL"),10,2),!,"TOTAL COMMITTED (ESTIMATED) COST: ",?70,$J(T("COM"),10,2)
- I I S REPORT2=1 D T2^PRCSAPP1 K REPORT2
- I $D(ZTSK) D KILL^%ZTLOAD K ZTSK G EXIT
- D W,W2 G SUB
- SUB2 S N1=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$P(PRC("CP")," "),N2=N1_"-0000"
- S1 S N2=$O(^PRCS(410,"B",N2)) Q:$P(N2,"-",1,4)'=N1
- S N3=0,N3=$O(^PRCS(410,"B",N2,N3)) G S1:'N3
- G S1:'$D(^PRCS(410,N3,0)),S1:$P(^(0),U,2)'="O"
- I $P(^PRCS(410,N3,0),"^",4)=1 D CALC2 G S2
- S N4=0 F I=0:0 S N4=$O(^PRCS(410,N3,"IT",N4)) Q:N4'>0 I $D(^(N4,0)) S X=^(0) I $P(X,U,4)]"",+$P(X,U,2),+$P(X,U,7) D CALC
- G S2
- CALC ;
- S S=$P(X,U,4),SA=$P(X,U,2)*$P(X,U,7)
- I $D(^PRCS(410,N3,"IT",N4,3)) S AMT=$P($G(^(0)),"^")-$P($G(^(0)),"^",2),SA=AMT
- S:'$D(T("S",+S)) T("S",+S)=0 S T("S",+S)=T("S",+S)+SA,T("OBL")=T("OBL")+SA Q
- CALC2 ; Changes to include 1358s begin here
- N AA,BB,PRCTMP
- S PRCTMP=^PRCS(410,N3,3) F AA=6,8 S BB=AA+1 I $P(PRCTMP,"^",AA),$P(PRCTMP,"^",BB) D
- .S S=$P(PRCTMP,"^",AA),SA=$P(PRCTMP,"^",BB)
- .I '$D(T("S",+S)) S T("S",+S)=0
- .S T("S",+S)=T("S",+S)+SA,T("OBL")=T("OBL")+SA
- K AA,BB,PRCTMP
- Q
- S2 S:$D(^PRCS(410,N3,4)) T("COM")=T("COM")+$P(^(4),U,1)
- G S1
- SUBHD S P=P+1 W @IOF,!!,"BUDGET OBJECT CODE TOTALS REPORT",?50 D NOW^%DTC S Y=% D DD^%DT W Y,?73,"PAGE ",P
- W !,"STATION ",PRC("SITE"),", ",PRC("QTR")_$S(PRC("QTR")=1:"ST",PRC("QTR")=2:"ND",PRC("QTR")=3:"RD",1:"TH")," QUARTER, FY",PRC("FY")," ,CONTROL POINT ",PRC("CP")
- S L="",$P(L,"-",IOM)="-" W !,L Q
- HOLD Q:$D(ZTQUEUED) Q:IO'=IO(0) W !,"Press return to continue, uparrow (^) to exit: " R Z1:DTIME S:'$T Z1=U Q
- W1 W !!,"You are not an authorized control point user.",!,"Contact your control point official." R X:5 G EXIT
- W2 W !!,"Enter information for another report or an uparrow to return to the menu.",! Q
- W I '$D(ZTQUEUED),IO'=IO(0) U IO(0) W !!,"Press return to continue: " R X:DTIME
- I (IO'=IO(0))!($D(ZTQUEUED)) D ^%ZISC
- I (IO=IO(0))!($D(ZTQUEUED)) D ^%ZISC
- EXIT K IO("Q"),S,SA,%,%DT,%ZIS,I,J,L,N,N1,N2,N3,N4,P,PRCS,T,X,Y,Z1,ZTRTN,ZTSAVE,PRC("SUB") Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSP1C1 2990 printed Jan 18, 2025@03:19:20 Page 2
- PRCSP1C1 ;SF/LJP-CONTROL POINT ACTIVITY PRINT OPTIONS CON'T ;4-26-94/3:45 PM
- V ;;5.1;IFCAP;**101**;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- SUB ;BUDGET OBJECT CODE TOTALS
- +1 DO EN1^PRCSUT
- if '$DATA(PRC("SITE"))
- GOTO W1
- if Y<0
- GOTO EXIT
- WRITE !
- SET %ZIS="MQ"
- DO ^%ZIS
- if POP
- GOTO EXIT
- IF $DATA(IO("Q"))
- SET ZTRTN="SUB1^PRCSP1C1"
- SET ZTSAVE("DUZ")=""
- SET ZTSAVE("PRC*")=""
- DO ^%ZTLOAD
- DO EXIT
- DO W2
- GOTO SUB
- SUB1 KILL T
- SET (N,Z1)=""
- SET (T("COM"),T("OBL"),P)=0
- DO SUB2
- +1 USE IO
- DO SUBHD
- WRITE !,"BUDGET OBJECT CODE TOTALS",!
- SET X=""
- SET $PIECE(X,"-",18)=""
- WRITE X
- SET N=""
- +2 SET S=0
- FOR I=0:1
- SET S=$ORDER(T("S",S))
- if S'>0
- QUIT
- SET PRC("SUB")=^PRCD(420.2,+S,0)
- SET PRC("SUB")=$PIECE(PRC("SUB"),"^")
- WRITE !,$EXTRACT(PRC("SUB"),1,60),?70,$JUSTIFY(T("S",S),10,2)
- IF IOSL-$Y<6
- DO HOLD
- if Z1[U
- QUIT
- DO SUBHD
- +3 if Z1[U
- GOTO SUB
- IF 'I
- WRITE !!,"There are no transactions for this control point for the station and time frame",!,"you selected."
- +4 IF IOSL-($Y#IOSL)<6
- DO HOLD
- if Z1[U
- QUIT
- DO SUBHD
- +5 IF I
- SET X=""
- SET $PIECE(X,"-",38)=""
- WRITE !,X
- WRITE !,"TOTAL OBLIGATED (ACTUAL) COST: ",?70,$JUSTIFY(T("OBL"),10,2),!,"TOTAL COMMITTED (ESTIMATED) COST: ",?70,$JUSTIFY(T("COM"),10,2)
- +6 IF I
- SET REPORT2=1
- DO T2^PRCSAPP1
- KILL REPORT2
- +7 IF $DATA(ZTSK)
- DO KILL^%ZTLOAD
- KILL ZTSK
- GOTO EXIT
- +8 DO W
- DO W2
- GOTO SUB
- SUB2 SET N1=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$PIECE(PRC("CP")," ")
- SET N2=N1_"-0000"
- S1 SET N2=$ORDER(^PRCS(410,"B",N2))
- if $PIECE(N2,"-",1,4)'=N1
- QUIT
- +1 SET N3=0
- SET N3=$ORDER(^PRCS(410,"B",N2,N3))
- if 'N3
- GOTO S1
- +2 if '$DATA(^PRCS(410,N3,0))
- GOTO S1
- if $PIECE(^(0),U,2)'="O"
- GOTO S1
- +3 IF $PIECE(^PRCS(410,N3,0),"^",4)=1
- DO CALC2
- GOTO S2
- +4 SET N4=0
- FOR I=0:0
- SET N4=$ORDER(^PRCS(410,N3,"IT",N4))
- if N4'>0
- QUIT
- IF $DATA(^(N4,0))
- SET X=^(0)
- IF $PIECE(X,U,4)]""
- IF +$PIECE(X,U,2)
- IF +$PIECE(X,U,7)
- DO CALC
- +5 GOTO S2
- CALC ;
- +1 SET S=$PIECE(X,U,4)
- SET SA=$PIECE(X,U,2)*$PIECE(X,U,7)
- +2 IF $DATA(^PRCS(410,N3,"IT",N4,3))
- SET AMT=$PIECE($GET(^(0)),"^")-$PIECE($GET(^(0)),"^",2)
- SET SA=AMT
- +3 if '$DATA(T("S",+S))
- SET T("S",+S)=0
- SET T("S",+S)=T("S",+S)+SA
- SET T("OBL")=T("OBL")+SA
- QUIT
- CALC2 ; Changes to include 1358s begin here
- +1 NEW AA,BB,PRCTMP
- +2 SET PRCTMP=^PRCS(410,N3,3)
- FOR AA=6,8
- SET BB=AA+1
- IF $PIECE(PRCTMP,"^",AA)
- IF $PIECE(PRCTMP,"^",BB)
- Begin DoDot:1
- +3 SET S=$PIECE(PRCTMP,"^",AA)
- SET SA=$PIECE(PRCTMP,"^",BB)
- +4 IF '$DATA(T("S",+S))
- SET T("S",+S)=0
- +5 SET T("S",+S)=T("S",+S)+SA
- SET T("OBL")=T("OBL")+SA
- End DoDot:1
- +6 KILL AA,BB,PRCTMP
- +7 QUIT
- S2 if $DATA(^PRCS(410,N3,4))
- SET T("COM")=T("COM")+$PIECE(^(4),U,1)
- +1 GOTO S1
- SUBHD SET P=P+1
- WRITE @IOF,!!,"BUDGET OBJECT CODE TOTALS REPORT",?50
- DO NOW^%DTC
- SET Y=%
- DO DD^%DT
- WRITE Y,?73,"PAGE ",P
- +1 WRITE !,"STATION ",PRC("SITE"),", ",PRC("QTR")_$SELECT(PRC("QTR")=1:"ST",PRC("QTR")=2:"ND",PRC("QTR")=3:"RD",1:"TH")," QUARTER, FY",PRC("FY")," ,CONTROL POINT ",PRC("CP")
- +2 SET L=""
- SET $PIECE(L,"-",IOM)="-"
- WRITE !,L
- QUIT
- HOLD if $DATA(ZTQUEUED)
- QUIT
- if IO'=IO(0)
- QUIT
- WRITE !,"Press return to continue, uparrow (^) to exit: "
- READ Z1:DTIME
- if '$TEST
- SET Z1=U
- QUIT
- W1 WRITE !!,"You are not an authorized control point user.",!,"Contact your control point official."
- READ X:5
- GOTO EXIT
- W2 WRITE !!,"Enter information for another report or an uparrow to return to the menu.",!
- QUIT
- W IF '$DATA(ZTQUEUED)
- IF IO'=IO(0)
- USE IO(0)
- WRITE !!,"Press return to continue: "
- READ X:DTIME
- +1 IF (IO'=IO(0))!($DATA(ZTQUEUED))
- DO ^%ZISC
- +2 Press return to continue: IF (IO=IO(0))!($DATA(ZTQUEUED))
- DO ^%ZISC
- EXIT KILL IO("Q"),S,SA,%,%DT,%ZIS,I,J,L,N,N1,N2,N3,N4,P,PRCS,T,X,Y,Z1,ZTRTN,ZTSAVE,PRC("SUB")
- QUIT