source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPOPPC.m@ 1800

Last change on this file since 1800 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.5 KB
RevLine 
[613]1PRCPOPPC ;WISC/RFJ-post items in a case cart or instrument kit ;27 Sep 93
2 ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5 ;
6 ;
7HDR ; -- header code
8 D HDR^PRCPOPL
9 S VALMHDR(3)=$J(" ",49)_"* * * Q U A N T I T Y * * *"
10 Q
11 ;
12 ;
13INIT ; start list manager here and set up variables, clean up
14 ; ^tmp($j,"prcpopccik",ccikitem)=qty ordered (passed to program)
15 ; ^tmp($j,"prcpoppc",line,0)="" (list array)
16 ; ^tmp($j,"prcpoppc-no",item)="" (do not include in list)
17 ; ^tmp($j,"prcpoppc-items",item)=qty ordered ^ qty returned
18 ; ^tmp($j,"prcpoppc-return",item)=qty entered by user for return
19 ;
20 K ^TMP($J,"PRCPOPPC-RETURN"),^TMP($J,"PRCPOPPC-NO")
21 D VARIABLE^PRCPOPU
22 ;
23BUILD ; build list manager array
24 N CCIKITEM,DATA,ITEMDA,ITEMQTY,QTYORD,PRCPFILE,SEQUENCE
25 ;
26 K ^TMP($J,"PRCPOPPC"),^TMP($J,"PRCPOPPC-IK"),^TMP($J,"PRCPOPPC-ITEMS")
27 S (VALMCNT,CCIKITEM)=0 F S CCIKITEM=$O(^TMP($J,"PRCPOPCCIK",CCIKITEM)) Q:'CCIKITEM S QTYORD=^(CCIKITEM) I QTYORD D
28 . I $D(^TMP($J,"PRCPOPPC-NO",CCIKITEM)) Q
29 . S PRCPFILE=$$FILENUMB^PRCPCUT1(CCIKITEM) I 'PRCPFILE Q
30 . D CCIKNAME
31 . S ITEMDA=0 F S ITEMDA=$O(^PRCP(PRCPFILE,CCIKITEM,1,ITEMDA)) Q:'ITEMDA S DATA=$G(^(ITEMDA,0)) I $P(DATA,"^",2) D
32 . . S ITEMQTY=$P(DATA,"^",2)*QTYORD
33 . . I PRCPFILE=445.7,$D(^PRCP(445.8,ITEMDA)) S ^TMP($J,"PRCPOPPC-IK",ITEMDA)=$G(^TMP($J,"PRCPOPPC-IK",ITEMDA))+ITEMQTY
34 . . D ITEMNAME
35 ;
36 ; build list of instrument kits in case carts
37 S PRCPFILE=445.8,CCIKITEM=0 F S CCIKITEM=$O(^TMP($J,"PRCPOPPC-IK",CCIKITEM)) Q:'CCIKITEM S QTYORD=^(CCIKITEM) I QTYORD D
38 . I $D(^TMP($J,"PRCPOPPC-NO",CCIKITEM)) Q
39 . D CCIKNAME
40 . ; sort by sequence
41 . K ^TMP($J,"PRCPOPPCSEQ")
42 . 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)=""
43 . 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
44 . . S ITEMQTY=$P(DATA,"^",2)*QTYORD
45 . . D ITEMNAME
46 K ^TMP($J,"PRCPOPPC-IK"),^TMP($J,"PRCPOPPCSEQ")
47 ;
48 I VALMCNT=0 S VALMQUIT=1 Q
49 Q
50 ;
51EXIT ; -- exit code
52 K ^TMP($J,"PRCPOPCCIK")
53 K ^TMP($J,"PRCPOPPC")
54 K ^TMP($J,"PRCPOPPC-IK")
55 K ^TMP($J,"PRCPOPPC-ITEMS")
56 K ^TMP($J,"PRCPOPPC-NO")
57 K ^TMP($J,"PRCPOPPC-RETURN")
58 Q
59 ;
60 ;
61EEITEMS ; called from protocol file to enter/edit invpt items
62 D FULL^VALM1
63 N PRC,PRCP
64 S PRCP("DPTYPE")="PS"
65 D ^PRCPEILM
66 D BUILD
67 S VALMBCK="R"
68 Q
69 ;
70 ;
71CCIKNAME ; set up ccikname header
72 D SET^PRCPOPL(" ")
73 D SET^PRCPOPL(" * * * * * "_$S(PRCPFILE=445.7:" CASE CART ",1:"INSTRUMENT KIT")_" * * * * *")
74 D SET^PRCPOPL($E($E($$DESCR^PRCPUX1(PRCP("I"),CCIKITEM),1,40)_" (#"_CCIKITEM_") ...................................",1,49)_QTYORD)
75 Q
76 ;
77 ;
78ITEMNAME ; set up item information
79 I $D(^TMP($J,"PRCPOPPC-NO",ITEMDA)) Q
80 N QTYRET,REUSABLE
81 S REUSABLE=$$REUSABLE^PRCPU441(ITEMDA)
82 S VALMCNT=VALMCNT+1
83 S X=$$SETFLD^VALM1(" "_$E($$DESCR^PRCPUX1(PRCP("I"),ITEMDA),1,28)_" (#"_ITEMDA_")","","ITEM")
84 S X=$$SETFLD^VALM1($S(REUSABLE:"R",1:" "),X,"REUSABLE")
85 S X=$$SETFLD^VALM1($P($$UNIT^PRCPUX1(PRCP("I"),ITEMDA,"^"),"^",2),X,"UNIT")
86 S X=$$SETFLD^VALM1(ITEMQTY,X,"ORDERED")
87 S QTYRET=$S($D(^TMP($J,"PRCPOPPC-RETURN",CCIKITEM,ITEMDA)):^(ITEMDA),REUSABLE:ITEMQTY,1:0)
88 S X=$$SETFLD^VALM1(QTYRET,X,"RETURNED")
89 S X=$$SETFLD^VALM1(ITEMQTY-QTYRET,X,"POSTING")
90 D SET^VALM10(VALMCNT,X,VALMCNT)
91 S ^TMP($J,"PRCPOPPC-ITEMS",CCIKITEM,ITEMDA)=ITEMQTY_"^"_QTYRET
92 Q
Note: See TracBrowser for help on using the repository browser.