| [613] | 1 | PRCHDIS2 ;WISC/SC,ID/RSD/RHD-ENTER NEW PURCHASE ORDER/REQUISITION ;1/12/95 2:08 PM
|
|---|
| 2 | V ;;5.1;IFCAP;;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | N I,J,PRCHAMT,PRCHCN,PRCHEC,PRCHL0,PRCHL1,PRCHL2,PRCHL3,PRCHLI,PRCHX
|
|---|
| 5 | S (PRCH,PRCHEC)=0 F I=1:1 S PRCH=$O(^PRC(443.6,PRCHPO,2,PRCH)) Q:PRCH=""!(PRCH'>0) D CHG I $D(^PRC(443.6,PRCHPO,2,PRCH,0)) S PRCHAMT=+$P(^(2),U,1),PRCHCN=$P(^(2),U,2) D CN:PRCHCN]"",OM:PRCHCN=""
|
|---|
| 6 | S PRCH=0 F I=0:1 S PRCH=$O(PRCH("AM",PRCH)) Q:PRCH="" S PRCH("COUNT",+PRCH("AM",PRCH),PRCH)=""
|
|---|
| 7 | Q
|
|---|
| 8 | LI S PRCHL0=$P(PRCH("AM",PRCHL3),U,3) Q:PRCHL0="" F J=1:1 S PRCHL1=$E(PRCHL0,$L(PRCHL0)-J) Q:PRCHL1'=+PRCHL1
|
|---|
| 9 | S PRCHL2=$E(PRCHL0,$L(PRCHL0)-J+1,$L(PRCHL0)-1),PRCHL2=PRCHL2+1 I PRCHL2'=PRCHLI S PRCHLI=PRCHL0_PRCHLI Q
|
|---|
| 10 | I PRCHL1=":" S PRCHLI=$E(PRCHL0,1,$L(PRCHL0)-J)_PRCHLI Q
|
|---|
| 11 | S PRCHLI=$E(PRCHL0,1,$L(PRCHL0)-1)_":1:"_PRCHLI
|
|---|
| 12 | Q
|
|---|
| 13 | CHG ;S X=$P(^PRC(443.6,PRCHPO,2,PRCH,0),U,5),X1=$P(^(0),U,4)
|
|---|
| 14 | S PRCHLI=I,PRCHX=PRCH
|
|---|
| 15 | Q
|
|---|
| 16 | CN S:'$D(PRCH("AM",PRCHCN)) PRCH("AM",PRCHCN)="",PRCHEC=PRCHEC+1 S PRCHL3=PRCHCN
|
|---|
| 17 | D LI S PRCH("AM",PRCHCN)=($P(PRCH("AM",PRCHCN),U,1)+1)_U_($P(PRCH("AM",PRCHCN),U,2)+PRCHAMT)_U_PRCHLI_","
|
|---|
| 18 | Q
|
|---|
| 19 | OM S:'$D(PRCH("AM",".OM")) PRCH("AM",".OM")="",PRCHEC=PRCHEC+1 S PRCHL3=".OM" D LI S PRCH("AM",".OM")=($P(PRCH("AM",".OM"),U,1)+1)_U_($P(PRCH("AM",".OM"),U,2)+PRCHAMT)_U_PRCHLI_","
|
|---|
| 20 | Q
|
|---|
