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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHDIS2 1356 printed Sep 23, 2025@19:42:44 Page 2
PRCHDIS2 ;WISC/SC,ID/RSD/RHD-ENTER NEW PURCHASE ORDER/REQUISITION ;1/12/95 2:08 PM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 NEW I,J,PRCHAMT,PRCHCN,PRCHEC,PRCHL0,PRCHL1,PRCHL2,PRCHL3,PRCHLI,PRCHX
+3 SET (PRCH,PRCHEC)=0
FOR I=1:1
SET PRCH=$ORDER(^PRC(443.6,PRCHPO,2,PRCH))
if PRCH=""!(PRCH'>0)
QUIT
DO CHG
IF $DATA(^PRC(443.6,PRCHPO,2,PRCH,0))
SET PRCHAMT=+$PIECE(^(2),U,1)
SET PRCHCN=$PIECE(^(2),U,2)
if PRCHCN]""
DO CN
if PRCHCN=""
DO OM
+4 SET PRCH=0
FOR I=0:1
SET PRCH=$ORDER(PRCH("AM",PRCH))
if PRCH=""
QUIT
SET PRCH("COUNT",+PRCH("AM",PRCH),PRCH)=""
+5 QUIT
LI SET PRCHL0=$PIECE(PRCH("AM",PRCHL3),U,3)
if PRCHL0=""
QUIT
FOR J=1:1
SET PRCHL1=$EXTRACT(PRCHL0,$LENGTH(PRCHL0)-J)
if PRCHL1'=+PRCHL1
QUIT
+1 SET PRCHL2=$EXTRACT(PRCHL0,$LENGTH(PRCHL0)-J+1,$LENGTH(PRCHL0)-1)
SET PRCHL2=PRCHL2+1
IF PRCHL2'=PRCHLI
SET PRCHLI=PRCHL0_PRCHLI
QUIT
+2 IF PRCHL1=":"
SET PRCHLI=$EXTRACT(PRCHL0,1,$LENGTH(PRCHL0)-J)_PRCHLI
QUIT
+3 SET PRCHLI=$EXTRACT(PRCHL0,1,$LENGTH(PRCHL0)-1)_":1:"_PRCHLI
+4 QUIT
CHG ;S X=$P(^PRC(443.6,PRCHPO,2,PRCH,0),U,5),X1=$P(^(0),U,4)
+1 SET PRCHLI=I
SET PRCHX=PRCH
+2 QUIT
CN if '$DATA(PRCH("AM",PRCHCN))
SET PRCH("AM",PRCHCN)=""
SET PRCHEC=PRCHEC+1
SET PRCHL3=PRCHCN
+1 DO LI
SET PRCH("AM",PRCHCN)=($PIECE(PRCH("AM",PRCHCN),U,1)+1)_U_($PIECE(PRCH("AM",PRCHCN),U,2)+PRCHAMT)_U_PRCHLI_","
+2 QUIT
OM if '$DATA(PRCH("AM",".OM"))
SET PRCH("AM",".OM")=""
SET PRCHEC=PRCHEC+1
SET PRCHL3=".OM"
DO LI
SET PRCH("AM",".OM")=($PIECE(PRCH("AM",".OM"),U,1)+1)_U_($PIECE(PRCH("AM",".OM"),U,2)+PRCHAMT)_U_PRCHLI_","
+1 QUIT
