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 Dec 13, 2024@02:14:18 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
