source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHAMY2.m@ 1638

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

initial load of WorldVistAEHR
File size: 5.1 KB
Line 
1PRCHAMY2 ;WISC/DJM-PRINT AMENDMENT, ROUTINE #2 ;9/15/95 11:40 AM
2V ;;5.1;IFCAP;**21**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5E22 ;LINE ITEM Delete
6 N FIELD,CHANGE,CHANGES,OLD,ITEM,ITEM0,ITEM1,ITEM2,LCNT,DATA,I,UOP
7 S FIELD=0 K ITEM D LCNT^PRCHPAM5(.LCNT)
8 F S FIELD=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,FIELD)) Q:FIELD'>0 D
9 .S CHANGE=0 F S CHANGE=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,FIELD,CHANGE)) Q:CHANGE'>0 D
10 ..S CHANGES=$G(^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,0)),OLD=$G(^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0))
11 ..S ITEM=$P(CHANGES,U,4) Q:$D(ITEM(ITEM)) S ITEM(ITEM)=1
12 ..S ITEM0=$G(^PRC(442,PRCHPO,2,ITEM,0))
13 ..I ITEM0="" Q
14 ..S ITEM1=$G(^PRC(442,PRCHPO,2,ITEM,1,1,0))
15 ..D LINE^PRCHPAM5(.LCNT,2) S DATA="The following line item has been cancelled:" D DATA^PRCHPAM5(.LCNT,DATA)
16 ..S DATA="Item No. "_$P(ITEM0,U)_" Item Master File No. "
17 ..S DATA=DATA_$P(ITEM0,U,5)_" BOC: "_$P(ITEM0,U,4)
18 ..S DATA=DATA_" CONTRACT: "_$P($G(^PRC(442,PRCHPO,2,ITEM,2)),U,2)
19 ..D DATA^PRCHPAM5(.LCNT,DATA)
20 ..D NEW^PRCHAMY3
21 ..S UOP=$S($P(ITEM0,U,3)>0:$P($G(^PRCD(420.5,$P(ITEM0,U,3),0)),U),1:"")
22 ..S DATA=" Items per "_UOP_": "_$P(ITEM0,U,12)
23 ..F I=1:1:26-$L(DATA) S DATA=DATA_" "
24 ..S DATA=DATA_"NSN: "_$P(ITEM0,U,13) D DATA^PRCHPAM5(.LCNT,DATA)
25 ..I $P(ITEM0,U,6)]"" S DATA=" STK#: "_$P(ITEM0,U,6) D DATA^PRCHPAM5(.LCNT,DATA)
26 ..S QTY=$$FETCH(2,ITEM)
27 ..S AUC=$$FETCH(5,ITEM)
28 ..S DATA=" "_QTY_" "_$P($G(^PRCD(420.5,$P(ITEM0,U,3),0)),U)_" at $"_$J(AUC,12,4)_" = $"_$J(QTY*AUC,9,2) D DATA^PRCHPAM5(.LCNT,DATA),LCNT1^PRCHPAM5(LCNT)
29 Q
30 ;
31E23 ;LINE ITEM Edit
32 N FIELD,CHANGE,CHANGES,OLD,ITEM,ITEM0,ITEM1,ITEMZ,QTY,AUC,UOP,UOP1,NSN,UCF,LCNT,DATA,VAL,ABC,VSN,CONOLD,CON442
33 S FIELD=0 K ITEM D LCNT^PRCHPAM5(.LCNT)
34 F S FIELD=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,FIELD)) Q:FIELD'>0 D
35 .S CHANGE=0 F S CHANGE=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,FIELD,CHANGE)) Q:CHANGE'>0 D
36 ..S CHANGES=$G(^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,0)),OLD=$G(^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0))
37 ..S ITEM=$P(CHANGES,U,4) Q:$D(ITEM(ITEM)) S ITEM(ITEM)=1
38 ..S ITEM0=$G(^PRC(442,PRCHPO,2,ITEM,0))
39 ..I ITEM0="" Q
40 ..I $P(ITEM0,U,2)=0,$P(ITEM0,U,9)=0 Q
41 ..S ITEM1=$G(^PRC(442,PRCHPO,2,ITEM,1,1,0))
42 ..S (ABC,DES)=$$FETCH(1,ITEM) S PRCHLN=VAL
43 ..S IMF=$$FETCH(1.5,ITEM) I IMF'>0 S IMF=$P(ITEM0,U,5)
44 ..S BOC=+$$FETCH(3.5,ITEM) I BOC'>0 S BOC=+$P(ITEM0,U,4)
45 ..S QTY=$$FETCH(2,ITEM) I QTY'>0 S QTY=$P(ITEM0,U,2)
46 ..S AUC=$$FETCH(5,ITEM) I AUC="" S AUC=$P(ITEM0,U,9)
47 ..S UOP=$$FETCH(3,ITEM) I UOP'>0 S UOP=$P(ITEM0,U,3)
48 ..S NSN=$$FETCH(9.5,ITEM) I NSN="" S NSN=$P(ITEM0,U,13)
49 ..S UCF=$$FETCH(3.1,ITEM) I UCF'>0 S UCF=$P(ITEM0,U,12)
50 ..S VSN=$$FETCH(9,ITEM) I VSN="" S VSN=$P(ITEM0,U,6)
51 ..S CONOLD=$$FETCH(4,ITEM)
52 ..S CON442=$P($G(^PRC(442,PRCHPO,2,ITEM,2)),U,2)
53 ..I CONOLD="",CON442'="" S CONOLD=CON442
54 ..D LINE^PRCHPAM5(.LCNT,2) S DATA="**Currently:"
55 ..D DATA^PRCHPAM5(.LCNT,DATA)
56 ..S DATA="Item No. "_$P(ITEM0,U)_" Item Master File No. "
57 ..S DATA=DATA_IMF_" BOC: "_BOC_" CONTRACT: "_CONOLD
58 ..D DATA^PRCHPAM5(.LCNT,DATA)
59 ..I $L(ABC)>0 D OLD^PRCHAMY3
60 ..I $L(ABC)'>0 S ITEMZ=ITEM1 D NEW^PRCHAMY3
61 ..S UOP1=$S($L(UOP)>0:$P($G(^PRCD(420.5,UOP,0)),U),1:"")
62 ..S DATA=" Items per "_UOP1_": "_UCF
63 ..F I=1:1:26-$L(DATA) S DATA=DATA_" "
64 ..S DATA=DATA_"NSN: "_NSN D DATA^PRCHPAM5(.LCNT,DATA)
65 ..I $L(VSN)>0 S DATA=" STK#: "_VSN D DATA^PRCHPAM5(.LCNT,DATA)
66 ..S UOP1=$S($L(UOP)>0:$P($G(^PRCD(420.5,UOP,0)),U),1:"")
67 ..S DATA=" "_QTY_" "_UOP1_" at $"_$J(AUC,12,2)_" = $"_$J(QTY*AUC,9,2) D DATA^PRCHPAM5(.LCNT,DATA)
68 ..S DATA=" "
69 ..D DATA^PRCHPAM5(.LCNT,DATA)
70 ..S DATA=" **Will now be AMENDED to read:" D DATA^PRCHPAM5(.LCNT,DATA)
71 ..S DATA="Item No. "_$P(ITEM0,U)_" Item Master File No. "
72 ..S DATA=DATA_$P(ITEM0,U,5)_" BOC: "_+$P(ITEM0,U,4)
73 ..S DATA=DATA_" CONTRACT: "_CON442
74 ..D DATA^PRCHPAM5(.LCNT,DATA)
75 ..S:$D(ITEMZ) ITEM1=ITEMZ D NEW^PRCHAMY3
76 ..S UOP1=$S($P(ITEM0,U,3)>0:$P($G(^PRCD(420.5,$P(ITEM0,U,3),0)),U),1:"")
77 ..S DATA=" Items per "_UOP1_": "_$P(ITEM0,U,12)
78 ..F I=1:1:26-$L(DATA) S DATA=DATA_" "
79 ..S DATA=DATA_"NSN: "_$P(ITEM0,U,13) D DATA^PRCHPAM5(.LCNT,DATA)
80 ..I $P(ITEM0,U,5)]"" S DATA=" STK:# "_$P(ITEM0,U,6) D DATA^PRCHPAM5(.LCNT,DATA)
81 ..S UOP1=$S($P(ITEM0,U,3)>0:$P($G(^PRCD(420.5,$P(ITEM0,U,3),0)),U),1:"")
82 ..S DATA=" "_$P(ITEM0,U,2)_" "_UOP1_" $"_$J($P(ITEM0,U,9),12,4)_" = $"_$J($P(ITEM0,U,2)*$P(ITEM0,U,9),9,2)
83 ..D DATA^PRCHPAM5(.LCNT,DATA),LCNT1^PRCHPAM5(LCNT)
84 Q
85 ;
86FETCH(FIELD,ITEM) ;EXTRINSIC FUNCTION TO RETURN THE 'VALUE' FOR A FIELD FROM 'LINE ITEM
87 ;AMENDMENT' OPTIONS.
88 N VAL1
89 S VAL=0 F S VAL=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",21,FIELD,VAL)) Q:VAL'>0 S VAL1=$P($G(^PRC(442,PRCHPO,6,PRCHAM,3,VAL,0)),U,4) I VAL1=ITEM S VAL1=0 G EXIT
90 S VAL=0 F S VAL=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",22,FIELD,VAL)) Q:VAL'>0 S VAL1=$P($G(^PRC(442,PRCHPO,6,PRCHAM,3,VAL,0)),U,4) I VAL1=ITEM D G EXIT
91 .S VAL1=$G(^PRC(442,PRCHPO,6,PRCHAM,3,VAL,1,1,0))
92 .Q
93 S VAL=0 F S VAL=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",23,FIELD,VAL)) Q:VAL'>0 S VAL1=$P($G(^PRC(442,PRCHPO,6,PRCHAM,3,VAL,0)),U,4) I VAL1=ITEM D G EXIT
94 .S VAL1=$G(^PRC(442,PRCHPO,6,PRCHAM,3,VAL,1,1,0))
95 .Q
96 S VAL1=""
97EXIT Q VAL1
Note: See TracBrowser for help on using the repository browser.