PRCPSMPR ;WISC/RFJ-receiving code sheets to isms ;28 May 92
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
DQ ; create/trans receiving code sheets to isms
; poda=internal entry number for purchase order
; partlda=internal entry number for partial
N %,AVGCOST,COUNT,D,DATEDA,DATEDATA,DATEREC,I,ITEMDA,LASTCOST,LIDA,LINEDATA,NSN,PARTDATA,PARTIAL,PODATA,QTY,TOTCOST,UI,X,Y
S PODATA=$G(^PRC(442,PODA,0)) Q:PODATA=""
S PARTDATA=$G(^PRC(442,PODA,11,PARTLDA,0)) Q:PARTDATA=""
S DATEREC=$P(PARTDATA,"^"),PARTIAL=$S($P(PARTDATA,"^",9)="F":"F",1:"P")
; start gathering items received
S COUNT=1 K ^TMP($J,"STRING")
S LIDA=0 F S LIDA=$O(^PRC(442,PODA,2,"AB",DATEREC,LIDA)) Q:'LIDA S DATEDA=0 F S DATEDA=$O(^PRC(442,PODA,2,"AB",DATEREC,LIDA,DATEDA)) Q:'DATEDA S DATEDATA=$G(^PRC(442,PODA,2,LIDA,3,DATEDA,0)) I DATEDATA'="" D
. S LINEDATA=$G(^PRC(442,PODA,2,LIDA,0)) Q:LINEDATA=""
. S ITEMDA=+$P(LINEDATA,"^",5),NSN=$TR($$NSN^PRCPUX1(ITEMDA),"-"),UI=$TR($$UNITCODE^PRCPUX1($P(LINEDATA,"^",3)),"?")
. ; determine quantity and total cost
. S QTY=$P(DATEDATA,"^",2),TOTCOST=$P(DATEDATA,"^",3)-$P(DATEDATA,"^",5)
. ; lookup in transaction register for qty received and units
. S %=0 F S %=$O(^PRCP(445.2,"C",$P(PODATA,"^"),%)) Q:'% S D=$G(^PRCP(445.2,+%,0)) I $P(D,"^",5)=ITEMDA,$P(D,"^",2)=("RC"_$G(ORDERNO)) S X1=$P($P(D,"^",6),"/",2),X2=+$P(D,"^",7) S:$L(X1)=2 UI=X1 S:X2 QTY=X2 Q
. S TOTCOST=$TR($J(TOTCOST,0,2),"."),%=$G(^PRCP(445,PRCP("I"),1,ITEMDA,0)),LASTCOST=$TR($J($P(%,"^",15),0,4),"."),AVGCOST=$TR($J($P(%,"^",22),0,4),".")
. S ^TMP($J,"STRING",COUNT)="PL^"_NSN_"^"_UI_"^"_QTY_"00^"_TOTCOST_"^"_LASTCOST_"^"_AVGCOST_"^"_PARTIAL_"^"_$P(LINEDATA,"^")_"^|",COUNT=COUNT+1
I COUNT=1 Q
;
; prcpwait used in routine prcpsmsp when retransmitting
; isms code sheets
I '$G(PRCPWAIT) D CODESHT^PRCPSMGO(PRC("SITE"),"REP",$P($P(PODATA,"^"),"-",2))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPSMPR 1991 printed Apr 09, 2024@21:07:17 Page 2
PRCPSMPR ;WISC/RFJ-receiving code sheets to isms ;28 May 92
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
DQ ; create/trans receiving code sheets to isms
+1 ; poda=internal entry number for purchase order
+2 ; partlda=internal entry number for partial
+3 NEW %,AVGCOST,COUNT,D,DATEDA,DATEDATA,DATEREC,I,ITEMDA,LASTCOST,LIDA,LINEDATA,NSN,PARTDATA,PARTIAL,PODATA,QTY,TOTCOST,UI,X,Y
+4 SET PODATA=$GET(^PRC(442,PODA,0))
if PODATA=""
QUIT
+5 SET PARTDATA=$GET(^PRC(442,PODA,11,PARTLDA,0))
if PARTDATA=""
QUIT
+6 SET DATEREC=$PIECE(PARTDATA,"^")
SET PARTIAL=$SELECT($PIECE(PARTDATA,"^",9)="F":"F",1:"P")
+7 ; start gathering items received
+8 SET COUNT=1
KILL ^TMP($JOB,"STRING")
+9 SET LIDA=0
FOR
SET LIDA=$ORDER(^PRC(442,PODA,2,"AB",DATEREC,LIDA))
if 'LIDA
QUIT
SET DATEDA=0
FOR
SET DATEDA=$ORDER(^PRC(442,PODA,2,"AB",DATEREC,LIDA,DATEDA))
if 'DATEDA
QUIT
SET DATEDATA=$GET(^PRC(442,PODA,2,LIDA,3,DATEDA,0))
IF DATEDATA'=""
Begin DoDot:1
+10 SET LINEDATA=$GET(^PRC(442,PODA,2,LIDA,0))
if LINEDATA=""
QUIT
+11 SET ITEMDA=+$PIECE(LINEDATA,"^",5)
SET NSN=$TRANSLATE($$NSN^PRCPUX1(ITEMDA),"-")
SET UI=$TRANSLATE($$UNITCODE^PRCPUX1($PIECE(LINEDATA,"^",3)),"?")
+12 ; determine quantity and total cost
+13 SET QTY=$PIECE(DATEDATA,"^",2)
SET TOTCOST=$PIECE(DATEDATA,"^",3)-$PIECE(DATEDATA,"^",5)
+14 ; lookup in transaction register for qty received and units
+15 SET %=0
FOR
SET %=$ORDER(^PRCP(445.2,"C",$PIECE(PODATA,"^"),%))
if '%
QUIT
SET D=$GET(^PRCP(445.2,+%,0))
IF $PIECE(D,"^",5)=ITEMDA
IF $PIECE(D,"^",2)=("RC"_$GET(ORDERNO))
SET X1=$PIECE($PIECE(D,"^",6),"/",2)
SET X2=+$PIECE(D,"^",7)
if $LENGTH(X1)=2
SET UI=X1
if X2
SET QTY=X2
QUIT
+16 SET TOTCOST=$TRANSLATE($JUSTIFY(TOTCOST,0,2),".")
SET %=$GET(^PRCP(445,PRCP("I"),1,ITEMDA,0))
SET LASTCOST=$TRANSLATE($JUSTIFY($PIECE(%,"^",15),0,4),".")
SET AVGCOST=$TRANSLATE($JUSTIFY($PIECE(%,"^",22),0,4),".")
+17 SET ^TMP($JOB,"STRING",COUNT)="PL^"_NSN_"^"_UI_"^"_QTY_"00^"_TOTCOST_"^"_LASTCOST_"^"_AVGCOST_"^"_PARTIAL_"^"_$PIECE(LINEDATA,"^")_"^|"
SET COUNT=COUNT+1
End DoDot:1
+18 IF COUNT=1
QUIT
+19 ;
+20 ; prcpwait used in routine prcpsmsp when retransmitting
+21 ; isms code sheets
+22 IF '$GET(PRCPWAIT)
DO CODESHT^PRCPSMGO(PRC("SITE"),"REP",$PIECE($PIECE(PODATA,"^"),"-",2))
+23 QUIT
