- PRCSP124 ;SF-ISC/LJP-2237 CON'T - DISTRIBUTION LIST ;4/21/93 08:55
- V ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- LST K ^UTILITY($J,"W"),P(0) S DIWL=3,DIWR=80,DIWF="N",P(1)=0,PRCSPG=""
- F I=1:1 S P(1)=$O(^PRCS(410,DA,"IT",P(1))) Q:P(1)'>0 I $D(^PRCS(410,DA,"IT",P(1),0)),$D(^PRCS(410,DA,"IT",P(1),2,0)),$P(^(0),"^",4)>0 S:'$D(P(0)) (P(0),PRCSPG)=1 D HDR:P(0)=1 D HDR1,LST1 S P(0)=P(0)+1
- D WRT:$D(^UTILITY($J,"W",DIWL))
- Q
- LST1 Q:'$D(^PRCS(410,DA,"IT",+P(1),0)) S Z=^(0),(PRCSIN,PRCSQTY,P("PR"),P("PR1"))=""
- S PRCSIN=$P(Z,U),PRCSQTY=$P(Z,U,2),PRCSDES="" S:$D(^PRCS(410,DA,"IT",P(1),1,1,0)) PRCSDES=$E(^(0),1,10)
- S P("PR1")="",P("PR")=$P(Z,U,5) I $D(^PRC(441,+P("PR"),1,0)) S P("PR1")=0 S P("PR1")=$O(^PRC(441,P("PR"),1,P("PR1"),0)) I P("PR1")'="" S PRCSDES=$E(P("PR1"),1,10)
- S:PRCSDES="" PRCSDES="**NONE**" S X=PRCSIN_"|TAB(6)|"_$J(P("PR"),4)_"|TAB(12)|"_PRCSDES_"|TAB(26)|"_$J(PRCSQTY,4) D DIWP^PRCUTL($G(DA))
- D DS,DS1 Q
- DS K PRCSDS S PRCSDS=0,PRCSDSD="",PRCSLNT=""
- F J=1:1 S PRCSDS=$O(^PRCS(410,DA,"IT",P(1),2,PRCSDS)) Q:PRCSDS'>0 I $D(^(PRCSDS,0)),$P(^(0),U,2),$D(^PRCS(410.6,+$P(^(0),U,2),0)) S PRCSDSD=$P(^(0),U,2) I PRCSDSD'="" S PRCSDS(PRCSDSD,J)=^(0)
- Q
- DS1 S PRCSDSD=0
- F K=1:1 S PRCSDSD=$O(PRCSDS(PRCSDSD)) Q:PRCSDSD'>0 S PRCSLN=0 F M=1:1 S PRCSLN=$O(PRCSDS(PRCSDSD,PRCSLN)) Q:PRCSLN'>0 D DS2
- Q
- DS2 S PRCSLNT=PRCSDS(PRCSDSD,PRCSLN),X="|TAB(32)|"_$E($P(PRCSLNT,U,2),4,5)_"-"_$E($P(PRCSLNT,U,2),6,7)_"-"_$E($P(PRCSLNT,U,2),2,3)
- S XX=X_"|TAB(42)|"_$J($P(PRCSLNT,U,4),4)_"|TAB(49)|"_$S($D(^PRCS(410.4,+$P(PRCSLNT,U,5),0)):$E($P(^(0),U),1,10),1:"**NONE**")_"|TAB(60)|"_$S($D(^PRCS(410.8,+$P(PRCSLNT,U,3),0)):$E($P(^(0),U),1,10),1:"**NONE**")
- S X=XX D DIWP^PRCUTL($G(DA)) Q
- HDR W:$Y>0 @IOF W ?31,$P(^PRCS(410,DA,0),U),!,L,!?16,"REQUEST, TURN-IN, AND RECEIPT FOR PROPERTY OR SERVICES",!,L,!!,"MULTIPLE DELIVERY DISTRIBUTION LIST",?50,"PAGE: "_$S($D(PRCSPG):PRCSPG,1:""),! Q
- HDR1 S X="" D DIWP^PRCUTL($G(DA)) S X="ITEM PR# DESCRIPTION QTY DATE QTY SCP LOCATION" D DIWP^PRCUTL($G(DA)) Q
- HDR2 W !,"MULTIPLE DELIVERY DISTRIBUTION LIST",?50,"PAGE: ",$S($D(PRCSPG):PRCSPG,1:"") Q ;,!,"ITEM# PR# DESCRIPTION QTY DATE QTY SCP LOCATION",! Q
- WRT I '$D(^UTILITY($J,"W",DIWL)) S ^(DIWL)=1,^(DIWL,1,0)="***NO DESCRIPTION***"
- S PRCSILP=0 F N=1:1 S PRCSILP=$O(^UTILITY($J,"W",DIWL,PRCSILP)) Q:PRCSILP'>0 W ?3,^UTILITY($J,"W",DIWL,PRCSILP,0),! S:IOSL-$Y<2 PRCSPG=PRCSPG+1 D:IOSL-$Y<2 HDR Q:Z1=U
- Q
- S Z=^UTILITY($J,"W",DIWL)
- I Z>1 F J=1:1:(Z-1) W ?3,^UTILITY($J,"W",DIWL) Q:DIWL'>0 D:IOSL-$Y<2 HDR Q:Z1=U W !
- I Z>1 W ?3,^UTILITY($J,"W",DIWL,Z,0) D:IOSL-$Y<2 HDR Q:Z1=U W !
- I Z<2 W ?3,^UTILITY($J,"W",DIWL,1,0) D:IOSL-$Y<2 HDR Q:Z1=U W !
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSP124 2772 printed Apr 23, 2025@18:32:29 Page 2
- PRCSP124 ;SF-ISC/LJP-2237 CON'T - DISTRIBUTION LIST ;4/21/93 08:55
- V ;;5.1;IFCAP;;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- LST KILL ^UTILITY($JOB,"W"),P(0)
- SET DIWL=3
- SET DIWR=80
- SET DIWF="N"
- SET P(1)=0
- SET PRCSPG=""
- +1 FOR I=1:1
- SET P(1)=$ORDER(^PRCS(410,DA,"IT",P(1)))
- if P(1)'>0
- QUIT
- IF $DATA(^PRCS(410,DA,"IT",P(1),0))
- IF $DATA(^PRCS(410,DA,"IT",P(1),2,0))
- IF $PIECE(^(0),"^",4)>0
- if '$DATA(P(0))
- SET (P(0),PRCSPG)=1
- if P(0)=1
- DO HDR
- DO HDR1
- DO LST1
- SET P(0)=P(0)+1
- +2 if $DATA(^UTILITY($JOB,"W",DIWL))
- DO WRT
- +3 QUIT
- LST1 if '$DATA(^PRCS(410,DA,"IT",+P(1),0))
- QUIT
- SET Z=^(0)
- SET (PRCSIN,PRCSQTY,P("PR"),P("PR1"))=""
- +1 SET PRCSIN=$PIECE(Z,U)
- SET PRCSQTY=$PIECE(Z,U,2)
- SET PRCSDES=""
- if $DATA(^PRCS(410,DA,"IT",P(1),1,1,0))
- SET PRCSDES=$EXTRACT(^(0),1,10)
- +2 SET P("PR1")=""
- SET P("PR")=$PIECE(Z,U,5)
- IF $DATA(^PRC(441,+P("PR"),1,0))
- SET P("PR1")=0
- SET P("PR1")=$ORDER(^PRC(441,P("PR"),1,P("PR1"),0))
- IF P("PR1")'=""
- SET PRCSDES=$EXTRACT(P("PR1"),1,10)
- +3 if PRCSDES=""
- SET PRCSDES="**NONE**"
- SET X=PRCSIN_"|TAB(6)|"_$JUSTIFY(P("PR"),4)_"|TAB(12)|"_PRCSDES_"|TAB(26)|"_$JUSTIFY(PRCSQTY,4)
- DO DIWP^PRCUTL($GET(DA))
- +4 DO DS
- DO DS1
- QUIT
- DS KILL PRCSDS
- SET PRCSDS=0
- SET PRCSDSD=""
- SET PRCSLNT=""
- +1 FOR J=1:1
- SET PRCSDS=$ORDER(^PRCS(410,DA,"IT",P(1),2,PRCSDS))
- if PRCSDS'>0
- QUIT
- IF $DATA(^(PRCSDS,0))
- IF $PIECE(^(0),U,2)
- IF $DATA(^PRCS(410.6,+$PIECE(^(0),U,2),0))
- SET PRCSDSD=$PIECE(^(0),U,2)
- IF PRCSDSD'=""
- SET PRCSDS(PRCSDSD,J)=^(0)
- +2 QUIT
- DS1 SET PRCSDSD=0
- +1 FOR K=1:1
- SET PRCSDSD=$ORDER(PRCSDS(PRCSDSD))
- if PRCSDSD'>0
- QUIT
- SET PRCSLN=0
- FOR M=1:1
- SET PRCSLN=$ORDER(PRCSDS(PRCSDSD,PRCSLN))
- if PRCSLN'>0
- QUIT
- DO DS2
- +2 QUIT
- DS2 SET PRCSLNT=PRCSDS(PRCSDSD,PRCSLN)
- SET X="|TAB(32)|"_$EXTRACT($PIECE(PRCSLNT,U,2),4,5)_"-"_$EXTRACT($PIECE(PRCSLNT,U,2),6,7)_"-"_$EXTRACT($PIECE(PRCSLNT,U,2),2,3)
- +1 SET XX=X_"|TAB(42)|"_$JUSTIFY($PIECE(PRCSLNT,U,4),4)_"|TAB(49)|"_$SELECT($DATA(^PRCS(410.4,+$PIECE(PRCSLNT,U,5),0)):$EXTRACT($PIECE(^(0),U),1,10),1:"**NONE**")_"|TAB(60)|"_$SELECT($DATA(^PRCS(410.8,+...
- ... $PIECE(PRCSLNT,U,3),0)):$EXTRACT($PIECE(^(0),U),1,10),1:"**NONE**")
- +2 SET X=XX
- DO DIWP^PRCUTL($GET(DA))
- QUIT
- HDR if $Y>0
- WRITE @IOF
- WRITE ?31,$PIECE(^PRCS(410,DA,0),U),!,L,!?16,"REQUEST, TURN-IN, AND RECEIPT FOR PROPERTY OR SERVICES",!,L,!!,"MULTIPLE DELIVERY DISTRIBUTION LIST",?50,"PAGE: "_$SELECT($DATA(PRCSPG):PRCSPG,1:""),!
- QUIT
- HDR1 SET X=""
- DO DIWP^PRCUTL($GET(DA))
- SET X="ITEM PR# DESCRIPTION QTY DATE QTY SCP LOCATION"
- DO DIWP^PRCUTL($GET(DA))
- QUIT
- HDR2 ;,!,"ITEM# PR# DESCRIPTION QTY DATE QTY SCP LOCATION",! Q
- WRITE !,"MULTIPLE DELIVERY DISTRIBUTION LIST",?50,"PAGE: ",$SELECT($DATA(PRCSPG):PRCSPG,1:"")
- QUIT
- WRT IF '$DATA(^UTILITY($JOB,"W",DIWL))
- SET ^(DIWL)=1
- SET ^(DIWL,1,0)="***NO DESCRIPTION***"
- +1 SET PRCSILP=0
- FOR N=1:1
- SET PRCSILP=$ORDER(^UTILITY($JOB,"W",DIWL,PRCSILP))
- if PRCSILP'>0
- QUIT
- WRITE ?3,^UTILITY($JOB,"W",DIWL,PRCSILP,0),!
- if IOSL-$Y<2
- SET PRCSPG=PRCSPG+1
- if IOSL-$Y<2
- DO HDR
- if Z1=U
- QUIT
- +2 QUIT
- +3 SET Z=^UTILITY($JOB,"W",DIWL)
- +4 IF Z>1
- FOR J=1:1:(Z-1)
- WRITE ?3,^UTILITY($JOB,"W",DIWL)
- if DIWL'>0
- QUIT
- if IOSL-$Y<2
- DO HDR
- if Z1=U
- QUIT
- WRITE !
- +5 IF Z>1
- WRITE ?3,^UTILITY($JOB,"W",DIWL,Z,0)
- if IOSL-$Y<2
- DO HDR
- if Z1=U
- QUIT
- WRITE !
- +6 IF Z<2
- WRITE ?3,^UTILITY($JOB,"W",DIWL,1,0)
- if IOSL-$Y<2
- DO HDR
- if Z1=U
- QUIT
- WRITE !
