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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPOPP2 1374 printed Nov 22, 2024@17:24:21 Page 2
PRCPOPP2 ;WISC/RFJ-case cart/instrument kit post 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 ;
POST ; post cc's and ik's including items in cc's and ik's
+1 SET VALMBCK="R"
+2 NEW CCIKITEM,DATA,ITEMDA,PRCPFLAG,QTYPOST
+3 ;
+4 WRITE !!,"CHECKING CASE CART AND INSTRUMENT KIT ITEMS ON ORDER..."
+5 SET (CCIKITEM,PRCPFLAG)=0
FOR
SET CCIKITEM=$ORDER(^TMP($JOB,"PRCPOPPC-ITEMS",CCIKITEM))
if 'CCIKITEM!(PRCPFLAG)
QUIT
Begin DoDot:1
+6 IF $$ITEMCHK^PRCPOPER(PRCPPRIM,PRCPSECO,CCIKITEM)'=""
SET PRCPFLAG=1
QUIT
+7 SET ITEMDA=0
FOR
SET ITEMDA=$ORDER(^TMP($JOB,"PRCPOPPC-ITEMS",CCIKITEM,ITEMDA))
if 'ITEMDA
QUIT
SET DATA=^(ITEMDA)
Begin DoDot:2
+8 SET QTYPOST=$PIECE(DATA,"^")-$PIECE(DATA,"^",2)
+9 ; if reusable items returned, do nothing
+10 IF $$REUSABLE^PRCPU441(ITEMDA)
IF 'QTYPOST
QUIT
+11 IF $$ITEMCHK^PRCPOPER(PRCPPRIM,PRCPSECO,ITEMDA)'=""
SET PRCPFLAG=1
QUIT
End DoDot:2
End DoDot:1
+12 ;
+13 IF PRCPFLAG
SET VALMSG="ORDER CANNOT BE POSTED - FIX ALL ERRORS FIRST"
DO EN^VALM("PRCP DIST ORDER CC/IK CHECK")
QUIT
+14 WRITE " NO ERRORS FOUND !",!
+15 ;
+16 SET XP="Are you sure you want to POST the CC/IK items to "_$$INVNAME^PRCPUX1(PRCPSECO)
SET XH="Enter 'YES' to start posting the CC/IK items to the secondary inventory point"
SET XH(1)="Enter 'NO' or '^' to exit."
+17 WRITE !
IF $$YN^PRCPUYN(1)'=1
QUIT
+18 WRITE !,"POSTING CASE CART AND INSTRUMENT KIT ITEMS ..."
+19 DO POST^PRCPOPP3
+20 SET VALMQUIT=1
+21 KILL VALMBCK
+22 QUIT
