PRCPRADJ ;WISC/RFJ-adjustment voucher recap (option, whse) ;9.9.97
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
D ^PRCPUSEL Q:'$G(PRCP("I"))
N %,%DT,%H,%I,DEFAULT,PRCPDATE,PRCPSUMM,X,Y
K X S X(1)="The Adjustment Voucher Recap Report will print all adjustments to the inventory point for a specified month-year."
I PRCP("DPTYPE")="W" S X(2)="The report will sort Warehouse inventory items by the NSN and the date of the adjustment."
E S X(2)="The report will sort Primary and Secondary inventory items by the description and the date of the adjustment."
D DISPLAY^PRCPUX2(40,79,.X)
S Y=$E(DT,1,5)_"00" D DD^%DT S DEFAULT=Y
K X S X(1)="Select the Adjustment Month-Year to display" D DISPLAY^PRCPUX2(2,40,.X)
S %DT("A")="Print Adjustment Voucher Recap for Month-Year: ",%DT("B")=DEFAULT,%DT="AEP",%DT(0)=-DT D ^%DT I Y<0 Q
S PRCPDATE=Y
S PRCPSUMM=$$SUMMARY^PRCPURS0 I PRCPSUMM<0 Q
W ! S %ZIS="Q" D ^%ZIS Q:POP I $D(IO("Q")) D D ^%ZTLOAD K IO("Q"),ZTSK Q
. S ZTDESC="Adjustment Voucher Recap",ZTRTN="DQ^PRCPRADJ"
. S ZTSAVE("PRCP*")="",ZTSAVE("ZTREQ")="@"
W !!,"<*> please wait <*>"
DQ ; queue starts here
I PRCP("DPTYPE")'="W" D DQ^PRCPRADP Q
; adjustment voucher recap for whse
N ACCT,DA,DATA,DATE,DATEREPT,FCP,ITEMDA,ITEMDATA,NOW,NSN,PAGE,PRCPFLAG,REASON,SCREEN,TOTAL,TOTALM,TOTALP
K ^TMP($J,"PRCPRADJ")
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 NSN=$$NSN^PRCPUX1(ITEMDA),ACCT=$$ACCT1^PRCPUX1($E(NSN,1,4)) S:NSN="" NSN=" "
. . S %=$P(DATA,"^",19),REASON="O",FCP=$P(%,"-",4) I FCP'="" S REASON="I"
. . I %'="",FCP="" S REASON="R"
. . S ^TMP($J,"PRCPRADJ",ACCT,NSN,ITEMDA,DATE,DA)=$P(DATA,"^",15)_"^"_$P(DATA,"^",2)_"^"_$P(DATA,"^",6)_"^"_$P(DATA,"^",7)_"^"_$P(DATA,"^",22)_"^"_$P(DATA,"^",23)_"^"_FCP_"^"_REASON_"^"_$P(DATA,"^",16)
; 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
K TOTAL
S ACCT=0 F S ACCT=$O(^TMP($J,"PRCPRADJ",ACCT)) Q:'ACCT!($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
. W:'PRCPSUMM !!?5,"ACCOUNT NUMBER: ",ACCT
. S NSN="" F S NSN=$O(^TMP($J,"PRCPRADJ",ACCT,NSN)) Q:NSN=""!($G(PRCPFLAG)) S ITEMDA=0 F S ITEMDA=$O(^TMP($J,"PRCPRADJ",ACCT,NSN,ITEMDA)) Q:'ITEMDA!($G(PRCPFLAG)) D
. . 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 !!,$TR(NSN,"-"),?15,$E($$DESCR^PRCPUX1(PRCP("I"),ITEMDA),1,23),?39,"[",ITEMDA,"]",?48,$J($$UNIT^PRCPUX1(PRCP("I"),ITEMDA,"/"),8)
. . S DATE=0 F S DATE=$O(^TMP($J,"PRCPRADJ",ACCT,NSN,ITEMDA,DATE)) Q:'DATE!($G(PRCPFLAG)) S DA=0 F S DA=$O(^TMP($J,"PRCPRADJ",ACCT,NSN,ITEMDA,DATE,DA)) Q:'DA!($G(PRCPFLAG)) S DATA=^(DA) D
. . . W:'PRCPSUMM !?5,$P(DATA,"^"),?12,$P(DATA,"^",2),?22,$J($E(DATE,6,7),2),$J($P(DATA,"^",3),8),$J($P(DATA,"^",4),10),$J($P(DATA,"^",5),12,2),$J($P(DATA,"^",6),12,2),$J($P(DATA,"^",7),6),$J($P(DATA,"^",8),3)
. . . W:'PRCPSUMM $J($E($$INITIALS^PRCPUREP($P(DATA,"^",9)),1,5),5)
. . . I $P(DATA,"^",5)>0 S TOTAL(ACCT,"+")=$G(TOTAL(ACCT,"+"))+$P(DATA,"^",5)
. . . I $P(DATA,"^",5)<0 S TOTAL(ACCT,"-")=$G(TOTAL(ACCT,"-"))+$P(DATA,"^",5)
. . . I $Y>(IOSL-6) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
I $G(PRCPFLAG) D Q Q
I $Y>(IOSL-10) D:SCREEN P^PRCPUREP G:$G(PRCPFLAG) Q D H
W !!?5,"ACCT SUMMARY",?20,$J("PLUS ADJUSTMENTS",20),$J("MINUS ADJUSTMENTS",20),$J("DIFFERENCE",20)
S (ACCT,TOTALM,TOTALP)=0 F S ACCT=$O(TOTAL(ACCT)) Q:'ACCT!($G(PRCPFLAG)) D
. W !?5,"ACCT: ",ACCT,?20,$J($G(TOTAL(ACCT,"+")),20,2),$J($G(TOTAL(ACCT,"-")),20,2),$J($G(TOTAL(ACCT,"+"))+$G(TOTAL(ACCT,"-")),20,2)
. S TOTALM=TOTALM+$G(TOTAL(ACCT,"-")),TOTALP=TOTALP+$G(TOTAL(ACCT,"+"))
. I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$G(PRCPFLAG) D H
I $G(PRCPFLAG) D Q Q
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,"PRCPRADJ")
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 !,"NSN",?15,"DESCRIPTION",?40,"MI",$J("ISSUE",14)
W !?5,"REF#",?12,"TRAN#",?22,"DT",$J("UNITS",8),$J("QUANTITY",10),$J("INV VALUE",12),$J("SELL VALUE",12),$J("FCP",6),$J("RC",3),$J("USER",5)
W !,%
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPRADJ 4951 printed Oct 16, 2024@18:15:14 Page 2
PRCPRADJ ;WISC/RFJ-adjustment voucher recap (option, whse) ;9.9.97
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 DO ^PRCPUSEL
if '$GET(PRCP("I"))
QUIT
+4 NEW %,%DT,%H,%I,DEFAULT,PRCPDATE,PRCPSUMM,X,Y
+5 KILL X
SET X(1)="The Adjustment Voucher Recap Report will print all adjustments to the inventory point for a specified month-year."
+6 IF PRCP("DPTYPE")="W"
SET X(2)="The report will sort Warehouse inventory items by the NSN and the date of the adjustment."
+7 IF '$TEST
SET X(2)="The report will sort Primary and Secondary inventory items by the description and the date of the adjustment."
+8 DO DISPLAY^PRCPUX2(40,79,.X)
+9 SET Y=$EXTRACT(DT,1,5)_"00"
DO DD^%DT
SET DEFAULT=Y
+10 KILL X
SET X(1)="Select the Adjustment Month-Year to display"
DO DISPLAY^PRCPUX2(2,40,.X)
+11 SET %DT("A")="Print Adjustment Voucher Recap for Month-Year: "
SET %DT("B")=DEFAULT
SET %DT="AEP"
SET %DT(0)=-DT
DO ^%DT
IF Y<0
QUIT
+12 SET PRCPDATE=Y
+13 SET PRCPSUMM=$$SUMMARY^PRCPURS0
IF PRCPSUMM<0
QUIT
+14 WRITE !
SET %ZIS="Q"
DO ^%ZIS
if POP
QUIT
IF $DATA(IO("Q"))
Begin DoDot:1
+15 SET ZTDESC="Adjustment Voucher Recap"
SET ZTRTN="DQ^PRCPRADJ"
+16 SET ZTSAVE("PRCP*")=""
SET ZTSAVE("ZTREQ")="@"
End DoDot:1
DO ^%ZTLOAD
KILL IO("Q"),ZTSK
QUIT
+17 WRITE !!,"<*> please wait <*>"
DQ ; queue starts here
+1 IF PRCP("DPTYPE")'="W"
DO DQ^PRCPRADP
QUIT
+2 ; adjustment voucher recap for whse
+3 NEW ACCT,DA,DATA,DATE,DATEREPT,FCP,ITEMDA,ITEMDATA,NOW,NSN,PAGE,PRCPFLAG,REASON,SCREEN,TOTAL,TOTALM,TOTALP
+4 KILL ^TMP($JOB,"PRCPRADJ")
+5 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
+6 SET DA=0
FOR
SET DA=$ORDER(^PRCP(445.2,"AX",PRCP("I"),DATE,"A",DA))
if 'DA
QUIT
Begin DoDot:2
+7 SET DATA=$GET(^PRCP(445.2,DA,0))
SET ITEMDA=+$PIECE(DATA,"^",5)
IF 'ITEMDA
QUIT
+8 SET NSN=$$NSN^PRCPUX1(ITEMDA)
SET ACCT=$$ACCT1^PRCPUX1($EXTRACT(NSN,1,4))
if NSN=""
SET NSN=" "
+9 SET %=$PIECE(DATA,"^",19)
SET REASON="O"
SET FCP=$PIECE(%,"-",4)
IF FCP'=""
SET REASON="I"
+10 IF %'=""
IF FCP=""
SET REASON="R"
+11 SET ^TMP($JOB,"PRCPRADJ",ACCT,NSN,ITEMDA,DATE,DA)=$PIECE(DATA,"^",15)_"^"_$PIECE(DATA,"^",2)_"^"_$PIECE(DATA,"^",6)_"^"_$PIECE(DATA,"^",7)_"^"_$PIECE(DATA,"^",22)_"^"_$PIECE(DATA,"^",23)_"^"_FCP_"^"_REASON_"^"_$PIECE(DATA,"^",16
)
End DoDot:2
End DoDot:1
+12 ; print report
+13 SET Y=PRCPDATE
DO DD^%DT
SET DATEREPT=Y
+14 DO NOW^%DTC
SET Y=%
DO DD^%DT
SET NOW=Y
SET PAGE=1
SET SCREEN=$$SCRPAUSE^PRCPUREP
USE IO
DO H
+15 KILL TOTAL
+16 SET ACCT=0
FOR
SET ACCT=$ORDER(^TMP($JOB,"PRCPRADJ",ACCT))
if 'ACCT!($GET(PRCPFLAG))
QUIT
Begin DoDot:1
+17 IF $GET(ZTQUEUED)
IF $$S^%ZTLOAD
SET PRCPFLAG=1
WRITE !?10,"<<< TASKMANAGER JOB TERMINATED BY USER >>>"
QUIT
+18 IF $Y>(IOSL-6)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
+19 if 'PRCPSUMM
WRITE !!?5,"ACCOUNT NUMBER: ",ACCT
+20 SET NSN=""
FOR
SET NSN=$ORDER(^TMP($JOB,"PRCPRADJ",ACCT,NSN))
if NSN=""!($GET(PRCPFLAG))
QUIT
SET ITEMDA=0
FOR
SET ITEMDA=$ORDER(^TMP($JOB,"PRCPRADJ",ACCT,NSN,ITEMDA))
if 'ITEMDA!($GET(PRCPFLAG))
QUIT
Begin DoDot:2
+21 IF $Y>(IOSL-6)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
+22 SET ITEMDATA=$GET(^PRCP(445,PRCP("I"),1,ITEMDA,0))
+23 if 'PRCPSUMM
WRITE !!,$TRANSLATE(NSN,"-"),?15,$EXTRACT($$DESCR^PRCPUX1(PRCP("I"),ITEMDA),1,23),?39,"[",ITEMDA,"]",?48,$JUSTIFY($$UNIT^PRCPUX1(PRCP("I"),ITEMDA,"/"),8)
+24 SET DATE=0
FOR
SET DATE=$ORDER(^TMP($JOB,"PRCPRADJ",ACCT,NSN,ITEMDA,DATE))
if 'DATE!($GET(PRCPFLAG))
QUIT
SET DA=0
FOR
SET DA=$ORDER(^TMP($JOB,"PRCPRADJ",ACCT,NSN,ITEMDA,DATE,DA))
if 'DA!($GET(PRCPFLAG))
QUIT
SET DATA=^(DA)
Begin DoDot:3
+25 if 'PRCPSUMM
WRITE !?5,$PIECE(DATA,"^"),?12,$PIECE(DATA,"^",2),?22,$JUSTIFY($EXTRACT(DATE,6,7),2),$JUSTIFY($PIECE(DATA,"^",3),8),$JUSTIFY($PIECE(DATA,"^",4),10),$JUSTIFY($PIECE(DATA,"^",5),12,2),$JUSTIFY(...
... $PIECE(DATA,"^",6),12,2),$JUSTIFY($PIECE(DATA,"^",7),6),$JUSTIFY($PIECE(DATA,"^",8),3)
+26 if 'PRCPSUMM
WRITE $JUSTIFY($EXTRACT($$INITIALS^PRCPUREP($PIECE(DATA,"^",9)),1,5),5)
+27 IF $PIECE(DATA,"^",5)>0
SET TOTAL(ACCT,"+")=$GET(TOTAL(ACCT,"+"))+$PIECE(DATA,"^",5)
+28 IF $PIECE(DATA,"^",5)<0
SET TOTAL(ACCT,"-")=$GET(TOTAL(ACCT,"-"))+$PIECE(DATA,"^",5)
+29 IF $Y>(IOSL-6)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
End DoDot:3
End DoDot:2
End DoDot:1
+30 IF $GET(PRCPFLAG)
DO Q
QUIT
+31 IF $Y>(IOSL-10)
if SCREEN
DO P^PRCPUREP
if $GET(PRCPFLAG)
GOTO Q
DO H
+32 WRITE !!?5,"ACCT SUMMARY",?20,$JUSTIFY("PLUS ADJUSTMENTS",20),$JUSTIFY("MINUS ADJUSTMENTS",20),$JUSTIFY("DIFFERENCE",20)
+33 SET (ACCT,TOTALM,TOTALP)=0
FOR
SET ACCT=$ORDER(TOTAL(ACCT))
if 'ACCT!($GET(PRCPFLAG))
QUIT
Begin DoDot:1
+34 WRITE !?5,"ACCT: ",ACCT,?20,$JUSTIFY($GET(TOTAL(ACCT,"+")),20,2),$JUSTIFY($GET(TOTAL(ACCT,"-")),20,2),$JUSTIFY($GET(TOTAL(ACCT,"+"))+$GET(TOTAL(ACCT,"-")),20,2)
+35 SET TOTALM=TOTALM+$GET(TOTAL(ACCT,"-"))
SET TOTALP=TOTALP+$GET(TOTAL(ACCT,"+"))
+36 IF $Y>(IOSL-4)
if SCREEN
DO P^PRCPUREP
if $GET(PRCPFLAG)
QUIT
DO H
End DoDot:1
+37 IF $GET(PRCPFLAG)
DO Q
QUIT
+38 WRITE !?5,"TOTAL",?20,$JUSTIFY(TOTALP,20,2),$JUSTIFY(TOTALM,20,2),$JUSTIFY(TOTALP+TOTALM,20,2)
+39 if 'PRCPSUMM
WRITE !!?26,"REASON CODE (I:ISSUES, O:OTHER, R:RECEIPTS) == RC"
+40 DO END^PRCPUREP
Q DO ^%ZISC
KILL ^TMP($JOB,"PRCPRADJ")
+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 !,"NSN",?15,"DESCRIPTION",?40,"MI",$JUSTIFY("ISSUE",14)
+6 WRITE !?5,"REF#",?12,"TRAN#",?22,"DT",$JUSTIFY("UNITS",8),$JUSTIFY("QUANTITY",10),$JUSTIFY("INV VALUE",12),$JUSTIFY("SELL VALUE",12),$JUSTIFY("FCP",6),$JUSTIFY("RC",3),$JUSTIFY("USER",5)
+7 WRITE !,%
+8 QUIT
