- 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 Mar 13, 2025@21:23: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
