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