- 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 Feb 18, 2025@23:41:55 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