- 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 Jan 18, 2025@03:17:52 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)