- PRCPRSSR ;WISC/RFJ/dh/DWA/DAP-stock status report (option, whse) ;3.13.98
- ;;5.1;IFCAP;**17,41,98**;Oct 20, 2000;Build 37
- ;Per VHA Directive 2004-038, this routine should not be modified.
- ;
- ;*83 Routine PRCPLO2 associated with PRC*5.1*83 is a modified copy of
- ;this routine and any changes made to this routine should also be
- ;considered for that routine as well.
- ;
- ;*98 Changed previous displays of "issues" to "usage"
- ;
- D ^PRCPUSEL Q:'$D(PRCP("I"))
- N %,%DT,%H,%I,DATEINAC,DATESTRT,TODAY,X,X1,X2,Y
- K X S X(1)="The Stock Status Report will print a summary of all usage, receipts, and adjustments with the opening and closing balances by account codes."
- S X(2)="It will calculate the turnover rate, inactive item percent, long supply percent, and non-issuable percent."
- D DISPLAY^PRCPUX2(40,79,.X)
- K X S X(1)="Enter the date (month-year) for the Stock Status Report." D DISPLAY^PRCPUX2(2,40,.X)
- D NOW^%DTC S TODAY=X,Y=$E(X,1,5)_"00" S %DT(0)=-Y D DD^%DT S %DT="AEP",%DT("B")=Y,%DT("A")="Print Stock Status for MONTH and YEAR: " D ^%DT K %DT I Y<1 Q
- S DATESTRT=$E(Y,1,5)_"00"
- K X S X(1)="The inactive item percent is calculated for items which have not had activity (receipts or usage) after a specified cutoff date." D DISPLAY^PRCPUX2(40,79,.X)
- K X S X(1)="Enter the Inactivity cutoff date." D DISPLAY^PRCPUX2(2,40,.X)
- S X1=TODAY,X2=-90 D C^%DTC S Y=$E(X,1,5)_"00" D DD^%DT
- S %DT(0)=-($E(TODAY,1,5)_"00"),%DT="AEP",%DT("B")=Y,%DT("A")="Enter Inactivity Cutoff MONTH and YEAR: " D ^%DT K %DT I Y<1 Q
- S DATEINAC=$E(Y,1,5)_"00"
- ;
- ;*98 Branch to PRCPRSSP if the inventory point being reported is a
- ;primary or secondary
- ;
- I PRCP("DPTYPE")'="W" D ENT^PRCPRSSP Q
- ;
- N ZTDESC,ZTRTN,ZTSAVE,POP
- W ! S %ZIS="Q" D ^%ZIS Q:POP I $D(IO("Q")) D D ^%ZTLOAD K IO("Q"),ZTSK Q
- . S ZTDESC="Stock Status Report",ZTRTN="DQ^PRCPRSSR"
- . S ZTSAVE("PRCP*")="",ZTSAVE("DATE*")="",ZTSAVE("ZTREQ")="@"
- W !!,"<*> please wait <*>"
- ;
- DQ ; queue starts here
- N ACCT,ADJ,ADJN,AVERAGE,D,DA,DATE,DATELONG,DUEIN,DUEOUT,INACT,INACTN,INVVAL,ISS,ISSN,ITEMDA,LONG,LONGN,NONISS,NONISSN,ONHAND,OPEN,QTY,REC,RECN,TOTAL,TOTDAYS,TRANSNO,TYPE,VALUE
- K OPEN
- S ITEMDA=0 F S ITEMDA=$O(^PRCP(445.1,PRCP("I"),1,ITEMDA)) Q:'ITEMDA S X=$$GETOPEN^PRCPUBAL(PRCP("I"),ITEMDA,$E(DATESTRT,1,5)) I X'="" D
- . S ACCT=$$ACCT1^PRCPUX1($$FSC^PRCPUX1(ITEMDA))
- . S $P(OPEN(ACCT),"^")=$P($G(OPEN(ACCT)),"^")+$P(X,"^",2)+$P(X,"^",3)
- . S $P(OPEN(ACCT),"^",2)=$P($G(OPEN(ACCT)),"^",2)+$P(X,"^",8)
- S DATE=DATESTRT F S DATE=$O(^PRCP(445.2,"AX",PRCP("I"),DATE)) Q:$E(DATE,1,5)'=$E(DATESTRT,1,5) S TYPE="" F S TYPE=$O(^PRCP(445.2,"AX",PRCP("I"),DATE,TYPE)) Q:TYPE="" D
- . S DA=0 F S DA=$O(^PRCP(445.2,"AX",PRCP("I"),DATE,TYPE,DA)) Q:'DA D
- . . S D=$G(^PRCP(445.2,DA,0)) I '$P(D,"^",5) Q
- . . ; non-issuable
- . . Q:$P(D,"^",11)="N" ;count if not flagged as non-issueable
- . . S ACCT=$$ACCT1^PRCPUX1($$FSC^PRCPUX1($P(D,"^",5)))
- . . S TRANSNO=$P(D,"^",19)
- . . S INVVAL=$P(D,"^",7)*$P(D,"^",8) I $P(D,"^",22)'="" S INVVAL=$P(D,"^",22)
- . . ; set transno temporary for primary and secondary to
- . . ; indicate type of transaction
- . . I PRCP("DPTYPE")'="W" D
- . . . I TYPE="R"!(TYPE="C")!(TYPE="E")!(TYPE="U")!(TYPE="S") S TRANSNO="--1" Q ;usage
- . . . I TYPE="RC" S TRANSNO=1 Q ;receipt
- . . . S TRANSNO="" ;adjustment
- . . ; other adjustments
- . . I PRCP("DPTYPE")="W",$P(TRANSNO,"-",2)="" S ADJ(ACCT)=$G(ADJ(ACCT))+INVVAL,ADJN(ACCT)=$G(ADJN(ACCT))+1 Q
- . . I TRANSNO="" S ADJ(ACCT)=$G(ADJ(ACCT))+INVVAL,ADJN(ACCT)=$G(ADJN(ACCT))+1
- . . E D
- . . . ; purchase order
- . . . I $P(TRANSNO,"-",3)="" S REC(ACCT)=$G(REC(ACCT))+INVVAL,RECN(ACCT)=$G(RECN(ACCT))+1 Q
- . . . ; usage
- . . . S ISS(ACCT)=$G(ISS(ACCT))+INVVAL,ISSN(ACCT)=$G(ISSN(ACCT))+1
- ;
- ; calculate inactive, long supply, set non-issuable
- ;
- ;*98 Modified long supply range to be 90 days instead of 270 days for
- ;warehouse, primary, and secondary reporting
- ;
- S X1=$E(DT,1,5)_"01",X2=-89 D C^%DTC S DATELONG=$E(X,1,5),X1=DT,X2=$E(X,1,5)_"00" D ^%DTC S TOTDAYS=X
- S ITEMDA=0 F S ITEMDA=$O(^PRCP(445,PRCP("I"),1,ITEMDA)) Q:'ITEMDA S D=$G(^(ITEMDA,0)) I D'="" D
- . S ACCT=$$ACCT1^PRCPUX1($$FSC^PRCPUX1(ITEMDA))
- . ; value
- . S VALUE(ACCT)=$G(VALUE(ACCT))+$P(D,"^",27)
- . S DUEIN(ACCT)=$G(DUEIN(ACCT))+($$GETIN^PRCPUDUE(PRCP("I"),ITEMDA)*$P(D,"^",22))
- . S DUEOUT(ACCT)=$G(DUEOUT(ACCT))+($$GETOUT^PRCPUDUE(PRCP("I"),ITEMDA)*$P(D,"^",22))
- . ; non-issuable
- . I $P(D,"^",19) S NONISS(ACCT)=$G(NONISS(ACCT))+($J($P(D,"^",19)*$P(D,"^",22),0,2)),NONISSN(ACCT)=$G(NONISSN(ACCT))+1
- . ; inactive
- . ; if reusable, quit
- . I $$REUSABLE^PRCPU441(ITEMDA) Q
- . S QTY=$P(D,"^",7)+$P(D,"^",19)
- . I QTY,'$O(^PRCP(445,PRCP("I"),1,ITEMDA,2,$E(DATEINAC,1,5)-.01)),'$O(^PRCP(445,PRCP("I"),1,ITEMDA,3,DATEINAC)) S INACT(ACCT)=$G(INACT(ACCT))+$P(D,"^",27),INACTN(ACCT)=$G(INACTN(ACCT))+1
- . ; long supply
- . S DATE=DATELONG-.01,TOTAL=0 F S DATE=$O(^PRCP(445,PRCP("I"),1,ITEMDA,2,DATE)) Q:'DATE S TOTAL=TOTAL+$P($G(^(DATE,0)),"^",2)
- . S AVERAGE=$J(TOTAL/TOTDAYS,0,2),TOTAL=$S('AVERAGE&(QTY):9999999,'AVERAGE:0,1:QTY/AVERAGE\1)
- . I TOTAL>90 S LONG(ACCT)=$G(LONG(ACCT))+$P(D,"^",27),LONGN(ACCT)=$G(LONGN(ACCT))+1
- ;
- ;*98 Routed printing based on Warehouse
- D PRINT^PRCPRSS0
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPRSSR 5441 printed Feb 18, 2025@23:41:56 Page 2
- +1 ;;5.1;IFCAP;**17,41,98**;Oct 20, 2000;Build 37
- +2 ;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ;
- +4 ;*83 Routine PRCPLO2 associated with PRC*5.1*83 is a modified copy of
- +5 ;this routine and any changes made to this routine should also be
- +6 ;considered for that routine as well.
- +7 ;
- +8 ;*98 Changed previous displays of "issues" to "usage"
- +9 ;
- +10 DO ^PRCPUSEL
- if '$DATA(PRCP("I"))
- QUIT
- +11 NEW %,%DT,%H,%I,DATEINAC,DATESTRT,TODAY,X,X1,X2,Y
- +12 KILL X
- SET X(1)="The Stock Status Report will print a summary of all usage, receipts, and adjustments with the opening and closing balances by account codes."
- +13 SET X(2)="It will calculate the turnover rate, inactive item percent, long supply percent, and non-issuable percent."
- +14 DO DISPLAY^PRCPUX2(40,79,.X)
- +15 KILL X
- SET X(1)="Enter the date (month-year) for the Stock Status Report."
- DO DISPLAY^PRCPUX2(2,40,.X)
- +16 DO NOW^%DTC
- SET TODAY=X
- SET Y=$EXTRACT(X,1,5)_"00"
- SET %DT(0)=-Y
- DO DD^%DT
- SET %DT="AEP"
- SET %DT("B")=Y
- SET %DT("A")="Print Stock Status for MONTH and YEAR: "
- DO ^%DT
- KILL %DT
- IF Y<1
- QUIT
- +17 SET DATESTRT=$EXTRACT(Y,1,5)_"00"
- +18 KILL X
- SET X(1)="The inactive item percent is calculated for items which have not had activity (receipts or usage) after a specified cutoff date."
- DO DISPLAY^PRCPUX2(40,79,.X)
- +19 KILL X
- SET X(1)="Enter the Inactivity cutoff date."
- DO DISPLAY^PRCPUX2(2,40,.X)
- +20 SET X1=TODAY
- SET X2=-90
- DO C^%DTC
- SET Y=$EXTRACT(X,1,5)_"00"
- DO DD^%DT
- +21 SET %DT(0)=-($EXTRACT(TODAY,1,5)_"00")
- SET %DT="AEP"
- SET %DT("B")=Y
- SET %DT("A")="Enter Inactivity Cutoff MONTH and YEAR: "
- DO ^%DT
- KILL %DT
- IF Y<1
- QUIT
- +22 SET DATEINAC=$EXTRACT(Y,1,5)_"00"
- +23 ;
- +24 ;*98 Branch to PRCPRSSP if the inventory point being reported is a
- +25 ;primary or secondary
- +26 ;
- +27 IF PRCP("DPTYPE")'="W"
- DO ENT^PRCPRSSP
- QUIT
- +28 ;
- +29 NEW ZTDESC,ZTRTN,ZTSAVE,POP
- +30 WRITE !
- SET %ZIS="Q"
- DO ^%ZIS
- if POP
- QUIT
- IF $DATA(IO("Q"))
- Begin DoDot:1
- +31 SET ZTDESC="Stock Status Report"
- SET ZTRTN="DQ^PRCPRSSR"
- +32 SET ZTSAVE("PRCP*")=""
- SET ZTSAVE("DATE*")=""
- SET ZTSAVE("ZTREQ")="@"
- End DoDot:1
- DO ^%ZTLOAD
- KILL IO("Q"),ZTSK
- QUIT
- +33 WRITE !!,"<*> please wait <*>"
- +34 ;
- DQ ; queue starts here
- +1 NEW ACCT,ADJ,ADJN,AVERAGE,D,DA,DATE,DATELONG,DUEIN,DUEOUT,INACT,INACTN,INVVAL,ISS,ISSN,ITEMDA,LONG,LONGN,NONISS,NONISSN,ONHAND,OPEN,QTY,REC,RECN,TOTAL,TOTDAYS,TRANSNO,TYPE,VALUE
- +2 KILL OPEN
- +3 SET ITEMDA=0
- FOR
- SET ITEMDA=$ORDER(^PRCP(445.1,PRCP("I"),1,ITEMDA))
- if 'ITEMDA
- QUIT
- SET X=$$GETOPEN^PRCPUBAL(PRCP("I"),ITEMDA,$EXTRACT(DATESTRT,1,5))
- IF X'=""
- Begin DoDot:1
- +4 SET ACCT=$$ACCT1^PRCPUX1($$FSC^PRCPUX1(ITEMDA))
- +5 SET $PIECE(OPEN(ACCT),"^")=$PIECE($GET(OPEN(ACCT)),"^")+$PIECE(X,"^",2)+$PIECE(X,"^",3)
- +6 SET $PIECE(OPEN(ACCT),"^",2)=$PIECE($GET(OPEN(ACCT)),"^",2)+$PIECE(X,"^",8)
- End DoDot:1
- +7 SET DATE=DATESTRT
- FOR
- SET DATE=$ORDER(^PRCP(445.2,"AX",PRCP("I"),DATE))
- if $EXTRACT(DATE,1,5)'=$EXTRACT(DATESTRT,1,5)
- QUIT
- SET TYPE=""
- FOR
- SET TYPE=$ORDER(^PRCP(445.2,"AX",PRCP("I"),DATE,TYPE))
- if TYPE=""
- QUIT
- Begin DoDot:1
- +8 SET DA=0
- FOR
- SET DA=$ORDER(^PRCP(445.2,"AX",PRCP("I"),DATE,TYPE,DA))
- if 'DA
- QUIT
- Begin DoDot:2
- +9 SET D=$GET(^PRCP(445.2,DA,0))
- IF '$PIECE(D,"^",5)
- QUIT
- +10 ; non-issuable
- +11 ;count if not flagged as non-issueable
- if $PIECE(D,"^",11)="N"
- QUIT
- +12 SET ACCT=$$ACCT1^PRCPUX1($$FSC^PRCPUX1($PIECE(D,"^",5)))
- +13 SET TRANSNO=$PIECE(D,"^",19)
- +14 SET INVVAL=$PIECE(D,"^",7)*$PIECE(D,"^",8)
- IF $PIECE(D,"^",22)'=""
- SET INVVAL=$PIECE(D,"^",22)
- +15 ; set transno temporary for primary and secondary to
- +16 ; indicate type of transaction
- +17 IF PRCP("DPTYPE")'="W"
- Begin DoDot:3
- +18 ;usage
- IF TYPE="R"!(TYPE="C")!(TYPE="E")!(TYPE="U")!(TYPE="S")
- SET TRANSNO="--1"
- QUIT
- +19 ;receipt
- IF TYPE="RC"
- SET TRANSNO=1
- QUIT
- +20 ;adjustment
- SET TRANSNO=""
- End DoDot:3
- +21 ; other adjustments
- +22 IF PRCP("DPTYPE")="W"
- IF $PIECE(TRANSNO,"-",2)=""
- SET ADJ(ACCT)=$GET(ADJ(ACCT))+INVVAL
- SET ADJN(ACCT)=$GET(ADJN(ACCT))+1
- QUIT
- +23 IF TRANSNO=""
- SET ADJ(ACCT)=$GET(ADJ(ACCT))+INVVAL
- SET ADJN(ACCT)=$GET(ADJN(ACCT))+1
- +24 IF '$TEST
- Begin DoDot:3
- +25 ; purchase order
- +26 IF $PIECE(TRANSNO,"-",3)=""
- SET REC(ACCT)=$GET(REC(ACCT))+INVVAL
- SET RECN(ACCT)=$GET(RECN(ACCT))+1
- QUIT
- +27 ; usage
- +28 SET ISS(ACCT)=$GET(ISS(ACCT))+INVVAL
- SET ISSN(ACCT)=$GET(ISSN(ACCT))+1
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +29 ;
- +30 ; calculate inactive, long supply, set non-issuable
- +31 ;
- +32 ;*98 Modified long supply range to be 90 days instead of 270 days for
- +33 ;warehouse, primary, and secondary reporting
- +34 ;
- +35 SET X1=$EXTRACT(DT,1,5)_"01"
- SET X2=-89
- DO C^%DTC
- SET DATELONG=$EXTRACT(X,1,5)
- SET X1=DT
- SET X2=$EXTRACT(X,1,5)_"00"
- DO ^%DTC
- SET TOTDAYS=X
- +36 SET ITEMDA=0
- FOR
- SET ITEMDA=$ORDER(^PRCP(445,PRCP("I"),1,ITEMDA))
- if 'ITEMDA
- QUIT
- SET D=$GET(^(ITEMDA,0))
- IF D'=""
- Begin DoDot:1
- +37 SET ACCT=$$ACCT1^PRCPUX1($$FSC^PRCPUX1(ITEMDA))
- +38 ; value
- +39 SET VALUE(ACCT)=$GET(VALUE(ACCT))+$PIECE(D,"^",27)
- +40 SET DUEIN(ACCT)=$GET(DUEIN(ACCT))+($$GETIN^PRCPUDUE(PRCP("I"),ITEMDA)*$PIECE(D,"^",22))
- +41 SET DUEOUT(ACCT)=$GET(DUEOUT(ACCT))+($$GETOUT^PRCPUDUE(PRCP("I"),ITEMDA)*$PIECE(D,"^",22))
- +42 ; non-issuable
- +43 IF $PIECE(D,"^",19)
- SET NONISS(ACCT)=$GET(NONISS(ACCT))+($JUSTIFY($PIECE(D,"^",19)*$PIECE(D,"^",22),0,2))
- SET NONISSN(ACCT)=$GET(NONISSN(ACCT))+1
- +44 ; inactive
- +45 ; if reusable, quit
- +46 IF $$REUSABLE^PRCPU441(ITEMDA)
- QUIT
- +47 SET QTY=$PIECE(D,"^",7)+$PIECE(D,"^",19)
- +48 IF QTY
- IF '$ORDER(^PRCP(445,PRCP("I"),1,ITEMDA,2,$EXTRACT(DATEINAC,1,5)-.01))
- IF '$ORDER(^PRCP(445,PRCP("I"),1,ITEMDA,3,DATEINAC))
- SET INACT(ACCT)=$GET(INACT(ACCT))+$PIECE(D,"^",27)
- SET INACTN(ACCT)=$GET(INACTN(ACCT))+1
- +49 ; long supply
- +50 SET DATE=DATELONG-.01
- SET TOTAL=0
- FOR
- SET DATE=$ORDER(^PRCP(445,PRCP("I"),1,ITEMDA,2,DATE))
- if 'DATE
- QUIT
- SET TOTAL=TOTAL+$PIECE($GET(^(DATE,0)),"^",2)
- +51 SET AVERAGE=$JUSTIFY(TOTAL/TOTDAYS,0,2)
- SET TOTAL=$SELECT('AVERAGE&(QTY):9999999,'AVERAGE:0,1:QTY/AVERAGE\1)
- +52 IF TOTAL>90
- SET LONG(ACCT)=$GET(LONG(ACCT))+$PIECE(D,"^",27)
- SET LONGN(ACCT)=$GET(LONGN(ACCT))+1
- End DoDot:1
- +53 ;
- +54 ;*98 Routed printing based on Warehouse
- +55 DO PRINT^PRCPRSS0
- +56 QUIT