PRCEFIS5 ;WISC/CTB/CLH-DISPLAY 1358 TRANSACTIONS ;05/19/94
V ;;5.1;IFCAP;**148**;Oct 20, 2000;Build 5
;Per VHA Directive 2004-038, this routine should not be modified.
N PO,PODA,PRCFA,PRC410
I '$D(PRC("SITE")) N PRC,% S PRCF("X")="AS" D ^PRCFSITE Q:'%
EN1 N Y,DIR,PRCFAUTH,ZTSAVE,ZTRTN,ZTDESC
D HILO^PRCFQ
I '$D(PO(0)) N PODA D OBLK^PRCH58OB(.PODA) Q:'PODA D PO^PRCH58OB(PODA,.PO) Q:$G(PO(0))="" S PRCFA("PODA")=PODA
S PRC410(1)=$G(^PRCS(410,+$P($G(PO(0)),"^",12),1)),PRC410(11)=$G(^(11))
W !!,"SERVICE START DATE: ",$$FMTE^XLFDT($P(PRC410(1),"^",6),"2DZ")," SERVICE END DATE: ",$$FMTE^XLFDT($P(PRC410(1),"^",7),"2DZ")
W !,"AUTHORITY: ",$P($G(^PRCS(410.9,+$P(PRC410(11),"^",4),0)),"^")," ",$P($G(^(0)),"^",2)
W:$P(PRC410(11),"^",5) !,"SUB: ",$P($G(^PRCS(410.9,+$P(PRC410(11),"^",5),0)),"^")," ",$P($G(^(0)),"^",2) W !
S DIR("A")="Do you wish to view the Authorization information",DIR("B")="No",DIR(0)="YO",DIR("?")="Enter YES to view authorization information" D ^DIR Q:Y["^" K DIR S:Y=1 PRCFAUTH=""
S ZTSAVE("PO*")="",ZTSAVE("PR*")="",ZTSAVE("PRCFAUTH")="",ZTDESC="DISPLAY 1358 "_$P(PO(0),"^"),ZTRTN="Q^PRCEFIS5" D ^PRCFQ
Q
;
Q ;Entry point for queued report
N %X,AUTHAMT,C,CT,DATE,DIC,DREC,I,LIQAMT,OBNUM,S,TMP,UL,UT,X,X1,Z,ZX,DIR
S $P(UL,"_",80)="",OBNUM=$S($D(PO(0)):$P(PO(0),U),$D(PRCFA("PODA")):$P(^PRC(442,PRCFA("PODA"),0),U),1:"")
I '$D(DA) S DA=$S($D(PO(0)):+$P(PO(0),U,12),$D(PRCFA("PODA")):$P(^PRC(442,PRCFA("PODA"),0),U,12),1:0)
D HDR
I 'OBNUM!('$D(^PRC(424,"AD",OBNUM))) W !,"Daily Record entries have not yet been entered for this request.",!,"The total committed cost of this request is $" W $S($D(^PRCS(410,DA,4)):$J($P(^(4),U),0,2),1:0),!,UL D:'$D(ZTQUEUED) PAUSE^PRCFQ Q
S %=1,(X1,CT,UT)="" F S X1=$O(^PRC(424,"AD",OBNUM,X1)) Q:X1'>0 I $D(^PRC(424,X1,0)) S DREC=^(0) D I ($G(IOSL)-$Y<4) D:'$D(ZTQUEUED) PAUSE^PRCFQ Q:'% D HDR
. I '$D(PRCFAUTH),$P(DREC,U,3)="AU" Q
. S S="|",X=$P(DREC,U,7) D CNVD^PRCFQ S DATE=Y S TYPE=$P(DREC,U,3)
. I TYPE="" Q
. S AUTHAMT=$S(TYPE="AU":-$P(DREC,U,12),TYPE="O":$P(DREC,U,6),TYPE="A":$P(DREC,U,6),1:"")
. S LIQAMT=$S(TYPE="L":-$P(DREC,U,4),TYPE="O":$P(DREC,U,6),TYPE="A":$P(DREC,U,6),1:"")
. W !,DATE,?16,S," ",$S(TYPE="O":"OBLIGATION",TYPE="A":"ADJUSTMENT",1:$E($P(DREC,U,10),1,12)),?30,S
. I AUTHAMT]"",$D(PRCFAUTH) W $J(AUTHAMT,11,2),?42,S S CT=CT+AUTHAMT W $J(CT,11,2),?54,S
. E W ?42,S,?54,S
. I LIQAMT]"" W $J(LIQAMT,12,2),?67,S S UT=UT+LIQAMT W $J(UT,11,2)
. E W ?67,S
. K LIQAMT,AUTHAMT,ADJAMT,X,DREC,DATE,TYPE,Y
W !,UL D:'$D(ZTQUEUED) PAUSE^PRCFQ
Q
;
HDR W @IOF W ?25,"Obligation #: ",IOINHI,$P(PO(0),"^"),IOINORM
I $D(PO(8)) W !?$X+4,"Total Authorization:",IOINHI," $ "_$J($FN($P(PO(8),U,3),",",2),12),?$X+5,IOINORM,"Total Liquidation:",IOINHI," $ "_$J($FN($P(PO(8),U,2),",",2),12),IOINORM
W !?30,"|AUTHORIZATION/ORDER REC|",?59,"LIQUIDATION RECORD"
W !,?2,"Date/Time",?18,"Reference No",?30,"|Indiv/Daily",?48,"Cumul",?54,"| Liq. Amt",?67,"| Unliq Bal." W !,UL
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCEFIS5 3041 printed Sep 23, 2025@19:37:31 Page 2
PRCEFIS5 ;WISC/CTB/CLH-DISPLAY 1358 TRANSACTIONS ;05/19/94
V ;;5.1;IFCAP;**148**;Oct 20, 2000;Build 5
+1 ;Per VHA Directive 2004-038, this routine should not be modified.
+2 NEW PO,PODA,PRCFA,PRC410
+3 IF '$DATA(PRC("SITE"))
NEW PRC,%
SET PRCF("X")="AS"
DO ^PRCFSITE
if '%
QUIT
EN1 NEW Y,DIR,PRCFAUTH,ZTSAVE,ZTRTN,ZTDESC
+1 DO HILO^PRCFQ
+2 IF '$DATA(PO(0))
NEW PODA
DO OBLK^PRCH58OB(.PODA)
if 'PODA
QUIT
DO PO^PRCH58OB(PODA,.PO)
if $GET(PO(0))=""
QUIT
SET PRCFA("PODA")=PODA
+3 SET PRC410(1)=$GET(^PRCS(410,+$PIECE($GET(PO(0)),"^",12),1))
SET PRC410(11)=$GET(^(11))
+4 WRITE !!,"SERVICE START DATE: ",$$FMTE^XLFDT($PIECE(PRC410(1),"^",6),"2DZ")," SERVICE END DATE: ",$$FMTE^XLFDT($PIECE(PRC410(1),"^",7),"2DZ")
+5 WRITE !,"AUTHORITY: ",$PIECE($GET(^PRCS(410.9,+$PIECE(PRC410(11),"^",4),0)),"^")," ",$PIECE($GET(^(0)),"^",2)
+6 if $PIECE(PRC410(11),"^",5)
WRITE !,"SUB: ",$PIECE($GET(^PRCS(410.9,+$PIECE(PRC410(11),"^",5),0)),"^")," ",$PIECE($GET(^(0)),"^",2)
WRITE !
+7 SET DIR("A")="Do you wish to view the Authorization information"
SET DIR("B")="No"
SET DIR(0)="YO"
SET DIR("?")="Enter YES to view authorization information"
DO ^DIR
if Y["^"
QUIT
KILL DIR
if Y=1
SET PRCFAUTH=""
+8 SET ZTSAVE("PO*")=""
SET ZTSAVE("PR*")=""
SET ZTSAVE("PRCFAUTH")=""
SET ZTDESC="DISPLAY 1358 "_$PIECE(PO(0),"^")
SET ZTRTN="Q^PRCEFIS5"
DO ^PRCFQ
+9 QUIT
+10 ;
Q ;Entry point for queued report
+1 NEW %X,AUTHAMT,C,CT,DATE,DIC,DREC,I,LIQAMT,OBNUM,S,TMP,UL,UT,X,X1,Z,ZX,DIR
+2 SET $PIECE(UL,"_",80)=""
SET OBNUM=$SELECT($DATA(PO(0)):$PIECE(PO(0),U),$DATA(PRCFA("PODA")):$PIECE(^PRC(442,PRCFA("PODA"),0),U),1:"")
+3 IF '$DATA(DA)
SET DA=$SELECT($DATA(PO(0)):+$PIECE(PO(0),U,12),$DATA(PRCFA("PODA")):$PIECE(^PRC(442,PRCFA("PODA"),0),U,12),1:0)
+4 DO HDR
+5 IF 'OBNUM!('$DATA(^PRC(424,"AD",OBNUM)))
WRITE !,"Daily Record entries have not yet been entered for this request.",!,"The total committed cost of this request is $"
WRITE $SELECT($DATA(^PRCS(410,DA,4)):$JUSTIFY($PIECE(^(4),U),0,2),1:0),!,UL
if '$DATA(ZTQUEUED)
DO PAUSE^PRCFQ
QUIT
+6 SET %=1
SET (X1,CT,UT)=""
FOR
SET X1=$ORDER(^PRC(424,"AD",OBNUM,X1))
if X1'>0
QUIT
IF $DATA(^PRC(424,X1,0))
SET DREC=^(0)
Begin DoDot:1
+7 IF '$DATA(PRCFAUTH)
IF $PIECE(DREC,U,3)="AU"
QUIT
+8 SET S="|"
SET X=$PIECE(DREC,U,7)
DO CNVD^PRCFQ
SET DATE=Y
SET TYPE=$PIECE(DREC,U,3)
+9 IF TYPE=""
QUIT
+10 SET AUTHAMT=$SELECT(TYPE="AU":-$PIECE(DREC,U,12),TYPE="O":$PIECE(DREC,U,6),TYPE="A":$PIECE(DREC,U,6),1:"")
+11 SET LIQAMT=$SELECT(TYPE="L":-$PIECE(DREC,U,4),TYPE="O":$PIECE(DREC,U,6),TYPE="A":$PIECE(DREC,U,6),1:"")
+12 WRITE !,DATE,?16,S," ",$SELECT(TYPE="O":"OBLIGATION",TYPE="A":"ADJUSTMENT",1:$EXTRACT($PIECE(DREC,U,10),1,12)),?30,S
+13 IF AUTHAMT]""
IF $DATA(PRCFAUTH)
WRITE $JUSTIFY(AUTHAMT,11,2),?42,S
SET CT=CT+AUTHAMT
WRITE $JUSTIFY(CT,11,2),?54,S
+14 IF '$TEST
WRITE ?42,S,?54,S
+15 IF LIQAMT]""
WRITE $JUSTIFY(LIQAMT,12,2),?67,S
SET UT=UT+LIQAMT
WRITE $JUSTIFY(UT,11,2)
+16 IF '$TEST
WRITE ?67,S
+17 KILL LIQAMT,AUTHAMT,ADJAMT,X,DREC,DATE,TYPE,Y
End DoDot:1
IF ($GET(IOSL)-$Y<4)
if '$DATA(ZTQUEUED)
DO PAUSE^PRCFQ
if '%
QUIT
DO HDR
+18 WRITE !,UL
if '$DATA(ZTQUEUED)
DO PAUSE^PRCFQ
+19 QUIT
+20 ;
HDR WRITE @IOF
WRITE ?25,"Obligation #: ",IOINHI,$PIECE(PO(0),"^"),IOINORM
+1 IF $DATA(PO(8))
WRITE !?$X+4,"Total Authorization:",IOINHI," $ "_$JUSTIFY($FNUMBER($PIECE(PO(8),U,3),",",2),12),?$X+5,IOINORM,"Total Liquidation:",IOINHI," $ "_$JUSTIFY($FNUMBER($PIECE(PO(8),U,2),",",2),12),IOINORM
+2 WRITE !?30,"|AUTHORIZATION/ORDER REC|",?59,"LIQUIDATION RECORD"
+3 WRITE !,?2,"Date/Time",?18,"Reference No",?30,"|Indiv/Daily",?48,"Cumul",?54,"| Liq. Amt",?67,"| Unliq Bal."
WRITE !,UL
+4 QUIT
