- 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 Feb 18, 2025@23:40:38 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