PRCPOPP1 ;WISC/RFJ-case cart/instrument kit post utilities ;27 Sep 93
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
EDIT ; edit items on list
D FULL^VALM1
S VALMBCK="R"
N CCIKITEM,ITEMDA
F W ! S CCIKITEM=+$$ITEMSEL("C") Q:'CCIKITEM D
. F W ! S ITEMDA=+$$ITEMSEL("I") Q:'ITEMDA D
. . D QTYRETRN
D BUILD^PRCPOPPC
Q
;
;
QTYRETRN ; ask for quantity to return to primary
N DIR,X,Y
S X=$G(^TMP($J,"PRCPOPPC-ITEMS",CCIKITEM,ITEMDA))
S DIR(0)="NA^0:"_$P(X,"^")_":0",DIR("A")=" QUANTITY TO RETURN: ",DIR("B")=$P(X,"^",2)
S DIR("A",1)=" Quantity Ordered : "_$P(X,"^")
S DIR("A",2)=" Quantity Returned: "_$P(X,"^",2)
S DIR("A",3)=" Quantity to Post : "_($P(X,"^")-$P(X,"^",2))
S DIR("A",4)="Enter the quantity of this item to return to the primary inventory point."
W ! D ^DIR
I +Y=Y S ^TMP($J,"PRCPOPPC-RETURN",CCIKITEM,ITEMDA)=+Y,$P(^TMP($J,"PRCPOPPC-ITEMS",CCIKITEM,ITEMDA),"^",2)=+Y
Q
;
;
ITEMSEL(V1) ; select items
; v1=C for cc or ik items; v1=I for non cc or ik items
; returns item number
N %,DDH,DIC,DTOUT,DUOUT,PRCPSET,X,Y
I V1="C" D
. S DIC("S")="I $P(^(0),U,6)=""S"",$D(^TMP($J,""PRCPOPPC-ITEMS"",Y))",DIC("A")="Select CASE CART or INSTRUMENT KIT: "
I V1="I" D
. S DIC("S")="I $P(^(0),U,6)'=""S"",$D(^TMP($J,""PRCPOPPC-ITEMS"",CCIKITEM,Y))",DIC("A")=" Select ITEM: "
S PRCPSET="I 1"
S DIC="^PRC(441,",DIC(0)="QEAM" D ^DIC
Q $S(Y<1:0,1:+Y)
;
;
REMREUSE ; remove all reusable items from the list and post zero
D FULL^VALM1
S VALMBCK="R"
N %,CCIKITEM,ITEMDA
S XP="Do you want to remove ALL reusable items from the list and post ZERO"
S XH="Enter 'YES' to remove all REUSABLE items from the list and post zero"
S XH(1)="Enter 'NO' or '^' to leave the list as is and return to the main screen."
W ! I $$YN^PRCPUYN(2)'=1 Q
; remove reusables from list
S CCIKITEM=0 F S CCIKITEM=$O(^TMP($J,"PRCPOPPC-ITEMS",CCIKITEM)) Q:'CCIKITEM S ITEMDA=0 F S ITEMDA=$O(^TMP($J,"PRCPOPPC-ITEMS",CCIKITEM,ITEMDA)) Q:'ITEMDA D
. I $$REUSABLE^PRCPU441(ITEMDA) K ^TMP($J,"PRCPOPPC-ITEMS",CCIKITEM,ITEMDA),^TMP($J,"PRCPOPPC-RETURN",CCIKITEM,ITEMDA) S ^TMP($J,"PRCPOPPC-NO",ITEMDA)=""
D BUILD^PRCPOPPC
Q
;
;
REMCCIK ; remove cc or ik from list and post zero
D FULL^VALM1
S VALMBCK="R"
N %,CCIKITEM,ITEMDA,PRCPFILE,TYPE
W ! S CCIKITEM=+$$ITEMSEL("C") I 'CCIKITEM Q
S PRCPFILE=$$FILENUMB^PRCPCUT1(CCIKITEM),TYPE=$S(PRCPFILE=445.7:"CASE CART",1:"INSTRUMENT KIT")
S XP="Do you want to remove this "_TYPE_" from the list and post ZERO"
S XH="Enter 'YES' to remove "_TYPE_" from the list and post ZERO"
S XH(1)="Enter 'NO' or '^' to leave the list as is and return to the main screen."
W ! I $$YN^PRCPUYN(2)'=1 Q
; remove cc or ik from list
K ^TMP($J,"PRCPOPPC-ITEMS",CCIKITEM),^TMP($J,"PRCPOPPCCIK",CCIKITEM),^TMP($J,"PRCPOPPC-RETURN",CCIKITEM)
S ^TMP($J,"PRCPOPPC-NO",CCIKITEM)=""
D BUILD^PRCPOPPC
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPOPP1 3005 printed Dec 13, 2024@02:14:15 Page 2
PRCPOPP1 ;WISC/RFJ-case cart/instrument kit post utilities ;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 ;
EDIT ; edit items on list
+1 DO FULL^VALM1
+2 SET VALMBCK="R"
+3 NEW CCIKITEM,ITEMDA
+4 FOR
WRITE !
SET CCIKITEM=+$$ITEMSEL("C")
if 'CCIKITEM
QUIT
Begin DoDot:1
+5 FOR
WRITE !
SET ITEMDA=+$$ITEMSEL("I")
if 'ITEMDA
QUIT
Begin DoDot:2
+6 DO QTYRETRN
End DoDot:2
End DoDot:1
+7 DO BUILD^PRCPOPPC
+8 QUIT
+9 ;
+10 ;
QTYRETRN ; ask for quantity to return to primary
+1 NEW DIR,X,Y
+2 SET X=$GET(^TMP($JOB,"PRCPOPPC-ITEMS",CCIKITEM,ITEMDA))
+3 SET DIR(0)="NA^0:"_$PIECE(X,"^")_":0"
SET DIR("A")=" QUANTITY TO RETURN: "
SET DIR("B")=$PIECE(X,"^",2)
+4 SET DIR("A",1)=" Quantity Ordered : "_$PIECE(X,"^")
+5 SET DIR("A",2)=" Quantity Returned: "_$PIECE(X,"^",2)
+6 SET DIR("A",3)=" Quantity to Post : "_($PIECE(X,"^")-$PIECE(X,"^",2))
+7 SET DIR("A",4)="Enter the quantity of this item to return to the primary inventory point."
+8 WRITE !
DO ^DIR
+9 IF +Y=Y
SET ^TMP($JOB,"PRCPOPPC-RETURN",CCIKITEM,ITEMDA)=+Y
SET $PIECE(^TMP($JOB,"PRCPOPPC-ITEMS",CCIKITEM,ITEMDA),"^",2)=+Y
+10 QUIT
+11 ;
+12 ;
ITEMSEL(V1) ; select items
+1 ; v1=C for cc or ik items; v1=I for non cc or ik items
+2 ; returns item number
+3 NEW %,DDH,DIC,DTOUT,DUOUT,PRCPSET,X,Y
+4 IF V1="C"
Begin DoDot:1
+5 SET DIC("S")="I $P(^(0),U,6)=""S"",$D(^TMP($J,""PRCPOPPC-ITEMS"",Y))"
SET DIC("A")="Select CASE CART or INSTRUMENT KIT: "
End DoDot:1
+6 IF V1="I"
Begin DoDot:1
+7 SET DIC("S")="I $P(^(0),U,6)'=""S"",$D(^TMP($J,""PRCPOPPC-ITEMS"",CCIKITEM,Y))"
SET DIC("A")=" Select ITEM: "
End DoDot:1
+8 SET PRCPSET="I 1"
+9 SET DIC="^PRC(441,"
SET DIC(0)="QEAM"
DO ^DIC
+10 QUIT $SELECT(Y<1:0,1:+Y)
+11 ;
+12 ;
REMREUSE ; remove all reusable items from the list and post zero
+1 DO FULL^VALM1
+2 SET VALMBCK="R"
+3 NEW %,CCIKITEM,ITEMDA
+4 SET XP="Do you want to remove ALL reusable items from the list and post ZERO"
+5 SET XH="Enter 'YES' to remove all REUSABLE items from the list and post zero"
+6 SET XH(1)="Enter 'NO' or '^' to leave the list as is and return to the main screen."
+7 WRITE !
IF $$YN^PRCPUYN(2)'=1
QUIT
+8 ; remove reusables from list
+9 SET CCIKITEM=0
FOR
SET CCIKITEM=$ORDER(^TMP($JOB,"PRCPOPPC-ITEMS",CCIKITEM))
if 'CCIKITEM
QUIT
SET ITEMDA=0
FOR
SET ITEMDA=$ORDER(^TMP($JOB,"PRCPOPPC-ITEMS",CCIKITEM,ITEMDA))
if 'ITEMDA
QUIT
Begin DoDot:1
+10 IF $$REUSABLE^PRCPU441(ITEMDA)
KILL ^TMP($JOB,"PRCPOPPC-ITEMS",CCIKITEM,ITEMDA),^TMP($JOB,"PRCPOPPC-RETURN",CCIKITEM,ITEMDA)
SET ^TMP($JOB,"PRCPOPPC-NO",ITEMDA)=""
End DoDot:1
+11 DO BUILD^PRCPOPPC
+12 QUIT
+13 ;
+14 ;
REMCCIK ; remove cc or ik from list and post zero
+1 DO FULL^VALM1
+2 SET VALMBCK="R"
+3 NEW %,CCIKITEM,ITEMDA,PRCPFILE,TYPE
+4 WRITE !
SET CCIKITEM=+$$ITEMSEL("C")
IF 'CCIKITEM
QUIT
+5 SET PRCPFILE=$$FILENUMB^PRCPCUT1(CCIKITEM)
SET TYPE=$SELECT(PRCPFILE=445.7:"CASE CART",1:"INSTRUMENT KIT")
+6 SET XP="Do you want to remove this "_TYPE_" from the list and post ZERO"
+7 SET XH="Enter 'YES' to remove "_TYPE_" from the list and post ZERO"
+8 SET XH(1)="Enter 'NO' or '^' to leave the list as is and return to the main screen."
+9 WRITE !
IF $$YN^PRCPUYN(2)'=1
QUIT
+10 ; remove cc or ik from list
+11 KILL ^TMP($JOB,"PRCPOPPC-ITEMS",CCIKITEM),^TMP($JOB,"PRCPOPPCCIK",CCIKITEM),^TMP($JOB,"PRCPOPPC-RETURN",CCIKITEM)
+12 SET ^TMP($JOB,"PRCPOPPC-NO",CCIKITEM)=""
+13 DO BUILD^PRCPOPPC
+14 QUIT
