- PRCPOPEC ;WISC/RFJ-distribution order error report for cc,ik items ;27 Sep 93
- ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- Q
- ;
- ;
- INIT ; check order for errors and build array
- N DATA,ITEMDA,QTYORDER
- K ^TMP($J,"PRCPOPER")
- S VALMCNT=0
- S CCIKITEM=0 F S CCIKITEM=$O(^TMP($J,"PRCPOPPC-ITEMS",CCIKITEM)) Q:'CCIKITEM D
- . S QTYORDER=$P($G(^PRCP(445.3,ORDERDA,1,CCIKITEM,0)),"^",2)
- . D SETERROR(CCIKITEM)
- . ; check items to post
- . S ITEMDA=0 F S ITEMDA=$O(^TMP($J,"PRCPOPPC-ITEMS",CCIKITEM,ITEMDA)) Q:'ITEMDA S QTYORDER=$P(^(ITEMDA),"^")-$P(^(ITEMDA),"^",2) I QTYORDER D
- . . ; do not check cc/ik items twice
- . . I $D(^TMP($J,"PRCPOPPC-ITEMS",ITEMDA)) Q
- . . D SETERROR(ITEMDA)
- ;
- 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
- N PRC,PRCP
- S PRCP("DPTYPE")="PS"
- D ^PRCPEILM
- D INIT
- S VALMBCK="R"
- I $G(VALMQUIT) K VALMBCK
- Q
- ;
- ;
- SETERROR(ITEMDA) ; set error in list for itemda
- N ERROR
- S ERROR=$$ITEMCHK^PRCPOPER(PRCPPRIM,PRCPSECO,ITEMDA)
- I $P($G(^PRCP(445,PRCPPRIM,1,ITEMDA,0)),"^",7)<QTYORDER S ERROR=ERROR_$S(ERROR="":"",1:"^")_" ** PRIMARY QUANTITY ON-HAND LESS THAN QUANTITY ON ORDER **"
- I ERROR="" Q
- D BLDARRAY^PRCPOPL(PRCPPRIM,PRCPSECO,ITEMDA,QTYORDER)
- F %=1:1 Q:$P(ERROR,"^",%,99)="" I $P(ERROR,"^",%)'="" D SET^PRCPOPL($P(ERROR,"^",%))
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPOPEC 1541 printed Feb 18, 2025@23:40:33 Page 2
- PRCPOPEC ;WISC/RFJ-distribution order error report for cc,ik items ;27 Sep 93
- +1 ;;5.1;IFCAP;;Oct 20, 2000
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 QUIT
- +4 ;
- +5 ;
- INIT ; check order for errors and build array
- +1 NEW DATA,ITEMDA,QTYORDER
- +2 KILL ^TMP($JOB,"PRCPOPER")
- +3 SET VALMCNT=0
- +4 SET CCIKITEM=0
- FOR
- SET CCIKITEM=$ORDER(^TMP($JOB,"PRCPOPPC-ITEMS",CCIKITEM))
- if 'CCIKITEM
- QUIT
- Begin DoDot:1
- +5 SET QTYORDER=$PIECE($GET(^PRCP(445.3,ORDERDA,1,CCIKITEM,0)),"^",2)
- +6 DO SETERROR(CCIKITEM)
- +7 ; check items to post
- +8 SET ITEMDA=0
- FOR
- SET ITEMDA=$ORDER(^TMP($JOB,"PRCPOPPC-ITEMS",CCIKITEM,ITEMDA))
- if 'ITEMDA
- QUIT
- SET QTYORDER=$PIECE(^(ITEMDA),"^")-$PIECE(^(ITEMDA),"^",2)
- IF QTYORDER
- Begin DoDot:2
- +9 ; do not check cc/ik items twice
- +10 IF $DATA(^TMP($JOB,"PRCPOPPC-ITEMS",ITEMDA))
- QUIT
- +11 DO SETERROR(ITEMDA)
- End DoDot:2
- End DoDot:1
- +12 ;
- +13 IF VALMCNT=0
- SET VALMQUIT=1
- SET VALMSG="* * * NO ERRORS FOUND * * *"
- +14 QUIT
- +15 ;
- +16 ;
- 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 NEW PRC,PRCP
- +2 SET PRCP("DPTYPE")="PS"
- +3 DO ^PRCPEILM
- +4 DO INIT
- +5 SET VALMBCK="R"
- +6 IF $GET(VALMQUIT)
- KILL VALMBCK
- +7 QUIT
- +8 ;
- +9 ;
- SETERROR(ITEMDA) ; set error in list for itemda
- +1 NEW ERROR
- +2 SET ERROR=$$ITEMCHK^PRCPOPER(PRCPPRIM,PRCPSECO,ITEMDA)
- +3 IF $PIECE($GET(^PRCP(445,PRCPPRIM,1,ITEMDA,0)),"^",7)<QTYORDER
- SET ERROR=ERROR_$SELECT(ERROR="":"",1:"^")_" ** PRIMARY QUANTITY ON-HAND LESS THAN QUANTITY ON ORDER **"
- +4 IF ERROR=""
- QUIT
- +5 DO BLDARRAY^PRCPOPL(PRCPPRIM,PRCPSECO,ITEMDA,QTYORDER)
- +6 FOR %=1:1
- if $PIECE(ERROR,"^",%,99)=""
- QUIT
- IF $PIECE(ERROR,"^",%)'=""
- DO SET^PRCPOPL($PIECE(ERROR,"^",%))
- +7 QUIT