PRCPLO2 ;WISC/RFJ/dh/DWA/DAP-stock status report (option, whse) ; 2/23/07 5:00pm
;;5.1;IFCAP;**83,41,98**;Oct 20, 2000;Build 37
;Per VHA Directive 2004-038, this routine should not be modified.
;Copied from routine ^PRCPRSSR and modified for PRC*5.1*83 (CLRS)
;
ENT ;This report will be called from option PRCPLO CLO GIP OPTION with fixed
;input parameters and run for all stations and active inventory points
;on a given VistA system.
L +^PRCP(446.7,"STATUS"):3 I $T=0 S PRCPMSG(1)="Error encountered when attempting to run CLO GIP Reports due to other",PRCPMSG(2)="CLRS extracts in progress, please try again later." D MAIL^PRCPLO3 Q
K ^PRCP(446.7)
S ^PRCP(446.7,0)="CLRS REPORT STORAGE^446.7^^"
N CLRSFLAG
S CLRSFLAG="SS" D GETIPT^PRCPLO1
;*83 This call links the Stock on Hand Report in a series of two
;consecutive report runs to be executed on the 1st of each month.
L -^PRCP(446.7,"STATUS")
D ENT^PRCPLO
N PRCPMSG S PRCPMSG(1)="CLO GIP Reports completed on "_$$HTE^XLFDT($H) D MAIL^PRCPLO3
Q
;
EN1 ;*83 Call coming in from PRCPLO1 with station number and inventory point
;
N %,%DT,%H,%I,DATEINAC,DATESTRT,TODAY,X,X1,X2,Y,MNT,INARNG
;*83 The following was edited to always enter the previous month as the start date
D NOW^%DTC S TODAY=X,Y=$E(X,1,3),MNT=$E(X,4,5)
S MNT=MNT-1
I MNT=0 S MNT=12,Y=Y-1
I $L(MNT)=1 S MNT=0_MNT
S DATESTRT=Y_MNT_"00"
;
;*83 The following was edited to always enter a 90 day previous to
;current date default inactivity range if no other is indicated via the
;PRCPLO INACTIVITY RANGE parameter
S INARNG=$$GET^XPAR("SYS","PRCPLO INACTIVITY RANGE",1,"Q")
I INARNG="" S INARNG=90
S X1=TODAY,X2=(INARNG*-1) D C^%DTC S DATEINAC=$E(X,1,5)_"00"
S DT=TODAY
;
;*83 Build report with station and inventory point passed in from PRCPLO1 call
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
;*83 Added newing of variables
N STA,INV,TOTOPEN,TOTREC,TOTISS,TOTADJ,TOTCLOS,RECNM,TOTN,DATRN,TOTINA,TOTIS1,TOTAD1,TOTIND,TOTLNG,TOTLND,DAYS,DATRN1,ODITEM,NODE1
;*98 Modified calculations to separate ODI and Standard Items
K ^TMP($J)
K OPEN
;
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))
. 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))
. 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
. . I PRCP("DPTYPE")'="W" D
. . . I TYPE="R"!(TYPE="C")!(TYPE="E")!(TYPE="U")!(TYPE="S") S TRANSNO="--1" Q ;issue
. . . I TYPE="RC" S TRANSNO=1 Q ;receipt
. . . S TRANSNO="" ;adjustment
. . ; other adjustments
. . 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
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 NODE1=1
. S ODITEM=$$ODITEM^PRCPUX2(PRCP("I"),ITEMDA)
. I ODITEM="Y" S NODE1=2
. 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))
. ; non-issuable
. I $P(D,"^",19) S ^TMP($J,NODE1,"NISS",ACCT)=$G(^TMP($J,NODE1,"NISS",ACCT))+($J($P(D,"^",19)*$P(D,"^",22),0,2)),^TMP($J,NODE1,"NISSN",ACCT)=$G(^TMP($J,NODE1,"NISSN",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)) 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
. ; 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 On-Demand Items
N I,J,PRCPQ1,PRCPQ2,PRCPR1,PRCPR2,PRCPS1,PRCPS2,L,J,K,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)
;
F J=1:1:3 D
. S PRCPR1="" F S PRCPR1=$O(^TMP($J,3,PRCPR1)) Q:PRCPR1="" S ^TMP($J,J,PRCPR1,"TOTAL")=0
;
F K=1:1:3 D
. S PRCPS1="" F S PRCPS1=$O(^TMP($J,K,PRCPS1)) Q:PRCPS1="" D
.. S PRCPS2="" F S PRCPS2=$O(^TMP($J,K,PRCPS1,PRCPS2)) Q:+PRCPS2=0 D
... S ^TMP($J,K,PRCPS1,"TOTAL")=$G(^TMP($J,K,PRCPS1,"TOTAL"))+$G(^TMP($J,K,PRCPS1,PRCPS2))
;
D ENT^PRCPLO2A
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPLO2 7422 printed Sep 23, 2025@19:50:10 Page 2
PRCPLO2 ;WISC/RFJ/dh/DWA/DAP-stock status report (option, whse) ; 2/23/07 5:00pm
+1 ;;5.1;IFCAP;**83,41,98**;Oct 20, 2000;Build 37
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;Copied from routine ^PRCPRSSR and modified for PRC*5.1*83 (CLRS)
+4 ;
ENT ;This report will be called from option PRCPLO CLO GIP OPTION with fixed
+1 ;input parameters and run for all stations and active inventory points
+2 ;on a given VistA system.
+3 LOCK +^PRCP(446.7,"STATUS"):3
IF $TEST=0
SET PRCPMSG(1)="Error encountered when attempting to run CLO GIP Reports due to other"
SET PRCPMSG(2)="CLRS extracts in progress, please try again later."
DO MAIL^PRCPLO3
QUIT
+4 KILL ^PRCP(446.7)
+5 SET ^PRCP(446.7,0)="CLRS REPORT STORAGE^446.7^^"
+6 NEW CLRSFLAG
+7 SET CLRSFLAG="SS"
DO GETIPT^PRCPLO1
+8 ;*83 This call links the Stock on Hand Report in a series of two
+9 ;consecutive report runs to be executed on the 1st of each month.
+10 LOCK -^PRCP(446.7,"STATUS")
+11 DO ENT^PRCPLO
+12 NEW PRCPMSG
SET PRCPMSG(1)="CLO GIP Reports completed on "_$$HTE^XLFDT($HOROLOG)
DO MAIL^PRCPLO3
+13 QUIT
+14 ;
EN1 ;*83 Call coming in from PRCPLO1 with station number and inventory point
+1 ;
+2 NEW %,%DT,%H,%I,DATEINAC,DATESTRT,TODAY,X,X1,X2,Y,MNT,INARNG
+3 ;*83 The following was edited to always enter the previous month as the start date
+4 DO NOW^%DTC
SET TODAY=X
SET Y=$EXTRACT(X,1,3)
SET MNT=$EXTRACT(X,4,5)
+5 SET MNT=MNT-1
+6 IF MNT=0
SET MNT=12
SET Y=Y-1
+7 IF $LENGTH(MNT)=1
SET MNT=0_MNT
+8 SET DATESTRT=Y_MNT_"00"
+9 ;
+10 ;*83 The following was edited to always enter a 90 day previous to
+11 ;current date default inactivity range if no other is indicated via the
+12 ;PRCPLO INACTIVITY RANGE parameter
+13 SET INARNG=$$GET^XPAR("SYS","PRCPLO INACTIVITY RANGE",1,"Q")
+14 IF INARNG=""
SET INARNG=90
+15 SET X1=TODAY
SET X2=(INARNG*-1)
DO C^%DTC
SET DATEINAC=$EXTRACT(X,1,5)_"00"
+16 SET DT=TODAY
+17 ;
+18 ;*83 Build report with station and inventory point passed in from PRCPLO1 call
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 ;*83 Added newing of variables
+3 NEW STA,INV,TOTOPEN,TOTREC,TOTISS,TOTADJ,TOTCLOS,RECNM,TOTN,DATRN,TOTINA,TOTIS1,TOTAD1,TOTIND,TOTLNG,TOTLND,DAYS,DATRN1,ODITEM,NODE1
+4 ;*98 Modified calculations to separate ODI and Standard Items
+5 KILL ^TMP($JOB)
+6 KILL OPEN
+7 ;
+8 SET ITEMDA=0
FOR
SET ITEMDA=$ORDER(^PRCP(445,PRCP("I"),1,ITEMDA))
if 'ITEMDA
QUIT
Begin DoDot:1
+9 SET NODE1=1
+10 SET ODITEM=$$ODITEM^PRCPUX2(PRCP("I"),ITEMDA)
+11 IF ODITEM="Y"
SET NODE1=2
+12 SET ACCT=$$ACCT1^PRCPUX1($$FSC^PRCPUX1(ITEMDA))
+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 SET $PIECE(^TMP($JOB,NODE1,"OPEN",ACCT),"^")=$PIECE($GET(^TMP($JOB,NODE1,"OPEN",ACCT)),"^")+$PIECE(X,"^",2)+$PIECE(X,"^",3)
+21 SET $PIECE(^TMP($JOB,NODE1,"OPEN",ACCT),"^",2)=$PIECE($GET(^TMP($JOB,NODE1,"OPEN",ACCT)),"^",2)+$PIECE(X,"^",8)
End DoDot:1
+22 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
+23 SET DA=0
FOR
SET DA=$ORDER(^PRCP(445.2,"AX",PRCP("I"),DATE,TYPE,DA))
if 'DA
QUIT
Begin DoDot:2
+24 SET D=$GET(^PRCP(445.2,DA,0))
IF '$PIECE(D,"^",5)
QUIT
+25 ; non-issuable
+26 ;count if not flagged as non-issueable
if $PIECE(D,"^",11)="N"
QUIT
+27 SET ACCT=$$ACCT1^PRCPUX1($$FSC^PRCPUX1($PIECE(D,"^",5)))
+28 SET TRANSNO=$PIECE(D,"^",19)
+29 SET INVVAL=$PIECE(D,"^",7)*$PIECE(D,"^",8)
IF $PIECE(D,"^",22)'=""
SET INVVAL=$PIECE(D,"^",22)
+30 SET NODE1=1
+31 IF $$ODITEM^PRCPUX2(PRCP("I"),$PIECE(D,"^",5))="Y"
SET NODE1=2
+32 ; set transno temporary for primary and secondary to
+33 ; indicate type of transaction
+34 IF PRCP("DPTYPE")'="W"
Begin DoDot:3
+35 ;issue
IF TYPE="R"!(TYPE="C")!(TYPE="E")!(TYPE="U")!(TYPE="S")
SET TRANSNO="--1"
QUIT
+36 ;receipt
IF TYPE="RC"
SET TRANSNO=1
QUIT
+37 ;adjustment
SET TRANSNO=""
End DoDot:3
+38 ; other adjustments
+39 IF PRCP("DPTYPE")="W"
IF $PIECE(TRANSNO,"-",2)=""
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
QUIT
+40 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
+41 IF '$TEST
Begin DoDot:3
+42 ; purchase order
+43 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
+44 ; usage
+45 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
+46 ; calculate inactive, long supply, set non-issuable
+47 ;*98 modified long supply range to be 90 days instead of 270
+48 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
+49 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
+50 SET ACCT=$$ACCT1^PRCPUX1($$FSC^PRCPUX1(ITEMDA))
+51 ; value
+52 SET NODE1=1
+53 SET ODITEM=$$ODITEM^PRCPUX2(PRCP("I"),ITEMDA)
+54 IF ODITEM="Y"
SET NODE1=2
+55 SET ^TMP($JOB,NODE1,"VALUE",ACCT)=$GET(^TMP($JOB,NODE1,"VALUE",ACCT))+$PIECE(D,"^",27)
+56 SET ^TMP($JOB,NODE1,"DUEIN",ACCT)=$GET(^TMP($JOB,NODE1,"DUEIN",ACCT))+($$GETIN^PRCPUDUE(PRCP("I"),ITEMDA)*$PIECE(D,"^",22))
+57 SET ^TMP($JOB,NODE1,"DUEOUT",ACCT)=$GET(^TMP($JOB,NODE1,"DUEOUT",ACCT))+($$GETOUT^PRCPUDUE(PRCP("I"),ITEMDA)*$PIECE(D,"^",22))
+58 ; non-issuable
+59 IF $PIECE(D,"^",19)
SET ^TMP($JOB,NODE1,"NISS",ACCT)=$GET(^TMP($JOB,NODE1,"NISS",ACCT))+($JUSTIFY($PIECE(D,"^",19)*$PIECE(D,"^",22),0,2))
SET ^TMP($JOB,NODE1,"NISSN",ACCT)=$GET(^TMP($JOB,NODE1,"NISSN",ACCT))+1
+60 ; inactive
+61 ; if reusable, quit
+62 IF $$REUSABLE^PRCPU441(ITEMDA)
QUIT
+63 SET QTY=$PIECE(D,"^",7)+$PIECE(D,"^",19)
+64 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
+65 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
End DoDot:2
+66 ; long supply
+67 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)
+68 SET AVERAGE=$JUSTIFY(TOTAL/TOTDAYS,0,2)
SET TOTAL=$SELECT('AVERAGE&(QTY):9999999,'AVERAGE:0,1:QTY/AVERAGE\1)
+69 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
+70 ;
+71 ;*98 Create consolidated array of Standard and On-Demand Items
+72 NEW I,J,PRCPQ1,PRCPQ2,PRCPR1,PRCPR2,PRCPS1,PRCPS2,L,J,K,TEMPDATA
+73 FOR I=1:1:2
Begin DoDot:1
+74 SET PRCPQ1=""
FOR
SET PRCPQ1=$ORDER(^TMP($JOB,I,PRCPQ1))
if PRCPQ1=""
QUIT
Begin DoDot:2
+75 SET PRCPQ2=""
FOR
SET PRCPQ2=$ORDER(^TMP($JOB,I,PRCPQ1,PRCPQ2))
if PRCPQ2=""
QUIT
Begin DoDot:3
+76 SET TEMPDATA=^TMP($JOB,I,PRCPQ1,PRCPQ2)
+77 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
+78 ;
+79 FOR J=1:1:3
Begin DoDot:1
+80 SET PRCPR1=""
FOR
SET PRCPR1=$ORDER(^TMP($JOB,3,PRCPR1))
if PRCPR1=""
QUIT
SET ^TMP($JOB,J,PRCPR1,"TOTAL")=0
End DoDot:1
+81 ;
+82 FOR K=1:1:3
Begin DoDot:1
+83 SET PRCPS1=""
FOR
SET PRCPS1=$ORDER(^TMP($JOB,K,PRCPS1))
if PRCPS1=""
QUIT
Begin DoDot:2
+84 SET PRCPS2=""
FOR
SET PRCPS2=$ORDER(^TMP($JOB,K,PRCPS1,PRCPS2))
if +PRCPS2=0
QUIT
Begin DoDot:3
+85 SET ^TMP($JOB,K,PRCPS1,"TOTAL")=$GET(^TMP($JOB,K,PRCPS1,"TOTAL"))+$GET(^TMP($JOB,K,PRCPS1,PRCPS2))
End DoDot:3
End DoDot:2
End DoDot:1
+86 ;
+87 DO ENT^PRCPLO2A
+88 ;
+89 QUIT
