source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPSMPR.m@ 1078

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

initial load of WorldVistAEHR

File size: 1.9 KB
Line 
1PRCPSMPR ;WISC/RFJ-receiving code sheets to isms ;28 May 92
2 ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5 ;
6 ;
7DQ ; create/trans receiving code sheets to isms
8 ; poda=internal entry number for purchase order
9 ; partlda=internal entry number for partial
10 N %,AVGCOST,COUNT,D,DATEDA,DATEDATA,DATEREC,I,ITEMDA,LASTCOST,LIDA,LINEDATA,NSN,PARTDATA,PARTIAL,PODATA,QTY,TOTCOST,UI,X,Y
11 S PODATA=$G(^PRC(442,PODA,0)) Q:PODATA=""
12 S PARTDATA=$G(^PRC(442,PODA,11,PARTLDA,0)) Q:PARTDATA=""
13 S DATEREC=$P(PARTDATA,"^"),PARTIAL=$S($P(PARTDATA,"^",9)="F":"F",1:"P")
14 ; start gathering items received
15 S COUNT=1 K ^TMP($J,"STRING")
16 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
17 . S LINEDATA=$G(^PRC(442,PODA,2,LIDA,0)) Q:LINEDATA=""
18 . S ITEMDA=+$P(LINEDATA,"^",5),NSN=$TR($$NSN^PRCPUX1(ITEMDA),"-"),UI=$TR($$UNITCODE^PRCPUX1($P(LINEDATA,"^",3)),"?")
19 . ; determine quantity and total cost
20 . S QTY=$P(DATEDATA,"^",2),TOTCOST=$P(DATEDATA,"^",3)-$P(DATEDATA,"^",5)
21 . ; lookup in transaction register for qty received and units
22 . 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
23 . 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),".")
24 . S ^TMP($J,"STRING",COUNT)="PL^"_NSN_"^"_UI_"^"_QTY_"00^"_TOTCOST_"^"_LASTCOST_"^"_AVGCOST_"^"_PARTIAL_"^"_$P(LINEDATA,"^")_"^|",COUNT=COUNT+1
25 I COUNT=1 Q
26 ;
27 ; prcpwait used in routine prcpsmsp when retransmitting
28 ; isms code sheets
29 I '$G(PRCPWAIT) D CODESHT^PRCPSMGO(PRC("SITE"),"REP",$P($P(PODATA,"^"),"-",2))
30 Q
Note: See TracBrowser for help on using the repository browser.