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