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