- PRCSD122 ;WISC/SAW-CONTROL POINT ACT. 2237 TERM. DISP. CON'T ;4/21/93 08:46
- V ;;5.1;IFCAP;**107**;Oct 20, 2000;Build 13
- ;Per VHA Directive 2004-038, this routine should not be modified.
- I IOSL-$Y<5 D NEWP^PRCSD121 Q:Z1=U
- W !,"JUSTIFICATION OF NEED OR TURN-IN"
- I '$D(^PRCS(410,DA,8,0)) G SIG
- S DIWL=1,DIWR=80,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:IOSL-$Y<2 NEWP^PRCSD121 Q:Z1=U W !,^UTILITY($J,"W",DIWL,K,0)
- SIG ;PRINT SIGNATURE BLOCKS
- I IOSL-$Y<5 D NEWP^PRCSD121 Q:Z1=U
- 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",?37,"Signature of Approving Official Date"
- I '$D(^PRCS(410,DA,7)) W ! G SIG1
- W !,?37 K P1 S:$P(^PRCS(410,DA,7),U,3)'="" (P,P1)=$P(^(7),U,3) I $D(P1),$P(^(7),U,6)'="" W "/ES/",$$DECODE^PRCSC1(DA)
- N PRSHLB S PRSHLB=^DD(410,40,0) W ?69,! I $P(^PRCS(410,DA,7),U)'="" S (P,P2)=$P(^(7),U) I $P(PRSHLB,"^",2)[200,$D(^VA(200,P,20)),$P(^(20),U,2)]"" W $E($P(^(20),U,2),1,28)
- I $D(P2),$P(PRSHLB,"^",2)[200,$D(^VA(200,+P2,.13)),$L($P(^(.13),U,2))'>5 W " (",$P(^(.13),U,2),")"
- N PRSHLC S PRSHLC=^DD(410,42,0) K P2 W ?37 I $D(P1),$P(PRSHLC,"^",2)[200,$D(^VA(200,P1,20)),$P(^(20),U,2)]"" W $E($P(^(20),U,2),1,30)
- W ?69,! W:$P(^PRCS(410,DA,7),U,2)'="" $P(^(7),U,2) W ?37 W:$P(^(7),U,4)'="" $P(^(7),U,4) W ?69 I $P(^(7),U,5)'="" S Y=$P(^(7),U,5) D DD^%DT W Y
- SIG1 W !,$E(L,1,36)
- W " ",$E(L,38,68)
- W "------------" I IOSL-$Y<5 D NEWP^PRCSD121 Q:Z1=U
- W !,"Appropriation and Accounting Symbols"
- S P=$P(^PRCS(410,DA,0),U,5) I $D(^(3)) S X=^(3) S:$P(X,U,2)'="" P=P_"-"_$P(X,U,2) S:$P(X,U)'="" P=P_"-"_$P($P(X,U)," ") S:$P(X,U,3)'="" P=P_"-"_$P($P(X,U,3)," ")
- 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)
- S FPROJ=$P($G(^PRCS(410,DA,3)),"^",12) S P=P_" "_FPROJ
- W !,P,!,L
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSD122 1989 printed Feb 18, 2025@23:43:47 Page 2
- PRCSD122 ;WISC/SAW-CONTROL POINT ACT. 2237 TERM. DISP. CON'T ;4/21/93 08:46
- V ;;5.1;IFCAP;**107**;Oct 20, 2000;Build 13
- +1 ;Per VHA Directive 2004-038, this routine should not be modified.
- +2 IF IOSL-$Y<5
- DO NEWP^PRCSD121
- if Z1=U
- QUIT
- +3 WRITE !,"JUSTIFICATION OF NEED OR TURN-IN"
- +4 IF '$DATA(^PRCS(410,DA,8,0))
- GOTO SIG
- +5 SET DIWL=1
- SET DIWR=80
- 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))
- +6 SET Z=^UTILITY($JOB,"W",DIWL)
- FOR K=1:1:Z
- if IOSL-$Y<2
- DO NEWP^PRCSD121
- if Z1=U
- QUIT
- WRITE !,^UTILITY($JOB,"W",DIWL,K,0)
- SIG ;PRINT SIGNATURE BLOCKS
- +1 IF IOSL-$Y<5
- DO NEWP^PRCSD121
- if Z1=U
- QUIT
- +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",?37,"Signature of Approving Official Date"
- +5 IF '$DATA(^PRCS(410,DA,7))
- WRITE !
- GOTO SIG1
- +6 WRITE !,?37
- KILL P1
- if $PIECE(^PRCS(410,DA,7),U,3)'=""
- SET (P,P1)=$PIECE(^(7),U,3)
- IF $DATA(P1)
- IF $PIECE(^(7),U,6)'=""
- WRITE "/ES/",$$DECODE^PRCSC1(DA)
- +7 NEW PRSHLB
- SET PRSHLB=^DD(410,40,0)
- WRITE ?69,!
- IF $PIECE(^PRCS(410,DA,7),U)'=""
- SET (P,P2)=$PIECE(^(7),U)
- IF $PIECE(PRSHLB,"^",2)[200
- IF $DATA(^VA(200,P,20))
- IF $PIECE(^(20),U,2)]""
- WRITE $EXTRACT($PIECE(^(20),U,2),1,28)
- +8 IF $DATA(P2)
- IF $PIECE(PRSHLB,"^",2)[200
- IF $DATA(^VA(200,+P2,.13))
- IF $LENGTH($PIECE(^(.13),U,2))'>5
- WRITE " (",$PIECE(^(.13),U,2),")"
- +9 NEW PRSHLC
- SET PRSHLC=^DD(410,42,0)
- KILL P2
- WRITE ?37
- IF $DATA(P1)
- IF $PIECE(PRSHLC,"^",2)[200
- IF $DATA(^VA(200,P1,20))
- IF $PIECE(^(20),U,2)]""
- WRITE $EXTRACT($PIECE(^(20),U,2),1,30)
- +10 WRITE ?69,!
- if $PIECE(^PRCS(410,DA,7),U,2)'=""
- WRITE $PIECE(^(7),U,2)
- WRITE ?37
- if $PIECE(^(7),U,4)'=""
- WRITE $PIECE(^(7),U,4)
- WRITE ?69
- IF $PIECE(^(7),U,5)'=""
- SET Y=$PIECE(^(7),U,5)
- DO DD^%DT
- WRITE Y
- SIG1 WRITE !,$EXTRACT(L,1,36)
- +1 WRITE " ",$EXTRACT(L,38,68)
- +2 WRITE "------------"
- IF IOSL-$Y<5
- DO NEWP^PRCSD121
- if Z1=U
- QUIT
- +3 WRITE !,"Appropriation and Accounting Symbols"
- +4 SET P=$PIECE(^PRCS(410,DA,0),U,5)
- IF $DATA(^(3))
- SET X=^(3)
- if $PIECE(X,U,2)'=""
- SET P=P_"-"_$PIECE(X,U,2)
- if $PIECE(X,U)'=""
- SET P=P_"-"_$PIECE($PIECE(X,U)," ")
- if $PIECE(X,U,3)'=""
- SET P=P_"-"_$PIECE($PIECE(X,U,3)," ")
- +5 if $DATA(PRCS("SUB"))
- SET P=P_"-"_PRCS("SUB")
- +6 IF $DATA(^PRCS(410,DA,4))
- IF $PIECE(^(4),U,5)'=""
- SET P=P_"-"_$PIECE(^(4),U,5)
- +7 SET FPROJ=$PIECE($GET(^PRCS(410,DA,3)),"^",12)
- SET P=P_" "_FPROJ
- +8 WRITE !,P,!,L
- +9 QUIT