- PRCSP2N ;WISC/SAW-CONTROL POINT ACTIVITY 2237 PRINTOUT (PRE-PRINTED 8-1/2X11) ;4/21/93 10:02
- 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)="N" 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)="P" 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 ?49,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=54,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>29 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>30 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>30 F=1 D:F H S F=0
- I Z>1 W ?18,^UTILITY($J,"W",DIWL,Z,0),?56,P(0),! S L=L+1 S:L>30 F=1 D:F H S F=0
- I Z<2 W ?18,^UTILITY($J,"W",DIWL,1,0),?56,P(0),! S L=L+1 S:L>30 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>29 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>24 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)'="" ?56,"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)'="" ?57,"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 ^PRCSP21N
- 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[HPRCSP2N 3723 printed Feb 18, 2025@23:44:38 Page 2
- PRCSP2N ;WISC/SAW-CONTROL POINT ACTIVITY 2237 PRINTOUT (PRE-PRINTED 8-1/2X11) ;4/21/93 10:02
- 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)="N"
- 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)="P"
- 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 ?49,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=54
- 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>29
- 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>30
- 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>30
- SET F=1
- if F
- DO H
- SET F=0
- +3 IF Z>1
- WRITE ?18,^UTILITY($JOB,"W",DIWL,Z,0),?56,P(0),!
- SET L=L+1
- if L>30
- SET F=1
- if F
- DO H
- SET F=0
- +4 IF Z<2
- WRITE ?18,^UTILITY($JOB,"W",DIWL,1,0),?56,P(0),!
- SET L=L+1
- if L>30
- 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>29
- 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>24
- 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 ?56,"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 ?57,"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 ^PRCSP21N
- +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