source: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPOPP2.m@ 897

Last change on this file since 897 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 1.3 KB
Line 
1PRCPOPP2 ;WISC/RFJ-case cart/instrument kit post items ;27 Sep 93
2 ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5 ;
6 ;
7POST ; post cc's and ik's including items in cc's and ik's
8 S VALMBCK="R"
9 N CCIKITEM,DATA,ITEMDA,PRCPFLAG,QTYPOST
10 ;
11 W !!,"CHECKING CASE CART AND INSTRUMENT KIT ITEMS ON ORDER..."
12 S (CCIKITEM,PRCPFLAG)=0 F S CCIKITEM=$O(^TMP($J,"PRCPOPPC-ITEMS",CCIKITEM)) Q:'CCIKITEM!(PRCPFLAG) D
13 . I $$ITEMCHK^PRCPOPER(PRCPPRIM,PRCPSECO,CCIKITEM)'="" S PRCPFLAG=1 Q
14 . S ITEMDA=0 F S ITEMDA=$O(^TMP($J,"PRCPOPPC-ITEMS",CCIKITEM,ITEMDA)) Q:'ITEMDA S DATA=^(ITEMDA) D
15 . . S QTYPOST=$P(DATA,"^")-$P(DATA,"^",2)
16 . . ; if reusable items returned, do nothing
17 . . I $$REUSABLE^PRCPU441(ITEMDA),'QTYPOST Q
18 . . I $$ITEMCHK^PRCPOPER(PRCPPRIM,PRCPSECO,ITEMDA)'="" S PRCPFLAG=1 Q
19 ;
20 I PRCPFLAG S VALMSG="ORDER CANNOT BE POSTED - FIX ALL ERRORS FIRST" D EN^VALM("PRCP DIST ORDER CC/IK CHECK") Q
21 W " NO ERRORS FOUND !",!
22 ;
23 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."
24 W ! I $$YN^PRCPUYN(1)'=1 Q
25 W !,"POSTING CASE CART AND INSTRUMENT KIT ITEMS ..."
26 D POST^PRCPOPP3
27 S VALMQUIT=1
28 K VALMBCK
29 Q
Note: See TracBrowser for help on using the repository browser.