- PRCHDP2 ;ID/RSD/RHD-DISPLAY P.O. ; [7/22/98 11:11am]
- V ;;5.1;IFCAP;**38,131,221**;Oct 20, 2000;Build 14
- ;Per VA Directive 6402, this routine should not be modified.
- ;
- ;PRC*5.1*221 Modify an item description display to skip '|' logic
- ; if description contains a undefined display command
- ; like '| IN '.
- ;
- N PRCHAMNT,PRCHAMCT S PRCHAMNT=0 I $D(^PRC(442,D0,6,0)) S PRCHAMCT=$P(^PRC(442,D0,6,0),U,3),PRCHAMNT=1 ;PRC*5.1*221
- W !?8,"ENTER '^' TO HALT: " S PRCHDQ=0 R X:DTIME S:X["^" PRCHDQ=1 G ASK2:PRCHDQ D HDR
- S (N,PRCHDI)=0 F I=0:0 S PRCHDI=$O(^PRC(442,D0,2,PRCHDI)) Q:PRCHDI'>0 S PRCHDI0=^(PRCHDI,0),PRCHDI2=$S($D(^(2)):^(2),1:""),N=+PRCHDI0 D ITEM G:PRCHDQ ASK2
- S PRCHDI=0 F I=0:0 S PRCHDI=$O(^PRC(442,D0,3,PRCHDI)) Q:PRCHDI'>0 S PRCHDI0=^(PRCHDI,0),N=N+1 W !?2,$J(N,3),?7,"LESS ",$P(PRCHDI0,U,2),$S($E($P(PRCHDI0,U,2),1)="$":"",1:" %")," FOR " D DIS
- I $P(PRCHD0,U,13)>0 W !?2,$J(N+1,3),?7,"EST. SHIPPING AND/OR HANDLING",?58,$J($P(PRCHD0,U,13),7,2)
- G:'$D(^PRC(442,D0,15,0)) COM K ^(9999999),^UTILITY($J,"W")
- F PRCHK=0:0 S PRCHK=$O(^PRC(442,D0,15,PRCHK)) Q:'PRCHK S PRCHI=^(PRCHK,0) I $D(^PRC(442.7,+PRCHI,0)),$O(^(1,0)) S DIWL=1,DIWR=60 F PRCHJ=0:0 S PRCHJ=$O(^PRC(442.7,+PRCHI,1,PRCHJ)) Q:'PRCHJ S X=^(PRCHJ,0) D DIWP^PRCUTL($G(DA))
- ;
- K ^TMP($J,"W") S %X="^UTILITY($J,""W"",",%Y="^TMP($J,""W""," D %XY^%RCR
- W ! F J=0:0 S J=$O(^TMP($J,"W",1,J)) Q:'J W !?8,^(J,0) D ASK G:PRCHDQ ASK2
- COM G:'$D(^PRC(442,D0,4,0)) PT K ^UTILITY($J,"W") S DIWL=1,DIWR=60,PRCHJ=0 F S PRCHJ=$O(^PRC(442,D0,4,PRCHJ)) Q:PRCHJ="" S X=^(PRCHJ,0) D DIWP^PRCUTL($G(DA))
- K ^TMP($J,"W") S %X="^UTILITY($J,""W"",",%Y="^TMP($J,""W""," D %XY^%RCR
- W ! S J=0 F S J=$O(^TMP($J,"W",1,J)) Q:J="" W !?8,^(J,0) D ASK G:PRCHDQ ASK2
- PT I $O(^PRC(442,D0,13,0)) W !!?8,"V.A. TRANSACTION NUMBERS: " F PRCHI=0:0 S PRCHI=$O(^PRC(442,D0,13,PRCHI)) Q:'PRCHI I $D(^PRCS(410,PRCHI,0)) W !?14,$P(^(0),U,1)
- D AMENDS^PRCHDP6
- I $D(^PRC(442,D0,6,0)) F PRCHI=0:0 S PRCHI=$O(^PRC(442,D0,6,PRCHI)) Q:'PRCHI I $D(^(PRCHI,0)) W !!?3,"AMENDMENT NUMBER: ",PRCHI,?40,"EFFECTIVE DATE: " S Y=$P(^(0),U,2) D DT D AMD Q:PRCHDQ
- K ^TMP($J,"PRCHDP6")
- ASK2 D:'PRCHDQ EN^PRCHDP4 G:'$O(^PRC(442,D0,11,0)) ASK1 W ! S %A=" Review a Receiving Report ",%B="",%=2 D ^PRCFYN G:%'=1 Q
- PT1 K DIC S (PRCHPO,DA(1))=D0,DIC="^PRC(442,DA(1),11,",DIC(0)="NEAZ"
- ;--added for PRC*5.1*38
- S DIC("W")="D ADJCHK^PRCHDP2"
- D ^DIC G:Y<0 Q S PRCHDPT=+Y,PRCHDRD=$P(Y(0),U,1),PRCHDTP=1 D ^PRCHDP3 G PT1
- ASK I $Y+5>IOSL W !?8,"ENTER '^' TO HALT: " R X:DTIME S:X["^" PRCHDQ=1 D:'PRCHDQ HDR Q
- Q
- ASK1 I $G(PRCHAMNT)=2 D ;PRC*5.1*221
- . W !!,"** An amendment updated the order during your display that affected **"
- . W !,"** the order's first page total and any items that were amended **"
- . W !,"** for price/quantity. If the accuracy of the displayed order is **"
- . W !,"** critical, you should re-display the order again with the updated **"
- . W !,"** order total and items. **"
- . W !,""
- . Q
- W !,$C(7) G:PRCHDQ Q W "END OF DISPLAY--PRESS RETURN OR ENTER '^' TO HALT: " R X:DTIME G Q
- HDR W:$Y>0 @IOF,!!?55,"UNIT",?70,"TOTAL",!,"ITEM",?15,"DESCRIPTION",?42,"QTY",?46,"UNIT",?55,"COST",?70,"COST",! F I=1:1:80 W "-"
- Q
- ITEM S DIWL=1,DIWR=33,DIWF="",PRCHDIW=0 K ^UTILITY($J,"W")
- N PURCTYPE,PURPIPE,PRCHI,PRCHJ S:$P($G(^PRC(442,D0,23)),"^",11)="S" PURCTYPE=1 ;PRC*5.1*221
- D PIPECK S PRCHDIW=0 ;PRC*5.1*221
- F PRCHJ=1:1 S PRCHDIW=$O(^PRC(442,D0,2,PRCHDI,1,PRCHDIW)) Q:PRCHDIW'>0 S X=$S($D(^(PRCHDIW,0)):^(0),1:"") S:PURPIPE DIWF=$G(DIWF)_"|" D DIWP^PRCUTL($G(DA)) ;PRC*5.1*221
- K ^TMP($J,"W") S %X="^UTILITY($J,""W"",",%Y="^TMP($J,""W""," D %XY^%RCR
- S PRCHDCNT=$S($D(^TMP($J,"W",1)):^(1),1:"") W ! I $G(PURCTYPE)="" W ?2,$J(+$P(PRCHDI0,U,1),3)
- W ?7,$S($D(^(1,1,0)):^(0),1:"")
- I $G(PURCTYPE)="" W ?40,$J($P(PRCHDI0,U,2),5),?47,$S($D(^PRCD(420.5,+$P(PRCHDI0,U,3),0)):$P(^(0),U,1),1:"")
- S X=$P($P(PRCHDI0,U,9),".",2) I $G(PURCTYPE)="" W ?52,$S($L(X)>3:$J($P(PRCHDI0,U,9),5,4),$L(X)>2:$J($P(PRCHDI0,U,9),6,3),$P(PRCHDI0,U,9)="N/C":" N/C",1:$J($P(PRCHDI0,U,9),7,2))
- W ?67,$J($P(PRCHDI2,U,1),7,2)
- I PRCHDCNT>1 S K=1 F S K=$O(^TMP($J,"W",1,K)) Q:K=""!(K'>0) D:$Y+5>IOSL ASK Q:PRCHDQ W !?8,^(K,0)
- Q:PRCHDQ
- W:$P(PRCHDI0,U,6)]"" !?8,"STK#: ",$P(PRCHDI0,U,6) W:$P(PRCHDI0,U,13)]"" !,?8,"NSN: ",$P(PRCHDI0,U,13) W:$P($G(^PRC(442,D0,2,PRCHDI,4)),U,12)]"" !,?8,"FOOD GROUP: ",$P(^(4),U,12)
- W:$P(PRCHDI2,U,8)]"" !,?8,"QTY PREV RCVD: ",$J($P(PRCHDI2,U,8),5) I $D(^PRC(442,D0,2,PRCHDI,3,"AC")) W !,?8,"PARTIAL NO.: " S X=0 F K=1:1 S X=$O(^PRC(442,D0,2,PRCHDI,3,"AC",X)) Q:X="" W:K>1 "," W X
- N ZZ S ZZ=0 D EDISTAT^PRCHUTL(D0,PRCHDI,.ZZ) ;***** NEW CODE EDI STATUS DISPLAY *****
- I $G(PURCTYPE)="",$P(PRCHDI0,U,12) W:'ZZ ! W ?8,"Items per ",$S($D(^PRCD(420.5,+$P(PRCHDI0,U,3),0)):$P(^(0),U,1),1:""),": ",$P(PRCHDI0,U,12),!
- D ASK ;***** NEW CODE TO CORRECT PAGING PROBLEM *****
- W:$X>1 !
- W ?8,"BOC: ",$P($P(PRCHDI0,U,4)," ",1) S FMSLN=$O(^PRC(442,D0,22,"B",+$P(PRCHDI0,U,4),0))
- I FMSLN>0,'$P($G(^PRC(442,D0,23)),U,8) S FMSLN="00"_$P($G(^PRC(442,D0,22,FMSLN,0)),U,3),FMSLN=$E(FMSLN,$L(FMSLN)-2,99) W ?22,"FMS LINE: ",FMSLN
- W:$P(PRCHDI2,U,2)]"" ?40,"CONTRACT: ",$P(PRCHDI2,U,2)
- W !
- Q
- DIS W $S($P(PRCHDI0,U,1)="Q":"QUANTITY DISCOUNT",1:"ITEMS: "_$P(PRCHDI0,U,1)),?57,$J($P(PRCHDI0,U,3),8,2),! Q
- Q
- AMD D:$D(^PRC(442,D0,6,PRCHI,3)) Q:PRCHDQ
- .K ^TMP($J,"W") D START^PRCHDP5(D0,PRCHI)
- .W ! F J=0:0 S J=$O(^TMP($J,"W",1,J)) Q:'J W !?8,^(J,0) D ASK Q:PRCHDQ
- .Q
- D:$D(^PRC(442,D0,6,PRCHI,2))
- .K ^UTILITY($J,"W") S DIWL=1,DIWR=60 F PRCHJ=0:0 S PRCHJ=$O(^PRC(442,D0,6,PRCHI,2,PRCHJ)) Q:'PRCHJ S X=^(PRCHJ,0) D DIWP^PRCUTL($G(DA))
- .K ^TMP($J,"W") S %X="^UTILITY($J,""W"",",%Y="^TMP($J,""W""," D %XY^%RCR
- .W ! F J=0:0 S J=$O(^TMP($J,"W",1,J)) Q:'J W !?8,^(J,0) D ASK Q:PRCHDQ
- .Q
- Q
- DT I Y W Y\100#100,"/",Y#100\1,"/",Y\10000+1700
- Q
- ADJCHK ;Check for any Adjustment on PO. If any show the adjuster. PRC*5.1*38
- Q:'$D(^PRC(442,PRCHPO,6,0))
- N CHKADJ,ISADJ,ADJDT,ADJDATA,ADJNUM
- S CHKADJ="",ISADJ=0,ADJDT=""
- S CHKADJ=$P($G(^PRC(442,PRCHPO,11,Y,0)),U,21)
- I CHKADJ="" Q
- S ADJDATA=$G(^PRC(442,PRCHPO,6,CHKADJ,0))
- N Y
- S Y=$P($G(ADJDATA),"^",2)
- Q:'Y
- D DD^%DT
- W ?30,"(Adjustment date: ",Y,")"
- Q
- Q ;W @IOF ;REMOVE IF PROBLEM WITH KERNEL V6.5
- K I,J,K,N,DIC,DIWF,DIWL,DIWR,IOP,PRCHDI,PRCHD0,PRCHD1,PRCHFTYP,PRCHDSIT,PRCHDHSP,PRCHDSHP,PRCHDST,PRCHDS,PRCHDV,PRCHDQ,PRCHDI0,PRCHDI2,PRCHDIW,PRCHDCNT,PRCHI,PRCHJ,PRCHK,S,V,^TMP($J,"W"),^UTILITY($J,"W"),KK,JJ Q
- PIPECK ;check for invalid pipe '|IN ' command in item description ;PRC*5.1*221
- S PURPIPE=0,PRCH=0
- F PRCHI=1:1 S PRCH=$O(^PRC(442,D0,2,PRCH)),PRCHDIW=0 Q:'PRCH D Q:PURPIPE
- . F PRCHJ=1:1 S PRCHDIW=$O(^PRC(442,D0,2,PRCH,1,PRCHDIW)) Q:PRCHDIW'>0 S X=$S($D(^(PRCHDIW,0)):^(0),1:"") D Q:PURPIPE
- . . I X["| IN " S PURPIPE=1
- . . Q
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHDP2 6929 printed Mar 13, 2025@21:11:30 Page 2
- PRCHDP2 ;ID/RSD/RHD-DISPLAY P.O. ; [7/22/98 11:11am]
- V ;;5.1;IFCAP;**38,131,221**;Oct 20, 2000;Build 14
- +1 ;Per VA Directive 6402, this routine should not be modified.
- +2 ;
- +3 ;PRC*5.1*221 Modify an item description display to skip '|' logic
- +4 ; if description contains a undefined display command
- +5 ; like '| IN '.
- +6 ;
- +7 ;PRC*5.1*221
- NEW PRCHAMNT,PRCHAMCT
- SET PRCHAMNT=0
- IF $DATA(^PRC(442,D0,6,0))
- SET PRCHAMCT=$PIECE(^PRC(442,D0,6,0),U,3)
- SET PRCHAMNT=1
- +8 WRITE !?8,"ENTER '^' TO HALT: "
- SET PRCHDQ=0
- READ X:DTIME
- if X["^"
- SET PRCHDQ=1
- if PRCHDQ
- GOTO ASK2
- DO HDR
- +9 SET (N,PRCHDI)=0
- FOR I=0:0
- SET PRCHDI=$ORDER(^PRC(442,D0,2,PRCHDI))
- if PRCHDI'>0
- QUIT
- SET PRCHDI0=^(PRCHDI,0)
- SET PRCHDI2=$SELECT($DATA(^(2)):^(2),1:"")
- SET N=+PRCHDI0
- DO ITEM
- if PRCHDQ
- GOTO ASK2
- +10 SET PRCHDI=0
- FOR I=0:0
- SET PRCHDI=$ORDER(^PRC(442,D0,3,PRCHDI))
- if PRCHDI'>0
- QUIT
- SET PRCHDI0=^(PRCHDI,0)
- SET N=N+1
- WRITE !?2,$JUSTIFY(N,3),?7,"LESS ",$PIECE(PRCHDI0,U,2),$SELECT($EXTRACT($PIECE(PRCHDI0,U,2),1)="$":"",1:" %")," FOR "
- DO DIS
- +11 IF $PIECE(PRCHD0,U,13)>0
- WRITE !?2,$JUSTIFY(N+1,3),?7,"EST. SHIPPING AND/OR HANDLING",?58,$JUSTIFY($PIECE(PRCHD0,U,13),7,2)
- +12 if '$DATA(^PRC(442,D0,15,0))
- GOTO COM
- KILL ^(9999999),^UTILITY($JOB,"W")
- +13 FOR PRCHK=0:0
- SET PRCHK=$ORDER(^PRC(442,D0,15,PRCHK))
- if 'PRCHK
- QUIT
- SET PRCHI=^(PRCHK,0)
- IF $DATA(^PRC(442.7,+PRCHI,0))
- IF $ORDER(^(1,0))
- SET DIWL=1
- SET DIWR=60
- FOR PRCHJ=0:0
- SET PRCHJ=$ORDER(^PRC(442.7,+PRCHI,1,PRCHJ))
- if 'PRCHJ
- QUIT
- SET X=^(PRCHJ,0)
- DO DIWP^PRCUTL($GET(DA))
- +14 ;
- +15 KILL ^TMP($JOB,"W")
- SET %X="^UTILITY($J,""W"","
- SET %Y="^TMP($J,""W"","
- DO %XY^%RCR
- +16 WRITE !
- FOR J=0:0
- SET J=$ORDER(^TMP($JOB,"W",1,J))
- if 'J
- QUIT
- WRITE !?8,^(J,0)
- DO ASK
- if PRCHDQ
- GOTO ASK2
- COM if '$DATA(^PRC(442,D0,4,0))
- GOTO PT
- KILL ^UTILITY($JOB,"W")
- SET DIWL=1
- SET DIWR=60
- SET PRCHJ=0
- FOR
- SET PRCHJ=$ORDER(^PRC(442,D0,4,PRCHJ))
- if PRCHJ=""
- QUIT
- SET X=^(PRCHJ,0)
- DO DIWP^PRCUTL($GET(DA))
- +1 KILL ^TMP($JOB,"W")
- SET %X="^UTILITY($J,""W"","
- SET %Y="^TMP($J,""W"","
- DO %XY^%RCR
- +2 WRITE !
- SET J=0
- FOR
- SET J=$ORDER(^TMP($JOB,"W",1,J))
- if J=""
- QUIT
- WRITE !?8,^(J,0)
- DO ASK
- if PRCHDQ
- GOTO ASK2
- PT IF $ORDER(^PRC(442,D0,13,0))
- WRITE !!?8,"V.A. TRANSACTION NUMBERS: "
- FOR PRCHI=0:0
- SET PRCHI=$ORDER(^PRC(442,D0,13,PRCHI))
- if 'PRCHI
- QUIT
- IF $DATA(^PRCS(410,PRCHI,0))
- WRITE !?14,$PIECE(^(0),U,1)
- +1 DO AMENDS^PRCHDP6
- +2 IF $DATA(^PRC(442,D0,6,0))
- FOR PRCHI=0:0
- SET PRCHI=$ORDER(^PRC(442,D0,6,PRCHI))
- if 'PRCHI
- QUIT
- IF $DATA(^(PRCHI,0))
- WRITE !!?3,"AMENDMENT NUMBER: ",PRCHI,?40,"EFFECTIVE DATE: "
- SET Y=$PIECE(^(0),U,2)
- DO DT
- DO AMD
- if PRCHDQ
- QUIT
- +3 KILL ^TMP($JOB,"PRCHDP6")
- ASK2 if 'PRCHDQ
- DO EN^PRCHDP4
- if '$ORDER(^PRC(442,D0,11,0))
- GOTO ASK1
- WRITE !
- SET %A=" Review a Receiving Report "
- SET %B=""
- SET %=2
- DO ^PRCFYN
- if %'=1
- GOTO Q
- PT1 KILL DIC
- SET (PRCHPO,DA(1))=D0
- SET DIC="^PRC(442,DA(1),11,"
- SET DIC(0)="NEAZ"
- +1 ;--added for PRC*5.1*38
- +2 SET DIC("W")="D ADJCHK^PRCHDP2"
- +3 DO ^DIC
- if Y<0
- GOTO Q
- SET PRCHDPT=+Y
- SET PRCHDRD=$PIECE(Y(0),U,1)
- SET PRCHDTP=1
- DO ^PRCHDP3
- GOTO PT1
- ASK IF $Y+5>IOSL
- WRITE !?8,"ENTER '^' TO HALT: "
- READ X:DTIME
- if X["^"
- SET PRCHDQ=1
- if 'PRCHDQ
- DO HDR
- QUIT
- +1 QUIT
- ASK1 ;PRC*5.1*221
- IF $GET(PRCHAMNT)=2
- Begin DoDot:1
- +1 WRITE !!,"** An amendment updated the order during your display that affected **"
- +2 WRITE !,"** the order's first page total and any items that were amended **"
- +3 WRITE !,"** for price/quantity. If the accuracy of the displayed order is **"
- +4 WRITE !,"** critical, you should re-display the order again with the updated **"
- +5 WRITE !,"** order total and items. **"
- +6 WRITE !,""
- +7 QUIT
- End DoDot:1
- +8 WRITE !,$CHAR(7)
- if PRCHDQ
- GOTO Q
- WRITE "END OF DISPLAY--PRESS RETURN OR ENTER '^' TO HALT: "
- READ X:DTIME
- GOTO Q
- HDR if $Y>0
- WRITE @IOF,!!?55,"UNIT",?70,"TOTAL",!,"ITEM",?15,"DESCRIPTION",?42,"QTY",?46,"UNIT",?55,"COST",?70,"COST",!
- FOR I=1:1:80
- WRITE "-"
- +1 QUIT
- ITEM SET DIWL=1
- SET DIWR=33
- SET DIWF=""
- SET PRCHDIW=0
- KILL ^UTILITY($JOB,"W")
- +1 ;PRC*5.1*221
- NEW PURCTYPE,PURPIPE,PRCHI,PRCHJ
- if $PIECE($GET(^PRC(442,D0,23)),"^",11)="S"
- SET PURCTYPE=1
- +2 ;PRC*5.1*221
- DO PIPECK
- SET PRCHDIW=0
- +3 ;PRC*5.1*221
- FOR PRCHJ=1:1
- SET PRCHDIW=$ORDER(^PRC(442,D0,2,PRCHDI,1,PRCHDIW))
- if PRCHDIW'>0
- QUIT
- SET X=$SELECT($DATA(^(PRCHDIW,0)):^(0),1:"")
- if PURPIPE
- SET DIWF=$GET(DIWF)_"|"
- DO DIWP^PRCUTL($GET(DA))
- +4 KILL ^TMP($JOB,"W")
- SET %X="^UTILITY($J,""W"","
- SET %Y="^TMP($J,""W"","
- DO %XY^%RCR
- +5 SET PRCHDCNT=$SELECT($DATA(^TMP($JOB,"W",1)):^(1),1:"")
- WRITE !
- IF $GET(PURCTYPE)=""
- WRITE ?2,$JUSTIFY(+$PIECE(PRCHDI0,U,1),3)
- +6 WRITE ?7,$SELECT($DATA(^(1,1,0)):^(0),1:"")
- +7 IF $GET(PURCTYPE)=""
- WRITE ?40,$JUSTIFY($PIECE(PRCHDI0,U,2),5),?47,$SELECT($DATA(^PRCD(420.5,+$PIECE(PRCHDI0,U,3),0)):$PIECE(^(0),U,1),1:"")
- +8 SET X=$PIECE($PIECE(PRCHDI0,U,9),".",2)
- IF $GET(PURCTYPE)=""
- WRITE ?52,$SELECT($LENGTH(X)>3:$JUSTIFY($PIECE(PRCHDI0,U,9),5,4),$LENGTH(X)>2:$JUSTIFY($PIECE(PRCHDI0,U,9),6,3),$PIECE(PRCHDI0,U,9)="N/C":" N/C",1:$JUSTIFY($PIECE(PRCHDI0,U,9),7,2))
- +9 WRITE ?67,$JUSTIFY($PIECE(PRCHDI2,U,1),7,2)
- +10 IF PRCHDCNT>1
- SET K=1
- FOR
- SET K=$ORDER(^TMP($JOB,"W",1,K))
- if K=""!(K'>0)
- QUIT
- if $Y+5>IOSL
- DO ASK
- if PRCHDQ
- QUIT
- WRITE !?8,^(K,0)
- +11 if PRCHDQ
- QUIT
- +12 if $PIECE(PRCHDI0,U,6)]""
- WRITE !?8,"STK#: ",$PIECE(PRCHDI0,U,6)
- if $PIECE(PRCHDI0,U,13)]""
- WRITE !,?8,"NSN: ",$PIECE(PRCHDI0,U,13)
- if $PIECE($GET(^PRC(442,D0,2,PRCHDI,4)),U,12)]""
- WRITE !,?8,"FOOD GROUP: ",$PIECE(^(4),U,12)
- +13 if $PIECE(PRCHDI2,U,8)]""
- WRITE !,?8,"QTY PREV RCVD: ",$JUSTIFY($PIECE(PRCHDI2,U,8),5)
- IF $DATA(^PRC(442,D0,2,PRCHDI,3,"AC"))
- WRITE !,?8,"PARTIAL NO.: "
- SET X=0
- FOR K=1:1
- SET X=$ORDER(^PRC(442,D0,2,PRCHDI,3,"AC",X))
- if X=""
- QUIT
- if K>1
- WRITE ","
- WRITE X
- +14 ;***** NEW CODE EDI STATUS DISPLAY *****
- NEW ZZ
- SET ZZ=0
- DO EDISTAT^PRCHUTL(D0,PRCHDI,.ZZ)
- +15 IF $GET(PURCTYPE)=""
- IF $PIECE(PRCHDI0,U,12)
- if 'ZZ
- WRITE !
- WRITE ?8,"Items per ",$SELECT($DATA(^PRCD(420.5,+$PIECE(PRCHDI0,U,3),0)):$PIECE(^(0),U,1),1:""),": ",$PIECE(PRCHDI0,U,12),!
- +16 ;***** NEW CODE TO CORRECT PAGING PROBLEM *****
- DO ASK
- +17 if $X>1
- WRITE !
- +18 WRITE ?8,"BOC: ",$PIECE($PIECE(PRCHDI0,U,4)," ",1)
- SET FMSLN=$ORDER(^PRC(442,D0,22,"B",+$PIECE(PRCHDI0,U,4),0))
- +19 IF FMSLN>0
- IF '$PIECE($GET(^PRC(442,D0,23)),U,8)
- SET FMSLN="00"_$PIECE($GET(^PRC(442,D0,22,FMSLN,0)),U,3)
- SET FMSLN=$EXTRACT(FMSLN,$LENGTH(FMSLN)-2,99)
- WRITE ?22,"FMS LINE: ",FMSLN
- +20 if $PIECE(PRCHDI2,U,2)]""
- WRITE ?40,"CONTRACT: ",$PIECE(PRCHDI2,U,2)
- +21 WRITE !
- +22 QUIT
- DIS WRITE $SELECT($PIECE(PRCHDI0,U,1)="Q":"QUANTITY DISCOUNT",1:"ITEMS: "_$PIECE(PRCHDI0,U,1)),?57,$JUSTIFY($PIECE(PRCHDI0,U,3),8,2),!
- QUIT
- +1 QUIT
- AMD if $DATA(^PRC(442,D0,6,PRCHI,3))
- Begin DoDot:1
- +1 KILL ^TMP($JOB,"W")
- DO START^PRCHDP5(D0,PRCHI)
- +2 WRITE !
- FOR J=0:0
- SET J=$ORDER(^TMP($JOB,"W",1,J))
- if 'J
- QUIT
- WRITE !?8,^(J,0)
- DO ASK
- if PRCHDQ
- QUIT
- +3 QUIT
- End DoDot:1
- if PRCHDQ
- QUIT
- +4 if $DATA(^PRC(442,D0,6,PRCHI,2))
- Begin DoDot:1
- +5 KILL ^UTILITY($JOB,"W")
- SET DIWL=1
- SET DIWR=60
- FOR PRCHJ=0:0
- SET PRCHJ=$ORDER(^PRC(442,D0,6,PRCHI,2,PRCHJ))
- if 'PRCHJ
- QUIT
- SET X=^(PRCHJ,0)
- DO DIWP^PRCUTL($GET(DA))
- +6 KILL ^TMP($JOB,"W")
- SET %X="^UTILITY($J,""W"","
- SET %Y="^TMP($J,""W"","
- DO %XY^%RCR
- +7 WRITE !
- FOR J=0:0
- SET J=$ORDER(^TMP($JOB,"W",1,J))
- if 'J
- QUIT
- WRITE !?8,^(J,0)
- DO ASK
- if PRCHDQ
- QUIT
- +8 QUIT
- End DoDot:1
- +9 QUIT
- DT IF Y
- WRITE Y\100#100,"/",Y#100\1,"/",Y\10000+1700
- +1 QUIT
- ADJCHK ;Check for any Adjustment on PO. If any show the adjuster. PRC*5.1*38
- +1 if '$DATA(^PRC(442,PRCHPO,6,0))
- QUIT
- +2 NEW CHKADJ,ISADJ,ADJDT,ADJDATA,ADJNUM
- +3 SET CHKADJ=""
- SET ISADJ=0
- SET ADJDT=""
- +4 SET CHKADJ=$PIECE($GET(^PRC(442,PRCHPO,11,Y,0)),U,21)
- +5 IF CHKADJ=""
- QUIT
- +6 SET ADJDATA=$GET(^PRC(442,PRCHPO,6,CHKADJ,0))
- +7 NEW Y
- +8 SET Y=$PIECE($GET(ADJDATA),"^",2)
- +9 if 'Y
- QUIT
- +10 DO DD^%DT
- +11 WRITE ?30,"(Adjustment date: ",Y,")"
- +12 QUIT
- Q ;W @IOF ;REMOVE IF PROBLEM WITH KERNEL V6.5
- +1 KILL I,J,K,N,DIC,DIWF,DIWL,DIWR,IOP,PRCHDI,PRCHD0,PRCHD1,PRCHFTYP,PRCHDSIT,PRCHDHSP,PRCHDSHP,PRCHDST,PRCHDS,PRCHDV,PRCHDQ,PRCHDI0,PRCHDI2,PRCHDIW,PRCHDCNT,PRCHI,PRCHJ,PRCHK,S,V,^TMP($JOB,"W"),^UTILITY($JOB,"W"),KK,JJ
- QUIT
- PIPECK ;check for invalid pipe '|IN ' command in item description ;PRC*5.1*221
- +1 SET PURPIPE=0
- SET PRCH=0
- +2 FOR PRCHI=1:1
- SET PRCH=$ORDER(^PRC(442,D0,2,PRCH))
- SET PRCHDIW=0
- if 'PRCH
- QUIT
- Begin DoDot:1
- +3 FOR PRCHJ=1:1
- SET PRCHDIW=$ORDER(^PRC(442,D0,2,PRCH,1,PRCHDIW))
- if PRCHDIW'>0
- QUIT
- SET X=$SELECT($DATA(^(PRCHDIW,0)):^(0),1:"")
- Begin DoDot:2
- +4 IF X["| IN "
- SET PURPIPE=1
- +5 QUIT
- End DoDot:2
- if PURPIPE
- QUIT
- End DoDot:1
- if PURPIPE
- QUIT
- +6 QUIT
