PRCB2A ;WISC/(SKR@LBVAMC) - PLT,DGL-ROUTINE TO PRINT RECEIVING REPORT PENDING ACTION; 7/20/98 2:18pm
V ;;5.1;IFCAP;**126,186,217**;Oct 20, 2000;Build 4
;Per VA Directive 6402, this routine should not be modified.
;
;PRC*5.1*186 Added new reporting for all approved amendments
; to insure fiscal is aware of any dangling
; amendments waiting fiscal processing.
;PRC*5.1*217 Fixed display issues in header
; User terminated message
;
QUIT ;invalid entry point
;
EN ;pending fiscal action rpt
INIT S U="^",LINE="" K %ZIS,%IS,IOP,IOC,ZTIO S %IS="MQ" D ^%ZIS Q:POP
S (ZSTAT,IEN,PRCQ,A,C)=0,PAGE=1
S $P(LINE,"=",IOM)=""
U IO(0) S TRM=1 S:IO=IO(0) IOC=1
I $D(IO("Q")) S ZTRTN="START^PRCB2A",ZTDTH="OBLIGATIONS PENDING ACTION",ZTSAVE("IOC")=1,ZTSAVE("LINE")="",ZTSAVE("PRCQ")="",ZTSAVE("PAGE")=""
I $D(IO("Q")) K IO("Q") D ^%ZTLOAD W !,"REQUEST QUEUED" G EXIT
START ;Loop picks up only specific entries
S A="",A0="",A1="",A2="",B=0,C=" - Purchase Orders",D=""
D HDR,HDR1
S PRCQ="" F ZSTAT=10,15,20 QUIT:PRCQ S IEN="" F S IEN=$O(^PRC(442,"AI",ZSTAT,IEN)) Q:IEN'>0 D PRINT QUIT:PRCQ
I PRCQ=1 G EXIT
;
;PRC*5.1*186 Check for dangling amendments
D ASK G:PRCQ EXIT D HDR0,HDR1A
S PRCTT=0,PRCQ=0 S IEN=0 F S IEN=$O(^PRC(443.6,IEN)) Q:IEN'>0 D PRINT1 QUIT:PRCQ
I PRCTT=0 W !!,"** NO APPROVED AMENDMENTS AWAITING FISCAL ACTION **"
I PRCQ=1 G EXIT
;
;Loop through 2237s & 1358s looking for GFP entries with status=10
S IEN=0,IEN1=0,IEN2=0,B=0,C=" - 2237s & 1358s"
D ASK G:PRCQ EXIT D HDR,HDR2 ;PRC*5.1*186
F S IEN1=$O(^PRC(420,IEN1)),IEN2=0 Q:IEN1'>0 D G:PRCQ EXIT
. F S IEN2=$O(^PRC(420,IEN1,1,IEN2)),IEN=0 Q:IEN2'>0 S D=$P($G(^PRC(420,IEN1,1,IEN2,0)),U,1) D:$G(D)'="" Q:PRCQ
. . F S IEN=$O(^PRCS(410,"AN",D,IEN)) Q:IEN'>0 D Q:PRCQ
. . . S A=$G(^PRCS(410,IEN,3)) Q:A=""
. . . S A=$G(^PRCS(410,IEN,1)) Q:A="" S A=$P(A,U,1) Q:A=""
. . . S A0=$G(^PRCS(410,IEN,0)) Q:A0=""
. . . S A1=$G(^PRCS(410,IEN,10)) Q:A1=""
. . . I $P(A0,U,4)=1&($P(A1,U,4)=10) D PRINT2(1) Q ; form type 1358
. . . S A2=$G(^PRC(443,IEN,0)) Q:A2=""
. . . I $P(A1,U,3)=""&($P(A2,U,7)=10) D PRINT2(0) Q ; No PO#
I B=0 W !!,"NO 2237s or 1358s to print"
E W !!,"(Note: '*' indicates transaction is a 1358. All others are 2237s.)",!
EXIT ;PRC*5.1*217 ADDS USER TERMINTED REPORT
I PRCQ=1 D EN^DDIOL("USER TERMINATED REPORT")
I PRCQ'=1 D EN^DDIOL("END OF REPORT")
K ZSTAT,IEN,L1,POP,ZTDTH,ZTRTN,ZTSAVE,TRM,LINE,PAGE,PRCQ,PRCTT,A,A0,A1,A2,B,C,D
D ^%ZISC
Q
HDR ;
U IO W @IOF W !,?70,"Page ",PAGE S PAGE=PAGE+1
W !,"IFCAP OBLIGATIONS PENDING ACTION REPORT",C
W !,?45,"PRINTED ON " D ^%D W " AT " D ^%T
Q
HDR0 ;prc*5.1*186
U IO W @IOF W !,?70,"Page ",PAGE S PAGE=PAGE+1
W !,"IFCAP APPROVED AMENDMENTS PENDING FISCAL ACTION REPORT",C
W !,?45,"PRINTED ON " D ^%D W " AT " D ^%T
Q
HDR1 ;Purchase orders
W !,LINE,!,"P.O. NUMBER",?12,"FCP ",?18,"AMOUNT",?32,"DATE",?42,"STATUS",!,LINE,!
Q
HDR1A ;Purchase orders PRC*5.1*186
W !,LINE,!,"P.O. NUMBER",?12,"FCP ",?18,"AMOUNT",?32,"DATE",?45,"DAYS SINCE APPROVED",!,LINE,!
Q
HDR2 ;GPF 2237s
W !,LINE,!,"TRANSACTION NUMBER",?22,"FCP ",?32,"AMOUNT",?45,"DATE",?55,"STATUS",?77,"SCP",!,LINE,!
Q
PRINT ;
Q:'$D(^PRC(442,IEN,0))
I $Y+8>IOSL D ASK Q:PRCQ D HDR,HDR1
W !,$P(^PRC(442,+IEN,0),U,1),?12,$P($P(^(0),U,3)," "),?18,"$"_$J($P(^(0),U,15),9,2)
W:$D(^PRC(442,IEN,1)) ?32,$E($P(^(1),U,15),4,5)_"-"_$E($P(^(1),U,15),6,7)_"-"_$E($P(^(1),U,15),2,3),?42,$E($S($D(^PRCD(442.3,+$P(^PRC(442,+IEN,7),U,1),0)):$P(^(0),U,1),1:""),1,39)
Q
PRINT1 ;PRC*5.1*186
N PRCAMD,PRCAMD1,X1,X2
Q:'$D(^PRC(443.6,IEN,0))
S PRCAMD=0,PRCAMD=$O(^PRC(443.6,IEN,6,PRCAMD)) Q:'PRCAMD
S PRCAMD1=$G(^PRC(443.6,IEN,6,PRCAMD,1))
I $P(PRCAMD1,U,2)']"" Q
S PRCTT=PRCTT+1
I $Y+8>IOSL D ASK Q:PRCQ D HDR0,HDR1A
W !,$P(^PRC(442,+IEN,0),U,1),?12,$P($P(^(0),U,3)," "),?18,"$"_$J($P(^(0),U,15),9,2)
I $D(^PRC(442,IEN,1)) W ?32,$E($P(^(1),U,15),4,5),"-",$E($P(^(1),U,15),6,7),"-",$E($P(^(1),U,15),2,3)
I $P(PRCAMD1,U,3)]"" S X1=DT,X2=$P($P(PRCAMD1,U,3),".") D ^%DTC W ?51,X
Q
PRINT2(X) ;
I $Y+8>IOSL D ASK Q:PRCQ D HDR,HDR2 ;PRC*5.1*217 HEADER PRINT FIX
W !,$P(A0,U,1)
I X=1 W "*"
W ?22,$P($P(^PRCS(410,IEN,3),U,1)," "),?28
I $D(^PRCS(410,IEN,4))=0 W "Bad record"
E W "$"_$J($P(^(4),U,8),9,2),?42,$E(A,4,5),"-",$E(A,6,7),"-",$E(A,2,3)
W ?52,$P(^PRCD(442.3,10,0),U,1),?77,$P("NON^GPF^SF^CON^CAN",U,($P(^PRC(420,IEN1,1,IEN2,0),U,12)+1))
S B=B+1
Q
ASK ;
I B>0 W !!,"(Note: '*' indicates transaction is a 1358. All others are 2237s.)"
I $E(IOST,1,2)="C-" W !!,"Press <RET> to continue or '^' to quit. " R X:DTIME I '$T!(X="^") S PRCQ=1 Q
Q
INFO ;routine provides Fiscal Service with a listing of all Purchase orders
;from file 442, that have a Supply Status of 10,15,20. These numbers
;reflect IEN from file 442.3
;As of PRC*5*163, the routine also lists 2237s in General Post Funds
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCB2A 4988 printed Apr 09, 2024@21:17:52 Page 2
PRCB2A ;WISC/(SKR@LBVAMC) - PLT,DGL-ROUTINE TO PRINT RECEIVING REPORT PENDING ACTION; 7/20/98 2:18pm
V ;;5.1;IFCAP;**126,186,217**;Oct 20, 2000;Build 4
+1 ;Per VA Directive 6402, this routine should not be modified.
+2 ;
+3 ;PRC*5.1*186 Added new reporting for all approved amendments
+4 ; to insure fiscal is aware of any dangling
+5 ; amendments waiting fiscal processing.
+6 ;PRC*5.1*217 Fixed display issues in header
+7 ; User terminated message
+8 ;
+9 ;invalid entry point
QUIT
+10 ;
EN ;pending fiscal action rpt
INIT SET U="^"
SET LINE=""
KILL %ZIS,%IS,IOP,IOC,ZTIO
SET %IS="MQ"
DO ^%ZIS
if POP
QUIT
+1 SET (ZSTAT,IEN,PRCQ,A,C)=0
SET PAGE=1
+2 SET $PIECE(LINE,"=",IOM)=""
+3 USE IO(0)
SET TRM=1
if IO=IO(0)
SET IOC=1
+4 IF $DATA(IO("Q"))
SET ZTRTN="START^PRCB2A"
SET ZTDTH="OBLIGATIONS PENDING ACTION"
SET ZTSAVE("IOC")=1
SET ZTSAVE("LINE")=""
SET ZTSAVE("PRCQ")=""
SET ZTSAVE("PAGE")=""
+5 IF $DATA(IO("Q"))
KILL IO("Q")
DO ^%ZTLOAD
WRITE !,"REQUEST QUEUED"
GOTO EXIT
START ;Loop picks up only specific entries
+1 SET A=""
SET A0=""
SET A1=""
SET A2=""
SET B=0
SET C=" - Purchase Orders"
SET D=""
+2 DO HDR
DO HDR1
+3 SET PRCQ=""
FOR ZSTAT=10,15,20
if PRCQ
QUIT
SET IEN=""
FOR
SET IEN=$ORDER(^PRC(442,"AI",ZSTAT,IEN))
if IEN'>0
QUIT
DO PRINT
if PRCQ
QUIT
+4 IF PRCQ=1
GOTO EXIT
+5 ;
+6 ;PRC*5.1*186 Check for dangling amendments
+7 DO ASK
if PRCQ
GOTO EXIT
DO HDR0
DO HDR1A
+8 SET PRCTT=0
SET PRCQ=0
SET IEN=0
FOR
SET IEN=$ORDER(^PRC(443.6,IEN))
if IEN'>0
QUIT
DO PRINT1
if PRCQ
QUIT
+9 IF PRCTT=0
WRITE !!,"** NO APPROVED AMENDMENTS AWAITING FISCAL ACTION **"
+10 IF PRCQ=1
GOTO EXIT
+11 ;
+12 ;Loop through 2237s & 1358s looking for GFP entries with status=10
+13 SET IEN=0
SET IEN1=0
SET IEN2=0
SET B=0
SET C=" - 2237s & 1358s"
+14 ;PRC*5.1*186
DO ASK
if PRCQ
GOTO EXIT
DO HDR
DO HDR2
+15 FOR
SET IEN1=$ORDER(^PRC(420,IEN1))
SET IEN2=0
if IEN1'>0
QUIT
Begin DoDot:1
+16 FOR
SET IEN2=$ORDER(^PRC(420,IEN1,1,IEN2))
SET IEN=0
if IEN2'>0
QUIT
SET D=$PIECE($GET(^PRC(420,IEN1,1,IEN2,0)),U,1)
if $GET(D)'=""
Begin DoDot:2
+17 FOR
SET IEN=$ORDER(^PRCS(410,"AN",D,IEN))
if IEN'>0
QUIT
Begin DoDot:3
+18 SET A=$GET(^PRCS(410,IEN,3))
if A=""
QUIT
+19 SET A=$GET(^PRCS(410,IEN,1))
if A=""
QUIT
SET A=$PIECE(A,U,1)
if A=""
QUIT
+20 SET A0=$GET(^PRCS(410,IEN,0))
if A0=""
QUIT
+21 SET A1=$GET(^PRCS(410,IEN,10))
if A1=""
QUIT
+22 ; form type 1358
IF $PIECE(A0,U,4)=1&($PIECE(A1,U,4)=10)
DO PRINT2(1)
QUIT
+23 SET A2=$GET(^PRC(443,IEN,0))
if A2=""
QUIT
+24 ; No PO#
IF $PIECE(A1,U,3)=""&($PIECE(A2,U,7)=10)
DO PRINT2(0)
QUIT
End DoDot:3
if PRCQ
QUIT
End DoDot:2
if PRCQ
QUIT
End DoDot:1
if PRCQ
GOTO EXIT
+25 IF B=0
WRITE !!,"NO 2237s or 1358s to print"
+26 IF '$TEST
WRITE !!,"(Note: '*' indicates transaction is a 1358. All others are 2237s.)",!
EXIT ;PRC*5.1*217 ADDS USER TERMINTED REPORT
+1 IF PRCQ=1
DO EN^DDIOL("USER TERMINATED REPORT")
+2 IF PRCQ'=1
DO EN^DDIOL("END OF REPORT")
+3 KILL ZSTAT,IEN,L1,POP,ZTDTH,ZTRTN,ZTSAVE,TRM,LINE,PAGE,PRCQ,PRCTT,A,A0,A1,A2,B,C,D
+4 DO ^%ZISC
+5 QUIT
HDR ;
+1 USE IO
WRITE @IOF
WRITE !,?70,"Page ",PAGE
SET PAGE=PAGE+1
+2 WRITE !,"IFCAP OBLIGATIONS PENDING ACTION REPORT",C
+3 WRITE !,?45,"PRINTED ON "
DO ^%D
WRITE " AT "
DO ^%T
+4 QUIT
HDR0 ;prc*5.1*186
+1 USE IO
WRITE @IOF
WRITE !,?70,"Page ",PAGE
SET PAGE=PAGE+1
+2 WRITE !,"IFCAP APPROVED AMENDMENTS PENDING FISCAL ACTION REPORT",C
+3 WRITE !,?45,"PRINTED ON "
DO ^%D
WRITE " AT "
DO ^%T
+4 QUIT
HDR1 ;Purchase orders
+1 WRITE !,LINE,!,"P.O. NUMBER",?12,"FCP ",?18,"AMOUNT",?32,"DATE",?42,"STATUS",!,LINE,!
+2 QUIT
HDR1A ;Purchase orders PRC*5.1*186
+1 WRITE !,LINE,!,"P.O. NUMBER",?12,"FCP ",?18,"AMOUNT",?32,"DATE",?45,"DAYS SINCE APPROVED",!,LINE,!
+2 QUIT
HDR2 ;GPF 2237s
+1 WRITE !,LINE,!,"TRANSACTION NUMBER",?22,"FCP ",?32,"AMOUNT",?45,"DATE",?55,"STATUS",?77,"SCP",!,LINE,!
+2 QUIT
PRINT ;
+1 if '$DATA(^PRC(442,IEN,0))
QUIT
+2 IF $Y+8>IOSL
DO ASK
if PRCQ
QUIT
DO HDR
DO HDR1
+3 WRITE !,$PIECE(^PRC(442,+IEN,0),U,1),?12,$PIECE($PIECE(^(0),U,3)," "),?18,"$"_$JUSTIFY($PIECE(^(0),U,15),9,2)
+4 if $DATA(^PRC(442,IEN,1))
WRITE ?32,$EXTRACT($PIECE(^(1),U,15),4,5)_"-"_$EXTRACT($PIECE(^(1),U,15),6,7)_"-"_$EXTRACT($PIECE(^(1),U,15),2,3),?42,$EXTRACT($SELECT($DATA(^PRCD(442.3,+$PIECE(^PRC(442,+IEN,7),U,1),0)):$PIECE(^(0),U,1),1:""),1,39)
+5 QUIT
PRINT1 ;PRC*5.1*186
+1 NEW PRCAMD,PRCAMD1,X1,X2
+2 if '$DATA(^PRC(443.6,IEN,0))
QUIT
+3 SET PRCAMD=0
SET PRCAMD=$ORDER(^PRC(443.6,IEN,6,PRCAMD))
if 'PRCAMD
QUIT
+4 SET PRCAMD1=$GET(^PRC(443.6,IEN,6,PRCAMD,1))
+5 IF $PIECE(PRCAMD1,U,2)']""
QUIT
+6 SET PRCTT=PRCTT+1
+7 IF $Y+8>IOSL
DO ASK
if PRCQ
QUIT
DO HDR0
DO HDR1A
+8 WRITE !,$PIECE(^PRC(442,+IEN,0),U,1),?12,$PIECE($PIECE(^(0),U,3)," "),?18,"$"_$JUSTIFY($PIECE(^(0),U,15),9,2)
+9 IF $DATA(^PRC(442,IEN,1))
WRITE ?32,$EXTRACT($PIECE(^(1),U,15),4,5),"-",$EXTRACT($PIECE(^(1),U,15),6,7),"-",$EXTRACT($PIECE(^(1),U,15),2,3)
+10 IF $PIECE(PRCAMD1,U,3)]""
SET X1=DT
SET X2=$PIECE($PIECE(PRCAMD1,U,3),".")
DO ^%DTC
WRITE ?51,X
+11 QUIT
PRINT2(X) ;
+1 ;PRC*5.1*217 HEADER PRINT FIX
IF $Y+8>IOSL
DO ASK
if PRCQ
QUIT
DO HDR
DO HDR2
+2 WRITE !,$PIECE(A0,U,1)
+3 IF X=1
WRITE "*"
+4 WRITE ?22,$PIECE($PIECE(^PRCS(410,IEN,3),U,1)," "),?28
+5 IF $DATA(^PRCS(410,IEN,4))=0
WRITE "Bad record"
+6 IF '$TEST
WRITE "$"_$JUSTIFY($PIECE(^(4),U,8),9,2),?42,$EXTRACT(A,4,5),"-",$EXTRACT(A,6,7),"-",$EXTRACT(A,2,3)
+7 WRITE ?52,$PIECE(^PRCD(442.3,10,0),U,1),?77,$PIECE("NON^GPF^SF^CON^CAN",U,($PIECE(^PRC(420,IEN1,1,IEN2,0),U,12)+1))
+8 SET B=B+1
+9 QUIT
ASK ;
+1 IF B>0
WRITE !!,"(Note: '*' indicates transaction is a 1358. All others are 2237s.)"
+2 IF $EXTRACT(IOST,1,2)="C-"
WRITE !!,"Press <RET> to continue or '^' to quit. "
READ X:DTIME
IF '$TEST!(X="^")
SET PRCQ=1
QUIT
+3 QUIT
INFO ;routine provides Fiscal Service with a listing of all Purchase orders
+1 ;from file 442, that have a Supply Status of 10,15,20. These numbers
+2 ;reflect IEN from file 442.3
+3 ;As of PRC*5*163, the routine also lists 2237s in General Post Funds
