source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPRDO1.m@ 1111

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

initial load of WorldVistAEHR
File size: 3.7 KB
Line 
1PRCPRDO1 ;WISC/RFJ-distribution duein and dueout reports ; 7/9/99 3:39pm
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5 ;
6 ;
7DQ ; queue comes here
8 N %,%I,D,DATA,INVPT,ITEMDA,ITEMDATA,NOW,ORDDATA,ORDERDA,PAGE,PRCPFLAG,PRIMARDA,QTY,SCREEN,SECONDA,TOTAL,VDA,VDATA,XREF,X,Y
9 K ^TMP($J,"PRCPRDOR")
10 S XREF="AC" I PRCP("DPTYPE")="S" S XREF="AD"
11 S ORDERDA=0 F S ORDERDA=$O(^PRCP(445.3,XREF,PRCP("I"),ORDERDA)) Q:'ORDERDA D
12 . I $G(UPDATE) L +^PRCP(445.3,ORDERDA)
13 . S ORDDATA=$G(^PRCP(445.3,ORDERDA,0))
14 . I $P(ORDDATA,"^",6)=""!($P(ORDDATA,"^",6)="P") L -^PRCP(445.3,ORDERDA) Q
15 . S PRIMARDA=+$P(ORDDATA,"^",2),SECONDA=+$P(ORDDATA,"^",3)
16 . S ITEMDA=0 F S ITEMDA=$O(^PRCP(445.3,ORDERDA,1,ITEMDA)) Q:'ITEMDA S ITEMDATA=$G(^PRCP(445.3,ORDERDA,1,ITEMDA,0)) I ITEMDATA'="" D
17 . . S QTY=$P(ITEMDATA,"^",2)
18 . . S VDATA=$$GETVEN^PRCPUVEN(SECONDA,ITEMDA,PRIMARDA_";PRCP(445,",1)
19 . . S ^TMP($J,"PRCPRDOR",ITEMDA,ORDERDA)=PRIMARDA_"^"_SECONDA_"^"_(QTY*$P(VDATA,"^",4))_"^"_QTY_"^"_$$UNIT^PRCPUX1(PRIMARDA,ITEMDA,"/")_"^"_$$UNIT^PRCPUX1(SECONDA,ITEMDA,"/")_"^"_$P(VDATA,"^",4)
20 . I $G(UPDATE) L -^PRCP(445.3,ORDERDA)
21 ;
22 ; print report from tmp global
23 K ^TMP($J,"PRCPUPDATE")
24 D NOW^%DTC S Y=% D DD^%DT S NOW=Y,PAGE=1,SCREEN=$$SCRPAUSE^PRCPUREP U IO D H
25 S ITEMDA=0 F S ITEMDA=$O(^TMP($J,"PRCPRDOR",ITEMDA)) Q:'ITEMDA!($G(PRCPFLAG)) D
26 . S ITEMDATA=$G(^PRCP(445,PRCP("I"),1,ITEMDA,0))
27 . S QTY=$S(TYPE="IN":$$GETIN^PRCPUDUE(PRCP("I"),ITEMDA),1:$$GETOUT^PRCPUDUE(PRCP("I"),ITEMDA))
28 . W !!,$E($$DESCR^PRCPUX1(PRCP("I"),ITEMDA),1,25),?27,"#",ITEMDA,?35,$J($$UNIT^PRCPUX1(PRCP("I"),ITEMDA,"/"),9),$J(+$P(ITEMDATA,"^",7),15),$J(QTY,21)
29 . S (ORDERDA,TOTAL)=0 F S ORDERDA=$O(^TMP($J,"PRCPRDOR",ITEMDA,ORDERDA)) Q:'ORDERDA!($G(PRCPFLAG)) S DATA=^(ORDERDA) D
30 . . S D=$G(^PRCP(445.3,ORDERDA,0)),Y=$P($P(D,"^",4),".") S:'Y Y="?" D DD^%DT
31 . . W !?5,$P(D,"^"),?12,Y,?24,$S($P(D,"^",8)="R":"REGU",$P(D,"^",8)="C":"CALL",$P(D,"^",8)="E":"EMER",1:"----"),?29,$S($P(D,"^",6)="R":"RELE",$P(D,"^",6)="B":"BACK",1:"----")
32 . . S INVPT=$P(DATA,"^") I TYPE="OUT" S INVPT=$P(DATA,"^",2)
33 . . W ?36,$E($P($$INVNAME^PRCPUX1(INVPT),"-",2),1,16)
34 . . I TYPE="OUT" W ?69,$J(+$P(DATA,"^",4),11) S TOTAL=TOTAL+$P(DATA,"^",4)
35 . . I TYPE="IN" W ?53,$J($P(DATA,"^",6),9),$J($P(DATA,"^",7),7),$J(+$P(DATA,"^",3),11) S TOTAL=TOTAL+$P(DATA,"^",3)
36 . . I $Y>(IOSL-5) D:SCREEN P^PRCPUREP Q:$G(PRCPFLAG) D H
37 . I $G(PRCPFLAG) Q
38 . I +TOTAL'=+QTY W !?5,"** CURRENT QUANTITY DUE-",TYPE,$S($G(UPDATE):" IS NOW EQUAL TO",1:" DOES NOT MATCH")," CALCULATED QUANTITY DUE-",TYPE," **"
39 . I $G(UPDATE) S ^TMP($J,"PRCPUPDATE",ITEMDA)=TOTAL
40 . I $Y>(IOSL-5) D:SCREEN P^PRCPUREP Q:$G(PRCPFLAG) D H
41 ;
42 ; update dueins or dueouts
43 I $G(UPDATE) S ITEMDA=0 F S ITEMDA=$O(^PRCP(445,PRCP("I"),1,ITEMDA)) Q:'ITEMDA I $D(^(ITEMDA,0)) D
44 . ; subtract off current qty duein,out to reset to zero
45 . S QTY=$G(^TMP($J,"PRCPUPDATE",ITEMDA))-$S(TYPE="IN":$$GETIN^PRCPUDUE(PRCP("I"),ITEMDA),1:$$GETOUT^PRCPUDUE(PRCP("I"),ITEMDA))
46 . I TYPE="IN" D SETIN^PRCPUDUE(PRCP("I"),ITEMDA,QTY) Q
47 . D SETOUT^PRCPUDUE(PRCP("I"),ITEMDA,QTY)
48 ;
49 I '$G(PRCPFLAG) D END^PRCPUREP
50 D ^%ZISC
51 K ^TMP($J,"PRCPRDOR"),^TMP($J,"PRCPUDPATE")
52 Q
53 ;
54 ;
55H S %=NOW_" PAGE "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF
56 W $C(13),"DUE-",TYPE," ITEM REPORT FOR ",PRCP("IN"),?(80-$L(%)),%
57 W !,"ITEM DESCRIPTION",?27,"#MI",?35,$J("UNIT/IS",9),$J("QTY ON-HAND",15),$J("QTY DUE-"_TYPE,21)
58 W !?5,"ORD#",?12,"DATE ORD",?24,"TYPE",?29,"STAT",?36,$S(TYPE="IN":"FROM",1:"TO")," INVPT"
59 I TYPE="OUT" W ?69,"QTY DUE-OUT"
60 I TYPE="IN" W ?55,"UNIT/REC",?67,"CF",?70,"QTY DUE-IN"
61 S %="",$P(%,"-",81)="" W !,%
62 Q
Note: See TracBrowser for help on using the repository browser.