source: FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPRDI1.m@ 1413

Last change on this file since 1413 was 628, checked in by George Lilly, 16 years ago

initial load of FOIAVistA 6/30/08 version
File size: 4.1 KB
Line 
1PRCPRDI1 ;WISC/RFJ/DGL-update/print due-ins from 410,442 (build tmp) ; 5/3/00 12:43pm
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 %,CONV,D,PRCPDAT0,PRCPDAT1,PRCPDAT3,PRCPDAT4,PRCPDAT7,PRCPDAT9,DUEIN,ITEMDA,L,L1,PARENT,PRCPCP,PRCPNO,PRCPPO,TRANDA,TRANNO,TRANSTRT,UPKG,UREC,VENDOR
9 ;
10 ; tmp($j,"prcprdi1-di",itemda,tranda)=tranno^qtyduein^u/r^pkg^conv
11 ; tmp($j,"prcprdi1-ck",tranda)="" <- to mark transactions checked
12 ; prcprdi1-no <- used temporary
13 K ^TMP($J,"PRCPRDI1-DI"),^TMP($J,"PRCPRDI1-CK"),^TMP($J,"PRCPRDI1-NO")
14 ;
15 S TRANSTRT=PRC("SITE")_"-"_$E(PRCPDATE,2,3)_"-"_$P("2^2^2^3^3^3^4^4^4^1^1^1","^",+$E(PRCPDATE,4,5))
16 S PRCPCP=0 F S PRCPCP=$O(^PRC(420,"AE",PRC("SITE"),PRCP("I"),PRCPCP)) Q:'PRCPCP S TRANNO=TRANSTRT_"-"_PRCPCP F S TRANNO=$O(^PRCS(410,"B",TRANNO)) Q:'TRANNO S TRANDA=+$O(^(TRANNO,0)) I TRANDA D
17 . I $G(PRCPFUPD) L +^PRCS(410,TRANDA)
18 . S ^TMP($J,"PRCPRDI1-CK",TRANDA)=""
19 . S PRCPDAT0=$G(^PRCS(410,TRANDA,0)),PRCPDAT1=$G(^(1))
20 . I PRCPDAT0=""!($P(PRCPDAT1,"^")'>PRCPDATE) L -^PRCS(410,TRANDA) Q
21 . S PRCPDAT3=$G(^PRCS(410,TRANDA,3)),PRCPDAT4=$G(^(4)),PRCPDAT7=$G(^(7)),PRCPDAT9=$G(^(9))
22 . I $P(PRCPDAT0,"^",6)=PRCP("I"),$P(PRCPDAT0,"^",2)="O",$P(PRCPDAT0,"^",4)>2,$P(PRCPDAT7,"^",6)]"",$S('$D(^PRC(443,TRANDA,0)):1,$P(^(0),"^",3)]"":1,1:0)
23 . I '$T L -^PRCS(410,TRANDA) Q
24 . ;
25 . ; issue book (9;3 = date recd)
26 . I $P(PRCPDAT0,"^",4)=5,$P(PRCPDAT9,"^",3) L -^PRCS(410,TRANDA) Q
27 . I $P(PRCPDAT0,"^",4)=5,PRCP("DPTYPE")'="W",+PRCPWHSE'=0 D L -^PRCS(410,TRANDA) Q
28 . . S L=0 F S L=$O(^PRCS(410,TRANDA,"IT",L)) Q:'L S D=$G(^(L,0)) I D'="" S ITEMDA=+$P(D,"^",5) I $D(^PRCP(445,PRCP("I"),1,ITEMDA,0)) D
29 . . . S %=$$GETVEN^PRCPUVEN(PRCP("I"),ITEMDA,PRCPWHSE,1),UREC=$P(%,"^",2),UPKG=$P(%,"^",3),CONV=+$P(%,"^",4)
30 . . . S DUEIN=$P(D,"^",2)-$P(D,"^",13) S:$P(D,"^",14)'="" DUEIN=0 S DUEIN=DUEIN*CONV
31 . . . I DUEIN>0 S %=$P($G(^TMP($J,"PRCPRDI1-DI",ITEMDA,TRANDA)),"^",2),^TMP($J,"PRCPRDI1-DI",ITEMDA,TRANDA)=TRANNO_"^"_(%+DUEIN)_"^"_UREC_"^"_UPKG_"^"_CONV
32 . ;
33 . ; purchase order
34 . S PRCPNO=$P(PRCPDAT4,"^",5) S:PRCPNO'="" PRCPNO=$O(^PRC(442,"C",PRCPNO,0)) S PARENT=$P($G(^PRCS(410,TRANDA,10)),"^",2) S:PARENT'="" PARENT=$O(^PRCS(410,"B",PARENT,0))
35 . S L=0 F S L=$O(^PRCS(410,TRANDA,"IT",L)) Q:'L S D=$G(^(L,0)) I D'="" S ITEMDA=+$P(D,"^",5) I $D(^PRCP(445,PRCP("I"),1,ITEMDA,0)),'$D(^TMP($J,"PRCPRDI1-DI",ITEMDA,TRANDA)) D
36 . . I PARENT K:$D(^TMP($J,"PRCPRDI1-DI",ITEMDA,PARENT)) ^(PARENT) S ^TMP($J,"PRCPRDI1-NO",ITEMDA,PARENT)="" ;split request, kill old
37 . . I $D(^TMP($J,"PRCPRDI1-NO",ITEMDA,TRANDA)) Q ;split request
38 . . ;
39 . . ; purchase order
40 . . I PRCPNO!($G(^PRC(442,+$P(D,"^",10),0))) S PRCPPO=$S(PRCPNO:PRCPNO,1:+$P(D,"^",10)) Q:+$G(^PRC(442,PRCPPO,7))=45 D Q
41 . . . L:$G(PRCPFUPD) +^PRC(442,PRCPPO)
42 . . . S %=$$GETVEN^PRCPUVEN(PRCP("I"),ITEMDA,+$P($G(^PRC(442,PRCPPO,1)),"^")_";PRC(440,",1),UREC=$P(%,"^",2),UPKG=$P(%,"^",3),CONV=+$P(%,"^",4)
43 . . . S (L1,DUEIN)=0 F S L1=$O(^PRC(442,PRCPPO,2,"AE",ITEMDA,L1)) Q:L1="" I $D(^PRC(442,PRCPPO,2,L1,0)) S DUEIN=DUEIN+$P(^(0),"^",2)-$$RECD(PRCPPO,L1)
44 . . . S DUEIN=DUEIN*CONV\1
45 . . . I DUEIN>0 S ^TMP($J,"PRCPRDI1-DI",ITEMDA,TRANDA)=TRANNO_"^"_DUEIN_"^"_UREC_"^"_UPKG_"^"_CONV_"^"_PRCPPO
46 . . . L -^PRC(442,PRCPPO)
47 . . ;
48 . . ; transaction 2237
49 . . S %=$$GETVEN^PRCPUVEN(PRCP("I"),ITEMDA,+$P(PRCPDAT3,"^",4)_";PRC(440,",1),UREC=$P(%,"^",2),UPKG=$P(%,"^",3),CONV=+$P(%,"^",4)
50 . . S DUEIN=$P(D,"^",2)*CONV\1,%=$P($G(^TMP($J,"PRCPRDI1-DI",ITEMDA,TRANDA)),"^",2),^TMP($J,"PRCPRDI1-DI",ITEMDA,TRANDA)=TRANNO_"^"_(%+DUEIN)_"^"_UREC_"^"_UPKG_"^"_CONV
51 . L -^PRCS(410,TRANDA)
52 K ^TMP($J,"PRCPRDI1-NO")
53 ;
54 D PRINT^PRCPRDI2
55 K ^TMP($J,"PRCPRDI1-DI"),^TMP($J,"PRCPRDI1-CK")
56 Q
57 ;
58 ;
59RECD(PODA,LINEITEM) ; return qty received for poda and lineitem
60 N %,D,PARTDATA,RECD
61 S (%,RECD)=0 F S %=$O(^PRC(442,PODA,2,LINEITEM,3,%)) Q:'% S D=$G(^(%,0)),PARTDATA=$G(^PRC(442,PODA,11,+$P(D,"^",4),0)) I $P(PARTDATA,"^",17)'="" S RECD=RECD+$P(D,"^",2)
62 Q $S(RECD<0:0,1:RECD)
Note: See TracBrowser for help on using the repository browser.