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