- 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 Feb 18, 2025@23:33:03 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