PRCSP2 ;WISC/SAW-CONTROL POINT ACTIVITY 2237 PRINTOUT (PRE-PRINTED 8X10 1/2) ;4/21/93 09:57
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
U IO S U="^",P(1)=0,PRCS("P")=1,F=0 D NOW^%DTC S Y=% D DD^%DT
S P(5)=$S($D(^PRCS(410,DA,1)):$P(^(1),U,3),1:""),P(5)=$S(P(5)="EM":"***EMERGENCY***",P(5)="SP":"*SPECIAL*",1:"STANDARD")
H I F,$D(^DIC(6910,1,0)),$P(^(0),"^",3)="O" S PRCS("P")=PRCS("P")+1 W ! U IO(0) W !,$C(7) R "PRESS RETURN WHEN READY TO PRINT NEXT PAGE: ",X:DTIME U IO
I F,$D(^DIC(6910,1,0)),$P(^(0),"^",3)="M" W !,@IOF S PRCS("P")=PRCS("P")+1
W ?36,"PRIORITY: ",P(5),! W:PRCS("P")=1 ?3,Y W ?36,$P(^PRCS(410,DA,0),U),?80,"PAGE ",PRCS("P")
W !!!!,?24 S P=$P(^PRCS(410,DA,0),U,5),P1=$S($D(^(3)):+$P(^(3),U),1:"") I P,P1 S P=$S($D(^PRC(420,P,1,P1,0)):$P(^(0),U,10),1:"") I P,$D(^DIC(49,P,0)) W $P(^(0),U) W:$P(^(0),U,8)]"" " ("_$P(^(0),U,8)_")"
W !!,?4,"X" I $D(^PRCS(410,DA,1)),$P(^(1),U)'="" S Y=$P(^(1),U) D DD^%DT W ?24,Y I $P(^PRCS(410,DA,1),U,4)'="" S Y=$P(^(1),U,4) D DD^%DT W ?45,Y
I F W !!! S L=10 Q
W !!! I $D(^PRCS(410,DA,1)),$P(^(1),U,5)'="" S P=$P(^(1),U,5) I $D(^PRCS(410.2,P,0)),$P(^(0),U)'="" S P=$P(^(0),U) W ?18,P,":" W $C(13),?18 S I="",$P(I,"_",$L(P))="" W I S I=""
;PRINT ITEMS
W ! S DIWL=18,DIWR=51,DIWF="",P(1)=0,L=11
F I=1:1 K ^UTILITY($J,"W") S P(1)=$O(^PRCS(410,DA,"IT",P(1))) G VENDOR:P(1)'>0 D ITEM1
ITEM1 Q:'$D(^PRCS(410,DA,"IT",P(1),0)) S Z=^(0)
S P(4)=$P(Z,U,6) I $L(P(4))>15 S:L>26 F=1 D:F H S F=0 W !,?2,$E(P(4),1,15),!,?2,$E(P(4),16,24) S L=L+2
I $L(P(4))<16 S:L>27 F=1 D:F H S F=0 W !,?2,P(4) S L=L+1
S PRCS("SUB")=+$P(Z,U,4),P(3)=$P(Z,U,3) S:P(3) P(3)=$P(^PRCD(420.5,P(3),0),U)
S P(0)=$S($P(Z,U,2)[".":$J($P(Z,U,2),5,2),1:$J($P(Z,U,2),5))_$J(P(3),3)_$S($P(Z,U,7)="N/C":$J("N/C",8),1:$J($P(Z,U,7),8,2))
G PRCARD:$P(Z,U,5)
S P(2)=0 F I=1:1 S P(2)=$O(^PRCS(410,DA,"IT",P(1),1,P(2))) Q:P(2)="" S X=^(P(2),0) S:I=1 X=$P(^PRCS(410,DA,"IT",P(1),0),U)_" "_X D DIWP^PRCUTL($G(DA))
ITEM2 I '$D(^UTILITY($J,"W",DIWL)) W ! S L=L+1 Q
S Z=^UTILITY($J,"W",DIWL)
I Z>1 F J=1:1:(Z-1) W ?18,^UTILITY($J,"W",DIWL,J,0),! S L=L+1 S:L>27 F=1 D:F H S F=0
I Z>1 W ?18,^UTILITY($J,"W",DIWL,Z,0),?53,P(0),! S L=L+1 S:L>27 F=1 D:F H S F=0
I Z<2 W ?18,^UTILITY($J,"W",DIWL,1,0),?53,P(0),! S L=L+1 S:L>27 F=1 D:F H S F=0
Q
PRCARD S P("PR")=$P(^PRCS(410,DA,"IT",P(1),0),U,5) Q:'$D(^PRC(441,P("PR"),1,0))
S Z="" S:$P(^PRC(441,P("PR"),0),U,5)'="" Z=Z_" (NSN: "_$P(^(0),U,5)_")" S Z1=$P(^PRCS(410,DA,3),U,4) I Z1,$D(^PRC(441,P("PR"),2,Z1,0)) S:$P(^(0),U,5)'="" Z=Z_" (NDC: "_$P(^(0),U,5)_")"
S P("PR1")=0 F I=1:1 S P("PR1")=$O(^PRC(441,P("PR"),1,P("PR1"))) Q:P("PR1")="" S X=^(P("PR1"),0) S:I=1 X=$P(^PRCS(410,DA,"IT",P(1),0),U)_" "_"ITEM ID NO. "_P("PR")_","_Z_", "_X D DIWP^PRCUTL($G(DA))
G ITEM2
VENDOR ;PRINT VENDOR AND REQ MESSAGES
I L>26 S F=1 D H S F=0
I $D(^PRCS(410,DA,4)),$P(^(4),U)'="" W !,?18,"TOTAL COST: ","$"_$J($P(^(4),U),0,2),!! S L=L+3
G RM:'$D(^PRCS(410,DA,2))
I $P(^PRCS(410,DA,2),U)="" G RM
I L>22 S F=1 D H S F=0
S P1=^PRCS(410,DA,2)
W ?11,"VENDOR: " W $P(P1,U) W:$P(P1,U,9)'="" ?57,"CONTACT: ",$P(P1,U,9)
W:$P(P1,U,2)'="" !,?18,$P(P1,U,2) W:$P(P1,U,10)'=""&($P(P1,U,2)="") ! W:$P(P1,U,10)'="" ?59,"PHONE: ",$P(P1,U,10) S:$P(P1,U,2)'=""!($P(P1,U,10)'="") L=L+1
I $P(P1,U,3)'="" W !,?18,$P(P1,U,3) S L=L+1
I $P(P1,U,4)'="" W !,?18,$P(P1,U,4) S L=L+1
I $P(P1,U,5)'="" W !,?18,$P(P1,U,5) S L=L+1
W !,?18 S L=L+1 W:$P(P1,U,6)'="" $P(P1,U,6) W:$P(P1,U,7)'="" ",",$P(^DIC(5,$P(P1,U,7),0),U,2) W:$P(P1,U,8)'="" " ",$P(P1,U,8)
RM W ! S L=L+1 D ^PRCSP21
W @IOF K %DT,F,P,P1,X,X1,Y,Z,Z1,DA,DIWL,DIWR,DIWF,I,J,K,PRCS,^UTILITY($J,"W") W @IOF D:$D(ZTSK) KILL^%ZTLOAD Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSP2 3721 printed Dec 13, 2024@02:18:12 Page 2
PRCSP2 ;WISC/SAW-CONTROL POINT ACTIVITY 2237 PRINTOUT (PRE-PRINTED 8X10 1/2) ;4/21/93 09:57
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 USE IO
SET U="^"
SET P(1)=0
SET PRCS("P")=1
SET F=0
DO NOW^%DTC
SET Y=%
DO DD^%DT
+3 SET P(5)=$SELECT($DATA(^PRCS(410,DA,1)):$PIECE(^(1),U,3),1:"")
SET P(5)=$SELECT(P(5)="EM":"***EMERGENCY***",P(5)="SP":"*SPECIAL*",1:"STANDARD")
H IF F
IF $DATA(^DIC(6910,1,0))
IF $PIECE(^(0),"^",3)="O"
SET PRCS("P")=PRCS("P")+1
WRITE !
USE IO(0)
WRITE !,$CHAR(7)
READ "PRESS RETURN WHEN READY TO PRINT NEXT PAGE: ",X:DTIME
USE IO
+1 IF F
IF $DATA(^DIC(6910,1,0))
IF $PIECE(^(0),"^",3)="M"
WRITE !,@IOF
SET PRCS("P")=PRCS("P")+1
+2 WRITE ?36,"PRIORITY: ",P(5),!
if PRCS("P")=1
WRITE ?3,Y
WRITE ?36,$PIECE(^PRCS(410,DA,0),U),?80,"PAGE ",PRCS("P")
+3 WRITE !!!!,?24
SET P=$PIECE(^PRCS(410,DA,0),U,5)
SET P1=$SELECT($DATA(^(3)):+$PIECE(^(3),U),1:"")
IF P
IF P1
SET P=$SELECT($DATA(^PRC(420,P,1,P1,0)):$PIECE(^(0),U,10),1:"")
IF P
IF $DATA(^DIC(49,P,0))
WRITE $PIECE(^(0),U)
if $PIECE(^(0),U,8)]""
WRITE " ("_$PIECE(^(0),U,8)_")"
+4 WRITE !!,?4,"X"
IF $DATA(^PRCS(410,DA,1))
IF $PIECE(^(1),U)'=""
SET Y=$PIECE(^(1),U)
DO DD^%DT
WRITE ?24,Y
IF $PIECE(^PRCS(410,DA,1),U,4)'=""
SET Y=$PIECE(^(1),U,4)
DO DD^%DT
WRITE ?45,Y
+5 IF F
WRITE !!!
SET L=10
QUIT
+6 WRITE !!!
IF $DATA(^PRCS(410,DA,1))
IF $PIECE(^(1),U,5)'=""
SET P=$PIECE(^(1),U,5)
IF $DATA(^PRCS(410.2,P,0))
IF $PIECE(^(0),U)'=""
SET P=$PIECE(^(0),U)
WRITE ?18,P,":"
WRITE $CHAR(13),?18
SET I=""
SET $PIECE(I,"_",$LENGTH(P))=""
WRITE I
SET I=""
+7 ;PRINT ITEMS
+8 WRITE !
SET DIWL=18
SET DIWR=51
SET DIWF=""
SET P(1)=0
SET L=11
+9 FOR I=1:1
KILL ^UTILITY($JOB,"W")
SET P(1)=$ORDER(^PRCS(410,DA,"IT",P(1)))
if P(1)'>0
GOTO VENDOR
DO ITEM1
ITEM1 if '$DATA(^PRCS(410,DA,"IT",P(1),0))
QUIT
SET Z=^(0)
+1 SET P(4)=$PIECE(Z,U,6)
IF $LENGTH(P(4))>15
if L>26
SET F=1
if F
DO H
SET F=0
WRITE !,?2,$EXTRACT(P(4),1,15),!,?2,$EXTRACT(P(4),16,24)
SET L=L+2
+2 IF $LENGTH(P(4))<16
if L>27
SET F=1
if F
DO H
SET F=0
WRITE !,?2,P(4)
SET L=L+1
+3 SET PRCS("SUB")=+$PIECE(Z,U,4)
SET P(3)=$PIECE(Z,U,3)
if P(3)
SET P(3)=$PIECE(^PRCD(420.5,P(3),0),U)
+4 SET P(0)=$SELECT($PIECE(Z,U,2)[".":$JUSTIFY($PIECE(Z,U,2),5,2),1:$JUSTIFY($PIECE(Z,U,2),5))_$JUSTIFY(P(3),3)_$SELECT($PIECE(Z,U,7)="N/C":$JUSTIFY("N/C",8),1:$JUSTIFY($PIECE(Z,U,7),8,2))
+5 if $PIECE(Z,U,5)
GOTO PRCARD
+6 SET P(2)=0
FOR I=1:1
SET P(2)=$ORDER(^PRCS(410,DA,"IT",P(1),1,P(2)))
if P(2)=""
QUIT
SET X=^(P(2),0)
if I=1
SET X=$PIECE(^PRCS(410,DA,"IT",P(1),0),U)_" "_X
DO DIWP^PRCUTL($GET(DA))
ITEM2 IF '$DATA(^UTILITY($JOB,"W",DIWL))
WRITE !
SET L=L+1
QUIT
+1 SET Z=^UTILITY($JOB,"W",DIWL)
+2 IF Z>1
FOR J=1:1:(Z-1)
WRITE ?18,^UTILITY($JOB,"W",DIWL,J,0),!
SET L=L+1
if L>27
SET F=1
if F
DO H
SET F=0
+3 IF Z>1
WRITE ?18,^UTILITY($JOB,"W",DIWL,Z,0),?53,P(0),!
SET L=L+1
if L>27
SET F=1
if F
DO H
SET F=0
+4 IF Z<2
WRITE ?18,^UTILITY($JOB,"W",DIWL,1,0),?53,P(0),!
SET L=L+1
if L>27
SET F=1
if F
DO H
SET F=0
+5 QUIT
PRCARD SET P("PR")=$PIECE(^PRCS(410,DA,"IT",P(1),0),U,5)
if '$DATA(^PRC(441,P("PR"),1,0))
QUIT
+1 SET Z=""
if $PIECE(^PRC(441,P("PR"),0),U,5)'=""
SET Z=Z_" (NSN: "_$PIECE(^(0),U,5)_")"
SET Z1=$PIECE(^PRCS(410,DA,3),U,4)
IF Z1
IF $DATA(^PRC(441,P("PR"),2,Z1,0))
if $PIECE(^(0),U,5)'=""
SET Z=Z_" (NDC: "_$PIECE(^(0),U,5)_")"
+2 SET P("PR1")=0
FOR I=1:1
SET P("PR1")=$ORDER(^PRC(441,P("PR"),1,P("PR1")))
if P("PR1")=""
QUIT
SET X=^(P("PR1"),0)
if I=1
SET X=$PIECE(^PRCS(410,DA,"IT",P(1),0),U)_" "_"ITEM ID NO. "_P("PR")_","_Z_", "_X
DO DIWP^PRCUTL($GET(DA))
+3 GOTO ITEM2
VENDOR ;PRINT VENDOR AND REQ MESSAGES
+1 IF L>26
SET F=1
DO H
SET F=0
+2 IF $DATA(^PRCS(410,DA,4))
IF $PIECE(^(4),U)'=""
WRITE !,?18,"TOTAL COST: ","$"_$JUSTIFY($PIECE(^(4),U),0,2),!!
SET L=L+3
+3 if '$DATA(^PRCS(410,DA,2))
GOTO RM
+4 IF $PIECE(^PRCS(410,DA,2),U)=""
GOTO RM
+5 IF L>22
SET F=1
DO H
SET F=0
+6 SET P1=^PRCS(410,DA,2)
+7 WRITE ?11,"VENDOR: "
WRITE $PIECE(P1,U)
if $PIECE(P1,U,9)'=""
WRITE ?57,"CONTACT: ",$PIECE(P1,U,9)
+8 if $PIECE(P1,U,2)'=""
WRITE !,?18,$PIECE(P1,U,2)
if $PIECE(P1,U,10)'=""&($PIECE(P1,U,2)="")
WRITE !
if $PIECE(P1,U,10)'=""
WRITE ?59,"PHONE: ",$PIECE(P1,U,10)
if $PIECE(P1,U,2)'=""!($PIECE(P1,U,10)'="")
SET L=L+1
+9 IF $PIECE(P1,U,3)'=""
WRITE !,?18,$PIECE(P1,U,3)
SET L=L+1
+10 IF $PIECE(P1,U,4)'=""
WRITE !,?18,$PIECE(P1,U,4)
SET L=L+1
+11 IF $PIECE(P1,U,5)'=""
WRITE !,?18,$PIECE(P1,U,5)
SET L=L+1
+12 WRITE !,?18
SET L=L+1
if $PIECE(P1,U,6)'=""
WRITE $PIECE(P1,U,6)
if $PIECE(P1,U,7)'=""
WRITE ",",$PIECE(^DIC(5,$PIECE(P1,U,7),0),U,2)
if $PIECE(P1,U,8)'=""
WRITE " ",$PIECE(P1,U,8)
RM WRITE !
SET L=L+1
DO ^PRCSP21
+1 WRITE @IOF
KILL %DT,F,P,P1,X,X1,Y,Z,Z1,DA,DIWL,DIWR,DIWF,I,J,K,PRCS,^UTILITY($JOB,"W")
WRITE @IOF
if $DATA(ZTSK)
DO KILL^%ZTLOAD
QUIT
