source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPRSSP.m@ 1211

Last change on this file since 1211 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 5.7 KB
Line 
1PRCPRSSP ;WOIFO/DAP-stock status report for primaries and secondaries; 10/16/06 2:07pm ; 2/23/07 4:59pm
2 ;;5.1;IFCAP;**98**;Oct 20, 2000;Build 37
3 ;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 ;*83 Routine PRCPLO2 associated with PRC*5.1*83 is a modified copy of
6 ;this routine and any changes made to this routine should also be
7 ;considered for that routine as well.
8 ;
9 ;*98 Changed previous displays of "issues" to "usages"
10 ;
11ENT ;*98 Entry point from PRCPRSSR when inventory point is confirmed to be
12 ;primary or secondary
13 ;
14 N ZTDESC,ZTRTN,ZTSAVE,POP
15 W ! S %ZIS="Q" D ^%ZIS Q:POP I $D(IO("Q")) D D ^%ZTLOAD K IO("Q"),ZTSK Q
16 . S ZTDESC="Stock Status Report",ZTRTN="DQ^PRCPRSSP"
17 . S ZTSAVE("PRCP*")="",ZTSAVE("DATE*")="",ZTSAVE("ZTREQ")="@"
18 W !!,"<*> please wait <*>"
19 ;
20DQ ; queue starts here
21 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
22 N ODITEM,NODE1,X,X1,X2
23 K ^TMP($J)
24 K OPEN
25 ;*98 Modified calculations to separate ODI and Standard Items
26 ;
27 S ITEMDA=0 F S ITEMDA=$O(^PRCP(445,PRCP("I"),1,ITEMDA)) Q:'ITEMDA D
28 . S NODE1=1
29 . S ODITEM=$$ODITEM^PRCPUX2(PRCP("I"),ITEMDA)
30 . I ODITEM="Y" S NODE1=2
31 . S ACCT=$$ACCT1^PRCPUX1($$FSC^PRCPUX1(ITEMDA))
32 . ;*98 Added item counter logic
33 . S ^TMP($J,NODE1,"CNT",ACCT)=$G(^TMP($J,NODE1,"CNT",ACCT))+1
34 ;
35 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
36 . S NODE1=1
37 . S ODITEM=$$ODITEM^PRCPUX2(PRCP("I"),ITEMDA)
38 . I ODITEM="Y" S NODE1=2
39 . S ACCT=$$ACCT1^PRCPUX1($$FSC^PRCPUX1(ITEMDA))
40 . ;*98 Added item counter logic
41 . S $P(^TMP($J,NODE1,"OPEN",ACCT),"^")=$P($G(^TMP($J,NODE1,"OPEN",ACCT)),"^")+$P(X,"^",2)+$P(X,"^",3)
42 . S $P(^TMP($J,NODE1,"OPEN",ACCT),"^",2)=$P($G(^TMP($J,NODE1,"OPEN",ACCT)),"^",2)+$P(X,"^",8)
43 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
44 . S DA=0 F S DA=$O(^PRCP(445.2,"AX",PRCP("I"),DATE,TYPE,DA)) Q:'DA D
45 .. S D=$G(^PRCP(445.2,DA,0)) I '$P(D,"^",5) Q
46 .. ; non-issuable
47 .. Q:$P(D,"^",11)="N" ;count if not flagged as non-issueable
48 .. S ACCT=$$ACCT1^PRCPUX1($$FSC^PRCPUX1($P(D,"^",5)))
49 .. S TRANSNO=$P(D,"^",19)
50 .. S INVVAL=$P(D,"^",7)*$P(D,"^",8) I $P(D,"^",22)'="" S INVVAL=$P(D,"^",22)
51 .. S NODE1=1
52 .. I $$ODITEM^PRCPUX2(PRCP("I"),$P(D,"^",5))="Y" S NODE1=2
53 .. ; set transno temporary for primary and secondary to
54 .. ; indicate type of transaction
55 .. ;*98 Removed warehouse check from loop entry below
56 .. D
57 ... I TYPE="R"!(TYPE="C")!(TYPE="E")!(TYPE="U")!(TYPE="S") S TRANSNO="--1" Q ;usage
58 ... I TYPE="RC" S TRANSNO=1 Q ;receipt
59 ... S TRANSNO="" ;adjustment
60 .. ; other adjustments
61 .. ;*98 Removed line featuring warehouse logic
62 .. ;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
63 .. 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
64 .. E D
65 ... ; purchase order
66 ... 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
67 ... ; usage
68 ... 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
69 ;
70 ; calculate inactive, long supply, set non-issuable
71 ;
72 ;*98 Modified long supply range to be 90 days instead of 270 days for
73 ;warehouse, primary, and secondary reporting
74 ;
75 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
76 S ITEMDA=0 F S ITEMDA=$O(^PRCP(445,PRCP("I"),1,ITEMDA)) Q:'ITEMDA S D=$G(^(ITEMDA,0)) I D'="" D
77 . S NODE1=1
78 . S ODITEM=$$ODITEM^PRCPUX2(PRCP("I"),ITEMDA)
79 . I ODITEM="Y" S NODE1=2
80 . S ACCT=$$ACCT1^PRCPUX1($$FSC^PRCPUX1(ITEMDA))
81 . ; value
82 . S ^TMP($J,NODE1,"VALUE",ACCT)=$G(^TMP($J,NODE1,"VALUE",ACCT))+$P(D,"^",27)
83 . S ^TMP($J,NODE1,"DUEIN",ACCT)=$G(^TMP($J,NODE1,"DUEIN",ACCT))+($$GETIN^PRCPUDUE(PRCP("I"),ITEMDA)*$P(D,"^",22))
84 . S ^TMP($J,NODE1,"DUEOUT",ACCT)=$G(^TMP($J,NODE1,"DUEOUT",ACCT))+($$GETOUT^PRCPUDUE(PRCP("I"),ITEMDA)*$P(D,"^",22))
85 . ;*98 Removed non-issuable section since they never appear for primary or secondary inventory points
86 . ;
87 . ; inactive
88 . ; if reusable, quit
89 . I $$REUSABLE^PRCPU441(ITEMDA) Q
90 . S QTY=$P(D,"^",7)+$P(D,"^",19)
91 . 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
92 . . 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
93 . ; long supply
94 . 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)
95 . S AVERAGE=$J(TOTAL/TOTDAYS,0,2),TOTAL=$S('AVERAGE&(QTY):9999999,'AVERAGE:0,1:QTY/AVERAGE\1)
96 . 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
97 ;
98 ;*98 Create consolidated array of Standard and ODI items
99 N I,PRCPQ1,PRCPQ2,L,TEMPDATA
100 F I=1:1:2 D
101 . S PRCPQ1=""
102 . F S PRCPQ1=$O(^TMP($J,I,PRCPQ1)) Q:PRCPQ1="" D
103 .. S PRCPQ2=""
104 .. F S PRCPQ2=$O(^TMP($J,I,PRCPQ1,PRCPQ2)) Q:PRCPQ2="" D
105 ... S TEMPDATA=^TMP($J,I,PRCPQ1,PRCPQ2)
106 ... F L=1:1:2 S $P(^TMP($J,3,PRCPQ1,PRCPQ2),"^",L)=$P($G(^TMP($J,3,PRCPQ1,PRCPQ2)),"^",L)+$P(TEMPDATA,"^",L)
107 ;
108 ;*98 Routed printing based on Primary/Secondary status
109 D PRINT^PRCPRSS1
110 Q
Note: See TracBrowser for help on using the repository browser.