- PRCPOPER ;WISC/RFJ/DGL - distribution order error report;3/17/00 3:23pm
- V ;;5.1;IFCAP;**205**;Oct 20, 2000;Build 4
- ;;Per VA Directive 6402, this routine should not be modified.
- Q
- ;
- ;
- CHECKORD ; check order for errors (called from prcpopl protocol)
- D VARIABLE^PRCPOPU
- D EN^VALM("PRCP DIST ORDER CHECK ITEMS")
- D INIT^PRCPOPL
- S VALMBCK="R"
- Q
- ;
- ;
- INIT ; check order for errors and build array
- N DATA,ERROR,ITEMDA,QTYORDER,STATUS,QTYOH
- K ^TMP($J,"PRCPOPER")
- S VALMCNT=0
- I 'PRCPPRIM D SET^PRCPOPL("PRIMARY INVENTORY SOURCE MISSING. PLEASE RE-EDIT THE ORDER FIRST.") Q
- I 'PRCPSECO D SET^PRCPOPL("SECONDARY INVENTORY POINT IS MISSING, PLEASE RE-EDIT THE ORDER FIRST.") Q
- ;
- S STATUS=$P(^PRCP(445.3,ORDERDA,0),"^",6)
- ; check items on order
- S ITEMDA=0 F S ITEMDA=$O(^PRCP(445.3,ORDERDA,1,ITEMDA)) Q:'ITEMDA S DATA=^(ITEMDA,0) D
- . S QTYORDER=$P(DATA,"^",2)
- . I 'QTYORDER D BLDARRAY^PRCPOPL(PRCPPRIM,PRCPSECO,ITEMDA,QTYORDER,STATUS),SET^PRCPOPL(" ** THERE IS NO QUANTITY ORDERED, ITEM SHOULD BE DELETED FROM ORDER **") Q
- . S ERROR=$$ITEMCHK(PRCPPRIM,PRCPSECO,ITEMDA)
- . S X=$G(^PRCP(445,PRCPPRIM,1,ITEMDA,0))
- . I X]"" D
- . . S QTYOH=+$P(X,"^",7)
- . . I PRCP("DPTYPE")'="S",QTYOH<QTYORDER S ERROR=ERROR_$S(ERROR="":"",1:"^")_" ** QTY ORDERED ("_QTYORDER_") IS MORE THAN PRIMARY QTY ON HAND ("_QTYOH_") **"
- . . Q
- . I ERROR="" Q
- . D BLDARRAY^PRCPOPL(PRCPPRIM,PRCPSECO,ITEMDA,QTYORDER,STATUS)
- . F %=1:1 Q:$P(ERROR,"^",%,99)="" I $P(ERROR,"^",%)'="" D SET^PRCPOPL($P(ERROR,"^",%))
- ;
- I VALMCNT=0 S VALMQUIT=1,VALMSG="* * * NO ERRORS FOUND * * *"
- Q
- ;
- ;
- EXIT ; exit and clean up
- K ^TMP($J,"PRCPOPER")
- Q
- ;
- ;
- EEITEMS ; called from protocol file to enter/edit invpt items
- D
- . N PRC,PRCP
- . S PRCP("DPTYPE")="PS"
- . D ^PRCPEILM
- D INIT
- S VALMBCK="R"
- I $G(VALMQUIT) K VALMBCK
- Q
- ;
- ;
- ITEMCHK(PRCPPRIM,PRCPSECO,ITEMDA) ; check items
- ; returns errors delimited by ^ or ""
- N ITEMDATA,ERROR,VDATA
- S ERROR=""
- S ITEMDATA=$G(^PRCP(445,PRCPPRIM,1,ITEMDA,0))
- I ITEMDATA="" S ERROR=" ** ITEM NOT STORED IN PRIMARY INVENTORY POINT ** ^ Either add item to primary or delete item from order."
- I '$D(^PRCP(445,PRCPSECO,1,ITEMDA,0)) S ERROR=ERROR_$S(ERROR="":"",1:"^")_" ** ITEM NOT STORED IN SECONDARY INVENTORY POINT **"
- ;
- S VDATA=$$GETVEN^PRCPUVEN(PRCPSECO,ITEMDA,PRCPPRIM_";PRCP(445,",1)
- I 'VDATA S ERROR=ERROR_$S(ERROR="":"",1:"^")_" ** PRIMARY INVENTORY POINT IS NOT LISTED AS A SOURCE **"
- I $P(VDATA,"^",2,3)'=($P(ITEMDATA,"^",5)_"^"_$P(ITEMDATA,"^",14)) S ERROR=ERROR_$S(ERROR="":"",1:"^")_" ** SECONDARY UNIT PER RECEIPT DOES NOT EQUAL PRIMARY UNIT PER ISSUE **"
- Q ERROR
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPOPER 2735 printed Apr 23, 2025@18:28:43 Page 2
- PRCPOPER ;WISC/RFJ/DGL - distribution order error report;3/17/00 3:23pm
- V ;;5.1;IFCAP;**205**;Oct 20, 2000;Build 4
- +1 ;;Per VA Directive 6402, this routine should not be modified.
- +2 QUIT
- +3 ;
- +4 ;
- CHECKORD ; check order for errors (called from prcpopl protocol)
- +1 DO VARIABLE^PRCPOPU
- +2 DO EN^VALM("PRCP DIST ORDER CHECK ITEMS")
- +3 DO INIT^PRCPOPL
- +4 SET VALMBCK="R"
- +5 QUIT
- +6 ;
- +7 ;
- INIT ; check order for errors and build array
- +1 NEW DATA,ERROR,ITEMDA,QTYORDER,STATUS,QTYOH
- +2 KILL ^TMP($JOB,"PRCPOPER")
- +3 SET VALMCNT=0
- +4 IF 'PRCPPRIM
- DO SET^PRCPOPL("PRIMARY INVENTORY SOURCE MISSING. PLEASE RE-EDIT THE ORDER FIRST.")
- QUIT
- +5 IF 'PRCPSECO
- DO SET^PRCPOPL("SECONDARY INVENTORY POINT IS MISSING, PLEASE RE-EDIT THE ORDER FIRST.")
- QUIT
- +6 ;
- +7 SET STATUS=$PIECE(^PRCP(445.3,ORDERDA,0),"^",6)
- +8 ; check items on order
- +9 SET ITEMDA=0
- FOR
- SET ITEMDA=$ORDER(^PRCP(445.3,ORDERDA,1,ITEMDA))
- if 'ITEMDA
- QUIT
- SET DATA=^(ITEMDA,0)
- Begin DoDot:1
- +10 SET QTYORDER=$PIECE(DATA,"^",2)
- +11 IF 'QTYORDER
- DO BLDARRAY^PRCPOPL(PRCPPRIM,PRCPSECO,ITEMDA,QTYORDER,STATUS)
- DO SET^PRCPOPL(" ** THERE IS NO QUANTITY ORDERED, ITEM SHOULD BE DELETED FROM ORDER **")
- QUIT
- +12 SET ERROR=$$ITEMCHK(PRCPPRIM,PRCPSECO,ITEMDA)
- +13 SET X=$GET(^PRCP(445,PRCPPRIM,1,ITEMDA,0))
- +14 IF X]""
- Begin DoDot:2
- +15 SET QTYOH=+$PIECE(X,"^",7)
- +16 IF PRCP("DPTYPE")'="S"
- IF QTYOH<QTYORDER
- SET ERROR=ERROR_$SELECT(ERROR="":"",1:"^")_" ** QTY ORDERED ("_QTYORDER_") IS MORE THAN PRIMARY QTY ON HAND ("_QTYOH_") **"
- +17 QUIT
- End DoDot:2
- +18 IF ERROR=""
- QUIT
- +19 DO BLDARRAY^PRCPOPL(PRCPPRIM,PRCPSECO,ITEMDA,QTYORDER,STATUS)
- +20 FOR %=1:1
- if $PIECE(ERROR,"^",%,99)=""
- QUIT
- IF $PIECE(ERROR,"^",%)'=""
- DO SET^PRCPOPL($PIECE(ERROR,"^",%))
- End DoDot:1
- +21 ;
- +22 IF VALMCNT=0
- SET VALMQUIT=1
- SET VALMSG="* * * NO ERRORS FOUND * * *"
- +23 QUIT
- +24 ;
- +25 ;
- EXIT ; exit and clean up
- +1 KILL ^TMP($JOB,"PRCPOPER")
- +2 QUIT
- +3 ;
- +4 ;
- EEITEMS ; called from protocol file to enter/edit invpt items
- +1 Begin DoDot:1
- +2 NEW PRC,PRCP
- +3 SET PRCP("DPTYPE")="PS"
- +4 DO ^PRCPEILM
- End DoDot:1
- +5 DO INIT
- +6 SET VALMBCK="R"
- +7 IF $GET(VALMQUIT)
- KILL VALMBCK
- +8 QUIT
- +9 ;
- +10 ;
- ITEMCHK(PRCPPRIM,PRCPSECO,ITEMDA) ; check items
- +1 ; returns errors delimited by ^ or ""
- +2 NEW ITEMDATA,ERROR,VDATA
- +3 SET ERROR=""
- +4 SET ITEMDATA=$GET(^PRCP(445,PRCPPRIM,1,ITEMDA,0))
- +5 IF ITEMDATA=""
- SET ERROR=" ** ITEM NOT STORED IN PRIMARY INVENTORY POINT ** ^ Either add item to primary or delete item from order."
- +6 IF '$DATA(^PRCP(445,PRCPSECO,1,ITEMDA,0))
- SET ERROR=ERROR_$SELECT(ERROR="":"",1:"^")_" ** ITEM NOT STORED IN SECONDARY INVENTORY POINT **"
- +7 ;
- +8 SET VDATA=$$GETVEN^PRCPUVEN(PRCPSECO,ITEMDA,PRCPPRIM_";PRCP(445,",1)
- +9 IF 'VDATA
- SET ERROR=ERROR_$SELECT(ERROR="":"",1:"^")_" ** PRIMARY INVENTORY POINT IS NOT LISTED AS A SOURCE **"
- +10 IF $PIECE(VDATA,"^",2,3)'=($PIECE(ITEMDATA,"^",5)_"^"_$PIECE(ITEMDATA,"^",14))
- SET ERROR=ERROR_$SELECT(ERROR="":"",1:"^")_" ** SECONDARY UNIT PER RECEIPT DOES NOT EQUAL PRIMARY UNIT PER ISSUE **"
- +11 QUIT ERROR
