PRCSP21N ;WISC/SAW-CONTROL POINT ACTIVITY 2237 PRINTOUT (PRE-PRINTED 8-1/2X11) CON'T ;1/19/93 10:47 AM ;
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
I '$D(^PRCS(410,DA,"RM",0)) G DEL
W ! S L=L+1,P(1)=0,DIWL=2,DIWR=54,DIWF="" K ^UTILITY($J,"W") S X="SPECIAL REMARKS" F J=1:1 S P(1)=$O(^PRCS(410,DA,"RM",P(1))) Q:P(1)="" S X=^(P(1),0) D DIWP^PRCUTL($G(DA))
S Z=^UTILITY($J,"W",DIWL) F K=1:1:Z S:L>29 F=1 D:F H^PRCSP2N S F=0 W !,?2,^UTILITY($J,"W",DIWL,K,0) S L=L+1
DEL I L>29 S F=1 D H^PRCSP2N S F=0
I $D(^PRCS(410,DA,9)) S X=$P(^(9),U) I X'="" W !,?7,"DELIVER TO: ",X S L=L+1 W $C(13),?18 S I="",$P(I,"_",$L(X))="" W I S I=""
F I=1:1:(33-L) W !
S L=33 I '$D(^PRCS(410,DA,8,0)) G SIG
S DIWL=2,DIWR=70,DIWF="" K ^UTILITY($J,"W") S X1=0 F I=1:1 S X1=$O(^PRCS(410,DA,8,X1)) Q:X1="" S X=^(X1,0) D DIWP^PRCUTL($G(DA))
S Z=^UTILITY($J,"W",DIWL) S:Z>5 Z=5 F K=1:1:Z W ?2,^UTILITY($J,"W",DIWL,K,0),! S L=L+1
SIG ;PRINT SIGNATURE BLOCKS
F I=1:1:(38-L) W !
S L=38 I '$D(^PRCS(410,DA,7)) G APP
I $P(^PRCS(410,DA,7),U)'="" S P=$P(^(7),U),X=$P(^DD(410,40,0),"^",2) I X[200 S P=$S($D(^VA(200,+P,0)):$P(^(0),U),1:"") W ?2,P
I $P(^PRCS(410,DA,7),U,6)'="" W ?48,"/ES/",$$DECODE^PRCSC1(DA)
I $P(^PRCS(410,DA,7),U,6)="",$P(^(7),U,3)'="" S P=$P(^(7),U,3),X=$P(^DD(410,42,0),"^",2) I X[200 S P=$S($D(^VA(200,+P,0)):$P(^(0),U),1:"") W ?48,P
W !,?2 W:$P(^PRCS(410,DA,7),U,2)'="" $P(^(7),U,2) W:$P(^(7),U,4)'="" ?48,$P(^(7),U,4) I $P(^(7),U,5)'="" S Y=$P(^(7),U,5) D DD^%DT W ?81,Y
APP F I=1:1:(58-L) W !
S P=$P(^PRCS(410,DA,0),U,5) I $D(^(3)) S:$P(^(3),U,2)'="" P=P_"-"_$P(^(3),U,2) S:$P(^(3),U)'="" P=P_"-"_$E($P(^(3),U),1,3) S:$P(^(3),U,3)'="" P=P_"-"_$E($P(^(3),U,3),1,4) S:$D(PRCS("SUB")) P=P_"-"_PRCS("SUB")
I $D(^PRCS(410,DA,4)),$P(^(4),U,5)'="" S P=P_"-"_$P(^(4),U,5)
W ?2,P,! Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSP21N 1856 printed Dec 13, 2024@02:18:14 Page 2
PRCSP21N ;WISC/SAW-CONTROL POINT ACTIVITY 2237 PRINTOUT (PRE-PRINTED 8-1/2X11) CON'T ;1/19/93 10:47 AM ;
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 IF '$DATA(^PRCS(410,DA,"RM",0))
GOTO DEL
+3 WRITE !
SET L=L+1
SET P(1)=0
SET DIWL=2
SET DIWR=54
SET DIWF=""
KILL ^UTILITY($JOB,"W")
SET X="SPECIAL REMARKS"
FOR J=1:1
SET P(1)=$ORDER(^PRCS(410,DA,"RM",P(1)))
if P(1)=""
QUIT
SET X=^(P(1),0)
DO DIWP^PRCUTL($GET(DA))
+4 SET Z=^UTILITY($JOB,"W",DIWL)
FOR K=1:1:Z
if L>29
SET F=1
if F
DO H^PRCSP2N
SET F=0
WRITE !,?2,^UTILITY($JOB,"W",DIWL,K,0)
SET L=L+1
DEL IF L>29
SET F=1
DO H^PRCSP2N
SET F=0
+1 IF $DATA(^PRCS(410,DA,9))
SET X=$PIECE(^(9),U)
IF X'=""
WRITE !,?7,"DELIVER TO: ",X
SET L=L+1
WRITE $CHAR(13),?18
SET I=""
SET $PIECE(I,"_",$LENGTH(X))=""
WRITE I
SET I=""
+2 FOR I=1:1:(33-L)
WRITE !
+3 SET L=33
IF '$DATA(^PRCS(410,DA,8,0))
GOTO SIG
+4 SET DIWL=2
SET DIWR=70
SET DIWF=""
KILL ^UTILITY($JOB,"W")
SET X1=0
FOR I=1:1
SET X1=$ORDER(^PRCS(410,DA,8,X1))
if X1=""
QUIT
SET X=^(X1,0)
DO DIWP^PRCUTL($GET(DA))
+5 SET Z=^UTILITY($JOB,"W",DIWL)
if Z>5
SET Z=5
FOR K=1:1:Z
WRITE ?2,^UTILITY($JOB,"W",DIWL,K,0),!
SET L=L+1
SIG ;PRINT SIGNATURE BLOCKS
+1 FOR I=1:1:(38-L)
WRITE !
+2 SET L=38
IF '$DATA(^PRCS(410,DA,7))
GOTO APP
+3 IF $PIECE(^PRCS(410,DA,7),U)'=""
SET P=$PIECE(^(7),U)
SET X=$PIECE(^DD(410,40,0),"^",2)
IF X[200
SET P=$SELECT($DATA(^VA(200,+P,0)):$PIECE(^(0),U),1:"")
WRITE ?2,P
+4 IF $PIECE(^PRCS(410,DA,7),U,6)'=""
WRITE ?48,"/ES/",$$DECODE^PRCSC1(DA)
+5 IF $PIECE(^PRCS(410,DA,7),U,6)=""
IF $PIECE(^(7),U,3)'=""
SET P=$PIECE(^(7),U,3)
SET X=$PIECE(^DD(410,42,0),"^",2)
IF X[200
SET P=$SELECT($DATA(^VA(200,+P,0)):$PIECE(^(0),U),1:"")
WRITE ?48,P
+6 WRITE !,?2
if $PIECE(^PRCS(410,DA,7),U,2)'=""
WRITE $PIECE(^(7),U,2)
if $PIECE(^(7),U,4)'=""
WRITE ?48,$PIECE(^(7),U,4)
IF $PIECE(^(7),U,5)'=""
SET Y=$PIECE(^(7),U,5)
DO DD^%DT
WRITE ?81,Y
APP FOR I=1:1:(58-L)
WRITE !
+1 SET P=$PIECE(^PRCS(410,DA,0),U,5)
IF $DATA(^(3))
if $PIECE(^(3),U,2)'=""
SET P=P_"-"_$PIECE(^(3),U,2)
if $PIECE(^(3),U)'=""
SET P=P_"-"_$EXTRACT($PIECE(^(3),U),1,3)
if $PIECE(^(3),U,3)'=""
SET P=P_"-"_$EXTRACT($PIECE(^(3),U,3),1,4)
if $DATA(PRCS("SUB"))
SET P=P_"-"_PRCS("SUB")
+2 IF $DATA(^PRCS(410,DA,4))
IF $PIECE(^(4),U,5)'=""
SET P=P_"-"_$PIECE(^(4),U,5)
+3 WRITE ?2,P,!
QUIT
