PRCSP11 ;WISC/SAW-CONTROL POINT ACTIVITY 1358 PRINTOUT ;6/17/11 17:59
V ;;5.1;IFCAP;**158,161**;Oct 20, 2000;Build 19
;Per VHA Directive 2004-038, this routine should not be modified.
G P
QUE I $D(ZTQUEUED) S DA=D0
S DA=D0,PRCSOB=1
P U IO W:$Y>0 @IOF S U="^",PRCSP=1,L="",$P(L,"-",80)="-" D NOW^%DTC S Y=% D DD^%DT S PRCSTN=$P(^PRCS(410,DA,0),U),PRC("SITE")=+PRCSTN W !,PRCSTN,?36,Y,?72,"PAGE ",PRCSP D UL
D NEWP1 W !,"Requestor:",?41,"|Date Requested:",?62,"|Obligation No.:"
W ! K P1 I $D(^PRCS(410,DA,7)) S P1=^(7) I +P1 S X=$S($D(^VA(200,+P1,0)):$P(^(0),U),1:"") W X
W ?41,"|" I $D(^PRCS(410,DA,1)) S Y=$P(^(1),U) I Y D DD^%DT W Y
W ?62,"|" I $D(^PRCS(410,DA,4)),$P(^(4),U,5)'="" S PRCSPO=$P(^(4),U,5) W ?65,PRC("SITE")_"-"_PRCSPO
D UL W !,"Vendor:",?41,"|Contract Number:"
W ! I $D(^PRCS(410,DA,2)) W $P(^(2),U) ;S X=$P(^(2),U) I X]"" W X
W ?41,"|" K PRCSG I $D(^PRCS(410,DA,3)) S PRCSG=^(3) I $P(PRCSG,U,10)]"" W $P(PRCSG,U,10)
W ! I $D(^PRCS(410,DA,2)) W $P(^(2),U,2),?41,"|",!,$P(^(2),U,6)_", " W $S($D(^DIC(5,+$P(^PRCS(410,DA,2),U,7),0)):$P(^(0),U,2),1:" ")_" "_$P(^PRCS(410,DA,2),U,8)
W ?41,"|" D UL W !,"Name and Title Approving Official:",?41,"|Signature/Date Signed:"
N PRSHLD S PRSHLD=^DD(410,42,0) K P W ! I $D(P1),$P(PRSHLD,"^",2)[200 S P=$P(P1,U,3) I P S X=$S($D(^VA(200,P,20)):$P(^(20),U,2),1:"") W $E(X,1,30)
W ?41,"|" I $D(P),P,$P(P1,U,6)'="" W "/ES/"_$$DECODE^PRCSC1(DA)
W ?62,"/" I $D(P1) S Y=$S($P(P1,U,7):$P(P1,U,7),1:$P(P1,U,5)) I Y D DD^%DT W Y K Y
W ! I $D(P1) W $P(P1,U,4)
W ?41,"|" D UL W !,"FUND CERTIFICATION:",!,"The supplies and services listed on this request are properly chargeable"
W !,"to the following allotments, the available balances of which are"
W !,"sufficient to cover the cost thereof, and funds have been obligated."
D UL W !,"Appropriation and Accounting Symbols:",?41,"|Obligated By: ",?62,"|Date Obligated:"
S DIWL=0,DIWR=80,DIWF="" K ^UTILITY($J)
I $D(^PRCS(410,DA,8,0)) 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 P=PRC("SITE") I $D(PRCSG) S:$P(PRCSG,U,2)]"" P=P_"-"_$P(PRCSG,U,2) S P=P_"-"_$P(PRCSTN,"-",4) S:$P(PRCSG,U,3)]"" P=P_"-"_$P($P(PRCSG,U,3)," ") S:$P(PRCSG,U,6) P=P_"-"_+$P(PRCSG,U,6)
W !,P,?41,"|" K PRCSG I $D(^PRCS(410,DA,4)) S PRCSG=^(4) I $P(PRCSG,U,9),$P(PRCSG,U,10)'="" W "/ES/"_$$DECODE^PRCSC2(DA)
W ?62,"|" I $D(PRCSG) S Y=$P(PRCSG,U,4) I Y D DD^%DT W Y
D UL W !,"AUTHORITY: " S Y=$P($G(^PRCS(410,DA,11)),U,4) I Y>0 W $P($G(^PRCS(410.9,Y,0)),U)
S Y=$P($G(^PRCS(410,DA,11)),U,5) I Y>0 W ?40,"SUB: ",$P($G(^PRCS(410.9,Y,0)),U)
S Y=$G(^PRCS(410,DA,1)) W !,"SERVICE START DATE: ",$$FMTE^XLFDT($P(Y,U,6),"2DZ"),?40,"SERVICE END DATE: ",$$FMTE^XLFDT($P(Y,U,7),"2DZ")
D UL W !,"Purpose:" I $D(^UTILITY($J,"W",DIWL)) S Z=^UTILITY($J,"W",DIWL) F I=1:1:Z W !,^UTILITY($J,"W",DIWL,I,0) I IOSL-$Y<3 D UL,NEWP
I IOSL-$Y<10 D NEWP
D ^PRCSP111
W @IOF K %DT,CT,UT,P1,P,PRCSP,PRCSA,PRCSG,PRCSOB,PRCSPO,PRCSTN,X,X1,Y,DIWL,DIWR,DIWF,Z,DA,I,JJ,L,^UTILITY($J) D:$D(ZTSK) KILL^%ZTLOAD Q
UL W ! F JJ=1:1:80 W @IOBS ;PRC*5.1*161 change FOR loop to JJ= to fix infinite loop for excessive justification text printing
W L Q
NEWP ;PRINT HEADER FOR NEW PAGE
W !!,"VA FORM 4-1358a-ADP (NOV 1987)" W:$Y>0 @IOF
S PRCSP=PRCSP+1 W !,$P(^PRCS(410,DA,0),U) W:$D(PRCSPO) ?40,PRC("SITE")_"-"_PRCSPO W ?72,"PAGE ",PRCSP D UL
NEWP1 N PRCX S PRCX=$$AUTHR^PRCEMOA($P($G(^PRCS(410,DA,11)),U,4,5))
I '$D(PRCSOB) D
. W !,"1358 OBLIGATION OR CHANGE" W:$P(PRCX,U)]"" ":",$P(PRCX,U)
. W:$P(PRCX,U,2)]"" !,?5,$P(PRCX,U,2)
. D UL
E D
. W !,"REQUEST 1358 OBLIG/ADJUST" W:$P(PRCX,U)]"" ":",$P(PRCX,U)
. W:$P(PRCX,U,2)]"" !,?5,$P(PRCX,U,2)
. D UL
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSP11 3714 printed Oct 16, 2024@18:18:37 Page 2
PRCSP11 ;WISC/SAW-CONTROL POINT ACTIVITY 1358 PRINTOUT ;6/17/11 17:59
V ;;5.1;IFCAP;**158,161**;Oct 20, 2000;Build 19
+1 ;Per VHA Directive 2004-038, this routine should not be modified.
+2 GOTO P
QUE IF $DATA(ZTQUEUED)
SET DA=D0
+1 SET DA=D0
SET PRCSOB=1
P USE IO
if $Y>0
WRITE @IOF
SET U="^"
SET PRCSP=1
SET L=""
SET $PIECE(L,"-",80)="-"
DO NOW^%DTC
SET Y=%
DO DD^%DT
SET PRCSTN=$PIECE(^PRCS(410,DA,0),U)
SET PRC("SITE")=+PRCSTN
WRITE !,PRCSTN,?36,Y,?72,"PAGE ",PRCSP
DO UL
+1 DO NEWP1
WRITE !,"Requestor:",?41,"|Date Requested:",?62,"|Obligation No.:"
+2 WRITE !
KILL P1
IF $DATA(^PRCS(410,DA,7))
SET P1=^(7)
IF +P1
SET X=$SELECT($DATA(^VA(200,+P1,0)):$PIECE(^(0),U),1:"")
WRITE X
+3 WRITE ?41,"|"
IF $DATA(^PRCS(410,DA,1))
SET Y=$PIECE(^(1),U)
IF Y
DO DD^%DT
WRITE Y
+4 WRITE ?62,"|"
IF $DATA(^PRCS(410,DA,4))
IF $PIECE(^(4),U,5)'=""
SET PRCSPO=$PIECE(^(4),U,5)
WRITE ?65,PRC("SITE")_"-"_PRCSPO
+5 DO UL
WRITE !,"Vendor:",?41,"|Contract Number:"
+6 ;S X=$P(^(2),U) I X]"" W X
WRITE !
IF $DATA(^PRCS(410,DA,2))
WRITE $PIECE(^(2),U)
+7 WRITE ?41,"|"
KILL PRCSG
IF $DATA(^PRCS(410,DA,3))
SET PRCSG=^(3)
IF $PIECE(PRCSG,U,10)]""
WRITE $PIECE(PRCSG,U,10)
+8 WRITE !
IF $DATA(^PRCS(410,DA,2))
WRITE $PIECE(^(2),U,2),?41,"|",!,$PIECE(^(2),U,6)_", "
WRITE $SELECT($DATA(^DIC(5,+$PIECE(^PRCS(410,DA,2),U,7),0)):$PIECE(^(0),U,2),1:" ")_" "_$PIECE(^PRCS(410,DA,2),U,8)
+9 WRITE ?41,"|"
DO UL
WRITE !,"Name and Title Approving Official:",?41,"|Signature/Date Signed:"
+10 NEW PRSHLD
SET PRSHLD=^DD(410,42,0)
KILL P
WRITE !
IF $DATA(P1)
IF $PIECE(PRSHLD,"^",2)[200
SET P=$PIECE(P1,U,3)
IF P
SET X=$SELECT($DATA(^VA(200,P,20)):$PIECE(^(20),U,2),1:"")
WRITE $EXTRACT(X,1,30)
+11 WRITE ?41,"|"
IF $DATA(P)
IF P
IF $PIECE(P1,U,6)'=""
WRITE "/ES/"_$$DECODE^PRCSC1(DA)
+12 WRITE ?62,"/"
IF $DATA(P1)
SET Y=$SELECT($PIECE(P1,U,7):$PIECE(P1,U,7),1:$PIECE(P1,U,5))
IF Y
DO DD^%DT
WRITE Y
KILL Y
+13 WRITE !
IF $DATA(P1)
WRITE $PIECE(P1,U,4)
+14 WRITE ?41,"|"
DO UL
WRITE !,"FUND CERTIFICATION:",!,"The supplies and services listed on this request are properly chargeable"
+15 WRITE !,"to the following allotments, the available balances of which are"
+16 WRITE !,"sufficient to cover the cost thereof, and funds have been obligated."
+17 DO UL
WRITE !,"Appropriation and Accounting Symbols:",?41,"|Obligated By: ",?62,"|Date Obligated:"
+18 SET DIWL=0
SET DIWR=80
SET DIWF=""
KILL ^UTILITY($JOB)
+19 IF $DATA(^PRCS(410,DA,8,0))
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))
+20 SET P=PRC("SITE")
IF $DATA(PRCSG)
if $PIECE(PRCSG,U,2)]""
SET P=P_"-"_$PIECE(PRCSG,U,2)
SET P=P_"-"_$PIECE(PRCSTN,"-",4)
if $PIECE(PRCSG,U,3)]""
SET P=P_"-"_$PIECE($PIECE(PRCSG,U,3)," ")
if $PIECE(PRCSG,U,6)
SET P=P_"-"_+$PIECE(PRCSG,U,6)
+21 WRITE !,P,?41,"|"
KILL PRCSG
IF $DATA(^PRCS(410,DA,4))
SET PRCSG=^(4)
IF $PIECE(PRCSG,U,9)
IF $PIECE(PRCSG,U,10)'=""
WRITE "/ES/"_$$DECODE^PRCSC2(DA)
+22 WRITE ?62,"|"
IF $DATA(PRCSG)
SET Y=$PIECE(PRCSG,U,4)
IF Y
DO DD^%DT
WRITE Y
+23 DO UL
WRITE !,"AUTHORITY: "
SET Y=$PIECE($GET(^PRCS(410,DA,11)),U,4)
IF Y>0
WRITE $PIECE($GET(^PRCS(410.9,Y,0)),U)
+24 SET Y=$PIECE($GET(^PRCS(410,DA,11)),U,5)
IF Y>0
WRITE ?40,"SUB: ",$PIECE($GET(^PRCS(410.9,Y,0)),U)
+25 SET Y=$GET(^PRCS(410,DA,1))
WRITE !,"SERVICE START DATE: ",$$FMTE^XLFDT($PIECE(Y,U,6),"2DZ"),?40,"SERVICE END DATE: ",$$FMTE^XLFDT($PIECE(Y,U,7),"2DZ")
+26 DO UL
WRITE !,"Purpose:"
IF $DATA(^UTILITY($JOB,"W",DIWL))
SET Z=^UTILITY($JOB,"W",DIWL)
FOR I=1:1:Z
WRITE !,^UTILITY($JOB,"W",DIWL,I,0)
IF IOSL-$Y<3
DO UL
DO NEWP
+27 IF IOSL-$Y<10
DO NEWP
+28 DO ^PRCSP111
+29 WRITE @IOF
KILL %DT,CT,UT,P1,P,PRCSP,PRCSA,PRCSG,PRCSOB,PRCSPO,PRCSTN,X,X1,Y,DIWL,DIWR,DIWF,Z,DA,I,JJ,L,^UTILITY($JOB)
if $DATA(ZTSK)
DO KILL^%ZTLOAD
QUIT
UL ;PRC*5.1*161 change FOR loop to JJ= to fix infinite loop for excessive justification text printing
WRITE !
FOR JJ=1:1:80
WRITE @IOBS
+1 WRITE L
QUIT
NEWP ;PRINT HEADER FOR NEW PAGE
+1 WRITE !!,"VA FORM 4-1358a-ADP (NOV 1987)"
if $Y>0
WRITE @IOF
+2 SET PRCSP=PRCSP+1
WRITE !,$PIECE(^PRCS(410,DA,0),U)
if $DATA(PRCSPO)
WRITE ?40,PRC("SITE")_"-"_PRCSPO
WRITE ?72,"PAGE ",PRCSP
DO UL
NEWP1 NEW PRCX
SET PRCX=$$AUTHR^PRCEMOA($PIECE($GET(^PRCS(410,DA,11)),U,4,5))
+1 IF '$DATA(PRCSOB)
Begin DoDot:1
+2 WRITE !,"1358 OBLIGATION OR CHANGE"
if $PIECE(PRCX,U)]""
WRITE ":",$PIECE(PRCX,U)
+3 if $PIECE(PRCX,U,2)]""
WRITE !,?5,$PIECE(PRCX,U,2)
+4 DO UL
End DoDot:1
+5 IF '$TEST
Begin DoDot:1
+6 WRITE !,"REQUEST 1358 OBLIG/ADJUST"
if $PIECE(PRCX,U)]""
WRITE ":",$PIECE(PRCX,U)
+7 if $PIECE(PRCX,U,2)]""
WRITE !,?5,$PIECE(PRCX,U,2)
+8 DO UL
End DoDot:1
+9 QUIT
