- PRCPRTRA ;WISC/RFJ-transaction register report ;07 Sep 91
- V ;;5.1;IFCAP;**1,142**;Oct 20, 2000;Build 5
- ;Per VHA Directive 2004-038, this routine should not be modified.
- D ^PRCPUSEL Q:'$G(PRCP("I"))
- N %,%H,%I,ALLITEMS,ITEMDA,PRCPDT,PRCPDATE,PRCPDATB,PRCPSUMM,X,Y
- ;
- K X S X(1)="The Transaction Register Report prints all activity for specified items, including the opening and closing balances."
- S X(2)="The current month-year balance on file appears under the calculated closing balance if the two values differ."
- D DISPLAY^PRCPUX2(40,79,.X)
- ;
- K X S X(1)="Enter the beginning/ending month-year for printing the transaction register. If printing 'ALL' items the beginning/ending dates MUST be the same."
- D DISPLAY^PRCPUX2(2,40,.X)
- DAT S Y=$E(DT,1,5)_"00" S %DT(0)=-Y
- D DD^%DT
- DAT1 S %DT="AEP",%DT("B")=Y
- S %DT("A")="Print Transaction Register for beginning MONTH and YEAR: "
- D ^%DT K %DT I Y<1 Q
- S (Y,PRCPDATB)=$E(Y,1,5)
- DAT2 S Y=$E(Y,1,5)_"00" D DD^%DT
- S %DT="AEP",%DT("B")=Y
- S %DT("A")="Print Transaction Register for ending MONTH and YEAR: "
- D ^%DT K %DT I Y<1 Q
- S (Y,PRCPDATE)=$E(Y,1,5)
- I PRCPDATE<PRCPDATB W !," Ending date CANNOT be prior to beginning date" G DAT2
- ;
- SELECT I PRCPDATE=$E(DT,1,5),PRCPDATB=$E(DT,1,5) D I '% Q
- . K X S X(1)="You may now select to print only items whose calculated closing balance differs from the current on-hand inventory."
- . D DISPLAY^PRCPUX2(2,40,.X)
- . S XP="Display only items out of balance"
- . S XH="Enter 'YES' to only show those items out of balance, 'NO' to select items."
- . S %=$$YN^PRCPUYN(2) I '% Q
- . I %=1 S PRCPSUMM=1
- ;
- I $G(PRCPSUMM) S ALLITEMS=1 G DEVICE
- ;
- ITEMS ;return here after printing report
- ; get selected item list
- S HPRCPDT=PRCPDATE,PRCPDATE=""
- D ITEMMAST^PRCPURS4(PRCPDATE)
- S PRCPDATE=HPRCPDT K HPRCPDT
- I '$O(^TMP($J,"PRCPITEMS",0)),'$D(ALLITEMS) Q
- I $D(ALLITEMS),(PRCPDATB'=PRCPDATE) W !,"** All Items selection MUST use same begin/end month and year **" K ALLITEMS G DAT
- ;
- DEVICE ; ask device
- S %ZIS="Q" D ^%ZIS Q:POP
- I $D(IO("Q")) D D ^%ZTLOAD K IO("Q"),ZTSK,^TMP($J,"PRCPITEMS") Q
- . S ZTDESC="Transaction Register Report",ZTRTN="DQ^PRCPRTRA"
- . S ZTSAVE("PRCP*")="",ZTSAVE("ALLITEMS")="",ZTSAVE("^TMP($J,""PRCPITEMS"",")="",ZTSAVE("ZTREQ")="@"
- W !!,"<*> please wait <*>"
- ;
- DQ ;queue comes here
- N %,CURRQTY,CURRVAL,D,DATE,DESCR,ITEMDA,ITEMDATA,NSN,OPENQTY,OPENVAL,TOTALQTY,TOTALVAL,TRX,TT,UNIT,X,Y
- K ^TMP($J,"PRCPRTRA")
- S PRCPDT=PRCPDATB
- D1 S ITEMDA=0,TOTALQTY=0,TOTALVAL=0
- F S ITEMDA=$O(^PRCP(445.1,PRCP("I"),1,ITEMDA)) Q:'ITEMDA I $D(^(ITEMDA,1,PRCPDT,0))&($D(ALLITEMS)!($D(^TMP($J,"PRCPITEMS",ITEMDA)))) D
- . S %=$$GETOPEN^PRCPUBAL(PRCP("I"),ITEMDA,PRCPDT)
- . S OPENQTY=$P(%,"^",2)+$P(%,"^",3)
- . S OPENVAL=+$P(%,"^",8)
- . S NSN=$$NSN^PRCPUX1(ITEMDA) S:NSN="" NSN=" "
- . S TOTALQTY=OPENQTY,TOTALVAL=OPENVAL
- . S TRX=0
- . F S TRX=$O(^PRCP(445.2,"AD",PRCP("I"),ITEMDA,TRX)) Q:'TRX D
- . . S D=$G(^PRCP(445.2,TRX,0)),DATE=$P($P(D,"^",17),".")
- . . I $E(DATE,1,5)=PRCPDT D
- . . . S TT=$P(D,"^",4)
- . . . S TT=$S($E(TT,1,2)="RC":"R",$E(TT)="R":"D",1:TT)
- . . . S %=$E($P(D,"^",2),2,10) S:$E(%)?1A %=$E(%,2,10)
- . . . I PRCP("DPTYPE")="P"&(TT="D"!(TT="C")!(TT="E")) D
- . . . . S X=$P($P($G(^PRCP(445,+$P(D,"^",18),0)),"^"),"-",2,99)
- . . . . S:X'="" X=$E("to: "_X,1,18)
- . . . . S:$P(D,"^",19)="" $P(D,"^",19)=X
- . . . I PRCP("DPTYPE")="S",TT="U" D
- . . . . S X=$P($G(^PRCP(445.2,TRX,2)),"^",2)
- . . . . S:X'="" X=$E("to: "_X,1,18)
- . . . . S $P(D,"^",19)=X
- . . . I $P(D,"^",22)="",$P(D,"^",23)="" D
- . . . . S $P(D,"^",22)=$J($P(D,"^",7)*$S($E(TT,1,2)="R":$P(D,"^",9),1:$P(D,"^",8)),0,2)
- . . . . S $P(D,"^",23)=$J($P(D,"^",7)*$P(D,"^",9),0,2)
- . . . S $P(D,"^",22)=$J($P(D,"^",22),0,2)
- . . . S $P(D,"^",23)=$J($P(D,"^",23),0,2)
- . . . ; nonissuable
- . . . I $P(D,"^",11)'="" D
- . . . . S $P(D,"^",19)=$S($P(D,"^",7)<0:" TO",1:"FROM")
- . . . . S $P(D,"^",19)=$P(D,"^",19)_" noniss qty: "
- . . . . S $P(D,"^",19)=$P(D,"^",19)_$S($P(D,"^",7)<0:-$P(D,"^",7),1:$P(D,"^",7))
- . . . . S $P(D,"^",7)=""
- . . . . S $P(D,"^",22,23)="^"
- . . . S TOTALQTY=TOTALQTY+$P(D,"^",7),TOTALVAL=TOTALVAL+$P(D,"^",22)
- . . . S ^TMP($J,"PRCPRTRA",ITEMDA,PRCPDT,DATE,TRX)=TT_%_"^"_$P(D,"^",19)_"^"_$P(D,"^",6)_"^"_$P(D,"^",22)_"^"_$P(D,"^",23)_"^"_$P(D,"^",7)
- . S ITEMDATA=$G(^PRCP(445,PRCP("I"),1,ITEMDA,0))
- . S CURRQTY=$P(ITEMDATA,"^",7)+$P(ITEMDATA,"^",19)
- . S CURRVAL=$P(ITEMDATA,"^",27)
- . I CURRVAL="" S CURRVAL=+$J(CURRQTY*$P(ITEMDATA,"^",22),0,2)
- . I $G(PRCPSUMM),CURRQTY=TOTALQTY,CURRVAL=TOTALVAL K ^TMP($J,"PRCPRTRA",ITEMDA,PRCPDT) Q
- . S DESCR=$E($$DESCR^PRCPUX1(PRCP("I"),ITEMDA),1,30)
- . S UNIT=$$UNIT^PRCPUX1(PRCP("I"),ITEMDA,"/")
- . S ^TMP($J,"PRCPRTRA",ITEMDA,PRCPDT)=NSN_"^"_DESCR_"^"_UNIT_"^"_$$GETIN^PRCPUDUE(PRCP("I"),ITEMDA)_"^"_$$GETOUT^PRCPUDUE(PRCP("I"),ITEMDA)_"^"_$P(ITEMDATA,"^",19)_"^"_OPENQTY_"^"_OPENVAL_"^"_TOTALQTY_"^"_TOTALVAL
- . I CURRQTY=TOTALQTY,CURRVAL=TOTALVAL Q
- . S ^TMP($J,"PRCPRTRA",ITEMDA,PRCPDT,"BAL")=CURRQTY_"^"_CURRVAL
- S PRCPDT=PRCPDT+1 S:$E(PRCPDT,4,5)=13 PRCPDT=$E(PRCPDT,1,3)+1_"01"
- I PRCPDT'>PRCPDATE G D1
- D PRINT^PRCPRTR1
- I '$D(ZTQUEUED) W !!!! K PRCPSUMM G ITEMS
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPRTRA 5485 printed Feb 18, 2025@23:42 Page 2
- PRCPRTRA ;WISC/RFJ-transaction register report ;07 Sep 91
- V ;;5.1;IFCAP;**1,142**;Oct 20, 2000;Build 5
- +1 ;Per VHA Directive 2004-038, this routine should not be modified.
- +2 DO ^PRCPUSEL
- if '$GET(PRCP("I"))
- QUIT
- +3 NEW %,%H,%I,ALLITEMS,ITEMDA,PRCPDT,PRCPDATE,PRCPDATB,PRCPSUMM,X,Y
- +4 ;
- +5 KILL X
- SET X(1)="The Transaction Register Report prints all activity for specified items, including the opening and closing balances."
- +6 SET X(2)="The current month-year balance on file appears under the calculated closing balance if the two values differ."
- +7 DO DISPLAY^PRCPUX2(40,79,.X)
- +8 ;
- +9 KILL X
- SET X(1)="Enter the beginning/ending month-year for printing the transaction register. If printing 'ALL' items the beginning/ending dates MUST be the same."
- +10 DO DISPLAY^PRCPUX2(2,40,.X)
- DAT SET Y=$EXTRACT(DT,1,5)_"00"
- SET %DT(0)=-Y
- +1 DO DD^%DT
- DAT1 SET %DT="AEP"
- SET %DT("B")=Y
- +1 SET %DT("A")="Print Transaction Register for beginning MONTH and YEAR: "
- +2 DO ^%DT
- KILL %DT
- IF Y<1
- QUIT
- +3 SET (Y,PRCPDATB)=$EXTRACT(Y,1,5)
- DAT2 SET Y=$EXTRACT(Y,1,5)_"00"
- DO DD^%DT
- +1 SET %DT="AEP"
- SET %DT("B")=Y
- +2 SET %DT("A")="Print Transaction Register for ending MONTH and YEAR: "
- +3 DO ^%DT
- KILL %DT
- IF Y<1
- QUIT
- +4 SET (Y,PRCPDATE)=$EXTRACT(Y,1,5)
- +5 IF PRCPDATE<PRCPDATB
- WRITE !," Ending date CANNOT be prior to beginning date"
- GOTO DAT2
- +6 ;
- SELECT IF PRCPDATE=$EXTRACT(DT,1,5)
- IF PRCPDATB=$EXTRACT(DT,1,5)
- Begin DoDot:1
- +1 KILL X
- SET X(1)="You may now select to print only items whose calculated closing balance differs from the current on-hand inventory."
- +2 DO DISPLAY^PRCPUX2(2,40,.X)
- +3 SET XP="Display only items out of balance"
- +4 SET XH="Enter 'YES' to only show those items out of balance, 'NO' to select items."
- +5 SET %=$$YN^PRCPUYN(2)
- IF '%
- QUIT
- +6 IF %=1
- SET PRCPSUMM=1
- End DoDot:1
- IF '%
- QUIT
- +7 ;
- +8 IF $GET(PRCPSUMM)
- SET ALLITEMS=1
- GOTO DEVICE
- +9 ;
- ITEMS ;return here after printing report
- +1 ; get selected item list
- +2 SET HPRCPDT=PRCPDATE
- SET PRCPDATE=""
- +3 DO ITEMMAST^PRCPURS4(PRCPDATE)
- +4 SET PRCPDATE=HPRCPDT
- KILL HPRCPDT
- +5 IF '$ORDER(^TMP($JOB,"PRCPITEMS",0))
- IF '$DATA(ALLITEMS)
- QUIT
- +6 IF $DATA(ALLITEMS)
- IF (PRCPDATB'=PRCPDATE)
- WRITE !,"** All Items selection MUST use same begin/end month and year **"
- KILL ALLITEMS
- GOTO DAT
- +7 ;
- DEVICE ; ask device
- +1 SET %ZIS="Q"
- DO ^%ZIS
- if POP
- QUIT
- +2 IF $DATA(IO("Q"))
- Begin DoDot:1
- +3 SET ZTDESC="Transaction Register Report"
- SET ZTRTN="DQ^PRCPRTRA"
- +4 SET ZTSAVE("PRCP*")=""
- SET ZTSAVE("ALLITEMS")=""
- SET ZTSAVE("^TMP($J,""PRCPITEMS"",")=""
- SET ZTSAVE("ZTREQ")="@"
- End DoDot:1
- DO ^%ZTLOAD
- KILL IO("Q"),ZTSK,^TMP($JOB,"PRCPITEMS")
- QUIT
- +5 WRITE !!,"<*> please wait <*>"
- +6 ;
- DQ ;queue comes here
- +1 NEW %,CURRQTY,CURRVAL,D,DATE,DESCR,ITEMDA,ITEMDATA,NSN,OPENQTY,OPENVAL,TOTALQTY,TOTALVAL,TRX,TT,UNIT,X,Y
- +2 KILL ^TMP($JOB,"PRCPRTRA")
- +3 SET PRCPDT=PRCPDATB
- D1 SET ITEMDA=0
- SET TOTALQTY=0
- SET TOTALVAL=0
- +1 FOR
- SET ITEMDA=$ORDER(^PRCP(445.1,PRCP("I"),1,ITEMDA))
- if 'ITEMDA
- QUIT
- IF $DATA(^(ITEMDA,1,PRCPDT,0))&($DATA(ALLITEMS)!($DATA(^TMP($JOB,"PRCPITEMS",ITEMDA))))
- Begin DoDot:1
- +2 SET %=$$GETOPEN^PRCPUBAL(PRCP("I"),ITEMDA,PRCPDT)
- +3 SET OPENQTY=$PIECE(%,"^",2)+$PIECE(%,"^",3)
- +4 SET OPENVAL=+$PIECE(%,"^",8)
- +5 SET NSN=$$NSN^PRCPUX1(ITEMDA)
- if NSN=""
- SET NSN=" "
- +6 SET TOTALQTY=OPENQTY
- SET TOTALVAL=OPENVAL
- +7 SET TRX=0
- +8 FOR
- SET TRX=$ORDER(^PRCP(445.2,"AD",PRCP("I"),ITEMDA,TRX))
- if 'TRX
- QUIT
- Begin DoDot:2
- +9 SET D=$GET(^PRCP(445.2,TRX,0))
- SET DATE=$PIECE($PIECE(D,"^",17),".")
- +10 IF $EXTRACT(DATE,1,5)=PRCPDT
- Begin DoDot:3
- +11 SET TT=$PIECE(D,"^",4)
- +12 SET TT=$SELECT($EXTRACT(TT,1,2)="RC":"R",$EXTRACT(TT)="R":"D",1:TT)
- +13 SET %=$EXTRACT($PIECE(D,"^",2),2,10)
- if $EXTRACT(%)?1A
- SET %=$EXTRACT(%,2,10)
- +14 IF PRCP("DPTYPE")="P"&(TT="D"!(TT="C")!(TT="E"))
- Begin DoDot:4
- +15 SET X=$PIECE($PIECE($GET(^PRCP(445,+$PIECE(D,"^",18),0)),"^"),"-",2,99)
- +16 if X'=""
- SET X=$EXTRACT("to: "_X,1,18)
- +17 if $PIECE(D,"^",19)=""
- SET $PIECE(D,"^",19)=X
- End DoDot:4
- +18 IF PRCP("DPTYPE")="S"
- IF TT="U"
- Begin DoDot:4
- +19 SET X=$PIECE($GET(^PRCP(445.2,TRX,2)),"^",2)
- +20 if X'=""
- SET X=$EXTRACT("to: "_X,1,18)
- +21 SET $PIECE(D,"^",19)=X
- End DoDot:4
- +22 IF $PIECE(D,"^",22)=""
- IF $PIECE(D,"^",23)=""
- Begin DoDot:4
- +23 SET $PIECE(D,"^",22)=$JUSTIFY($PIECE(D,"^",7)*$SELECT($EXTRACT(TT,1,2)="R":$PIECE(D,"^",9),1:$PIECE(D,"^",8)),0,2)
- +24 SET $PIECE(D,"^",23)=$JUSTIFY($PIECE(D,"^",7)*$PIECE(D,"^",9),0,2)
- End DoDot:4
- +25 SET $PIECE(D,"^",22)=$JUSTIFY($PIECE(D,"^",22),0,2)
- +26 SET $PIECE(D,"^",23)=$JUSTIFY($PIECE(D,"^",23),0,2)
- +27 ; nonissuable
- +28 IF $PIECE(D,"^",11)'=""
- Begin DoDot:4
- +29 SET $PIECE(D,"^",19)=$SELECT($PIECE(D,"^",7)<0:" TO",1:"FROM")
- +30 SET $PIECE(D,"^",19)=$PIECE(D,"^",19)_" noniss qty: "
- +31 SET $PIECE(D,"^",19)=$PIECE(D,"^",19)_$SELECT($PIECE(D,"^",7)<0:-$PIECE(D,"^",7),1:$PIECE(D,"^",7))
- +32 SET $PIECE(D,"^",7)=""
- +33 SET $PIECE(D,"^",22,23)="^"
- End DoDot:4
- +34 SET TOTALQTY=TOTALQTY+$PIECE(D,"^",7)
- SET TOTALVAL=TOTALVAL+$PIECE(D,"^",22)
- +35 SET ^TMP($JOB,"PRCPRTRA",ITEMDA,PRCPDT,DATE,TRX)=TT_%_"^"_$PIECE(D,"^",19)_"^"_$PIECE(D,"^",6)_"^"_$PIECE(D,"^",22)_"^"_$PIECE(D,"^",23)_"^"_$PIECE(D,"^",7)
- End DoDot:3
- End DoDot:2
- +36 SET ITEMDATA=$GET(^PRCP(445,PRCP("I"),1,ITEMDA,0))
- +37 SET CURRQTY=$PIECE(ITEMDATA,"^",7)+$PIECE(ITEMDATA,"^",19)
- +38 SET CURRVAL=$PIECE(ITEMDATA,"^",27)
- +39 IF CURRVAL=""
- SET CURRVAL=+$JUSTIFY(CURRQTY*$PIECE(ITEMDATA,"^",22),0,2)
- +40 IF $GET(PRCPSUMM)
- IF CURRQTY=TOTALQTY
- IF CURRVAL=TOTALVAL
- KILL ^TMP($JOB,"PRCPRTRA",ITEMDA,PRCPDT)
- QUIT
- +41 SET DESCR=$EXTRACT($$DESCR^PRCPUX1(PRCP("I"),ITEMDA),1,30)
- +42 SET UNIT=$$UNIT^PRCPUX1(PRCP("I"),ITEMDA,"/")
- +43 SET ^TMP($JOB,"PRCPRTRA",ITEMDA,PRCPDT)=NSN_"^"_DESCR_"^"_UNIT_"^"_$$GETIN^PRCPUDUE(PRCP("I"),ITEMDA)_"^"_$$GETOUT^PRCPUDUE(PRCP("I"),ITEMDA)_"^"_$PIECE(ITEMDATA,"^",19)_"^"_OPENQTY_"^"_OPENVAL_"^"_TOTALQTY_"^"_TOTALVAL
- +44 IF CURRQTY=TOTALQTY
- IF CURRVAL=TOTALVAL
- QUIT
- +45 SET ^TMP($JOB,"PRCPRTRA",ITEMDA,PRCPDT,"BAL")=CURRQTY_"^"_CURRVAL
- End DoDot:1
- +46 SET PRCPDT=PRCPDT+1
- if $EXTRACT(PRCPDT,4,5)=13
- SET PRCPDT=$EXTRACT(PRCPDT,1,3)+1_"01"
- +47 IF PRCPDT'>PRCPDATE
- GOTO D1
- +48 DO PRINT^PRCPRTR1
- +49 IF '$DATA(ZTQUEUED)
- WRITE !!!!
- KILL PRCPSUMM
- GOTO ITEMS
- +50 QUIT
