- 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 Feb 18, 2025@23:42:19 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