PRCPRDI1 ;WISC/RFJ/DGL-update/print due-ins from 410,442 (build tmp) ; 5/3/00 12:43pm
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
DQ ; queue comes here
N %,CONV,D,PRCPDAT0,PRCPDAT1,PRCPDAT3,PRCPDAT4,PRCPDAT7,PRCPDAT9,DUEIN,ITEMDA,L,L1,PARENT,PRCPCP,PRCPNO,PRCPPO,TRANDA,TRANNO,TRANSTRT,UPKG,UREC,VENDOR
;
; tmp($j,"prcprdi1-di",itemda,tranda)=tranno^qtyduein^u/r^pkg^conv
; tmp($j,"prcprdi1-ck",tranda)="" <- to mark transactions checked
; prcprdi1-no <- used temporary
K ^TMP($J,"PRCPRDI1-DI"),^TMP($J,"PRCPRDI1-CK"),^TMP($J,"PRCPRDI1-NO")
;
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))
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
. I $G(PRCPFUPD) L +^PRCS(410,TRANDA)
. S ^TMP($J,"PRCPRDI1-CK",TRANDA)=""
. S PRCPDAT0=$G(^PRCS(410,TRANDA,0)),PRCPDAT1=$G(^(1))
. I PRCPDAT0=""!($P(PRCPDAT1,"^")'>PRCPDATE) L -^PRCS(410,TRANDA) Q
. S PRCPDAT3=$G(^PRCS(410,TRANDA,3)),PRCPDAT4=$G(^(4)),PRCPDAT7=$G(^(7)),PRCPDAT9=$G(^(9))
. 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)
. I '$T L -^PRCS(410,TRANDA) Q
. ;
. ; issue book (9;3 = date recd)
. I $P(PRCPDAT0,"^",4)=5,$P(PRCPDAT9,"^",3) L -^PRCS(410,TRANDA) Q
. I $P(PRCPDAT0,"^",4)=5,PRCP("DPTYPE")'="W",+PRCPWHSE'=0 D L -^PRCS(410,TRANDA) Q
. . 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
. . . S %=$$GETVEN^PRCPUVEN(PRCP("I"),ITEMDA,PRCPWHSE,1),UREC=$P(%,"^",2),UPKG=$P(%,"^",3),CONV=+$P(%,"^",4)
. . . S DUEIN=$P(D,"^",2)-$P(D,"^",13) S:$P(D,"^",14)'="" DUEIN=0 S DUEIN=DUEIN*CONV
. . . I DUEIN>0 S %=$P($G(^TMP($J,"PRCPRDI1-DI",ITEMDA,TRANDA)),"^",2),^TMP($J,"PRCPRDI1-DI",ITEMDA,TRANDA)=TRANNO_"^"_(%+DUEIN)_"^"_UREC_"^"_UPKG_"^"_CONV
. ;
. ; purchase order
. 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))
. 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
. . I PARENT K:$D(^TMP($J,"PRCPRDI1-DI",ITEMDA,PARENT)) ^(PARENT) S ^TMP($J,"PRCPRDI1-NO",ITEMDA,PARENT)="" ;split request, kill old
. . I $D(^TMP($J,"PRCPRDI1-NO",ITEMDA,TRANDA)) Q ;split request
. . ;
. . ; purchase order
. . 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
. . . L:$G(PRCPFUPD) +^PRC(442,PRCPPO)
. . . S %=$$GETVEN^PRCPUVEN(PRCP("I"),ITEMDA,+$P($G(^PRC(442,PRCPPO,1)),"^")_";PRC(440,",1),UREC=$P(%,"^",2),UPKG=$P(%,"^",3),CONV=+$P(%,"^",4)
. . . 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)
. . . S DUEIN=DUEIN*CONV\1
. . . I DUEIN>0 S ^TMP($J,"PRCPRDI1-DI",ITEMDA,TRANDA)=TRANNO_"^"_DUEIN_"^"_UREC_"^"_UPKG_"^"_CONV_"^"_PRCPPO
. . . L -^PRC(442,PRCPPO)
. . ;
. . ; transaction 2237
. . S %=$$GETVEN^PRCPUVEN(PRCP("I"),ITEMDA,+$P(PRCPDAT3,"^",4)_";PRC(440,",1),UREC=$P(%,"^",2),UPKG=$P(%,"^",3),CONV=+$P(%,"^",4)
. . 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
. L -^PRCS(410,TRANDA)
K ^TMP($J,"PRCPRDI1-NO")
;
D PRINT^PRCPRDI2
K ^TMP($J,"PRCPRDI1-DI"),^TMP($J,"PRCPRDI1-CK")
Q
;
;
RECD(PODA,LINEITEM) ; return qty received for poda and lineitem
N %,D,PARTDATA,RECD
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)
Q $S(RECD<0:0,1:RECD)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPRDI1 4251 printed Oct 16, 2024@18:15:31 Page 2
PRCPRDI1 ;WISC/RFJ/DGL-update/print due-ins from 410,442 (build tmp) ; 5/3/00 12:43pm
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 QUIT
+3 ;
+4 ;
DQ ; queue comes here
+1 NEW %,CONV,D,PRCPDAT0,PRCPDAT1,PRCPDAT3,PRCPDAT4,PRCPDAT7,PRCPDAT9,DUEIN,ITEMDA,L,L1,PARENT,PRCPCP,PRCPNO,PRCPPO,TRANDA,TRANNO,TRANSTRT,UPKG,UREC,VENDOR
+2 ;
+3 ; tmp($j,"prcprdi1-di",itemda,tranda)=tranno^qtyduein^u/r^pkg^conv
+4 ; tmp($j,"prcprdi1-ck",tranda)="" <- to mark transactions checked
+5 ; prcprdi1-no <- used temporary
+6 KILL ^TMP($JOB,"PRCPRDI1-DI"),^TMP($JOB,"PRCPRDI1-CK"),^TMP($JOB,"PRCPRDI1-NO")
+7 ;
+8 SET TRANSTRT=PRC("SITE")_"-"_$EXTRACT(PRCPDATE,2,3)_"-"_$PIECE("2^2^2^3^3^3^4^4^4^1^1^1","^",+$EXTRACT(PRCPDATE,4,5))
+9 SET PRCPCP=0
FOR
SET PRCPCP=$ORDER(^PRC(420,"AE",PRC("SITE"),PRCP("I"),PRCPCP))
if 'PRCPCP
QUIT
SET TRANNO=TRANSTRT_"-"_PRCPCP
FOR
SET TRANNO=$ORDER(^PRCS(410,"B",TRANNO))
if 'TRANNO
QUIT
SET TRANDA=+$ORDER(^(TRANNO,0))
IF TRANDA
Begin DoDot:1
+10 IF $GET(PRCPFUPD)
LOCK +^PRCS(410,TRANDA)
+11 SET ^TMP($JOB,"PRCPRDI1-CK",TRANDA)=""
+12 SET PRCPDAT0=$GET(^PRCS(410,TRANDA,0))
SET PRCPDAT1=$GET(^(1))
+13 IF PRCPDAT0=""!($PIECE(PRCPDAT1,"^")'>PRCPDATE)
LOCK -^PRCS(410,TRANDA)
QUIT
+14 SET PRCPDAT3=$GET(^PRCS(410,TRANDA,3))
SET PRCPDAT4=$GET(^(4))
SET PRCPDAT7=$GET(^(7))
SET PRCPDAT9=$GET(^(9))
+15 IF $PIECE(PRCPDAT0,"^",6)=PRCP("I")
IF $PIECE(PRCPDAT0,"^",2)="O"
IF $PIECE(PRCPDAT0,"^",4)>2
IF $PIECE(PRCPDAT7,"^",6)]""
IF $SELECT('$DATA(^PRC(443,TRANDA,0)):1,$PIECE(^(0),"^",3)]"":1,1:0)
+16 IF '$TEST
LOCK -^PRCS(410,TRANDA)
QUIT
+17 ;
+18 ; issue book (9;3 = date recd)
+19 IF $PIECE(PRCPDAT0,"^",4)=5
IF $PIECE(PRCPDAT9,"^",3)
LOCK -^PRCS(410,TRANDA)
QUIT
+20 IF $PIECE(PRCPDAT0,"^",4)=5
IF PRCP("DPTYPE")'="W"
IF +PRCPWHSE'=0
Begin DoDot:2
+21 SET L=0
FOR
SET L=$ORDER(^PRCS(410,TRANDA,"IT",L))
if 'L
QUIT
SET D=$GET(^(L,0))
IF D'=""
SET ITEMDA=+$PIECE(D,"^",5)
IF $DATA(^PRCP(445,PRCP("I"),1,ITEMDA,0))
Begin DoDot:3
+22 SET %=$$GETVEN^PRCPUVEN(PRCP("I"),ITEMDA,PRCPWHSE,1)
SET UREC=$PIECE(%,"^",2)
SET UPKG=$PIECE(%,"^",3)
SET CONV=+$PIECE(%,"^",4)
+23 SET DUEIN=$PIECE(D,"^",2)-$PIECE(D,"^",13)
if $PIECE(D,"^",14)'=""
SET DUEIN=0
SET DUEIN=DUEIN*CONV
+24 IF DUEIN>0
SET %=$PIECE($GET(^TMP($JOB,"PRCPRDI1-DI",ITEMDA,TRANDA)),"^",2)
SET ^TMP($JOB,"PRCPRDI1-DI",ITEMDA,TRANDA)=TRANNO_"^"_(%+DUEIN)_"^"_UREC_"^"_UPKG_"^"_CONV
End DoDot:3
End DoDot:2
LOCK -^PRCS(410,TRANDA)
QUIT
+25 ;
+26 ; purchase order
+27 SET PRCPNO=$PIECE(PRCPDAT4,"^",5)
if PRCPNO'=""
SET PRCPNO=$ORDER(^PRC(442,"C",PRCPNO,0))
SET PARENT=$PIECE($GET(^PRCS(410,TRANDA,10)),"^",2)
if PARENT'=""
SET PARENT=$ORDER(^PRCS(410,"B",PARENT,0))
+28 SET L=0
FOR
SET L=$ORDER(^PRCS(410,TRANDA,"IT",L))
if 'L
QUIT
SET D=$GET(^(L,0))
IF D'=""
SET ITEMDA=+$PIECE(D,"^",5)
IF $DATA(^PRCP(445,PRCP("I"),1,ITEMDA,0))
IF '$DATA(^TMP($JOB,"PRCPRDI1-DI",ITEMDA,TRANDA))
Begin DoDot:2
+29 ;split request, kill old
IF PARENT
if $DATA(^TMP($JOB,"PRCPRDI1-DI",ITEMDA,PARENT))
KILL ^(PARENT)
SET ^TMP($JOB,"PRCPRDI1-NO",ITEMDA,PARENT)=""
+30 ;split request
IF $DATA(^TMP($JOB,"PRCPRDI1-NO",ITEMDA,TRANDA))
QUIT
+31 ;
+32 ; purchase order
+33 IF PRCPNO!($GET(^PRC(442,+$PIECE(D,"^",10),0)))
SET PRCPPO=$SELECT(PRCPNO:PRCPNO,1:+$PIECE(D,"^",10))
if +$GET(^PRC(442,PRCPPO,7))=45
QUIT
Begin DoDot:3
+34 if $GET(PRCPFUPD)
LOCK +^PRC(442,PRCPPO)
+35 SET %=$$GETVEN^PRCPUVEN(PRCP("I"),ITEMDA,+$PIECE($GET(^PRC(442,PRCPPO,1)),"^")_";PRC(440,",1)
SET UREC=$PIECE(%,"^",2)
SET UPKG=$PIECE(%,"^",3)
SET CONV=+$PIECE(%,"^",4)
+36 SET (L1,DUEIN)=0
FOR
SET L1=$ORDER(^PRC(442,PRCPPO,2,"AE",ITEMDA,L1))
if L1=""
QUIT
IF $DATA(^PRC(442,PRCPPO,2,L1,0))
SET DUEIN=DUEIN+$PIECE(^(0),"^",2)-$$RECD(PRCPPO,L1)
+37 SET DUEIN=DUEIN*CONV\1
+38 IF DUEIN>0
SET ^TMP($JOB,"PRCPRDI1-DI",ITEMDA,TRANDA)=TRANNO_"^"_DUEIN_"^"_UREC_"^"_UPKG_"^"_CONV_"^"_PRCPPO
+39 LOCK -^PRC(442,PRCPPO)
End DoDot:3
QUIT
+40 ;
+41 ; transaction 2237
+42 SET %=$$GETVEN^PRCPUVEN(PRCP("I"),ITEMDA,+$PIECE(PRCPDAT3,"^",4)_";PRC(440,",1)
SET UREC=$PIECE(%,"^",2)
SET UPKG=$PIECE(%,"^",3)
SET CONV=+$PIECE(%,"^",4)
+43 SET DUEIN=$PIECE(D,"^",2)*CONV\1
SET %=$PIECE($GET(^TMP($JOB,"PRCPRDI1-DI",ITEMDA,TRANDA)),"^",2)
SET ^TMP($JOB,"PRCPRDI1-DI",ITEMDA,TRANDA)=TRANNO_"^"_(%+DUEIN)_"^"_UREC_"^"_UPKG_"^"_CONV
End DoDot:2
+44 LOCK -^PRCS(410,TRANDA)
End DoDot:1
+45 KILL ^TMP($JOB,"PRCPRDI1-NO")
+46 ;
+47 DO PRINT^PRCPRDI2
+48 KILL ^TMP($JOB,"PRCPRDI1-DI"),^TMP($JOB,"PRCPRDI1-CK")
+49 QUIT
+50 ;
+51 ;
RECD(PODA,LINEITEM) ; return qty received for poda and lineitem
+1 NEW %,D,PARTDATA,RECD
+2 SET (%,RECD)=0
FOR
SET %=$ORDER(^PRC(442,PODA,2,LINEITEM,3,%))
if '%
QUIT
SET D=$GET(^(%,0))
SET PARTDATA=$GET(^PRC(442,PODA,11,+$PIECE(D,"^",4),0))
IF $PIECE(PARTDATA,"^",17)'=""
SET RECD=RECD+$PIECE(D,"^",2)
+3 QUIT $SELECT(RECD<0:0,1:RECD)
