- PRCPOPPC ;WISC/RFJ-post items in a case cart or instrument kit ;27 Sep 93
- ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- Q
- ;
- ;
- HDR ; -- header code
- D HDR^PRCPOPL
- S VALMHDR(3)=$J(" ",49)_"* * * Q U A N T I T Y * * *"
- Q
- ;
- ;
- INIT ; start list manager here and set up variables, clean up
- ; ^tmp($j,"prcpopccik",ccikitem)=qty ordered (passed to program)
- ; ^tmp($j,"prcpoppc",line,0)="" (list array)
- ; ^tmp($j,"prcpoppc-no",item)="" (do not include in list)
- ; ^tmp($j,"prcpoppc-items",item)=qty ordered ^ qty returned
- ; ^tmp($j,"prcpoppc-return",item)=qty entered by user for return
- ;
- K ^TMP($J,"PRCPOPPC-RETURN"),^TMP($J,"PRCPOPPC-NO")
- D VARIABLE^PRCPOPU
- ;
- BUILD ; build list manager array
- N CCIKITEM,DATA,ITEMDA,ITEMQTY,QTYORD,PRCPFILE,SEQUENCE
- ;
- K ^TMP($J,"PRCPOPPC"),^TMP($J,"PRCPOPPC-IK"),^TMP($J,"PRCPOPPC-ITEMS")
- S (VALMCNT,CCIKITEM)=0 F S CCIKITEM=$O(^TMP($J,"PRCPOPCCIK",CCIKITEM)) Q:'CCIKITEM S QTYORD=^(CCIKITEM) I QTYORD D
- . I $D(^TMP($J,"PRCPOPPC-NO",CCIKITEM)) Q
- . S PRCPFILE=$$FILENUMB^PRCPCUT1(CCIKITEM) I 'PRCPFILE Q
- . D CCIKNAME
- . S ITEMDA=0 F S ITEMDA=$O(^PRCP(PRCPFILE,CCIKITEM,1,ITEMDA)) Q:'ITEMDA S DATA=$G(^(ITEMDA,0)) I $P(DATA,"^",2) D
- . . S ITEMQTY=$P(DATA,"^",2)*QTYORD
- . . I PRCPFILE=445.7,$D(^PRCP(445.8,ITEMDA)) S ^TMP($J,"PRCPOPPC-IK",ITEMDA)=$G(^TMP($J,"PRCPOPPC-IK",ITEMDA))+ITEMQTY
- . . D ITEMNAME
- ;
- ; build list of instrument kits in case carts
- S PRCPFILE=445.8,CCIKITEM=0 F S CCIKITEM=$O(^TMP($J,"PRCPOPPC-IK",CCIKITEM)) Q:'CCIKITEM S QTYORD=^(CCIKITEM) I QTYORD D
- . I $D(^TMP($J,"PRCPOPPC-NO",CCIKITEM)) Q
- . D CCIKNAME
- . ; sort by sequence
- . K ^TMP($J,"PRCPOPPCSEQ")
- . S ITEMDA=0 F S ITEMDA=$O(^PRCP(445.8,CCIKITEM,1,ITEMDA)) Q:'ITEMDA S DATA=$G(^(ITEMDA,0)),^TMP($J,"PRCPOPPCSEQ",+$P(DATA,"^",3),ITEMDA)=""
- . S SEQUENCE="" F S SEQUENCE=$O(^TMP($J,"PRCPOPPCSEQ",SEQUENCE)) Q:SEQUENCE="" S ITEMDA=0 F S ITEMDA=$O(^TMP($J,"PRCPOPPCSEQ",SEQUENCE,ITEMDA)) Q:'ITEMDA S DATA=$G(^PRCP(445.8,CCIKITEM,1,ITEMDA,0)) I $P(DATA,"^",2) D
- . . S ITEMQTY=$P(DATA,"^",2)*QTYORD
- . . D ITEMNAME
- K ^TMP($J,"PRCPOPPC-IK"),^TMP($J,"PRCPOPPCSEQ")
- ;
- I VALMCNT=0 S VALMQUIT=1 Q
- Q
- ;
- EXIT ; -- exit code
- K ^TMP($J,"PRCPOPCCIK")
- K ^TMP($J,"PRCPOPPC")
- K ^TMP($J,"PRCPOPPC-IK")
- K ^TMP($J,"PRCPOPPC-ITEMS")
- K ^TMP($J,"PRCPOPPC-NO")
- K ^TMP($J,"PRCPOPPC-RETURN")
- Q
- ;
- ;
- EEITEMS ; called from protocol file to enter/edit invpt items
- D FULL^VALM1
- N PRC,PRCP
- S PRCP("DPTYPE")="PS"
- D ^PRCPEILM
- D BUILD
- S VALMBCK="R"
- Q
- ;
- ;
- CCIKNAME ; set up ccikname header
- D SET^PRCPOPL(" ")
- D SET^PRCPOPL(" * * * * * "_$S(PRCPFILE=445.7:" CASE CART ",1:"INSTRUMENT KIT")_" * * * * *")
- D SET^PRCPOPL($E($E($$DESCR^PRCPUX1(PRCP("I"),CCIKITEM),1,40)_" (#"_CCIKITEM_") ...................................",1,49)_QTYORD)
- Q
- ;
- ;
- ITEMNAME ; set up item information
- I $D(^TMP($J,"PRCPOPPC-NO",ITEMDA)) Q
- N QTYRET,REUSABLE
- S REUSABLE=$$REUSABLE^PRCPU441(ITEMDA)
- S VALMCNT=VALMCNT+1
- S X=$$SETFLD^VALM1(" "_$E($$DESCR^PRCPUX1(PRCP("I"),ITEMDA),1,28)_" (#"_ITEMDA_")","","ITEM")
- S X=$$SETFLD^VALM1($S(REUSABLE:"R",1:" "),X,"REUSABLE")
- S X=$$SETFLD^VALM1($P($$UNIT^PRCPUX1(PRCP("I"),ITEMDA,"^"),"^",2),X,"UNIT")
- S X=$$SETFLD^VALM1(ITEMQTY,X,"ORDERED")
- S QTYRET=$S($D(^TMP($J,"PRCPOPPC-RETURN",CCIKITEM,ITEMDA)):^(ITEMDA),REUSABLE:ITEMQTY,1:0)
- S X=$$SETFLD^VALM1(QTYRET,X,"RETURNED")
- S X=$$SETFLD^VALM1(ITEMQTY-QTYRET,X,"POSTING")
- D SET^VALM10(VALMCNT,X,VALMCNT)
- S ^TMP($J,"PRCPOPPC-ITEMS",CCIKITEM,ITEMDA)=ITEMQTY_"^"_QTYRET
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPOPPC 3711 printed Feb 18, 2025@23:40:40 Page 2
- PRCPOPPC ;WISC/RFJ-post items in a case cart or instrument kit ;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 ;
- HDR ; -- header code
- +1 DO HDR^PRCPOPL
- +2 SET VALMHDR(3)=$JUSTIFY(" ",49)_"* * * Q U A N T I T Y * * *"
- +3 QUIT
- +4 ;
- +5 ;
- INIT ; start list manager here and set up variables, clean up
- +1 ; ^tmp($j,"prcpopccik",ccikitem)=qty ordered (passed to program)
- +2 ; ^tmp($j,"prcpoppc",line,0)="" (list array)
- +3 ; ^tmp($j,"prcpoppc-no",item)="" (do not include in list)
- +4 ; ^tmp($j,"prcpoppc-items",item)=qty ordered ^ qty returned
- +5 ; ^tmp($j,"prcpoppc-return",item)=qty entered by user for return
- +6 ;
- +7 KILL ^TMP($JOB,"PRCPOPPC-RETURN"),^TMP($JOB,"PRCPOPPC-NO")
- +8 DO VARIABLE^PRCPOPU
- +9 ;
- BUILD ; build list manager array
- +1 NEW CCIKITEM,DATA,ITEMDA,ITEMQTY,QTYORD,PRCPFILE,SEQUENCE
- +2 ;
- +3 KILL ^TMP($JOB,"PRCPOPPC"),^TMP($JOB,"PRCPOPPC-IK"),^TMP($JOB,"PRCPOPPC-ITEMS")
- +4 SET (VALMCNT,CCIKITEM)=0
- FOR
- SET CCIKITEM=$ORDER(^TMP($JOB,"PRCPOPCCIK",CCIKITEM))
- if 'CCIKITEM
- QUIT
- SET QTYORD=^(CCIKITEM)
- IF QTYORD
- Begin DoDot:1
- +5 IF $DATA(^TMP($JOB,"PRCPOPPC-NO",CCIKITEM))
- QUIT
- +6 SET PRCPFILE=$$FILENUMB^PRCPCUT1(CCIKITEM)
- IF 'PRCPFILE
- QUIT
- +7 DO CCIKNAME
- +8 SET ITEMDA=0
- FOR
- SET ITEMDA=$ORDER(^PRCP(PRCPFILE,CCIKITEM,1,ITEMDA))
- if 'ITEMDA
- QUIT
- SET DATA=$GET(^(ITEMDA,0))
- IF $PIECE(DATA,"^",2)
- Begin DoDot:2
- +9 SET ITEMQTY=$PIECE(DATA,"^",2)*QTYORD
- +10 IF PRCPFILE=445.7
- IF $DATA(^PRCP(445.8,ITEMDA))
- SET ^TMP($JOB,"PRCPOPPC-IK",ITEMDA)=$GET(^TMP($JOB,"PRCPOPPC-IK",ITEMDA))+ITEMQTY
- +11 DO ITEMNAME
- End DoDot:2
- End DoDot:1
- +12 ;
- +13 ; build list of instrument kits in case carts
- +14 SET PRCPFILE=445.8
- SET CCIKITEM=0
- FOR
- SET CCIKITEM=$ORDER(^TMP($JOB,"PRCPOPPC-IK",CCIKITEM))
- if 'CCIKITEM
- QUIT
- SET QTYORD=^(CCIKITEM)
- IF QTYORD
- Begin DoDot:1
- +15 IF $DATA(^TMP($JOB,"PRCPOPPC-NO",CCIKITEM))
- QUIT
- +16 DO CCIKNAME
- +17 ; sort by sequence
- +18 KILL ^TMP($JOB,"PRCPOPPCSEQ")
- +19 SET ITEMDA=0
- FOR
- SET ITEMDA=$ORDER(^PRCP(445.8,CCIKITEM,1,ITEMDA))
- if 'ITEMDA
- QUIT
- SET DATA=$GET(^(ITEMDA,0))
- SET ^TMP($JOB,"PRCPOPPCSEQ",+$PIECE(DATA,"^",3),ITEMDA)=""
- +20 SET SEQUENCE=""
- FOR
- SET SEQUENCE=$ORDER(^TMP($JOB,"PRCPOPPCSEQ",SEQUENCE))
- if SEQUENCE=""
- QUIT
- SET ITEMDA=0
- FOR
- SET ITEMDA=$ORDER(^TMP($JOB,"PRCPOPPCSEQ",SEQUENCE,ITEMDA))
- if 'ITEMDA
- QUIT
- SET DATA=$GET(^PRCP(445.8,CCIKITEM,1,ITEMDA,0))
- IF $PIECE(DATA,"^",2)
- Begin DoDot:2
- +21 SET ITEMQTY=$PIECE(DATA,"^",2)*QTYORD
- +22 DO ITEMNAME
- End DoDot:2
- End DoDot:1
- +23 KILL ^TMP($JOB,"PRCPOPPC-IK"),^TMP($JOB,"PRCPOPPCSEQ")
- +24 ;
- +25 IF VALMCNT=0
- SET VALMQUIT=1
- QUIT
- +26 QUIT
- +27 ;
- EXIT ; -- exit code
- +1 KILL ^TMP($JOB,"PRCPOPCCIK")
- +2 KILL ^TMP($JOB,"PRCPOPPC")
- +3 KILL ^TMP($JOB,"PRCPOPPC-IK")
- +4 KILL ^TMP($JOB,"PRCPOPPC-ITEMS")
- +5 KILL ^TMP($JOB,"PRCPOPPC-NO")
- +6 KILL ^TMP($JOB,"PRCPOPPC-RETURN")
- +7 QUIT
- +8 ;
- +9 ;
- EEITEMS ; called from protocol file to enter/edit invpt items
- +1 DO FULL^VALM1
- +2 NEW PRC,PRCP
- +3 SET PRCP("DPTYPE")="PS"
- +4 DO ^PRCPEILM
- +5 DO BUILD
- +6 SET VALMBCK="R"
- +7 QUIT
- +8 ;
- +9 ;
- CCIKNAME ; set up ccikname header
- +1 DO SET^PRCPOPL(" ")
- +2 DO SET^PRCPOPL(" * * * * * "_$SELECT(PRCPFILE=445.7:" CASE CART ",1:"INSTRUMENT KIT")_" * * * * *")
- +3 DO SET^PRCPOPL($EXTRACT($EXTRACT($$DESCR^PRCPUX1(PRCP("I"),CCIKITEM),1,40)_" (#"_CCIKITEM_") ...................................",1,49)_QTYORD)
- +4 QUIT
- +5 ;
- +6 ;
- ITEMNAME ; set up item information
- +1 IF $DATA(^TMP($JOB,"PRCPOPPC-NO",ITEMDA))
- QUIT
- +2 NEW QTYRET,REUSABLE
- +3 SET REUSABLE=$$REUSABLE^PRCPU441(ITEMDA)
- +4 SET VALMCNT=VALMCNT+1
- +5 SET X=$$SETFLD^VALM1(" "_$EXTRACT($$DESCR^PRCPUX1(PRCP("I"),ITEMDA),1,28)_" (#"_ITEMDA_")","","ITEM")
- +6 SET X=$$SETFLD^VALM1($SELECT(REUSABLE:"R",1:" "),X,"REUSABLE")
- +7 SET X=$$SETFLD^VALM1($PIECE($$UNIT^PRCPUX1(PRCP("I"),ITEMDA,"^"),"^",2),X,"UNIT")
- +8 SET X=$$SETFLD^VALM1(ITEMQTY,X,"ORDERED")
- +9 SET QTYRET=$SELECT($DATA(^TMP($JOB,"PRCPOPPC-RETURN",CCIKITEM,ITEMDA)):^(ITEMDA),REUSABLE:ITEMQTY,1:0)
- +10 SET X=$$SETFLD^VALM1(QTYRET,X,"RETURNED")
- +11 SET X=$$SETFLD^VALM1(ITEMQTY-QTYRET,X,"POSTING")
- +12 DO SET^VALM10(VALMCNT,X,VALMCNT)
- +13 SET ^TMP($JOB,"PRCPOPPC-ITEMS",CCIKITEM,ITEMDA)=ITEMQTY_"^"_QTYRET
- +14 QUIT