[613] | 1 | PRCPOPL ;WISC/RFJ/DGL-distribution order processing list manager ; 3/20/00 9:27am
|
---|
| 2 | V ;;5.1;IFCAP;**1,41**;Oct 20, 2000
|
---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
---|
| 4 | D ^PRCPUSEL Q:'$G(PRCP("I"))
|
---|
| 5 | I "PS"'[PRCP("DPTYPE") W !,"THIS OPTION SHOULD ONLY BE USED BY A PRIMARY OR SECONDARY INVENTORY POINT." Q
|
---|
| 6 | ;
|
---|
| 7 | N %,ORDERDA,PRCPFNEW,PRCPFONE,PRCPORD,PRCPPAT,PRCPPRIM,PRCPSECO,VA,X,Y
|
---|
| 8 | ;
|
---|
| 9 | I PRCP("DPTYPE")="S" S PRCPPRIM=+$$FROMCHEK^PRCPUDPT(PRCP("I"),1) Q:'PRCPPRIM S PRCPSECO=PRCP("I")
|
---|
| 10 | I PRCP("DPTYPE")="P" S PRCPSECO=+$$TO^PRCPUDPT(PRCP("I")) Q:'PRCPSECO S PRCPPRIM=PRCP("I")
|
---|
| 11 | W !!,"** Distribution ",$S(PRCP("DPTYPE")="S":"from",1:"to")_" inventory point: ",$$INVNAME^PRCPUX1($S(PRCP("DPTYPE")="S":PRCPPRIM,1:PRCPSECO))," **"
|
---|
| 12 | ;
|
---|
| 13 | F W !! S ORDERDA=+$$ORDERSEL^PRCPOPUS(PRCPPRIM,PRCPSECO,"*",1) Q:'ORDERDA D
|
---|
| 14 | . W !
|
---|
| 15 | . L +^PRCP(445.3,ORDERDA):5 I '$T D SHOWWHO^PRCPULOC(445.3,ORDERDA,0) D R^PRCPUREP Q
|
---|
| 16 | . D ADD^PRCPULOC(445.3,ORDERDA,0,"Distribution Order Processing")
|
---|
| 17 | . I $$TYPE^PRCPOPUS(ORDERDA) D UNLOCK Q
|
---|
| 18 | . W ! I $$REMARKS^PRCPOPUS(ORDERDA) D UNLOCK Q
|
---|
| 19 | . D VARIABLE^PRCPOPU
|
---|
| 20 | . D EN^VALM("PRCP DIST ORDER PROCESSING")
|
---|
| 21 | . D UNLOCK
|
---|
| 22 | Q
|
---|
| 23 | ;
|
---|
| 24 | ;
|
---|
| 25 | UNLOCK ; unlock distribution order
|
---|
| 26 | D CLEAR^PRCPULOC(445.3,ORDERDA,0)
|
---|
| 27 | L -^PRCP(445.3,ORDERDA)
|
---|
| 28 | Q
|
---|
| 29 | ;
|
---|
| 30 | ;
|
---|
| 31 | HDR ; build header
|
---|
| 32 | K VALMHDR
|
---|
| 33 | I $P($G(PRCPORD(2)),"^")'="" S VALMHDR(1)=$E("POST ITEMS TO: "_$P(PRCPORD(2),"^")_$J(" ",80),1,47)_" THRU SECONDARY: "_$E($P(PRCPORD(0),"^",3),1,15)
|
---|
| 34 | I $P($G(PRCPORD(2)),"^")="" S VALMHDR(1)="POST ITEMS TO SECONDARY: "_$P(PRCPORD(0),"^",3)
|
---|
| 35 | S VALMHDR(2)=$E(" "_$E($P(PRCPORD(0),"^",2),1,15)_" DISTRIBUTION ORDER: "_$P(PRCPORD(0),"^")_$J(" ",50),1,49)_"STATUS: "_$$STATUS^PRCPOPU(ORDERDA)
|
---|
| 36 | Q
|
---|
| 37 | ;
|
---|
| 38 | ;
|
---|
| 39 | INIT ; init variables and build array
|
---|
| 40 | N DATA,ITEMDA,ITEMDATA,QTYOH,STATUS
|
---|
| 41 | K ^TMP($J,"PRCPOP")
|
---|
| 42 | S VALMCNT=0
|
---|
| 43 | I $P(^PRCP(445.3,ORDERDA,0),"^",10)]"" D SET(" ***This Order was sent to the supply station and cannot be updated. ***"),SET(" ")
|
---|
| 44 | S STATUS=$P(^PRCP(445.3,ORDERDA,0),"^",6)
|
---|
| 45 | S ITEMDA=0 F S ITEMDA=$O(^PRCP(445.3,ORDERDA,1,ITEMDA)) Q:'ITEMDA S DATA=$G(^(ITEMDA,0)) I DATA'="" D
|
---|
| 46 | . D BLDARRAY(PRCPPRIM,PRCPSECO,ITEMDA,$P(DATA,"^",2),STATUS)
|
---|
| 47 | . S ITEMDATA=$G(^PRCP(445,PRCPPRIM,1,ITEMDA,0)),QTYOH=+$P($G(ITEMDATA),"^",7)
|
---|
| 48 | . I ITEMDATA="" D SET(" *** WARNING -- ITEM IS NO LONGER STOCKED IN PRIMARY INVENTORY POINT *** ") Q
|
---|
| 49 | . I STATUS'="P"&($P(DATA,"^",2)>QTYOH),QTYOH'<0 D
|
---|
| 50 | . . D SET(" *** WARNING -- QTY ORDERED ("_$P(DATA,"^",2)_") IS MORE THAN QTY ON HAND ("_QTYOH_") ***")
|
---|
| 51 | . . D SET(" *** Quantity on hand will be posted unless quantity ordered is edited ***")
|
---|
| 52 | . I STATUS'="P"&($P(DATA,"^",2)>QTYOH),QTYOH<0 D
|
---|
| 53 | . . D SET(" *** WARNING -- QTY ORDERED ("_$P(DATA,"^",2)_") IS MORE THAN QTY ON HAND ("_QTYOH_") ***")
|
---|
| 54 | . . D SET(" *** A quantity of ZERO(0) will be posted unless quantity ordered is edited ***")
|
---|
| 55 | . I STATUS="P"&($P(DATA,"^",2)'=$P(DATA,"^",7)) D SET(" *** Actual posted quantity was "_$P(DATA,"^",7)_" ***")
|
---|
| 56 | ;
|
---|
| 57 | I VALMCNT=0 D SET(" "),SET(" * * * NO ITEMS ARE ON THIS ORDER * * *")
|
---|
| 58 | Q
|
---|
| 59 | ;
|
---|
| 60 | ;
|
---|
| 61 | BLDARRAY(PRCPPRIM,PRCPSECO,ITEMDA,QTYORDER,STATUS) ; build item array
|
---|
| 62 | S:'$D(STATUS) STATUS=0
|
---|
| 63 | S X=$$SETFLD^VALM1(" "_$E($$DESCR^PRCPUX1(PRCPPRIM,ITEMDA),1,28)_" (#"_ITEMDA_")","","ITEM")
|
---|
| 64 | S X=$$SETFLD^VALM1($P($$UNIT^PRCPUX1(PRCPPRIM,ITEMDA,"^"),"^",2),X,"UNIT")
|
---|
| 65 | S X=$$SETFLD^VALM1(QTYORDER,X,"ORDERED")
|
---|
| 66 | S X=$$SETFLD^VALM1($P($$GETVEN^PRCPUVEN(PRCPSECO,ITEMDA,PRCPPRIM_";PRCP(445,",1),"^",4),X,"CONV")
|
---|
| 67 | I STATUS'="P" S X=$$SETFLD^VALM1($P($G(^PRCP(445,PRCPPRIM,1,ITEMDA,0)),"^",7),X,"ONHAND")
|
---|
| 68 | S VALMCNT=VALMCNT+1
|
---|
| 69 | D SET^VALM10(VALMCNT,X,VALMCNT)
|
---|
| 70 | Q
|
---|
| 71 | ;
|
---|
| 72 | ;
|
---|
| 73 | EXIT ; exit and clean up
|
---|
| 74 | K ^TMP($J,"PRCPOP")
|
---|
| 75 | Q
|
---|
| 76 | ;
|
---|
| 77 | ;
|
---|
| 78 | EEITEMS ; called from protocol file to enter/edit invpt items
|
---|
| 79 | N PRC,PRCP
|
---|
| 80 | S PRCP("DPTYPE")="PS"
|
---|
| 81 | D ^PRCPEILM
|
---|
| 82 | D INIT
|
---|
| 83 | S VALMBCK="R"
|
---|
| 84 | Q
|
---|
| 85 | ;
|
---|
| 86 | ;
|
---|
| 87 | CHECK(TYPE) ; called when screen displays and when protocol selected
|
---|
| 88 | ; causes () to be display around inappropriate protocol selections
|
---|
| 89 | ; type="edit" or "delete" or "release" or "picktick" or "post"
|
---|
| 90 | ; returns 1 for sucess, 0 for no
|
---|
| 91 | I '$D(^PRCP(445.3,$G(ORDERDA),0)) Q 0
|
---|
| 92 | N STATUS,SECID
|
---|
| 93 | S STATUS=$P(^PRCP(445.3,ORDERDA,0),"^",6) S:STATUS="B" STATUS="R"
|
---|
| 94 | S SECID=$P(^PRCP(445.3,ORDERDA,0),"^",3)
|
---|
| 95 | I TYPE="EDIT",PRCP("DPTYPE")="S",STATUS'="" Q 0
|
---|
| 96 | I TYPE'="DELETE",TYPE'="PICKTICK",TYPE'="SEND",$P(^PRCP(445.3,ORDERDA,0),"^",10)]"" Q 0
|
---|
| 97 | I TYPE="EDIT",STATUS="P" Q 0
|
---|
| 98 | I TYPE="DELETE",PRCP("DPTYPE")="S",STATUS'="" Q 0
|
---|
| 99 | I TYPE="DELETE",STATUS="P" Q 0
|
---|
| 100 | I TYPE="RELEASE",STATUS'="" Q 0
|
---|
| 101 | I TYPE="POST",PRCP("DPTYPE")="S" Q 0
|
---|
| 102 | I TYPE="POST",STATUS="" Q 0
|
---|
| 103 | ;I TYPE="POST",$P(^PRCP(445.3,ORDERDA,0),"^",7)="" Q 0
|
---|
| 104 | I TYPE="POST",STATUS="P" Q 0
|
---|
| 105 | I TYPE="PICKTICK",STATUS="P" Q 1
|
---|
| 106 | I TYPE="PICKTICK" I STATUS'="R" Q 0
|
---|
| 107 | I TYPE="SEND",$P(^PRCP(445.3,ORDERDA,0),"^",8)'="R" Q 0
|
---|
| 108 | I TYPE="SEND",$P($G(^PRCP(445,SECID,5)),"^",1)']"" Q 0
|
---|
| 109 | I TYPE="SEND",STATUS'="R" Q 0
|
---|
| 110 | Q 1
|
---|
| 111 | ;
|
---|
| 112 | ;
|
---|
| 113 | SET(STRING) ; set string in array
|
---|
| 114 | N %
|
---|
| 115 | S VALMCNT=VALMCNT+1
|
---|
| 116 | D SET^VALM10(VALMCNT,STRING)
|
---|
| 117 | Q
|
---|