source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHDIS2.m@ 1240

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