- PRCSP122 ;WISC/SAW-CONTROL POINT ACTIVITY 2237 PRINTOUT CON'T ;4/21/93 08:53
- V ;;5.1;IFCAP;**95,107**;Oct 20, 2000;Build 13
- ;Per VHA Directive 2004-038, this routine should not be modified.
- I '$D(^PRCS(410,DA,"RM",0)) G DEL
- I $D(^PRCS(410,DA,"RM",0)) W ! S P(1)=0,DIWL=6,DIWR=96,DIWF="" K ^UTILITY($J,"W") S X="SPECIAL REMARKS:" D DIWP^PRCUTL($G(DA)) 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 D:$Y>62 NEWP^PRCSP121 W !,^UTILITY($J,"W",DIWL,K,0)
- DEL I $D(^PRCS(410,DA,9)),$P(^(9),U)'="" W !,"DELIVER TO: ",$P(^(9),U)
- W !,L,!,"FOB",?24,"|TERMS",?48,"|DELIVERY DATE",?63,"|QUOTE DATE",?77,"|BY(Initials)",!,?24,"|",?48,"|",?63,"|",?77,"|"
- W !,$E(L,1,24),"|",$E(L,1,23),"|",$E(L,1,14),"|",$E(L,1,13),"|",$E(L,1,12)
- I $Y>58 D NEWP^PRCSP121
- W !,"JUSTIFICATION OF NEED OR TURN-IN (If recurring need, indicate 30-day estimate. If turn-in,",!,"do not use this form if circumstances require use of VA Form 90-1217, Report of Survey)"
- I '$D(^PRCS(410,DA,8,0)) G SIG
- S (MYTEMP,BFLAG)=0
- F I=1:1 S MYTEMP=$O(^PRCS(410,DA,8,MYTEMP)) Q:MYTEMP="" S BFLAG=1
- I BFLAG=0 G SIG
- S DIWL=6,DIWR=96,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) F K=1:1:Z D:$Y>62 NEWP^PRCSP121 W !,^UTILITY($J,"W",DIWL,K,0)
- SIG ;PRINT SIGNATURE BLOCKS
- I $Y>58 D NEWP^PRCSP121
- W !,L
- W !,"Originator of Request: " S XNAME=$P($G(^PRCS(410,DA,14)),"^") I XNAME'="" W $P($G(^VA(200,XNAME,0)),"^")
- W !,"Signature of Initiator",?39,"|Signature of Approving Official |Date"
- I '$D(^PRCS(410,DA,7)) W !,?39,"|",?72,"|",!,?39,"|",?72,"|" G SIG1
- K P1 W !,?39,"|" S:$P(^PRCS(410,DA,7),U,3)'="" (P,P1)=$P(^(7),U,3) I $D(P1) W "/ES/",$$DECODE^PRCSC1(DA)
- N PRSHLE S PRSHLE=^DD(410,40,0) W ?72,"|",! I $P(^PRCS(410,DA,7),U)'="" S (P,P2)=$P(^(7),U) I $P(PRSHLE,"^",2)[200,$D(^VA(200,P,20)),$P(^(20),U,2)]"" W $E($P(^(20),U,2),1,31)
- I $D(P2),$P(^DD(410,40,0),"^",2)[200,$D(^VA(200,+P2,.13)),$L($P(^(.13),U,2))'>5 W " (",$P(^(.13),U,2),")"
- K P2 W ?39,"|" I $D(P1),$P(^DD(410,42,0),"^",2)[200,$D(^VA(200,P1,20)),$P(^(20),U,2)]"" W $E($P(^(20),U,2),1,33)
- W ?72,"|",! W:$P(^PRCS(410,DA,7),U,2)'="" $P(^(7),U,2) W ?39,"|" W:$P(^(7),U,4)'="" $P(^(7),U,4) W ?72,"|" S Y=$S($P(^(7),U,7):$P(^(7),U,7),1:$P(^(7),U,5)) I Y D DD^%DT W Y
- SIG1 W !,$E(L,1,39)
- W "|",$E(L,1,32)
- W "|",$E(L,1,17) Q:PRNTALL=0 I $Y>41 D NEWP^PRCSP121
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSP122 2495 printed Mar 13, 2025@21:22:45 Page 2
- PRCSP122 ;WISC/SAW-CONTROL POINT ACTIVITY 2237 PRINTOUT CON'T ;4/21/93 08:53
- V ;;5.1;IFCAP;**95,107**;Oct 20, 2000;Build 13
- +1 ;Per VHA Directive 2004-038, this routine should not be modified.
- +2 IF '$DATA(^PRCS(410,DA,"RM",0))
- GOTO DEL
- +3 IF $DATA(^PRCS(410,DA,"RM",0))
- WRITE !
- SET P(1)=0
- SET DIWL=6
- SET DIWR=96
- SET DIWF=""
- KILL ^UTILITY($JOB,"W")
- SET X="SPECIAL REMARKS:"
- DO DIWP^PRCUTL($GET(DA))
- 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 $Y>62
- DO NEWP^PRCSP121
- WRITE !,^UTILITY($JOB,"W",DIWL,K,0)
- DEL IF $DATA(^PRCS(410,DA,9))
- IF $PIECE(^(9),U)'=""
- WRITE !,"DELIVER TO: ",$PIECE(^(9),U)
- +1 WRITE !,L,!,"FOB",?24,"|TERMS",?48,"|DELIVERY DATE",?63,"|QUOTE DATE",?77,"|BY(Initials)",!,?24,"|",?48,"|",?63,"|",?77,"|"
- +2 WRITE !,$EXTRACT(L,1,24),"|",$EXTRACT(L,1,23),"|",$EXTRACT(L,1,14),"|",$EXTRACT(L,1,13),"|",$EXTRACT(L,1,12)
- +3 IF $Y>58
- DO NEWP^PRCSP121
- +4 WRITE !,"JUSTIFICATION OF NEED OR TURN-IN (If recurring need, indicate 30-day estimate. If turn-in,",!,"do not use this form if circumstances require use of VA Form 90-1217, Report of Survey)"
- +5 IF '$DATA(^PRCS(410,DA,8,0))
- GOTO SIG
- +6 SET (MYTEMP,BFLAG)=0
- +7 FOR I=1:1
- SET MYTEMP=$ORDER(^PRCS(410,DA,8,MYTEMP))
- if MYTEMP=""
- QUIT
- SET BFLAG=1
- +8 IF BFLAG=0
- GOTO SIG
- +9 SET DIWL=6
- SET DIWR=96
- 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))
- +10 SET Z=^UTILITY($JOB,"W",DIWL)
- FOR K=1:1:Z
- if $Y>62
- DO NEWP^PRCSP121
- WRITE !,^UTILITY($JOB,"W",DIWL,K,0)
- SIG ;PRINT SIGNATURE BLOCKS
- +1 IF $Y>58
- DO NEWP^PRCSP121
- +2 WRITE !,L
- +3 WRITE !,"Originator of Request: "
- SET XNAME=$PIECE($GET(^PRCS(410,DA,14)),"^")
- IF XNAME'=""
- WRITE $PIECE($GET(^VA(200,XNAME,0)),"^")
- +4 WRITE !,"Signature of Initiator",?39,"|Signature of Approving Official |Date"
- +5 IF '$DATA(^PRCS(410,DA,7))
- WRITE !,?39,"|",?72,"|",!,?39,"|",?72,"|"
- GOTO SIG1
- +6 KILL P1
- WRITE !,?39,"|"
- if $PIECE(^PRCS(410,DA,7),U,3)'=""
- SET (P,P1)=$PIECE(^(7),U,3)
- IF $DATA(P1)
- WRITE "/ES/",$$DECODE^PRCSC1(DA)
- +7 NEW PRSHLE
- SET PRSHLE=^DD(410,40,0)
- WRITE ?72,"|",!
- IF $PIECE(^PRCS(410,DA,7),U)'=""
- SET (P,P2)=$PIECE(^(7),U)
- IF $PIECE(PRSHLE,"^",2)[200
- IF $DATA(^VA(200,P,20))
- IF $PIECE(^(20),U,2)]""
- WRITE $EXTRACT($PIECE(^(20),U,2),1,31)
- +8 IF $DATA(P2)
- IF $PIECE(^DD(410,40,0),"^",2)[200
- IF $DATA(^VA(200,+P2,.13))
- IF $LENGTH($PIECE(^(.13),U,2))'>5
- WRITE " (",$PIECE(^(.13),U,2),")"
- +9 KILL P2
- WRITE ?39,"|"
- IF $DATA(P1)
- IF $PIECE(^DD(410,42,0),"^",2)[200
- IF $DATA(^VA(200,P1,20))
- IF $PIECE(^(20),U,2)]""
- WRITE $EXTRACT($PIECE(^(20),U,2),1,33)
- +10 WRITE ?72,"|",!
- if $PIECE(^PRCS(410,DA,7),U,2)'=""
- WRITE $PIECE(^(7),U,2)
- WRITE ?39,"|"
- if $PIECE(^(7),U,4)'=""
- WRITE $PIECE(^(7),U,4)
- WRITE ?72,"|"
- SET Y=$SELECT($PIECE(^(7),U,7):$PIECE(^(7),U,7),1:$PIECE(^(7),U,5))
- IF Y
- DO DD^%DT
- WRITE Y
- SIG1 WRITE !,$EXTRACT(L,1,39)
- +1 WRITE "|",$EXTRACT(L,1,32)
- +2 WRITE "|",$EXTRACT(L,1,17)
- if PRNTALL=0
- QUIT
- IF $Y>41
- DO NEWP^PRCSP121
- +3 QUIT
