PRCPWPL2 ;WISC/RFJ/DGL-whse post issue book (cancel);13 Jan 94 [1/13/99 11:16am]
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
CANCEL ; cancel item
D FULL^VALM1
S VALMBCK="R"
N DATA,LINEDA,STATUS,X,XP
K X S X(1)="This option will allow you to CANCEL a line item on the issue book. Once a line item is cancelled, the due-ins and due-outs will be decreased by the outstanding quantity."
D DISPLAY^PRCPUX2(5,75,.X)
F W ! S LINEDA=$$LINEITEM^PRCPWPL0 Q:LINEDA<1 D
. S DATA=$G(^PRCS(410,PRCPDA,"IT",LINEDA,0)) I DATA="" W !,"CANNOT FIND LINE ITEM." Q
. S STATUS=$P(DATA,"^",14),XP=""
. I STATUS'="" W !,"ITEM IS ALREADY CANCELLED",$S(STATUS["S":" AND SUBSTITUTED WITH LINE #(S): "_$P(STATUS,",",2,99),1:"") Q
. I $P(DATA,"^",12)>$P(DATA,"^",13) S XP="Primary will NOT be able to receive this item. "
. S XP=XP_"ARE YOU SURE YOU WANT TO CANCEL THIS ITEM",XH="Enter YES to CANCEL this line item."
. W ! I $$YN^PRCPUYN(1)'=1 Q
. D CANCELIT
D REBUILD^PRCPWPLB
Q
;
;
CANCELIT ; cancel the item without asking
S ^TMP($J,"PRCPWPLMPOST",LINEDA)=0
N %,DATA,ITEMDA,QTYOUT
S DATA=$G(^PRCS(410,PRCPDA,"IT",LINEDA,0)) I DATA="" Q
S ITEMDA=+$P(DATA,"^",5)
S QTYOUT=$P(DATA,"^",2)-$P(DATA,"^",12) I QTYOUT<0 S QTYOUT=0
I $P(DATA,"^",14)'["C" S $P(^PRCS(410,PRCPDA,"IT",LINEDA,0),"^",14)="C"_$P(DATA,"^",14)
I $D(^PRCP(445,PRCPINPT,1,ITEMDA,0)) W !?5,"... decrementing due-outs@warehouse by ",QTYOUT D SETOUT^PRCPUDUE(PRCPINPT,ITEMDA,-QTYOUT)
I $D(^PRCP(445,PRCPPRIM,1,ITEMDA,7,PRCPDA,0)) D
. W !?5,"... decrementing due-ins @primary by ",QTYOUT
. I QTYOUT>0 D SETIN^PRCPUDUE(PRCPPRIM,ITEMDA,-QTYOUT)
. S DIK="^PRCP(445,"_PRCPPRIM_",1,"_ITEMDA_",7,"
. S DA=PRCPDA,DA(1)=ITEMDA,DA(2)=PRCPPRIM
. D ^DIK
W !,"*** Line item HAS BEEN cancelled ***"
Q
;
;
FINAL ; make issue book a final
D FULL^VALM1
S VALMBCK="R"
S PRCPFINL=$S($$FINALASK=1:1,1:0)
D HDR^PRCPWPLM
Q
;
;
FINALASK() ; ask to make issue book a final
N X
K X S X(1)="You have the option to make this issue book a FINAL. If you make the issue book a FINAL, all due-outs and due-ins will be cancelled and you will no longer be able to post the issue book."
D DISPLAY^PRCPUX2(5,75,.X)
S XP="Do you want to make this issue book a FINAL",XH="Enter YES to make this issue book a final."
Q $$YN^PRCPUYN(2)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPWPL2 2430 printed Dec 13, 2024@02:16:41 Page 2
PRCPWPL2 ;WISC/RFJ/DGL-whse post issue book (cancel);13 Jan 94 [1/13/99 11:16am]
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 QUIT
+3 ;
+4 ;
CANCEL ; cancel item
+1 DO FULL^VALM1
+2 SET VALMBCK="R"
+3 NEW DATA,LINEDA,STATUS,X,XP
+4 KILL X
SET X(1)="This option will allow you to CANCEL a line item on the issue book. Once a line item is cancelled, the due-ins and due-outs will be decreased by the outstanding quantity."
+5 DO DISPLAY^PRCPUX2(5,75,.X)
+6 FOR
WRITE !
SET LINEDA=$$LINEITEM^PRCPWPL0
if LINEDA<1
QUIT
Begin DoDot:1
+7 SET DATA=$GET(^PRCS(410,PRCPDA,"IT",LINEDA,0))
IF DATA=""
WRITE !,"CANNOT FIND LINE ITEM."
QUIT
+8 SET STATUS=$PIECE(DATA,"^",14)
SET XP=""
+9 IF STATUS'=""
WRITE !,"ITEM IS ALREADY CANCELLED",$SELECT(STATUS["S":" AND SUBSTITUTED WITH LINE #(S): "_$PIECE(STATUS,",",2,99),1:"")
QUIT
+10 IF $PIECE(DATA,"^",12)>$PIECE(DATA,"^",13)
SET XP="Primary will NOT be able to receive this item. "
+11 SET XP=XP_"ARE YOU SURE YOU WANT TO CANCEL THIS ITEM"
SET XH="Enter YES to CANCEL this line item."
+12 WRITE !
IF $$YN^PRCPUYN(1)'=1
QUIT
+13 DO CANCELIT
End DoDot:1
+14 DO REBUILD^PRCPWPLB
+15 QUIT
+16 ;
+17 ;
CANCELIT ; cancel the item without asking
+1 SET ^TMP($JOB,"PRCPWPLMPOST",LINEDA)=0
+2 NEW %,DATA,ITEMDA,QTYOUT
+3 SET DATA=$GET(^PRCS(410,PRCPDA,"IT",LINEDA,0))
IF DATA=""
QUIT
+4 SET ITEMDA=+$PIECE(DATA,"^",5)
+5 SET QTYOUT=$PIECE(DATA,"^",2)-$PIECE(DATA,"^",12)
IF QTYOUT<0
SET QTYOUT=0
+6 IF $PIECE(DATA,"^",14)'["C"
SET $PIECE(^PRCS(410,PRCPDA,"IT",LINEDA,0),"^",14)="C"_$PIECE(DATA,"^",14)
+7 IF $DATA(^PRCP(445,PRCPINPT,1,ITEMDA,0))
WRITE !?5,"... decrementing due-outs@warehouse by ",QTYOUT
DO SETOUT^PRCPUDUE(PRCPINPT,ITEMDA,-QTYOUT)
+8 IF $DATA(^PRCP(445,PRCPPRIM,1,ITEMDA,7,PRCPDA,0))
Begin DoDot:1
+9 WRITE !?5,"... decrementing due-ins @primary by ",QTYOUT
+10 IF QTYOUT>0
DO SETIN^PRCPUDUE(PRCPPRIM,ITEMDA,-QTYOUT)
+11 SET DIK="^PRCP(445,"_PRCPPRIM_",1,"_ITEMDA_",7,"
+12 SET DA=PRCPDA
SET DA(1)=ITEMDA
SET DA(2)=PRCPPRIM
+13 DO ^DIK
End DoDot:1
+14 WRITE !,"*** Line item HAS BEEN cancelled ***"
+15 QUIT
+16 ;
+17 ;
FINAL ; make issue book a final
+1 DO FULL^VALM1
+2 SET VALMBCK="R"
+3 SET PRCPFINL=$SELECT($$FINALASK=1:1,1:0)
+4 DO HDR^PRCPWPLM
+5 QUIT
+6 ;
+7 ;
FINALASK() ; ask to make issue book a final
+1 NEW X
+2 KILL X
SET X(1)="You have the option to make this issue book a FINAL. If you make the issue book a FINAL, all due-outs and due-ins will be cancelled and you will no longer be able to post the issue book."
+3 DO DISPLAY^PRCPUX2(5,75,.X)
+4 SET XP="Do you want to make this issue book a FINAL"
SET XH="Enter YES to make this issue book a final."
+5 QUIT $$YN^PRCPUYN(2)
