Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCPOPPC

PRCPOPPC.m

Go to the documentation of this file.
  1. PRCPOPPC ;WISC/RFJ-post items in a case cart or instrument kit ;27 Sep 93
  1. ;;5.1;IFCAP;;Oct 20, 2000
  1. ;Per VHA Directive 10-93-142, this routine should not be modified.
  1. Q
  1. ;
  1. ;
  1. HDR ; -- header code
  1. D HDR^PRCPOPL
  1. S VALMHDR(3)=$J(" ",49)_"* * * Q U A N T I T Y * * *"
  1. Q
  1. ;
  1. ;
  1. INIT ; start list manager here and set up variables, clean up
  1. ; ^tmp($j,"prcpopccik",ccikitem)=qty ordered (passed to program)
  1. ; ^tmp($j,"prcpoppc",line,0)="" (list array)
  1. ; ^tmp($j,"prcpoppc-no",item)="" (do not include in list)
  1. ; ^tmp($j,"prcpoppc-items",item)=qty ordered ^ qty returned
  1. ; ^tmp($j,"prcpoppc-return",item)=qty entered by user for return
  1. ;
  1. K ^TMP($J,"PRCPOPPC-RETURN"),^TMP($J,"PRCPOPPC-NO")
  1. D VARIABLE^PRCPOPU
  1. ;
  1. BUILD ; build list manager array
  1. N CCIKITEM,DATA,ITEMDA,ITEMQTY,QTYORD,PRCPFILE,SEQUENCE
  1. ;
  1. K ^TMP($J,"PRCPOPPC"),^TMP($J,"PRCPOPPC-IK"),^TMP($J,"PRCPOPPC-ITEMS")
  1. S (VALMCNT,CCIKITEM)=0 F S CCIKITEM=$O(^TMP($J,"PRCPOPCCIK",CCIKITEM)) Q:'CCIKITEM S QTYORD=^(CCIKITEM) I QTYORD D
  1. . I $D(^TMP($J,"PRCPOPPC-NO",CCIKITEM)) Q
  1. . S PRCPFILE=$$FILENUMB^PRCPCUT1(CCIKITEM) I 'PRCPFILE Q
  1. . D CCIKNAME
  1. . S ITEMDA=0 F S ITEMDA=$O(^PRCP(PRCPFILE,CCIKITEM,1,ITEMDA)) Q:'ITEMDA S DATA=$G(^(ITEMDA,0)) I $P(DATA,"^",2) D
  1. . . S ITEMQTY=$P(DATA,"^",2)*QTYORD
  1. . . I PRCPFILE=445.7,$D(^PRCP(445.8,ITEMDA)) S ^TMP($J,"PRCPOPPC-IK",ITEMDA)=$G(^TMP($J,"PRCPOPPC-IK",ITEMDA))+ITEMQTY
  1. . . D ITEMNAME
  1. ;
  1. ; build list of instrument kits in case carts
  1. S PRCPFILE=445.8,CCIKITEM=0 F S CCIKITEM=$O(^TMP($J,"PRCPOPPC-IK",CCIKITEM)) Q:'CCIKITEM S QTYORD=^(CCIKITEM) I QTYORD D
  1. . I $D(^TMP($J,"PRCPOPPC-NO",CCIKITEM)) Q
  1. . D CCIKNAME
  1. . ; sort by sequence
  1. . K ^TMP($J,"PRCPOPPCSEQ")
  1. . 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)=""
  1. . 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
  1. . . S ITEMQTY=$P(DATA,"^",2)*QTYORD
  1. . . D ITEMNAME
  1. K ^TMP($J,"PRCPOPPC-IK"),^TMP($J,"PRCPOPPCSEQ")
  1. ;
  1. I VALMCNT=0 S VALMQUIT=1 Q
  1. Q
  1. ;
  1. EXIT ; -- exit code
  1. K ^TMP($J,"PRCPOPCCIK")
  1. K ^TMP($J,"PRCPOPPC")
  1. K ^TMP($J,"PRCPOPPC-IK")
  1. K ^TMP($J,"PRCPOPPC-ITEMS")
  1. K ^TMP($J,"PRCPOPPC-NO")
  1. K ^TMP($J,"PRCPOPPC-RETURN")
  1. Q
  1. ;
  1. ;
  1. EEITEMS ; called from protocol file to enter/edit invpt items
  1. D FULL^VALM1
  1. N PRC,PRCP
  1. S PRCP("DPTYPE")="PS"
  1. D ^PRCPEILM
  1. D BUILD
  1. S VALMBCK="R"
  1. Q
  1. ;
  1. ;
  1. CCIKNAME ; set up ccikname header
  1. D SET^PRCPOPL(" ")
  1. D SET^PRCPOPL(" * * * * * "_$S(PRCPFILE=445.7:" CASE CART ",1:"INSTRUMENT KIT")_" * * * * *")
  1. D SET^PRCPOPL($E($E($$DESCR^PRCPUX1(PRCP("I"),CCIKITEM),1,40)_" (#"_CCIKITEM_") ...................................",1,49)_QTYORD)
  1. Q
  1. ;
  1. ;
  1. ITEMNAME ; set up item information
  1. I $D(^TMP($J,"PRCPOPPC-NO",ITEMDA)) Q
  1. N QTYRET,REUSABLE
  1. S REUSABLE=$$REUSABLE^PRCPU441(ITEMDA)
  1. S VALMCNT=VALMCNT+1
  1. S X=$$SETFLD^VALM1(" "_$E($$DESCR^PRCPUX1(PRCP("I"),ITEMDA),1,28)_" (#"_ITEMDA_")","","ITEM")
  1. S X=$$SETFLD^VALM1($S(REUSABLE:"R",1:" "),X,"REUSABLE")
  1. S X=$$SETFLD^VALM1($P($$UNIT^PRCPUX1(PRCP("I"),ITEMDA,"^"),"^",2),X,"UNIT")
  1. S X=$$SETFLD^VALM1(ITEMQTY,X,"ORDERED")
  1. S QTYRET=$S($D(^TMP($J,"PRCPOPPC-RETURN",CCIKITEM,ITEMDA)):^(ITEMDA),REUSABLE:ITEMQTY,1:0)
  1. S X=$$SETFLD^VALM1(QTYRET,X,"RETURNED")
  1. S X=$$SETFLD^VALM1(ITEMQTY-QTYRET,X,"POSTING")
  1. D SET^VALM10(VALMCNT,X,VALMCNT)
  1. S ^TMP($J,"PRCPOPPC-ITEMS",CCIKITEM,ITEMDA)=ITEMQTY_"^"_QTYRET
  1. Q