PRCPRSSP ;WOIFO/DAP-stock status report for primaries and secondaries; 10/16/06 2:07pm ; 2/23/07 4:59pm
;;5.1;IFCAP;**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 "usages"
;
ENT ;*98 Entry point from PRCPRSSR when inventory point is confirmed to be
;primary or secondary
;
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^PRCPRSSP"
. 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
N ODITEM,NODE1,X,X1,X2
K ^TMP($J)
K OPEN
;*98 Modified calculations to separate ODI and Standard Items
;
S ITEMDA=0 F S ITEMDA=$O(^PRCP(445,PRCP("I"),1,ITEMDA)) Q:'ITEMDA D
. S NODE1=1
. S ODITEM=$$ODITEM^PRCPUX2(PRCP("I"),ITEMDA)
. I ODITEM="Y" S NODE1=2
. S ACCT=$$ACCT1^PRCPUX1($$FSC^PRCPUX1(ITEMDA))
. ;*98 Added item counter logic
. S ^TMP($J,NODE1,"CNT",ACCT)=$G(^TMP($J,NODE1,"CNT",ACCT))+1
;
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 NODE1=1
. S ODITEM=$$ODITEM^PRCPUX2(PRCP("I"),ITEMDA)
. I ODITEM="Y" S NODE1=2
. S ACCT=$$ACCT1^PRCPUX1($$FSC^PRCPUX1(ITEMDA))
. ;*98 Added item counter logic
. S $P(^TMP($J,NODE1,"OPEN",ACCT),"^")=$P($G(^TMP($J,NODE1,"OPEN",ACCT)),"^")+$P(X,"^",2)+$P(X,"^",3)
. S $P(^TMP($J,NODE1,"OPEN",ACCT),"^",2)=$P($G(^TMP($J,NODE1,"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)
.. S NODE1=1
.. I $$ODITEM^PRCPUX2(PRCP("I"),$P(D,"^",5))="Y" S NODE1=2
.. ; set transno temporary for primary and secondary to
.. ; indicate type of transaction
.. ;*98 Removed warehouse check from loop entry below
.. 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
.. ;*98 Removed line featuring warehouse logic
.. ;I PRCP("DPTYPE")="W",$P(TRANSNO,"-",2)="" S ^TMP($J,NODE1,"ADJ",ACCT)=$G(^TMP($J,NODE1,"ADJ",ACCT))+INVVAL,^TMP($J,NODE1,"ADJN",ACCT)=$G(^TMP($J,NODE1,"ADJN",ACCT))+1 Q
.. I TRANSNO="" S ^TMP($J,NODE1,"ADJ",ACCT)=$G(^TMP($J,NODE1,"ADJ",ACCT))+INVVAL,^TMP($J,NODE1,"ADJN",ACCT)=$G(^TMP($J,NODE1,"ADJN",ACCT))+1
.. E D
... ; purchase order
... I $P(TRANSNO,"-",3)="" S ^TMP($J,NODE1,"REC",ACCT)=$G(^TMP($J,NODE1,"REC",ACCT))+INVVAL,^TMP($J,NODE1,"RECN",ACCT)=$G(^TMP($J,NODE1,"RECN",ACCT))+1 Q
... ; usage
... S ^TMP($J,NODE1,"ISS",ACCT)=$G(^TMP($J,NODE1,"ISS",ACCT))+INVVAL,^TMP($J,NODE1,"ISSN",ACCT)=$G(^TMP($J,NODE1,"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 NODE1=1
. S ODITEM=$$ODITEM^PRCPUX2(PRCP("I"),ITEMDA)
. I ODITEM="Y" S NODE1=2
. S ACCT=$$ACCT1^PRCPUX1($$FSC^PRCPUX1(ITEMDA))
. ; value
. S ^TMP($J,NODE1,"VALUE",ACCT)=$G(^TMP($J,NODE1,"VALUE",ACCT))+$P(D,"^",27)
. S ^TMP($J,NODE1,"DUEIN",ACCT)=$G(^TMP($J,NODE1,"DUEIN",ACCT))+($$GETIN^PRCPUDUE(PRCP("I"),ITEMDA)*$P(D,"^",22))
. S ^TMP($J,NODE1,"DUEOUT",ACCT)=$G(^TMP($J,NODE1,"DUEOUT",ACCT))+($$GETOUT^PRCPUDUE(PRCP("I"),ITEMDA)*$P(D,"^",22))
. ;*98 Removed non-issuable section since they never appear for primary or secondary inventory points
. ;
. ; 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)) D
. . S ^TMP($J,NODE1,"INACT",ACCT)=$G(^TMP($J,NODE1,"INACT",ACCT))+$P(D,"^",27),^TMP($J,NODE1,"INACTN",ACCT)=$G(^TMP($J,NODE1,"INACTN",ACCT))+1 Q
. ; 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 ^TMP($J,NODE1,"LONG",ACCT)=$G(^TMP($J,NODE1,"LONG",ACCT))+$P(D,"^",27),^TMP($J,NODE1,"LONGN",ACCT)=$G(^TMP($J,NODE1,"LONGN",ACCT))+1
;
;*98 Create consolidated array of Standard and ODI items
N I,PRCPQ1,PRCPQ2,L,TEMPDATA
F I=1:1:2 D
. S PRCPQ1=""
. F S PRCPQ1=$O(^TMP($J,I,PRCPQ1)) Q:PRCPQ1="" D
.. S PRCPQ2=""
.. F S PRCPQ2=$O(^TMP($J,I,PRCPQ1,PRCPQ2)) Q:PRCPQ2="" D
... S TEMPDATA=^TMP($J,I,PRCPQ1,PRCPQ2)
... F L=1:1:2 S $P(^TMP($J,3,PRCPQ1,PRCPQ2),"^",L)=$P($G(^TMP($J,3,PRCPQ1,PRCPQ2)),"^",L)+$P(TEMPDATA,"^",L)
;
;*98 Routed printing based on Primary/Secondary status
D PRINT^PRCPRSS1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPRSSP 5963 printed Dec 13, 2024@02:15:32 Page 2
+1 ;;5.1;IFCAP;**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 "usages"
+9 ;
ENT ;*98 Entry point from PRCPRSSR when inventory point is confirmed to be
+1 ;primary or secondary
+2 ;
+3 NEW ZTDESC,ZTRTN,ZTSAVE,POP
+4 WRITE !
SET %ZIS="Q"
DO ^%ZIS
if POP
QUIT
IF $DATA(IO("Q"))
Begin DoDot:1
+5 SET ZTDESC="Stock Status Report"
SET ZTRTN="DQ^PRCPRSSP"
+6 SET ZTSAVE("PRCP*")=""
SET ZTSAVE("DATE*")=""
SET ZTSAVE("ZTREQ")="@"
End DoDot:1
DO ^%ZTLOAD
KILL IO("Q"),ZTSK
QUIT
+7 WRITE !!,"<*> please wait <*>"
+8 ;
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 NEW ODITEM,NODE1,X,X1,X2
+3 KILL ^TMP($JOB)
+4 KILL OPEN
+5 ;*98 Modified calculations to separate ODI and Standard Items
+6 ;
+7 SET ITEMDA=0
FOR
SET ITEMDA=$ORDER(^PRCP(445,PRCP("I"),1,ITEMDA))
if 'ITEMDA
QUIT
Begin DoDot:1
+8 SET NODE1=1
+9 SET ODITEM=$$ODITEM^PRCPUX2(PRCP("I"),ITEMDA)
+10 IF ODITEM="Y"
SET NODE1=2
+11 SET ACCT=$$ACCT1^PRCPUX1($$FSC^PRCPUX1(ITEMDA))
+12 ;*98 Added item counter logic
+13 SET ^TMP($JOB,NODE1,"CNT",ACCT)=$GET(^TMP($JOB,NODE1,"CNT",ACCT))+1
End DoDot:1
+14 ;
+15 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
+16 SET NODE1=1
+17 SET ODITEM=$$ODITEM^PRCPUX2(PRCP("I"),ITEMDA)
+18 IF ODITEM="Y"
SET NODE1=2
+19 SET ACCT=$$ACCT1^PRCPUX1($$FSC^PRCPUX1(ITEMDA))
+20 ;*98 Added item counter logic
+21 SET $PIECE(^TMP($JOB,NODE1,"OPEN",ACCT),"^")=$PIECE($GET(^TMP($JOB,NODE1,"OPEN",ACCT)),"^")+$PIECE(X,"^",2)+$PIECE(X,"^",3)
+22 SET $PIECE(^TMP($JOB,NODE1,"OPEN",ACCT),"^",2)=$PIECE($GET(^TMP($JOB,NODE1,"OPEN",ACCT)),"^",2)+$PIECE(X,"^",8)
End DoDot:1
+23 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
+24 SET DA=0
FOR
SET DA=$ORDER(^PRCP(445.2,"AX",PRCP("I"),DATE,TYPE,DA))
if 'DA
QUIT
Begin DoDot:2
+25 SET D=$GET(^PRCP(445.2,DA,0))
IF '$PIECE(D,"^",5)
QUIT
+26 ; non-issuable
+27 ;count if not flagged as non-issueable
if $PIECE(D,"^",11)="N"
QUIT
+28 SET ACCT=$$ACCT1^PRCPUX1($$FSC^PRCPUX1($PIECE(D,"^",5)))
+29 SET TRANSNO=$PIECE(D,"^",19)
+30 SET INVVAL=$PIECE(D,"^",7)*$PIECE(D,"^",8)
IF $PIECE(D,"^",22)'=""
SET INVVAL=$PIECE(D,"^",22)
+31 SET NODE1=1
+32 IF $$ODITEM^PRCPUX2(PRCP("I"),$PIECE(D,"^",5))="Y"
SET NODE1=2
+33 ; set transno temporary for primary and secondary to
+34 ; indicate type of transaction
+35 ;*98 Removed warehouse check from loop entry below
+36 Begin DoDot:3
+37 ;usage
IF TYPE="R"!(TYPE="C")!(TYPE="E")!(TYPE="U")!(TYPE="S")
SET TRANSNO="--1"
QUIT
+38 ;receipt
IF TYPE="RC"
SET TRANSNO=1
QUIT
+39 ;adjustment
SET TRANSNO=""
End DoDot:3
+40 ; other adjustments
+41 ;*98 Removed line featuring warehouse logic
+42 ;I PRCP("DPTYPE")="W",$P(TRANSNO,"-",2)="" S ^TMP($J,NODE1,"ADJ",ACCT)=$G(^TMP($J,NODE1,"ADJ",ACCT))+INVVAL,^TMP($J,NODE1,"ADJN",ACCT)=$G(^TMP($J,NODE1,"ADJN",ACCT))+1 Q
+43 IF TRANSNO=""
SET ^TMP($JOB,NODE1,"ADJ",ACCT)=$GET(^TMP($JOB,NODE1,"ADJ",ACCT))+INVVAL
SET ^TMP($JOB,NODE1,"ADJN",ACCT)=$GET(^TMP($JOB,NODE1,"ADJN",ACCT))+1
+44 IF '$TEST
Begin DoDot:3
+45 ; purchase order
+46 IF $PIECE(TRANSNO,"-",3)=""
SET ^TMP($JOB,NODE1,"REC",ACCT)=$GET(^TMP($JOB,NODE1,"REC",ACCT))+INVVAL
SET ^TMP($JOB,NODE1,"RECN",ACCT)=$GET(^TMP($JOB,NODE1,"RECN",ACCT))+1
QUIT
+47 ; usage
+48 SET ^TMP($JOB,NODE1,"ISS",ACCT)=$GET(^TMP($JOB,NODE1,"ISS",ACCT))+INVVAL
SET ^TMP($JOB,NODE1,"ISSN",ACCT)=$GET(^TMP($JOB,NODE1,"ISSN",ACCT))+1
End DoDot:3
End DoDot:2
End DoDot:1
+49 ;
+50 ; calculate inactive, long supply, set non-issuable
+51 ;
+52 ;*98 Modified long supply range to be 90 days instead of 270 days for
+53 ;warehouse, primary, and secondary reporting
+54 ;
+55 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
+56 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
+57 SET NODE1=1
+58 SET ODITEM=$$ODITEM^PRCPUX2(PRCP("I"),ITEMDA)
+59 IF ODITEM="Y"
SET NODE1=2
+60 SET ACCT=$$ACCT1^PRCPUX1($$FSC^PRCPUX1(ITEMDA))
+61 ; value
+62 SET ^TMP($JOB,NODE1,"VALUE",ACCT)=$GET(^TMP($JOB,NODE1,"VALUE",ACCT))+$PIECE(D,"^",27)
+63 SET ^TMP($JOB,NODE1,"DUEIN",ACCT)=$GET(^TMP($JOB,NODE1,"DUEIN",ACCT))+($$GETIN^PRCPUDUE(PRCP("I"),ITEMDA)*$PIECE(D,"^",22))
+64 SET ^TMP($JOB,NODE1,"DUEOUT",ACCT)=$GET(^TMP($JOB,NODE1,"DUEOUT",ACCT))+($$GETOUT^PRCPUDUE(PRCP("I"),ITEMDA)*$PIECE(D,"^",22))
+65 ;*98 Removed non-issuable section since they never appear for primary or secondary inventory points
+66 ;
+67 ; inactive
+68 ; if reusable, quit
+69 IF $$REUSABLE^PRCPU441(ITEMDA)
QUIT
+70 SET QTY=$PIECE(D,"^",7)+$PIECE(D,"^",19)
+71 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))
Begin DoDot:2
+72 SET ^TMP($JOB,NODE1,"INACT",ACCT)=$GET(^TMP($JOB,NODE1,"INACT",ACCT))+$PIECE(D,"^",27)
SET ^TMP($JOB,NODE1,"INACTN",ACCT)=$GET(^TMP($JOB,NODE1,"INACTN",ACCT))+1
QUIT
End DoDot:2
+73 ; long supply
+74 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)
+75 SET AVERAGE=$JUSTIFY(TOTAL/TOTDAYS,0,2)
SET TOTAL=$SELECT('AVERAGE&(QTY):9999999,'AVERAGE:0,1:QTY/AVERAGE\1)
+76 IF TOTAL>90
SET ^TMP($JOB,NODE1,"LONG",ACCT)=$GET(^TMP($JOB,NODE1,"LONG",ACCT))+$PIECE(D,"^",27)
SET ^TMP($JOB,NODE1,"LONGN",ACCT)=$GET(^TMP($JOB,NODE1,"LONGN",ACCT))+1
End DoDot:1
+77 ;
+78 ;*98 Create consolidated array of Standard and ODI items
+79 NEW I,PRCPQ1,PRCPQ2,L,TEMPDATA
+80 FOR I=1:1:2
Begin DoDot:1
+81 SET PRCPQ1=""
+82 FOR
SET PRCPQ1=$ORDER(^TMP($JOB,I,PRCPQ1))
if PRCPQ1=""
QUIT
Begin DoDot:2
+83 SET PRCPQ2=""
+84 FOR
SET PRCPQ2=$ORDER(^TMP($JOB,I,PRCPQ1,PRCPQ2))
if PRCPQ2=""
QUIT
Begin DoDot:3
+85 SET TEMPDATA=^TMP($JOB,I,PRCPQ1,PRCPQ2)
+86 FOR L=1:1:2
SET $PIECE(^TMP($JOB,3,PRCPQ1,PRCPQ2),"^",L)=$PIECE($GET(^TMP($JOB,3,PRCPQ1,PRCPQ2)),"^",L)+$PIECE(TEMPDATA,"^",L)
End DoDot:3
End DoDot:2
End DoDot:1
+87 ;
+88 ;*98 Routed printing based on Primary/Secondary status
+89 DO PRINT^PRCPRSS1
+90 QUIT
