- 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 Feb 18, 2025@23:44:37 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