PRCPRADP ;WISC/RFJ-adjustment voucher recap (primary,second) ;25 May 93
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
DQ ; queue starts here
; adjusment voucher recap for primary,secondary (called from prcpradj)
N DA,DATA,DATE,DATEREPT,DESCR,ITEMDA,ITEMDATA,NOW,PAGE,PRCPFLAG,REASON,SCREEN,TOTALM,TOTALP
K ^TMP($J,"PRCPRADP")
S DATE=$E(PRCPDATE,1,5)_"00" F S DATE=$O(^PRCP(445.2,"AX",PRCP("I"),DATE)) Q:'DATE!($E(DATE,1,5)'=$E(PRCPDATE,1,5)) D
. S DA=0 F S DA=$O(^PRCP(445.2,"AX",PRCP("I"),DATE,"A",DA)) Q:'DA D
. . S DATA=$G(^PRCP(445.2,DA,0)),ITEMDA=+$P(DATA,"^",5) I 'ITEMDA Q
. . S DESCR=$$DESCR^PRCPUX1(PRCP("I"),ITEMDA) S:DESCR="" DESCR=" "
. . S %=$P(DATA,"^",19),REASON="O" I $P(%,"-",4)'="" S REASON="I"
. . I %'="",REASON'="I" S REASON="R"
. . S ^TMP($J,"PRCPRADP",$E(DESCR,1,12),ITEMDA,DATE,DA)=$P(DATA,"^",2)_"^"_$P(DATA,"^",6)_"^"_$P(DATA,"^",7)_"^"_$P(DATA,"^",22)_"^"_REASON_"^"_$P(DATA,"^",16)
. S DA=0 F S DA=$O(^PRCP(445.2,"AX",PRCP("I"),DATE,"P",DA)) Q:'DA D
. . S DATA=$G(^PRCP(445.2,DA,0)),ITEMDA=+$P(DATA,"^",5) I 'ITEMDA Q
. . S DESCR=$$DESCR^PRCPUX1(PRCP("I"),ITEMDA) S:DESCR="" DESCR=" "
. . S %=$P(DATA,"^",19),REASON="O"
. . S ^TMP($J,"PRCPRADP",$E(DESCR,1,12),ITEMDA,DATE,DA)=$P(DATA,"^",2)_"^"_$P(DATA,"^",6)_"^"_$P(DATA,"^",7)_"^"_$P(DATA,"^",22)_"^"_REASON_"^"_$P(DATA,"^",16)
; print report
; print report
S Y=PRCPDATE D DD^%DT S DATEREPT=Y
D NOW^%DTC S Y=% D DD^%DT S NOW=Y,PAGE=1,SCREEN=$$SCRPAUSE^PRCPUREP U IO D H
S (TOTALM,TOTALP)=0
S DESCR="" F S DESCR=$O(^TMP($J,"PRCPRADP",DESCR)) Q:DESCR=""!($G(PRCPFLAG)) S ITEMDA=0 F S ITEMDA=$O(^TMP($J,"PRCPRADP",DESCR,ITEMDA)) Q:'ITEMDA!($G(PRCPFLAG)) D
. I $G(ZTQUEUED),$$S^%ZTLOAD S PRCPFLAG=1 W !?10,"<<< TASKMANAGER JOB TERMINATED BY USER >>>" Q
. I $Y>(IOSL-6) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
. S ITEMDATA=$G(^PRCP(445,PRCP("I"),1,ITEMDA,0))
. W:'PRCPSUMM !!,$E($$DESCR^PRCPUX1(PRCP("I"),ITEMDA),1,32),?33,"[",ITEMDA,"]",?42,$J($$UNIT^PRCPUX1(PRCP("I"),ITEMDA,"/"),8)
. S DATE=0 F S DATE=$O(^TMP($J,"PRCPRADP",DESCR,ITEMDA,DATE)) Q:'DATE!($G(PRCPFLAG)) S DA=0 F S DA=$O(^TMP($J,"PRCPRADP",DESCR,ITEMDA,DATE,DA)) Q:'DA!($G(PRCPFLAG)) S DATA=^(DA) D
. . W:'PRCPSUMM !?30,$P(DATA,"^"),?40,$J($E(DATE,6,7),2),$J($P(DATA,"^",2),8),$J($P(DATA,"^",3),10),$J($P(DATA,"^",4),12,2),$J($P(DATA,"^",5),3)
. . W:'PRCPSUMM $J($E($$INITIALS^PRCPUREP($P(DATA,"^",6)),1,5),5)
. . I $P(DATA,"^",4)>0 S TOTALP=TOTALP+$P(DATA,"^",4)
. . I $P(DATA,"^",4)<0 S TOTALM=TOTALM+$P(DATA,"^",4)
. . I $Y>(IOSL-6) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
I $G(PRCPFLAG) D Q Q
I $Y>(IOSL-8) D:SCREEN P^PRCPUREP G:$G(PRCPFLAG) Q D H
W !!?5,"ADJ SUMMARY",?20,$J("PLUS ADJUSTMENTS",20),$J("MINUS ADJUSTMENTS",20),$J("DIFFERENCE",20)
W !?5,"TOTAL",?20,$J(TOTALP,20,2),$J(TOTALM,20,2),$J(TOTALP+TOTALM,20,2)
W:'PRCPSUMM !!?26,"REASON CODE (I:ISSUES, O:OTHER, R:RECEIPTS) == RC"
D END^PRCPUREP
Q D ^%ZISC K ^TMP($J,"PRCPRADP")
Q
;
H S %=NOW_" PAGE "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF
W $C(13),"ADJUSTMENT VOUCHER RECAP FOR: ",$E(PRCP("IN"),1,20),?(80-$L(%)),%
W !?5,"ADJUSTMENTS FOR MONTH-YEAR: ",DATEREPT
S %="",$P(%,"-",81)=""
I PRCPSUMM W !?1,"*** ONLY SUMMARY OF ADJUSTMENTS PRINTED ***",!,% Q
W !,"DESCRIPTION",?33,"MI",$J("ISSUE",15)
W !?30,"TRAN#",?40,"DT",$J("UNITS",8),$J("QUANTITY",10),$J("INV VALUE",12),$J("RC",3),$J("USER",5)
W !,%
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPRADP 3568 printed Sep 23, 2025@19:50:35 Page 2
PRCPRADP ;WISC/RFJ-adjustment voucher recap (primary,second) ;25 May 93
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
DQ ; queue starts here
+1 ; adjusment voucher recap for primary,secondary (called from prcpradj)
+2 NEW DA,DATA,DATE,DATEREPT,DESCR,ITEMDA,ITEMDATA,NOW,PAGE,PRCPFLAG,REASON,SCREEN,TOTALM,TOTALP
+3 KILL ^TMP($JOB,"PRCPRADP")
+4 SET DATE=$EXTRACT(PRCPDATE,1,5)_"00"
FOR
SET DATE=$ORDER(^PRCP(445.2,"AX",PRCP("I"),DATE))
if 'DATE!($EXTRACT(DATE,1,5)'=$EXTRACT(PRCPDATE,1,5))
QUIT
Begin DoDot:1
+5 SET DA=0
FOR
SET DA=$ORDER(^PRCP(445.2,"AX",PRCP("I"),DATE,"A",DA))
if 'DA
QUIT
Begin DoDot:2
+6 SET DATA=$GET(^PRCP(445.2,DA,0))
SET ITEMDA=+$PIECE(DATA,"^",5)
IF 'ITEMDA
QUIT
+7 SET DESCR=$$DESCR^PRCPUX1(PRCP("I"),ITEMDA)
if DESCR=""
SET DESCR=" "
+8 SET %=$PIECE(DATA,"^",19)
SET REASON="O"
IF $PIECE(%,"-",4)'=""
SET REASON="I"
+9 IF %'=""
IF REASON'="I"
SET REASON="R"
+10 SET ^TMP($JOB,"PRCPRADP",$EXTRACT(DESCR,1,12),ITEMDA,DATE,DA)=$PIECE(DATA,"^",2)_"^"_$PIECE(DATA,"^",6)_"^"_$PIECE(DATA,"^",7)_"^"_$PIECE(DATA,"^",22)_"^"_REASON_"^"_$PIECE(DATA,"^",16)
End DoDot:2
+11 SET DA=0
FOR
SET DA=$ORDER(^PRCP(445.2,"AX",PRCP("I"),DATE,"P",DA))
if 'DA
QUIT
Begin DoDot:2
+12 SET DATA=$GET(^PRCP(445.2,DA,0))
SET ITEMDA=+$PIECE(DATA,"^",5)
IF 'ITEMDA
QUIT
+13 SET DESCR=$$DESCR^PRCPUX1(PRCP("I"),ITEMDA)
if DESCR=""
SET DESCR=" "
+14 SET %=$PIECE(DATA,"^",19)
SET REASON="O"
+15 SET ^TMP($JOB,"PRCPRADP",$EXTRACT(DESCR,1,12),ITEMDA,DATE,DA)=$PIECE(DATA,"^",2)_"^"_$PIECE(DATA,"^",6)_"^"_$PIECE(DATA,"^",7)_"^"_$PIECE(DATA,"^",22)_"^"_REASON_"^"_$PIECE(DATA,"^",16)
End DoDot:2
End DoDot:1
+16 ; print report
+17 ; print report
+18 SET Y=PRCPDATE
DO DD^%DT
SET DATEREPT=Y
+19 DO NOW^%DTC
SET Y=%
DO DD^%DT
SET NOW=Y
SET PAGE=1
SET SCREEN=$$SCRPAUSE^PRCPUREP
USE IO
DO H
+20 SET (TOTALM,TOTALP)=0
+21 SET DESCR=""
FOR
SET DESCR=$ORDER(^TMP($JOB,"PRCPRADP",DESCR))
if DESCR=""!($GET(PRCPFLAG))
QUIT
SET ITEMDA=0
FOR
SET ITEMDA=$ORDER(^TMP($JOB,"PRCPRADP",DESCR,ITEMDA))
if 'ITEMDA!($GET(PRCPFLAG))
QUIT
Begin DoDot:1
+22 IF $GET(ZTQUEUED)
IF $$S^%ZTLOAD
SET PRCPFLAG=1
WRITE !?10,"<<< TASKMANAGER JOB TERMINATED BY USER >>>"
QUIT
+23 IF $Y>(IOSL-6)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
+24 SET ITEMDATA=$GET(^PRCP(445,PRCP("I"),1,ITEMDA,0))
+25 if 'PRCPSUMM
WRITE !!,$EXTRACT($$DESCR^PRCPUX1(PRCP("I"),ITEMDA),1,32),?33,"[",ITEMDA,"]",?42,$JUSTIFY($$UNIT^PRCPUX1(PRCP("I"),ITEMDA,"/"),8)
+26 SET DATE=0
FOR
SET DATE=$ORDER(^TMP($JOB,"PRCPRADP",DESCR,ITEMDA,DATE))
if 'DATE!($GET(PRCPFLAG))
QUIT
SET DA=0
FOR
SET DA=$ORDER(^TMP($JOB,"PRCPRADP",DESCR,ITEMDA,DATE,DA))
if 'DA!($GET(PRCPFLAG))
QUIT
SET DATA=^(DA)
Begin DoDot:2
+27 if 'PRCPSUMM
WRITE !?30,$PIECE(DATA,"^"),?40,$JUSTIFY($EXTRACT(DATE,6,7),2),$JUSTIFY($PIECE(DATA,"^",2),8),$JUSTIFY($PIECE(DATA,"^",3),10),$JUSTIFY($PIECE(DATA,"^",4),12,2),$JUSTIFY($PIECE(DATA,"^",5),3)
+28 if 'PRCPSUMM
WRITE $JUSTIFY($EXTRACT($$INITIALS^PRCPUREP($PIECE(DATA,"^",6)),1,5),5)
+29 IF $PIECE(DATA,"^",4)>0
SET TOTALP=TOTALP+$PIECE(DATA,"^",4)
+30 IF $PIECE(DATA,"^",4)<0
SET TOTALM=TOTALM+$PIECE(DATA,"^",4)
+31 IF $Y>(IOSL-6)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
End DoDot:2
End DoDot:1
+32 IF $GET(PRCPFLAG)
DO Q
QUIT
+33 IF $Y>(IOSL-8)
if SCREEN
DO P^PRCPUREP
if $GET(PRCPFLAG)
GOTO Q
DO H
+34 WRITE !!?5,"ADJ SUMMARY",?20,$JUSTIFY("PLUS ADJUSTMENTS",20),$JUSTIFY("MINUS ADJUSTMENTS",20),$JUSTIFY("DIFFERENCE",20)
+35 WRITE !?5,"TOTAL",?20,$JUSTIFY(TOTALP,20,2),$JUSTIFY(TOTALM,20,2),$JUSTIFY(TOTALP+TOTALM,20,2)
+36 if 'PRCPSUMM
WRITE !!?26,"REASON CODE (I:ISSUES, O:OTHER, R:RECEIPTS) == RC"
+37 DO END^PRCPUREP
Q DO ^%ZISC
KILL ^TMP($JOB,"PRCPRADP")
+1 QUIT
+2 ;
H SET %=NOW_" PAGE "_PAGE
SET PAGE=PAGE+1
IF PAGE'=2!(SCREEN)
WRITE @IOF
+1 WRITE $CHAR(13),"ADJUSTMENT VOUCHER RECAP FOR: ",$EXTRACT(PRCP("IN"),1,20),?(80-$LENGTH(%)),%
+2 WRITE !?5,"ADJUSTMENTS FOR MONTH-YEAR: ",DATEREPT
+3 SET %=""
SET $PIECE(%,"-",81)=""
+4 IF PRCPSUMM
WRITE !?1,"*** ONLY SUMMARY OF ADJUSTMENTS PRINTED ***",!,%
QUIT
+5 WRITE !,"DESCRIPTION",?33,"MI",$JUSTIFY("ISSUE",15)
+6 WRITE !?30,"TRAN#",?40,"DT",$JUSTIFY("UNITS",8),$JUSTIFY("QUANTITY",10),$JUSTIFY("INV VALUE",12),$JUSTIFY("RC",3),$JUSTIFY("USER",5)
+7 WRITE !,%
+8 QUIT
