- PRCE58P2 ;WISC/SAW,LDB-CONTROL POINT ACTIVITY 1358 PRINTOUT ;6/7/11 18:56
- V ;;5.1;IFCAP;**148,158**;Oct 20, 2000;Build 1
- ;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
- D NODE^PRCS58OB(DA,.TRNODE) S PRCSTN=$P($G(TRNODE(0)),U),PRC("SITE")=+PRCSTN W !,PRCSTN,?36,Y,?72,"PAGE ",PRCSP D UL
- D NEWP1 W !,"Originator of Request: " I $D(TRNODE(14)),TRNODE(14)'="" W $P($G(^VA(200,TRNODE(14),0)),"^"),!
- W !,"Requestor:",?41,"|Date Requested:",?62,"|Obligation No.:"
- W ! K P1 I $D(TRNODE(7)) S P1=TRNODE(7) I +P1 S X=$P($G(^VA(200,+P1,0)),U) W X
- W ?41,"|" I $D(TRNODE(1)) S Y=$P(TRNODE(1),U) I Y D DD^%DT W Y
- W ?62,"|" I $D(TRNODE(4)),$P(TRNODE(4),U,5)'="" S PRCSPO=$P(TRNODE(4),U,5) W ?65,PRC("SITE")_"-"_PRCSPO
- D UL W !,"Vendor:",?41,"|Contract Number:"
- W ! I $D(TRNODE(2)) W $P(TRNODE(2),U)
- W ?41,"|" K PRCSG I $D(TRNODE(3)) S PRCSG=TRNODE(3) I $P(PRCSG,U,10)]"" W $P(PRCSG,U,10)
- W ! I $D(TRNODE(2)),TRNODE(2)]"" W $P(TRNODE(2),U,2),?41,"|",!,$P(TRNODE(2),U,6)_", " W $S($D(^DIC(5,+$P(TRNODE(2),U,7),0)):$P(^(0),U,2),1:" ")_" "_$P(TRNODE(2),U,8)
- W ?41,"|" D UL W !,"Name and Title Approving Official:",?41,"|Signature/Date Signed:"
- K P W ! I $D(P1) 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)
- ;K P W ! I $D(P1) S P=$P(P1,U,3) I P S X=$S($G(^VA(200,P,20)):$P(^(20),U,2),1:"") W $E(X,1,30)
- W ?41,"|" I $D(P),P,$P(P1,U,6)'="" S X=$$DECODE^PRCSC1(DA) W "/ES/"_$E(X,1,28)
- 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(TRNODE(8)) S X1=0 F I=1:1 S X1=$O(TRNODE(8,X1)) Q:X1="" S X=TRNODE(8,X1),PRCSDAA=DA D DIWP^PRCUTL($G(DA)) S DA=PRCSDAA K PRCSDAA
- 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)
- I $D(TRNODE(3)),$P($G(TRNODE(3)),"^",12)'="" S PROJ=$P(TRNODE(3),"^",12),P=P_" "_PROJ
- W !,P,?41,"|" K PRCSG I $D(TRNODE(4)) S PRCSG=TRNODE(4) I $P(PRCSG,U,9),$P(PRCSG,U,10)'="" S X=$$DECODE^PRCSC2(DA) W "/ES/"_$E(X,1,28)
- W ?62,"|" I $D(PRCSG) S Y=$P(PRCSG,U,4) I Y D DD^%DT W Y
- D UL
- W !,"AUTHORITY: " I $P($G(TRNODE(11)),U,4) W $P($G(^PRCS(410.9,$P(TRNODE(11),U,4),0)),U)
- W:$P($G(TRNODE(11)),U,5) ?40,"SUB: ",$P($G(^PRCS(410.9,$P(TRNODE(11),U,5),0)),U)
- W !,"SERVICE START DATE: ",$$FMTE^XLFDT($P($G(TRNODE(1)),U,6),"2DZ"),?40,"SERVICE END DATE: ",$$FMTE^XLFDT($P($G(TRNODE(1)),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 ^PRCE58P3
- K %DT,CT,UT,P1,P,PRCSP,PRCSA,PRCSG,PRCSOB,PRCSPO,PRCSTN,X,X1,Y,DIWL,DIWR,DIWF,Z,DA,I,L,^UTILITY($J) D:$D(ZTQUEUED) KILL^%ZTLOAD Q
- UL W ! N I F I=1:1:80 W @IOBS
- 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(TRNODE(0),U) W:$D(PRCSPO) ?40,PRC("SITE")_"-"_PRCSPO W ?72,"PAGE ",PRCSP D UL
- NEWP1 N PRCX S PRCX=$$AUTHR^PRCEMOA($P($G(TRNODE(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[HPRCE58P2 3890 printed Feb 18, 2025@23:27:34 Page 2
- PRCE58P2 ;WISC/SAW,LDB-CONTROL POINT ACTIVITY 1358 PRINTOUT ;6/7/11 18:56
- V ;;5.1;IFCAP;**148,158**;Oct 20, 2000;Build 1
- +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
- +1 DO NODE^PRCS58OB(DA,.TRNODE)
- SET PRCSTN=$PIECE($GET(TRNODE(0)),U)
- SET PRC("SITE")=+PRCSTN
- WRITE !,PRCSTN,?36,Y,?72,"PAGE ",PRCSP
- DO UL
- +2 DO NEWP1
- WRITE !,"Originator of Request: "
- IF $DATA(TRNODE(14))
- IF TRNODE(14)'=""
- WRITE $PIECE($GET(^VA(200,TRNODE(14),0)),"^"),!
- +3 WRITE !,"Requestor:",?41,"|Date Requested:",?62,"|Obligation No.:"
- +4 WRITE !
- KILL P1
- IF $DATA(TRNODE(7))
- SET P1=TRNODE(7)
- IF +P1
- SET X=$PIECE($GET(^VA(200,+P1,0)),U)
- WRITE X
- +5 WRITE ?41,"|"
- IF $DATA(TRNODE(1))
- SET Y=$PIECE(TRNODE(1),U)
- IF Y
- DO DD^%DT
- WRITE Y
- +6 WRITE ?62,"|"
- IF $DATA(TRNODE(4))
- IF $PIECE(TRNODE(4),U,5)'=""
- SET PRCSPO=$PIECE(TRNODE(4),U,5)
- WRITE ?65,PRC("SITE")_"-"_PRCSPO
- +7 DO UL
- WRITE !,"Vendor:",?41,"|Contract Number:"
- +8 WRITE !
- IF $DATA(TRNODE(2))
- WRITE $PIECE(TRNODE(2),U)
- +9 WRITE ?41,"|"
- KILL PRCSG
- IF $DATA(TRNODE(3))
- SET PRCSG=TRNODE(3)
- IF $PIECE(PRCSG,U,10)]""
- WRITE $PIECE(PRCSG,U,10)
- +10 WRITE !
- IF $DATA(TRNODE(2))
- IF TRNODE(2)]""
- WRITE $PIECE(TRNODE(2),U,2),?41,"|",!,$PIECE(TRNODE(2),U,6)_", "
- WRITE $SELECT($DATA(^DIC(5,+$PIECE(TRNODE(2),U,7),0)):$PIECE(^(0),U,2),1:" ")_" "_$PIECE(TRNODE(2),U,8)
- +11 WRITE ?41,"|"
- DO UL
- WRITE !,"Name and Title Approving Official:",?41,"|Signature/Date Signed:"
- +12 KILL P
- WRITE !
- IF $DATA(P1)
- 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)
- +13 ;K P W ! I $D(P1) S P=$P(P1,U,3) I P S X=$S($G(^VA(200,P,20)):$P(^(20),U,2),1:"") W $E(X,1,30)
- +14 WRITE ?41,"|"
- IF $DATA(P)
- IF P
- IF $PIECE(P1,U,6)'=""
- SET X=$$DECODE^PRCSC1(DA)
- WRITE "/ES/"_$EXTRACT(X,1,28)
- +15 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
- +16 WRITE !
- IF $DATA(P1)
- WRITE $PIECE(P1,U,4)
- +17 WRITE ?41,"|"
- DO UL
- WRITE !,"FUND CERTIFICATION:",!,"The supplies and services listed on this request are properly chargeable"
- +18 WRITE !,"to the following allotments, the available balances of which are"
- +19 WRITE !,"sufficient to cover the cost thereof, and funds have been obligated."
- +20 DO UL
- WRITE !,"Appropriation and Accounting Symbols:",?41,"|Obligated By: ",?62,"|Date Obligated:"
- +21 SET DIWL=0
- SET DIWR=80
- SET DIWF=""
- KILL ^UTILITY($JOB)
- +22 IF $DATA(TRNODE(8))
- SET X1=0
- FOR I=1:1
- SET X1=$ORDER(TRNODE(8,X1))
- if X1=""
- QUIT
- SET X=TRNODE(8,X1)
- SET PRCSDAA=DA
- DO DIWP^PRCUTL($GET(DA))
- SET DA=PRCSDAA
- KILL PRCSDAA
- +23 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)
- +24 IF $DATA(TRNODE(3))
- IF $PIECE($GET(TRNODE(3)),"^",12)'=""
- SET PROJ=$PIECE(TRNODE(3),"^",12)
- SET P=P_" "_PROJ
- +25 WRITE !,P,?41,"|"
- KILL PRCSG
- IF $DATA(TRNODE(4))
- SET PRCSG=TRNODE(4)
- IF $PIECE(PRCSG,U,9)
- IF $PIECE(PRCSG,U,10)'=""
- SET X=$$DECODE^PRCSC2(DA)
- WRITE "/ES/"_$EXTRACT(X,1,28)
- +26 WRITE ?62,"|"
- IF $DATA(PRCSG)
- SET Y=$PIECE(PRCSG,U,4)
- IF Y
- DO DD^%DT
- WRITE Y
- +27 DO UL
- +28 WRITE !,"AUTHORITY: "
- IF $PIECE($GET(TRNODE(11)),U,4)
- WRITE $PIECE($GET(^PRCS(410.9,$PIECE(TRNODE(11),U,4),0)),U)
- +29 if $PIECE($GET(TRNODE(11)),U,5)
- WRITE ?40,"SUB: ",$PIECE($GET(^PRCS(410.9,$PIECE(TRNODE(11),U,5),0)),U)
- +30 WRITE !,"SERVICE START DATE: ",$$FMTE^XLFDT($PIECE($GET(TRNODE(1)),U,6),"2DZ"),?40,"SERVICE END DATE: ",$$FMTE^XLFDT($PIECE($GET(TRNODE(1)),U,7),"2DZ")
- +31 DO UL
- WRITE !,"Purpose: "
- +32 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
- +33 IF IOSL-$Y<10
- DO NEWP
- +34 DO ^PRCE58P3
- +35 KILL %DT,CT,UT,P1,P,PRCSP,PRCSA,PRCSG,PRCSOB,PRCSPO,PRCSTN,X,X1,Y,DIWL,DIWR,DIWF,Z,DA,I,L,^UTILITY($JOB)
- if $DATA(ZTQUEUED)
- DO KILL^%ZTLOAD
- QUIT
- UL WRITE !
- NEW I
- FOR I=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(TRNODE(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(TRNODE(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