- 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 Feb 18, 2025@23:40:36 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