source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPSMST.m@ 1351

PRCPSMST ;WISC/RFJ-transfer order isms code sheet                   ;27 Jan 92
 ;;5.1;IFCAP;;Oct 20, 2000
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 D ^PRCPUSEL Q:'$G(PRCP("I"))
 I PRCP("DPTYPE")'="W" W !,"THIS OPTION SHOULD ONLY BE USED BY THE WAREHOUSE INVENTORY POINT." Q
 I $$ISMSFLAG^PRCPUX2(PRC("SITE"))'=2 W !,"YOU NEED TO TURN THE ISMS SWITCH 'ON' BEFORE YOU CAN USE THIS OPTION." Q
 N %,AVGCOST,COUNT,DATA,DESCR,ITEMDA,LASTCOST,LINE,NSN,QTYREC,SKU,TOTVAL,TRANSNO,UNIT,UNITCOST,WHSE,X,PRCPFLAG
 S IOP="HOME" D ^%ZIS S WHSE=$O(^PRC(440,"AC","S",0)) K IOP,^TMP($J,"TO"),^TMP($J,"STRING")
 W !! S DIR(0)="FO^1:6^I X'?.AN K X",DIR("A")="Enter TRANSFER ORDER NUMBER",DIR("?",1)="Enter the transfer order number from 1 to 6 characters.",DIR("?")="Use only numbers or upper case alphabetical characters." D ^DIR K DIR I X="" Q
 S TRANSNO=X
 F  W @IOF,!!,"TRANSFER ORDER NUMBER: ",TRANSNO S DIR(0)="NO^1:999",DIR("A")="Enter LINE ITEM NUMBER",DIR("?",1)="Enter the line item number for the transfer order,",DIR("?")="from 1 to 999." D ^DIR K DIR Q:'X  D
 .   S LINE=X I $D(^TMP($J,"TO",LINE)) S %=^(LINE) D  Q:'$G(LINE)
 .   .   W !!,"  YOU ALREADY HAVE THE LINE ITEM DEFINED AS:",!,"  ",$P(%,"^"),?20,$P(%,"^",2),"  MI#: ",$P(%,"^",3),!?20,"QUANTITY: ",$P(%,"^",4),"  in ",$P(%,"^",5)
 .   .   S XP="  DO YOU WANT TO DELETE IT",XH="ENTER 'YES' TO REMOVE THE LINE NUMBER AND ITEM FROM THE TRANSFER ORDER." I $$YN^PRCPUYN(2)'=1 K LINE Q
 .   K ^TMP($J,"TO",LINE) W ! S ITEMDA=$$ITEM^PRCPUITM(PRCP("I"),0,"","") Q:'$G(ITEMDA)  D
 .   S NSN=$TR($$NSN^PRCPUX1(ITEMDA),"-") I NSN="" W !,"ITEM DOES NOT HAVE AN NSN!" Q
 .   S SKU=$$SKU^PRCPUX1(PRCP("I"),ITEMDA) I SKU["?" W !,"SKU IS NOT DEFINED!" Q
 .   S DESCR=$$DESCR^PRCPUX1(PRCP("I"),ITEMDA),DATA=$G(^PRCP(445,PRCP("I"),1,ITEMDA,0)),UNIT=$$UNITVAL^PRCPUX1($P(DATA,"^",14),$P(DATA,"^",5)," per ")
 .   W !!,ITEMDA,?7,$E(DESCR,1,50),?60,NSN,!!?5,"UNIT per ISSUE",?23,": ",UNIT,!?5,"QUANTITY ON-HAND",?23,": ",+$P(DATA,"^",7)
 .   W !?5,"AVERAGE COST",?23,": ",$J(+$P(DATA,"^",22),0,3),!?5,"LAST RECEIPT COST",?23,": ",+$P(DATA,"^",15),!?5,"LAST SALE PRICE",?23,": ",+$P($G(^PRC(441,ITEMDA,2,WHSE,0)),"^",2)
 .   W !! S DIR(0)="NO^1:99999999^I 1",DIR("A")="  QUANTITY RECEIVED (IN "_UNIT_")" D ^DIR K DIR Q:'X  S QTYREC=X
 .   S %=99999999\QTYREC-1,DIR(0)="NO^1:"_%_":2^I 1",DIR("A")="  UNIT COST" D ^DIR K DIR Q:'X  S UNITCOST=X
 .   S TOTVAL=$TR($J(QTYREC*UNITCOST,0,2),"."),LASTCOST=$TR($J($P(DATA,"^",15),0,4),"."),AVGCOST=$TR($J($P(DATA,"^",22),0,4),".")
 .   S ^TMP($J,"TO",LINE)=NSN_"^"_DESCR_"^"_ITEMDA_"^"_QTYREC_"^"_UNIT_"^"_UNITCOST,^TMP($J,"TO",LINE,"CS")="TL^"_NSN_"^"_SKU_"^"_$TR($J(QTYREC,0,2),".")_"^"_TOTVAL_"^"_LASTCOST_"^"_AVGCOST_"^"_TRANSNO_"^"_LINE_"^|"
 .   W !,"  CS: ",^TMP($J,"TO",LINE,"CS") D R^PRCPUREP
 I ITEMDA["^" D Q Q
 I '$O(^TMP($J,"TO",0)) W !,"NO ITEMS SELECTED." D Q Q
 W @IOF,!,"YOU HAVE SELECTED THE FOLLOWING LINE ITEMS FOR THE TRANSFER ORDER:" S LINE=0,COUNT=1 F  S LINE=$O(^TMP($J,"TO",LINE)) Q:'LINE!($D(PRCPFLAG))  S %=^(LINE) I %'="",$D(^TMP($J,"TO",LINE,"CS")) D
 .   W !,"LI#: ",LINE,?10,$E($P(%,"^",2),1,20),?32,"MI#: ",$P(%,"^",3),?42,"QTY: ",$P(%,"^",4),?55,"UNIT$: ",$P(%,"^",6),?68,$J($P(%,"^",5),11) S ^TMP($J,"STRING",COUNT)=^TMP($J,"TO",LINE,"CS"),COUNT=COUNT+1
 .   I $Y>(IOSL-5) D P^PRCPUREP
 I $D(PRCPFLAG) D Q Q
 I '$O(^TMP($J,"STRING",0)) W !!,"NO CODE SHEETS CREATED." D Q Q
 S XP="*** ARE YOU SURE YOU WANT TO CREATE THE ISMS TRANSACTION",XP(1)="    AND TRANSMIT IT TO AUSTIN",XH="ENTER 'YES' TO CREATE THE ISMS TRANSACTION AND TRANSMIT IT TO AUSTIN",XH(1)="ENTER 'NO' OR '^' TO EXIT."
 W !! I $$YN^PRCPUYN(1)'=1 D Q Q
 D CODESHT^PRCPSMGO(PRC("SITE"),"RET",TRANSNO)
Q K ^TMP($J,"TO"),^TMP($J,"STRING") Q