30 lines
1.3 KiB
Mathematica
30 lines
1.3 KiB
Mathematica
PRCPOPP2 ;WISC/RFJ-case cart/instrument kit post items ;27 Sep 93
|
|
;;5.1;IFCAP;;Oct 20, 2000
|
|
;Per VHA Directive 10-93-142, this routine should not be modified.
|
|
Q
|
|
;
|
|
;
|
|
POST ; post cc's and ik's including items in cc's and ik's
|
|
S VALMBCK="R"
|
|
N CCIKITEM,DATA,ITEMDA,PRCPFLAG,QTYPOST
|
|
;
|
|
W !!,"CHECKING CASE CART AND INSTRUMENT KIT ITEMS ON ORDER..."
|
|
S (CCIKITEM,PRCPFLAG)=0 F S CCIKITEM=$O(^TMP($J,"PRCPOPPC-ITEMS",CCIKITEM)) Q:'CCIKITEM!(PRCPFLAG) D
|
|
. I $$ITEMCHK^PRCPOPER(PRCPPRIM,PRCPSECO,CCIKITEM)'="" S PRCPFLAG=1 Q
|
|
. S ITEMDA=0 F S ITEMDA=$O(^TMP($J,"PRCPOPPC-ITEMS",CCIKITEM,ITEMDA)) Q:'ITEMDA S DATA=^(ITEMDA) D
|
|
. . S QTYPOST=$P(DATA,"^")-$P(DATA,"^",2)
|
|
. . ; if reusable items returned, do nothing
|
|
. . I $$REUSABLE^PRCPU441(ITEMDA),'QTYPOST Q
|
|
. . I $$ITEMCHK^PRCPOPER(PRCPPRIM,PRCPSECO,ITEMDA)'="" S PRCPFLAG=1 Q
|
|
;
|
|
I PRCPFLAG S VALMSG="ORDER CANNOT BE POSTED - FIX ALL ERRORS FIRST" D EN^VALM("PRCP DIST ORDER CC/IK CHECK") Q
|
|
W " NO ERRORS FOUND !",!
|
|
;
|
|
S XP="Are you sure you want to POST the CC/IK items to "_$$INVNAME^PRCPUX1(PRCPSECO),XH="Enter 'YES' to start posting the CC/IK items to the secondary inventory point",XH(1)="Enter 'NO' or '^' to exit."
|
|
W ! I $$YN^PRCPUYN(1)'=1 Q
|
|
W !,"POSTING CASE CART AND INSTRUMENT KIT ITEMS ..."
|
|
D POST^PRCPOPP3
|
|
S VALMQUIT=1
|
|
K VALMBCK
|
|
Q
|