PRCSFMS1 ;WISC/KMB-FMS TRANSACTIONS FOR CP QUARTERLY REPORT ;10-17-94 11:05
V ;;5.1;IFCAP;**90**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
BEGIN ; this routine is called from PRCSQR
; find FMS transactions, for selected quarter, for CP
N Z1,FMSTOT,LINE,STRING,RDATE1,FIRST,FINAL,AMT,TYPE,MINUS,OBL,REF,RECNO,P1,PRCSAPP S (P1,Z1)=0
D NOW^%DTC S Y=% D DD^%DT S RDATE1=Y
S FMSTOT=0 S:'$D(PRCS("O")) PRCS("O")=0 S FINAL=PRCS("O"),STRING=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_+PRC("CP")
S:'$D(PRCS("PRE")) PRCS("PRE")=0 S PRCSAPP=PRCS("PRE")
S MINUS="" S:'$D(PRCS("C")) PRCS("C")=0 S FIRST=PRCS("C")
S RECNO="" F S RECNO=$O(^PRCS(417,"C",STRING,RECNO)) Q:RECNO="" D Q:Z1=U
.I P1=0 D HDR1
.I IOSL-$Y<8 D HOLD1 Q:Z1=U
.S AMT=$P(^PRCS(417,RECNO,0),"^",20),REF=$P(^(0),"^",22),OBL=$P(^(0),"^",18),TYPE=$P(^(0),"^",17)
.S PRCSAPP=PRCSAPP-AMT,FIRST=FIRST-AMT,FINAL=FINAL-AMT
.S Y=$P(REF,".") D DD^%DT W !,Y
.W ?13,OBL,?24,TYPE,?32,$J(AMT,0,2),?42,$J(PRCSAPP,0,2),?54,$J(FIRST,0,2)
.W ?68,$J(FINAL,0,2)
.S FMSTOT=FMSTOT+AMT
I FMSTOT<0 S MINUS="-",FMSTOT=-FMSTOT
I Z1'=U W !!,"FMS transaction total for this quarter: ",MINUS,"$"_$J(FMSTOT,0,2)
S L="",$P(L,"=",IOM)="=" W !,L S L=""
S PRCS("PRE")=PRCSAPP,PRCS("C")=FIRST,PRCS("O")=FINAL Q
HOLD1 ;
Q:$D(C1)
G HDR1:$D(ZTQUEUED),HDR1:IO'=IO(0) W !,"Press return to continue, uparrow (^) to exit: " R Z1:DTIME S:'$T Z1=U D:Z1'=U HDR1 Q
HDR1 ;
S P1=1
S P=P+1 W @IOF W "QUARTERLY REPORT "_"- "_Z(0)_" "_$E($P(PRC("CP")," ",2),1,10),?50,RDATE1,?73,"PAGE ",P
W !,?40,"FMS Transactions",!
W !,"TRANS",?32,"TRANS",?42,"CONTROL PT.",?54,"UNCOMMITTED",?68,"UNOBLIGATED",!,"DATE",?13,"REF #",?24,"TYPE",?32,"AMOUNT",?42,"REQ TOT",?54,"BALANCE",?68,"BALANCE"
S L="",$P(L,"=",IOM)="=" W !,L S L="" Q
NONE ; find PO with no 2237 for running balance
N PRCSAPP,P1,Y,RDATE,TOTAL,AMT,AMT1,PI,REC,FIRST,FINAL,NET,STRING,NONNET
N YEAR,L,RDATE1,CP,LINE,MINUS,TYPR,RQTR
D NOW^%DTC S Y=% D DD^%DT S RDATE1=Y
S CP=$P(PRC("CP")," "),REC="",TOTAL=0,P1=0,Z1=""
S STRING="2^2^2^3^3^3^4^4^4^1^1^1"
S:'$D(PRCS("O")) PRCS("O")=0 S FINAL=PRCS("O")
S:'$D(PRCS("PRE")) PRCS("PRE")=0 S PRCSAPP=PRCS("PRE")
S MINUS="" S:'$D(PRCS("C")) PRCS("C")=0 S FIRST=PRCS("C")
S PRCC=+$$YEAR^PRC0C(PRC("FY"))
S PRCE=$$QTRDATE^PRC0D(PRCC,PRC("QTR"))
S REC=$P(PRCE,"^",8)+100,REC=$$DATE^PRC0C(REC,"H")
S PRCG=$$QTRDATE^PRC0D(+REC,$P(REC,"^",2))
S PRCE=$P(PRCE,"^",7)-1,PRCG=$P(PRCG,"^",7)-1
F S PRCE=$O(^PRC(442,"AB",PRCE)) QUIT:PRCE>PRCG!'PRCE D Q:Z1=U
. S REC=0 F S REC=$O(^PRC(442,"AB",PRCE,REC)) QUIT:'REC S PRCF=$G(^PRC(442,REC,0)) I $P(PRCF,"^",12)="",+PRCF=PRC("SITE"),+$P(PRCF,"^",3)=+PRC("CP") D:$P($G(^(12)),"^",2)]"" Q:Z1=U
..S AMT=$P($G(^PRC(442,REC,0)),"^",16) S:AMT="" AMT=0
..S:$P($G(^PRC(442,REC,7)),"^",2)=45 AMT=0
..I $P($G(^PRC(442,REC,0)),"^",2)=25,$P($G(^PRC(442,REC,7)),"^",2)=22 S AMT=0
..S PRCSAPP=PRCSAPP-AMT,FIRST=FIRST-AMT,FINAL=FINAL-AMT,TOTAL=TOTAL+AMT
..D:P1=0 HDR2
..W !,$P(^PRC(442,REC,0),"^")
..S Y=$P(^PRC(442,REC,1),"^",15) D DD^%DT W ?15,Y
..W ?30,$J(AMT,0,2),?41,$J(PRCSAPP,0,2),?55,$J(FIRST,0,2),?69,$J(FINAL,0,2)
..Q:Z1=U I IOSL-$Y<8 D HOLD2 Q:Z1=U
.. QUIT
. QUIT
S PRCS("C")=FIRST,PRCS("O")=FINAL,PRCS("PRE")=PRCSAPP
I TOTAL<0 S MINUS="-",TOTAL=-TOTAL
I Z1'=U W !!,"PO transaction (no 2237) total for this quarter: ",MINUS,"$",$J(TOTAL,0,2)
S L="",$P(L,"=",IOM)="=" W !,L S L="" QUIT
HOLD2 ;
Q:$D(C1)
G HDR2:$D(ZTQUEUED),HDR2:IO'=IO(0) W !,"Press return to continue, uparrow (^) to exit: " R Z1:DTIME S:'$T Z1=U D:Z1'=U HDR2 Q
HDR2 ;
S P1=1
S P=P+1 W @IOF W "QUARTERLY REPORT "_Z(0)_" "_$E($P(PRC("CP")," ",2),1,10),?50,RDATE1,?73,"PAGE ",P
W !,?5,"__________PO TRANSACTIONS WITHOUT 2237______________",!
W !,"PO/",?15,"PO ",?30,"OBLIGATED",?41,"CONTROL PT.",?55,"UNCOMMITTED",?69,"UNOBLIGATED",!,"OBL#",?15,"DATE",?30,"AMOUNT",?42,"REQ TOT",?55,"BALANCE",?69,"BALANCE"
S L="",$P(L,"=",IOM)="=" W !,L S L="" Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSFMS1 4029 printed Nov 22, 2024@17:27:53 Page 2
PRCSFMS1 ;WISC/KMB-FMS TRANSACTIONS FOR CP QUARTERLY REPORT ;10-17-94 11:05
V ;;5.1;IFCAP;**90**;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
BEGIN ; this routine is called from PRCSQR
+1 ; find FMS transactions, for selected quarter, for CP
+2 NEW Z1,FMSTOT,LINE,STRING,RDATE1,FIRST,FINAL,AMT,TYPE,MINUS,OBL,REF,RECNO,P1,PRCSAPP
SET (P1,Z1)=0
+3 DO NOW^%DTC
SET Y=%
DO DD^%DT
SET RDATE1=Y
+4 SET FMSTOT=0
if '$DATA(PRCS("O"))
SET PRCS("O")=0
SET FINAL=PRCS("O")
SET STRING=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_+PRC("CP")
+5 if '$DATA(PRCS("PRE"))
SET PRCS("PRE")=0
SET PRCSAPP=PRCS("PRE")
+6 SET MINUS=""
if '$DATA(PRCS("C"))
SET PRCS("C")=0
SET FIRST=PRCS("C")
+7 SET RECNO=""
FOR
SET RECNO=$ORDER(^PRCS(417,"C",STRING,RECNO))
if RECNO=""
QUIT
Begin DoDot:1
+8 IF P1=0
DO HDR1
+9 IF IOSL-$Y<8
DO HOLD1
if Z1=U
QUIT
+10 SET AMT=$PIECE(^PRCS(417,RECNO,0),"^",20)
SET REF=$PIECE(^(0),"^",22)
SET OBL=$PIECE(^(0),"^",18)
SET TYPE=$PIECE(^(0),"^",17)
+11 SET PRCSAPP=PRCSAPP-AMT
SET FIRST=FIRST-AMT
SET FINAL=FINAL-AMT
+12 SET Y=$PIECE(REF,".")
DO DD^%DT
WRITE !,Y
+13 WRITE ?13,OBL,?24,TYPE,?32,$JUSTIFY(AMT,0,2),?42,$JUSTIFY(PRCSAPP,0,2),?54,$JUSTIFY(FIRST,0,2)
+14 WRITE ?68,$JUSTIFY(FINAL,0,2)
+15 SET FMSTOT=FMSTOT+AMT
End DoDot:1
if Z1=U
QUIT
+16 IF FMSTOT<0
SET MINUS="-"
SET FMSTOT=-FMSTOT
+17 IF Z1'=U
WRITE !!,"FMS transaction total for this quarter: ",MINUS,"$"_$JUSTIFY(FMSTOT,0,2)
+18 SET L=""
SET $PIECE(L,"=",IOM)="="
WRITE !,L
SET L=""
+19 SET PRCS("PRE")=PRCSAPP
SET PRCS("C")=FIRST
SET PRCS("O")=FINAL
QUIT
HOLD1 ;
+1 if $DATA(C1)
QUIT
+2 if $DATA(ZTQUEUED)
GOTO HDR1
if IO'=IO(0)
GOTO HDR1
WRITE !,"Press return to continue, uparrow (^) to exit: "
READ Z1:DTIME
if '$TEST
SET Z1=U
if Z1'=U
DO HDR1
QUIT
HDR1 ;
+1 SET P1=1
+2 SET P=P+1
WRITE @IOF
WRITE "QUARTERLY REPORT "_"- "_Z(0)_" "_$EXTRACT($PIECE(PRC("CP")," ",2),1,10),?50,RDATE1,?73,"PAGE ",P
+3 WRITE !,?40,"FMS Transactions",!
+4 WRITE !,"TRANS",?32,"TRANS",?42,"CONTROL PT.",?54,"UNCOMMITTED",?68,"UNOBLIGATED",!,"DATE",?13,"REF #",?24,"TYPE",?32,"AMOUNT",?42,"REQ TOT",?54,"BALANCE",?68,"BALANCE"
+5 SET L=""
SET $PIECE(L,"=",IOM)="="
WRITE !,L
SET L=""
QUIT
NONE ; find PO with no 2237 for running balance
+1 NEW PRCSAPP,P1,Y,RDATE,TOTAL,AMT,AMT1,PI,REC,FIRST,FINAL,NET,STRING,NONNET
+2 NEW YEAR,L,RDATE1,CP,LINE,MINUS,TYPR,RQTR
+3 DO NOW^%DTC
SET Y=%
DO DD^%DT
SET RDATE1=Y
+4 SET CP=$PIECE(PRC("CP")," ")
SET REC=""
SET TOTAL=0
SET P1=0
SET Z1=""
+5 SET STRING="2^2^2^3^3^3^4^4^4^1^1^1"
+6 if '$DATA(PRCS("O"))
SET PRCS("O")=0
SET FINAL=PRCS("O")
+7 if '$DATA(PRCS("PRE"))
SET PRCS("PRE")=0
SET PRCSAPP=PRCS("PRE")
+8 SET MINUS=""
if '$DATA(PRCS("C"))
SET PRCS("C")=0
SET FIRST=PRCS("C")
+9 SET PRCC=+$$YEAR^PRC0C(PRC("FY"))
+10 SET PRCE=$$QTRDATE^PRC0D(PRCC,PRC("QTR"))
+11 SET REC=$PIECE(PRCE,"^",8)+100
SET REC=$$DATE^PRC0C(REC,"H")
+12 SET PRCG=$$QTRDATE^PRC0D(+REC,$PIECE(REC,"^",2))
+13 SET PRCE=$PIECE(PRCE,"^",7)-1
SET PRCG=$PIECE(PRCG,"^",7)-1
+14 FOR
SET PRCE=$ORDER(^PRC(442,"AB",PRCE))
if PRCE>PRCG!'PRCE
QUIT
Begin DoDot:1
+15 SET REC=0
FOR
SET REC=$ORDER(^PRC(442,"AB",PRCE,REC))
if 'REC
QUIT
SET PRCF=$GET(^PRC(442,REC,0))
IF $PIECE(PRCF,"^",12)=""
IF +PRCF=PRC("SITE")
IF +$PIECE(PRCF,"^",3)=+PRC("CP")
if $PIECE($GET(^(12)),"^",2)]""
Begin DoDot:2
+16 SET AMT=$PIECE($GET(^PRC(442,REC,0)),"^",16)
if AMT=""
SET AMT=0
+17 if $PIECE($GET(^PRC(442,REC,7)),"^",2)=45
SET AMT=0
+18 IF $PIECE($GET(^PRC(442,REC,0)),"^",2)=25
IF $PIECE($GET(^PRC(442,REC,7)),"^",2)=22
SET AMT=0
+19 SET PRCSAPP=PRCSAPP-AMT
SET FIRST=FIRST-AMT
SET FINAL=FINAL-AMT
SET TOTAL=TOTAL+AMT
+20 if P1=0
DO HDR2
+21 WRITE !,$PIECE(^PRC(442,REC,0),"^")
+22 SET Y=$PIECE(^PRC(442,REC,1),"^",15)
DO DD^%DT
WRITE ?15,Y
+23 WRITE ?30,$JUSTIFY(AMT,0,2),?41,$JUSTIFY(PRCSAPP,0,2),?55,$JUSTIFY(FIRST,0,2),?69,$JUSTIFY(FINAL,0,2)
+24 if Z1=U
QUIT
IF IOSL-$Y<8
DO HOLD2
if Z1=U
QUIT
+25 QUIT
End DoDot:2
if Z1=U
QUIT
+26 QUIT
End DoDot:1
if Z1=U
QUIT
+27 SET PRCS("C")=FIRST
SET PRCS("O")=FINAL
SET PRCS("PRE")=PRCSAPP
+28 IF TOTAL<0
SET MINUS="-"
SET TOTAL=-TOTAL
+29 IF Z1'=U
WRITE !!,"PO transaction (no 2237) total for this quarter: ",MINUS,"$",$JUSTIFY(TOTAL,0,2)
+30 SET L=""
SET $PIECE(L,"=",IOM)="="
WRITE !,L
SET L=""
QUIT
HOLD2 ;
+1 if $DATA(C1)
QUIT
+2 if $DATA(ZTQUEUED)
GOTO HDR2
if IO'=IO(0)
GOTO HDR2
WRITE !,"Press return to continue, uparrow (^) to exit: "
READ Z1:DTIME
if '$TEST
SET Z1=U
if Z1'=U
DO HDR2
QUIT
HDR2 ;
+1 SET P1=1
+2 SET P=P+1
WRITE @IOF
WRITE "QUARTERLY REPORT "_Z(0)_" "_$EXTRACT($PIECE(PRC("CP")," ",2),1,10),?50,RDATE1,?73,"PAGE ",P
+3 WRITE !,?5,"__________PO TRANSACTIONS WITHOUT 2237______________",!
+4 WRITE !,"PO/",?15,"PO ",?30,"OBLIGATED",?41,"CONTROL PT.",?55,"UNCOMMITTED",?69,"UNOBLIGATED",!,"OBL#",?15,"DATE",?30,"AMOUNT",?42,"REQ TOT",?55,"BALANCE",?69,"BALANCE"
+5 SET L=""
SET $PIECE(L,"=",IOM)="="
WRITE !,L
SET L=""
QUIT
