Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCPOPL

PRCPOPL.m

Go to the documentation of this file.
  1. PRCPOPL ;WISC/RFJ/DGL-distribution order processing list manager ; 3/20/00 9:27am
  1. V ;;5.1;IFCAP;**1,41,171**;Oct 20, 2000;Build 3
  1. ;Per VHA Directive 2004-028, this routine should not be modified.
  1. D ^PRCPUSEL Q:'$G(PRCP("I"))
  1. I "PS"'[PRCP("DPTYPE") W !,"THIS OPTION SHOULD ONLY BE USED BY A PRIMARY OR SECONDARY INVENTORY POINT." Q
  1. ;
  1. N %,ORDERDA,PRCPFNEW,PRCPFONE,PRCPORD,PRCPPAT,PRCPPRIM,PRCPSECO,VA,X,Y
  1. ;
  1. I PRCP("DPTYPE")="S" S PRCPPRIM=+$$FROMCHEK^PRCPUDPT(PRCP("I"),1) Q:'PRCPPRIM S PRCPSECO=PRCP("I")
  1. I PRCP("DPTYPE")="P" S PRCPSECO=+$$TO^PRCPUDPT(PRCP("I")) Q:'PRCPSECO S PRCPPRIM=PRCP("I")
  1. W !!,"** Distribution ",$S(PRCP("DPTYPE")="S":"from",1:"to")_" inventory point: ",$$INVNAME^PRCPUX1($S(PRCP("DPTYPE")="S":PRCPPRIM,1:PRCPSECO))," **"
  1. ;
  1. F W !! S ORDERDA=+$$ORDERSEL^PRCPOPUS(PRCPPRIM,PRCPSECO,"*",1) Q:'ORDERDA D
  1. . W !
  1. . L +^PRCP(445.3,ORDERDA):5 I '$T D SHOWWHO^PRCPULOC(445.3,ORDERDA,0) D R^PRCPUREP Q
  1. . D ADD^PRCPULOC(445.3,ORDERDA,0,"Distribution Order Processing")
  1. . I $$TYPE^PRCPOPUS(ORDERDA) D UNLOCK Q
  1. . W ! I $$REMARKS^PRCPOPUS(ORDERDA) D UNLOCK Q
  1. . D VARIABLE^PRCPOPU
  1. . D EN^VALM("PRCP DIST ORDER PROCESSING")
  1. . D UNLOCK
  1. Q
  1. ;
  1. ;
  1. UNLOCK ; unlock distribution order
  1. D CLEAR^PRCPULOC(445.3,ORDERDA,0)
  1. L -^PRCP(445.3,ORDERDA)
  1. Q
  1. ;
  1. ;
  1. HDR ; build header
  1. K VALMHDR
  1. 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)
  1. I $P($G(PRCPORD(2)),"^")="" S VALMHDR(1)="POST ITEMS TO SECONDARY: "_$P(PRCPORD(0),"^",3)
  1. S VALMHDR(2)=$E(" "_$E($P(PRCPORD(0),"^",2),1,15)_" DISTRIBUTION ORDER: "_$P(PRCPORD(0),"^")_$J(" ",50),1,49)_"STATUS: "_$$STATUS^PRCPOPU(ORDERDA)
  1. Q
  1. ;
  1. ;
  1. INIT ; init variables and build array
  1. N DATA,ITEMDA,ITEMDATA,QTYOH,STATUS
  1. K ^TMP($J,"PRCPOP")
  1. S VALMCNT=0
  1. I $P(^PRCP(445.3,ORDERDA,0),"^",10)]"" D SET(" ***This Order was sent to the supply station and cannot be updated. ***"),SET(" ")
  1. S STATUS=$P(^PRCP(445.3,ORDERDA,0),"^",6)
  1. S ITEMDA=0 F S ITEMDA=$O(^PRCP(445.3,ORDERDA,1,ITEMDA)) Q:'ITEMDA S DATA=$G(^(ITEMDA,0)) I DATA'="" D
  1. . D BLDARRAY(PRCPPRIM,PRCPSECO,ITEMDA,$P(DATA,"^",2),STATUS)
  1. . S ITEMDATA=$G(^PRCP(445,PRCPPRIM,1,ITEMDA,0)),QTYOH=+$P($G(ITEMDATA),"^",7)
  1. . I ITEMDATA="" D SET(" *** WARNING -- ITEM IS NO LONGER STOCKED IN PRIMARY INVENTORY POINT *** ") Q
  1. . I STATUS'="P"&($P(DATA,"^",2)>QTYOH),QTYOH'<0 D
  1. . . D SET(" *** WARNING -- QTY ORDERED ("_$P(DATA,"^",2)_") IS MORE THAN QTY ON HAND ("_QTYOH_") ***")
  1. . . D SET(" *** Quantity on hand will be posted unless quantity ordered is edited ***")
  1. . I STATUS'="P"&($P(DATA,"^",2)>QTYOH),QTYOH<0 D
  1. . . D SET(" *** WARNING -- QTY ORDERED ("_$P(DATA,"^",2)_") IS MORE THAN QTY ON HAND ("_QTYOH_") ***")
  1. . . D SET(" *** A quantity of ZERO(0) will be posted unless quantity ordered is edited ***")
  1. . I STATUS="P"&($P(DATA,"^",2)'=$P(DATA,"^",7)) D SET(" *** Actual posted quantity was "_$P(DATA,"^",7)_" ***")
  1. ;
  1. I VALMCNT=0 D SET(" "),SET(" * * * NO ITEMS ARE ON THIS ORDER * * *")
  1. Q
  1. ;
  1. ;
  1. BLDARRAY(PRCPPRIM,PRCPSECO,ITEMDA,QTYORDER,STATUS) ; build item array
  1. S:'$D(STATUS) STATUS=0
  1. S X=$$SETFLD^VALM1(" "_$E($$DESCR^PRCPUX1(PRCPPRIM,ITEMDA),1,28)_" (#"_ITEMDA_")","","ITEM")
  1. S X=$$SETFLD^VALM1($P($$UNIT^PRCPUX1(PRCPPRIM,ITEMDA,"^"),"^",2),X,"UNIT")
  1. S X=$$SETFLD^VALM1(QTYORDER,X,"ORDERED")
  1. S X=$$SETFLD^VALM1($P($$GETVEN^PRCPUVEN(PRCPSECO,ITEMDA,PRCPPRIM_";PRCP(445,",1),"^",4),X,"CONV")
  1. I STATUS'="P" S X=$$SETFLD^VALM1($P($G(^PRCP(445,PRCPPRIM,1,ITEMDA,0)),"^",7),X,"ONHAND")
  1. S VALMCNT=VALMCNT+1
  1. D SET^VALM10(VALMCNT,X,VALMCNT)
  1. Q
  1. ;
  1. ;
  1. EXIT ; exit and clean up
  1. K ^TMP($J,"PRCPOP")
  1. Q
  1. ;
  1. ;
  1. EEITEMS ; called from protocol file to enter/edit invpt items
  1. N PRC,PRCP
  1. S PRCP("DPTYPE")="PS"
  1. D FULL^VALM1 ;PRC*5.1*171 Insure screen write protect is cleared from current Listman run
  1. D ^PRCPEILM,FULL^VALM1 ;PRC*5.1*171 Insure screen write protect is cleared from subsidiary Listman run when returning to original Listman call
  1. D INIT
  1. S VALMBCK="R"
  1. Q
  1. ;
  1. ;
  1. CHECK(TYPE) ; called when screen displays and when protocol selected
  1. ; causes () to be display around inappropriate protocol selections
  1. ; type="edit" or "delete" or "release" or "picktick" or "post"
  1. ; returns 1 for sucess, 0 for no
  1. I '$D(^PRCP(445.3,$G(ORDERDA),0)) Q 0
  1. N STATUS,SECID
  1. S STATUS=$P(^PRCP(445.3,ORDERDA,0),"^",6) S:STATUS="B" STATUS="R"
  1. S SECID=$P(^PRCP(445.3,ORDERDA,0),"^",3)
  1. I TYPE="EDIT",PRCP("DPTYPE")="S",STATUS'="" Q 0
  1. I TYPE'="DELETE",TYPE'="PICKTICK",TYPE'="SEND",$P(^PRCP(445.3,ORDERDA,0),"^",10)]"" Q 0
  1. I TYPE="EDIT",STATUS="P" Q 0
  1. I TYPE="DELETE",PRCP("DPTYPE")="S",STATUS'="" Q 0
  1. I TYPE="DELETE",STATUS="P" Q 0
  1. I TYPE="RELEASE",STATUS'="" Q 0
  1. I TYPE="POST",PRCP("DPTYPE")="S" Q 0
  1. I TYPE="POST",STATUS="" Q 0
  1. ;I TYPE="POST",$P(^PRCP(445.3,ORDERDA,0),"^",7)="" Q 0
  1. I TYPE="POST",STATUS="P" Q 0
  1. I TYPE="PICKTICK",STATUS="P" Q 1
  1. I TYPE="PICKTICK" I STATUS'="R" Q 0
  1. I TYPE="SEND",$P(^PRCP(445.3,ORDERDA,0),"^",8)'="R" Q 0
  1. I TYPE="SEND",$P($G(^PRCP(445,SECID,5)),"^",1)']"" Q 0
  1. I TYPE="SEND",STATUS'="R" Q 0
  1. Q 1
  1. ;
  1. ;
  1. SET(STRING) ; set string in array
  1. N %
  1. S VALMCNT=VALMCNT+1
  1. D SET^VALM10(VALMCNT,STRING)
  1. Q