PRCSQR ;WISC/KMB-QUARTERLY REPORT ;10/17/94 9:00
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
START ;
N TY,PONUM,OBLAMT,ESTAMT,TOTAL,Z D EN1^PRCSUT G W2:'$D(PRC("SITE")),EXIT:Y<0 S PRCSZ=Z
K IO("Q") S %ZIS("B")="HOME",%ZIS="MQ" D ^%ZIS G EXIT:POP
I $D(IO("Q")) S ZTRTN="PROCESS^PRCSQR",ZTDESC="ESTIMATED BALANCE REPORT",ZTSAVE("TY")="",ZTSAVE("PRC*")="" D ^%ZTLOAD D ^%ZISC D W1 G EXIT:%'=1 W !! G START
D PROCESS D ^%ZISC D W1 G EXIT:%'=1 W @IOF G START
PROCESS ;
U IO S Z1="",P=0 D NOW^%DTC S Y=% D DD^%DT S TY=Y
S (N,Z,Z(0))=PRCSZ,Z(0)=Z(0)_"-"
S PRCS("PRE")=0,PRCS("O")=0,PRCS("C")=0,N(1)="" D HDR
F I=0:1 S N=$O(^PRCS(410,"B",N)) Q:N=""!(N'[Z(0)) S N(1)=$O(^PRCS(410,"B",N,0)) Q:N(1)="" D PROCESS1 Q:Z1=U
Q:Z1=U S L="",$P(L,"=",IOM)="=" W !,L S L="" H 2 D NONE^PRCSFMS1 Q:Z1=U
H 2 D ^PRCSFMS1 Q:Z1=U
S REPORT2=1 D WRITE,T2^PRCSAPP1
K REPORT2,PRCS QUIT
;
PROCESS1 ;
N PRCA,PRCB,PRCF,PRCG,PRCH,PRCJ,PRCACP
S TOTAL1="" S:$D(^PRCS(410,N(1),4)) TOTAL1=^(4) S X=^(0),Z=$P(X,"^",2),PONUM=$P(TOTAL1,"^",5),ADJAMT=$P(TOTAL1,"^",6),ESTAMT=$P(TOTAL1,"^",8),OBLAMT=$P(TOTAL1,"^",3),PRCA=$G(^(4)),PRCB=$G(^(7)),PRCH="*^*",PRCACP=$P(PRCA,"^",14)
S PRCF=$G(^PRCS(410,N(1),0)),PRCG=$P(PRCF,"^",2),PRCF=$P(PRCF,"^",4)
I PRCG="A",PRCF=1 S:$P(PRCB,"^",6)]"" PRCS("C")=PRCS("C")-ESTAMT,$P(PRCH,"^")="" S:$P(PRCA,"^",10)]"" PRCS("O")=PRCS("O")-OBLAMT,$P(PRCH,"^",2)="" S PRCS("PRE")=PRCS("PRE")-ESTAMT D PROCESS2 Q
I PRCG="O" D
.S:$P(PRCB,"^",6)]"" PRCS("C")=PRCS("C")-ESTAMT,$P(PRCH,"^")=""
.S:$P(PRCA,"^",10)]"" PRCS("O")=PRCS("O")-OBLAMT,$P(PRCH,"^",2)=""
.S PRCS("PRE")=PRCS("PRE")-ESTAMT
.S PRCJ=$O(^PRC(442,"B",PRC("SITE")_"-"_PONUM,0)) I +PRCJ'=0,$P($G(^PRC(442,PRCJ,0)),"^",2)=25 S PRCH="@^@"
I PRCG="C" S PRCH="",PRCS("C")=PRCS("C")+ESTAMT,PRCS("O")=PRCS("O")+OBLAMT
I PRCG="A" S PRCH="",PRCS("C")=PRCS("C")-ESTAMT S:PRCACP'="Y" PRCS("O")=PRCS("O")-OBLAMT S PRCS("PRE")=PRCS("PRE")-ESTAMT
I PRCG="CA" S PRCH="#^#"
D PROCESS2
QUIT
;
PROCESS2 ;
D:IOSL-$Y<3 HOLD Q:Z1=U S X1=$S(Z="C":"CEI",Z="O":"OBL",Z="A":"ADJ",Z="CA":"CAN",1:"")
S:PRCF=5 X1="ISS"
W !,$P($P(X,"^"),"-",5),?6,X1,?11,PONUM
W ?19,$J(ESTAMT,10,2),$P(PRCH,"^",1)
I OBLAMT W ?29,$J(OBLAMT,10,2),$P(PRCH,"^",2)
S T(1)=$P($G(^PRCS(410,N(1),1)),"^",4),T(2)=$P($G(^PRCS(410,N(1),4)),"^",4),T(3)=$P($G(^PRCS(410,N(1),9)),"^",3) S:Z="A" T(2)=$P($G(^PRCS(410,N(1),4)),"^",7)
F I=1:1:3 S Y=T(I) D DD^%DT S PLACE=(I*12)+31,PLACE=PLACE+2 W ?PLACE,Y
W !,?29,$J(PRCS("PRE"),10,2)
W ?44,$J(PRCS("C"),10,2)
W ?59,$J(PRCS("O"),10,2)
W !,$P($G(^PRCS(410,N(1),2)),"^")
N STR S STR=$P($G(^PRCS(410,N(1),"IT",1,1,1,0)),"^") W ?40,$E(STR,1,40)
W !,$G(^PRCS(410,N(1),"CO",1,0)),!
QUIT
;
HOLD ;
G HDR:$E(IOST,1,2)'="C-" W !,"Press return to continue, uparrow (^) to exit: " R Z1:DTIME S:'$T Z1=U D:Z1'=U HDR Q
HDR ;
S P=P+1 W @IOF,"QUARTERLY REPORT - ",Z(0)_" "_$E($P(PRC("CP")," ",2),1,15),?53,TY,?76,"PAGE: ",P
W !,?21,"TRANS $",?33,"OBL/CEIL",?45,"DATE",?57,"DATE",?69,"DATE",!,"SEQ#",?6,"TYPE",?11,"PO/OBL#",?21,"AMOUNT",?33,"$ AMOUNT",?45,"REQ.",?57,"OBL.",?69,"REC'D."
W !,?29,"CONTROL POINT",?44,"UNCOMMITTED",?59,"UNOBLIGATED",!,?29,"REQUEST TOTAL",?44,"BALANCE",?59,"BALANCE"
W !,"VENDOR",?40,"FIRST LINE DESCRIPTION",!,"COMMENT"
S L="",$P(L,"-",IOM)="-" W !,L S L="" Q
WRITE ;
S (SIGN(1),SIGN(2),SIGN(3))="$" S J=1 F I="PRE","C","O" S:PRCS(I)<0 PRCS(I)=-PRCS(I),SIGN(J)="-$" S J=J+1
W !!,"Total Request Amount: ",SIGN(1)_$J(PRCS("PRE"),0,2),!,"Control Point Official's Balance: ",SIGN(2)_$J(PRCS("C"),0,2),!,"Fiscal's Unobligated Balance: ",SIGN(3)_$J(PRCS("O"),0,2),! H 4
S J=1 F I="PRE","C","O" S:SIGN(J)="-$" PRCS(I)=-PRCS(I) S J=J+1
QUIT
W1 ;
W !,"Would you like to run another quarterly balance report" S %=2 D YN^DICN G W1:%=0 Q
W2 ;
W !,"You are not an authorized control point user.",!,"Contact your control point official." R X:5 G EXIT
EXIT K X,SIGN QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSQR 3985 printed Apr 09, 2024@21:19:05 Page 2
PRCSQR ;WISC/KMB-QUARTERLY REPORT ;10/17/94 9:00
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
START ;
+1 NEW TY,PONUM,OBLAMT,ESTAMT,TOTAL,Z
DO EN1^PRCSUT
if '$DATA(PRC("SITE"))
GOTO W2
if Y<0
GOTO EXIT
SET PRCSZ=Z
+2 KILL IO("Q")
SET %ZIS("B")="HOME"
SET %ZIS="MQ"
DO ^%ZIS
if POP
GOTO EXIT
+3 IF $DATA(IO("Q"))
SET ZTRTN="PROCESS^PRCSQR"
SET ZTDESC="ESTIMATED BALANCE REPORT"
SET ZTSAVE("TY")=""
SET ZTSAVE("PRC*")=""
DO ^%ZTLOAD
DO ^%ZISC
DO W1
if %'=1
GOTO EXIT
WRITE !!
GOTO START
+4 DO PROCESS
DO ^%ZISC
DO W1
if %'=1
GOTO EXIT
WRITE @IOF
GOTO START
PROCESS ;
+1 USE IO
SET Z1=""
SET P=0
DO NOW^%DTC
SET Y=%
DO DD^%DT
SET TY=Y
+2 SET (N,Z,Z(0))=PRCSZ
SET Z(0)=Z(0)_"-"
+3 SET PRCS("PRE")=0
SET PRCS("O")=0
SET PRCS("C")=0
SET N(1)=""
DO HDR
+4 FOR I=0:1
SET N=$ORDER(^PRCS(410,"B",N))
if N=""!(N'[Z(0))
QUIT
SET N(1)=$ORDER(^PRCS(410,"B",N,0))
if N(1)=""
QUIT
DO PROCESS1
if Z1=U
QUIT
+5 if Z1=U
QUIT
SET L=""
SET $PIECE(L,"=",IOM)="="
WRITE !,L
SET L=""
HANG 2
DO NONE^PRCSFMS1
if Z1=U
QUIT
+6 HANG 2
DO ^PRCSFMS1
if Z1=U
QUIT
+7 SET REPORT2=1
DO WRITE
DO T2^PRCSAPP1
+8 KILL REPORT2,PRCS
QUIT
+9 ;
PROCESS1 ;
+1 NEW PRCA,PRCB,PRCF,PRCG,PRCH,PRCJ,PRCACP
+2 SET TOTAL1=""
if $DATA(^PRCS(410,N(1),4))
SET TOTAL1=^(4)
SET X=^(0)
SET Z=$PIECE(X,"^",2)
SET PONUM=$PIECE(TOTAL1,"^",5)
SET ADJAMT=$PIECE(TOTAL1,"^",6)
SET ESTAMT=$PIECE(TOTAL1,"^",8)
SET OBLAMT=$PIECE(TOTAL1,"^",3)
SET PRCA=$GET(^(4))
SET PRCB=$GET(^(7))
SET PRCH="*^*"
SET PRCACP=$PIECE(PRCA,"^",14)
+3 SET PRCF=$GET(^PRCS(410,N(1),0))
SET PRCG=$PIECE(PRCF,"^",2)
SET PRCF=$PIECE(PRCF,"^",4)
+4 IF PRCG="A"
IF PRCF=1
if $PIECE(PRCB,"^",6)]""
SET PRCS("C")=PRCS("C")-ESTAMT
SET $PIECE(PRCH,"^")=""
if $PIECE(PRCA,"^",10)]""
SET PRCS("O")=PRCS("O")-OBLAMT
SET $PIECE(PRCH,"^",2)=""
SET PRCS("PRE")=PRCS("PRE")-ESTAMT
DO PROCESS2
QUIT
+5 IF PRCG="O"
Begin DoDot:1
+6 if $PIECE(PRCB,"^",6)]""
SET PRCS("C")=PRCS("C")-ESTAMT
SET $PIECE(PRCH,"^")=""
+7 if $PIECE(PRCA,"^",10)]""
SET PRCS("O")=PRCS("O")-OBLAMT
SET $PIECE(PRCH,"^",2)=""
+8 SET PRCS("PRE")=PRCS("PRE")-ESTAMT
+9 SET PRCJ=$ORDER(^PRC(442,"B",PRC("SITE")_"-"_PONUM,0))
IF +PRCJ'=0
IF $PIECE($GET(^PRC(442,PRCJ,0)),"^",2)=25
SET PRCH="@^@"
End DoDot:1
+10 IF PRCG="C"
SET PRCH=""
SET PRCS("C")=PRCS("C")+ESTAMT
SET PRCS("O")=PRCS("O")+OBLAMT
+11 IF PRCG="A"
SET PRCH=""
SET PRCS("C")=PRCS("C")-ESTAMT
if PRCACP'="Y"
SET PRCS("O")=PRCS("O")-OBLAMT
SET PRCS("PRE")=PRCS("PRE")-ESTAMT
+12 IF PRCG="CA"
SET PRCH="#^#"
+13 DO PROCESS2
+14 QUIT
+15 ;
PROCESS2 ;
+1 if IOSL-$Y<3
DO HOLD
if Z1=U
QUIT
SET X1=$SELECT(Z="C":"CEI",Z="O":"OBL",Z="A":"ADJ",Z="CA":"CAN",1:"")
+2 if PRCF=5
SET X1="ISS"
+3 WRITE !,$PIECE($PIECE(X,"^"),"-",5),?6,X1,?11,PONUM
+4 WRITE ?19,$JUSTIFY(ESTAMT,10,2),$PIECE(PRCH,"^",1)
+5 IF OBLAMT
WRITE ?29,$JUSTIFY(OBLAMT,10,2),$PIECE(PRCH,"^",2)
+6 SET T(1)=$PIECE($GET(^PRCS(410,N(1),1)),"^",4)
SET T(2)=$PIECE($GET(^PRCS(410,N(1),4)),"^",4)
SET T(3)=$PIECE($GET(^PRCS(410,N(1),9)),"^",3)
if Z="A"
SET T(2)=$PIECE($GET(^PRCS(410,N(1),4)),"^",7)
+7 FOR I=1:1:3
SET Y=T(I)
DO DD^%DT
SET PLACE=(I*12)+31
SET PLACE=PLACE+2
WRITE ?PLACE,Y
+8 WRITE !,?29,$JUSTIFY(PRCS("PRE"),10,2)
+9 WRITE ?44,$JUSTIFY(PRCS("C"),10,2)
+10 WRITE ?59,$JUSTIFY(PRCS("O"),10,2)
+11 WRITE !,$PIECE($GET(^PRCS(410,N(1),2)),"^")
+12 NEW STR
SET STR=$PIECE($GET(^PRCS(410,N(1),"IT",1,1,1,0)),"^")
WRITE ?40,$EXTRACT(STR,1,40)
+13 WRITE !,$GET(^PRCS(410,N(1),"CO",1,0)),!
+14 QUIT
+15 ;
HOLD ;
+1 if $EXTRACT(IOST,1,2)'="C-"
GOTO HDR
WRITE !,"Press return to continue, uparrow (^) to exit: "
READ Z1:DTIME
if '$TEST
SET Z1=U
if Z1'=U
DO HDR
QUIT
HDR ;
+1 SET P=P+1
WRITE @IOF,"QUARTERLY REPORT - ",Z(0)_" "_$EXTRACT($PIECE(PRC("CP")," ",2),1,15),?53,TY,?76,"PAGE: ",P
+2 WRITE !,?21,"TRANS $",?33,"OBL/CEIL",?45,"DATE",?57,"DATE",?69,"DATE",!,"SEQ#",?6,"TYPE",?11,"PO/OBL#",?21,"AMOUNT",?33,"$ AMOUNT",?45,"REQ.",?57,"OBL.",?69,"REC'D."
+3 WRITE !,?29,"CONTROL POINT",?44,"UNCOMMITTED",?59,"UNOBLIGATED",!,?29,"REQUEST TOTAL",?44,"BALANCE",?59,"BALANCE"
+4 WRITE !,"VENDOR",?40,"FIRST LINE DESCRIPTION",!,"COMMENT"
+5 SET L=""
SET $PIECE(L,"-",IOM)="-"
WRITE !,L
SET L=""
QUIT
WRITE ;
+1 SET (SIGN(1),SIGN(2),SIGN(3))="$"
SET J=1
FOR I="PRE","C","O"
if PRCS(I)<0
SET PRCS(I)=-PRCS(I)
SET SIGN(J)="-$"
SET J=J+1
+2 WRITE !!,"Total Request Amount: ",SIGN(1)_$JUSTIFY(PRCS("PRE"),0,2),!,"Control Point Official's Balance: ",SIGN(2)_$JUSTIFY(PRCS("C"),0,2),!,"Fiscal's Unobligated Balance: ",SIGN(3)_$JUSTIFY(PRCS("O"),0,2),!
HANG 4
+3 SET J=1
FOR I="PRE","C","O"
if SIGN(J)="-$"
SET PRCS(I)=-PRCS(I)
SET J=J+1
+4 QUIT
W1 ;
+1 WRITE !,"Would you like to run another quarterly balance report"
SET %=2
DO YN^DICN
if %=0
GOTO W1
QUIT
W2 ;
+1 WRITE !,"You are not an authorized control point user.",!,"Contact your control point official."
READ X:5
GOTO EXIT
EXIT KILL X,SIGN
QUIT
