PRCHDP4 ;WISC/RSD/RHD-DISPLAY P.O.(CONT.) ;12/1/93 09:49
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
EN ;ONLINE DISPLAY OF DELIVERY SCHEDULE
S PRCHONL=1,PRCHQUIT=0
;
EN2 ;ENTRY POINT USED TO EITHER PRINT OR DISPLAY DELIVERY SCHEDULE
Q:'$D(D0) S PRCHPONO=$P(^PRC(442,D0,0),U,1),PRCHQUIT="" G:PRCHPONO="" EXDELV K ^TMP($J,"MDEL")
F PRCHI=0:0 S PRCHI=$O(^PRC(442.8,"B",PRCHPONO,PRCHI)) Q:'PRCHI I $D(^PRC(442.8,PRCHI,0)) S Y(0)=^(0) D BLD
G:'$D(^TMP($J,"MDEL")) EXDELV S L=100
F I=0:0 S I=$O(^TMP($J,"MDEL",I)) Q:'I Q:PRCHQUIT S PRCHX=^(I) D PRT1 S PRCHZ="" F J=0:0 S J=$O(^TMP($J,"MDEL",I,J)) Q:'J Q:PRCHQUIT S PRCHY="" F K=0:0 S PRCHY=$O(^TMP($J,"MDEL",I,J,PRCHY)) Q:PRCHY="" S PRCHX=^(PRCHY) D PRT2
;
EXDELV W ! K ^TMP($J,"MDEL"),PRCHI,PRCHONL,PRCHPONO,PRCHQUIT,PRCHX,PRCHY,PRCHZ,I,J,K,X,Y,Z,L
Q
;
BLD S I=+$P(Y(0),U,2) I '$D(^TMP($J,"MDEL",I)) S X=$G(^PRC(442,D0,2,I,0)),J=$O(^PRC(442,D0,2,I,1,0)),K=$S($D(^(+J,0)):^(0),1:""),^TMP($J,"MDEL",I)=$P(X,U,5)_U_+$P(X,U,2)_U_$E(K,1,40)_U_+X
; <<< FOR NOIS PTB-0695-20438
;
; S I=+$P(Y(0),U,2) I '$D(^TMP($J,"MDEL",I)) S J=+$O(^PRC(442,D0,2,"B",I,0)),X=$G(^PRC(442,D0,2,J,0)),J=$O(^PRC(442,D0,2,J,1,0)),K=$S($D(^(+J,0)):^(0),1:""),^TMP($J,"MDEL",I)=+$P(X,U,5)_U_+$P(X,U,2)_U_$E(K,1,40)
;
S Y=$P(Y(0),U,3),Y=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3),Z=$P($G(^PRCS(410.8,+$P(Y(0),U,4),0)),U,1) S:Z="" Z=" "
S ^TMP($J,"MDEL",I,+$P(Y(0),U,3),Z)=Y_U_$P(Y(0),U,5)
Q
;
PRT1 D:L>(IOSL-3) PAUSE Q:PRCHQUIT W !,$J($P(PRCHX,U,4),4),?5,$J($P(PRCHX,U),4),?11,$P(PRCHX,U,3),?54,$J($P(PRCHX,U,2),6),! S L=L+2
; <<< FOR NOIS PTB-0695-20438
Q
;
PRT2 D:L>(IOSL-2) PAUSE Q:PRCHQUIT
I PRCHZ'=$P(PRCHX,U,1) S PRCHZ=$P(PRCHX,U,1) W ?31,PRCHZ
W ?41,PRCHY,?73,$J($P(PRCHX,U,2),6),!
S L=L+1
Q
;
H W:$Y>0 @IOF W !!,?10,"**** P.O. "_$P(PRCHPONO,"-",2)_" DELIVERY SCHEDULE ****"
W:L'=100 ?55,"(CONTINUED)" W !!
W "LI#",?5,"IMF# DESCRIPTION",?53,"QTY.ORD",!,?31,"DEL.DATE LOCATION",?72,"DELV.QTY",!
S L=5
Q
;
PAUSE I 'PRCHONL D H Q
W !?8,"ENTER '^' TO HALT: " S PRCHQUIT=0 R X:DTIME S:X["^" PRCHQUIT=1 Q:PRCHQUIT D H
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHDP4 2171 printed Nov 22, 2024@17:16:50 Page 2
PRCHDP4 ;WISC/RSD/RHD-DISPLAY P.O.(CONT.) ;12/1/93 09:49
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN ;ONLINE DISPLAY OF DELIVERY SCHEDULE
+1 SET PRCHONL=1
SET PRCHQUIT=0
+2 ;
EN2 ;ENTRY POINT USED TO EITHER PRINT OR DISPLAY DELIVERY SCHEDULE
+1 if '$DATA(D0)
QUIT
SET PRCHPONO=$PIECE(^PRC(442,D0,0),U,1)
SET PRCHQUIT=""
if PRCHPONO=""
GOTO EXDELV
KILL ^TMP($JOB,"MDEL")
+2 FOR PRCHI=0:0
SET PRCHI=$ORDER(^PRC(442.8,"B",PRCHPONO,PRCHI))
if 'PRCHI
QUIT
IF $DATA(^PRC(442.8,PRCHI,0))
SET Y(0)=^(0)
DO BLD
+3 if '$DATA(^TMP($JOB,"MDEL"))
GOTO EXDELV
SET L=100
+4 FOR I=0:0
SET I=$ORDER(^TMP($JOB,"MDEL",I))
if 'I
QUIT
if PRCHQUIT
QUIT
SET PRCHX=^(I)
DO PRT1
SET PRCHZ=""
FOR J=0:0
SET J=$ORDER(^TMP($JOB,"MDEL",I,J))
if 'J
QUIT
if PRCHQUIT
QUIT
SET PRCHY=""
FOR K=0:0
SET PRCHY=$ORDER(^TMP($JOB,"MDEL",I,J,PRCHY))
if PRCHY=""
QUIT
SET PRCHX=^(PRCHY)
DO PRT2
+5 ;
EXDELV WRITE !
KILL ^TMP($JOB,"MDEL"),PRCHI,PRCHONL,PRCHPONO,PRCHQUIT,PRCHX,PRCHY,PRCHZ,I,J,K,X,Y,Z,L
+1 QUIT
+2 ;
BLD SET I=+$PIECE(Y(0),U,2)
IF '$DATA(^TMP($JOB,"MDEL",I))
SET X=$GET(^PRC(442,D0,2,I,0))
SET J=$ORDER(^PRC(442,D0,2,I,1,0))
SET K=$SELECT($DATA(^(+J,0)):^(0),1:"")
SET ^TMP($JOB,"MDEL",I)=$PIECE(X,U,5)_U_+$PIECE(X,U,2)_U_$EXTRACT(K,1,40)_U_+X
+1 ; <<< FOR NOIS PTB-0695-20438
+2 ;
+3 ; S I=+$P(Y(0),U,2) I '$D(^TMP($J,"MDEL",I)) S J=+$O(^PRC(442,D0,2,"B",I,0)),X=$G(^PRC(442,D0,2,J,0)),J=$O(^PRC(442,D0,2,J,1,0)),K=$S($D(^(+J,0)):^(0),1:""),^TMP($J,"MDEL",I)=+$P(X,U,5)_U_+$P(X,U,2)_U_$E(K,1,40)
+4 ;
+5 SET Y=$PIECE(Y(0),U,3)
SET Y=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_$EXTRACT(Y,2,3)
SET Z=$PIECE($GET(^PRCS(410.8,+$PIECE(Y(0),U,4),0)),U,1)
if Z=""
SET Z=" "
+6 SET ^TMP($JOB,"MDEL",I,+$PIECE(Y(0),U,3),Z)=Y_U_$PIECE(Y(0),U,5)
+7 QUIT
+8 ;
PRT1 if L>(IOSL-3)
DO PAUSE
if PRCHQUIT
QUIT
WRITE !,$JUSTIFY($PIECE(PRCHX,U,4),4),?5,$JUSTIFY($PIECE(PRCHX,U),4),?11,$PIECE(PRCHX,U,3),?54,$JUSTIFY($PIECE(PRCHX,U,2),6),!
SET L=L+2
+1 ; <<< FOR NOIS PTB-0695-20438
+2 QUIT
+3 ;
PRT2 if L>(IOSL-2)
DO PAUSE
if PRCHQUIT
QUIT
+1 IF PRCHZ'=$PIECE(PRCHX,U,1)
SET PRCHZ=$PIECE(PRCHX,U,1)
WRITE ?31,PRCHZ
+2 WRITE ?41,PRCHY,?73,$JUSTIFY($PIECE(PRCHX,U,2),6),!
+3 SET L=L+1
+4 QUIT
+5 ;
H if $Y>0
WRITE @IOF
WRITE !!,?10,"**** P.O. "_$PIECE(PRCHPONO,"-",2)_" DELIVERY SCHEDULE ****"
+1 if L'=100
WRITE ?55,"(CONTINUED)"
WRITE !!
+2 WRITE "LI#",?5,"IMF# DESCRIPTION",?53,"QTY.ORD",!,?31,"DEL.DATE LOCATION",?72,"DELV.QTY",!
+3 SET L=5
+4 QUIT
+5 ;
PAUSE IF 'PRCHONL
DO H
QUIT
+1 WRITE !?8,"ENTER '^' TO HALT: "
SET PRCHQUIT=0
READ X:DTIME
if X["^"
SET PRCHQUIT=1
if PRCHQUIT
QUIT
DO H
+2 QUIT
