PRCEOB1 ;WISC/CTB/CLH-SUBROUTINES FOR PRCEOB ;2/10/92
V ;;5.1;IFCAP;**148,196**;Oct 20, 2000;Build 15
;Per VA Directive 6402, this routine should not be modified.
;
;PRC*5.1*196 Display Date Committed on Obligation display for
; obligator verification.
;
SCREEN D HILO^PRCFQ,SW,SC Q
Q
SW ;SWITCH BOCS IF NECESSARY
F I=6:1:9 S @("S"_I)=$P(TRNODE(3),"^",I)
I S8=0!(S9=0) S S8="",S9=""
I S6=0!(S7=0) S S6=S8,S7=S9,S8="",S9=""
S $P(TRNODE(3),"^",6,9)=S6_"^"_S7_"^"_S8_"^"_S9 K S6,S7,S8,S9 Q
;
SC ;DISPLAY SCREEN
W @IOF,!?15,"1358 TRANSACTION - ",IOINHI,$P(TRNODE(0),"^"),IOINLOW
W !!," COST CENTER: ",IOINHI,+$P(TRNODE(3),"^",3),IOINLOW,?IOM-4\2,"AMOUNT: ",IOINHI,"$ ",$J($P(TRNODE(4),"^"),0,2)
W !!,IOINLOW,"BOC #1: ",IOINHI,+$P(TRNODE(3),"^",6),IOINLOW,?IOM-10\2,"AMOUNT #1: ",IOINHI,"$ "_$J($P(TRNODE(3),"^",7),0,2)
I $P(TRNODE(3),"^",8,9)'="^" W !!,IOINLOW,"BOC #2: ",IOINHI,+$P(TRNODE(3),"^",8),?IOM-10\2,IOINLOW,"AMOUNT #2: ",IOINHI,"$ "_$J($P(TRNODE(3),"^",9),0,2)
W !!,IOINLOW,"AUTHORITY: ",IOINHI,$P($G(^PRCS(410.9,+$P($G(TRNODE(11)),"^",4),0)),"^")," ",$P($G(^(0)),"^",2)
W:$P($G(TRNODE(11)),"^",5) !,IOINLOW,"SUB: ",IOINHI,$P($G(^PRCS(410.9,+$P($G(TRNODE(11)),"^",5),0)),"^")," ",$P($G(^(0)),"^",2)
W !,IOINLOW,"DATE REQUIRED: ",IOINHI,$$FMTE^XLFDT($P($G(TRNODE(1)),"^",4)) ;PRC*5.1*196
W !,IOINLOW,"DATE COMMITTED: ",IOINHI,$$FMTE^XLFDT($P($G(TRNODE(4)),"^",2)) ;PRC*5.1*196
W !,IOINLOW,"SERVICE START DATE: ",IOINHI,$$FMTE^XLFDT($P($G(TRNODE(1)),"^",6))
W !,IOINLOW,"SERVICE END DATE: ",IOINHI,$$FMTE^XLFDT($P($G(TRNODE(1)),"^",7))
W IOINORM Q:'$D(^PRCS(410,PRCFA("TRDA"),8,0))#2 W !!,IOINHI K ^UTILITY($J,"W") S DIWF="W",DIWL=1,DIWR=IOM*.75\1,N=0 F I=1:1 S N=$O(^PRCS(410,PRCFA("TRDA"),8,N)) Q:'N S X=^(N,0) D DIWP^PRCUTL($G(DA))
D ^DIWW,DIWKILL^PRCFQ W IOINORM Q
S $P(^PRC(424,DA,0),"^",2,14)=X,DIK="^PRC(424," D IX1^DIK K DIK S %=1 Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCEOB1 1924 printed Dec 13, 2024@02:01:32 Page 2
PRCEOB1 ;WISC/CTB/CLH-SUBROUTINES FOR PRCEOB ;2/10/92
V ;;5.1;IFCAP;**148,196**;Oct 20, 2000;Build 15
+1 ;Per VA Directive 6402, this routine should not be modified.
+2 ;
+3 ;PRC*5.1*196 Display Date Committed on Obligation display for
+4 ; obligator verification.
+5 ;
SCREEN DO HILO^PRCFQ
DO SW
DO SC
QUIT
+1 QUIT
SW ;SWITCH BOCS IF NECESSARY
+1 FOR I=6:1:9
SET @("S"_I)=$PIECE(TRNODE(3),"^",I)
+2 IF S8=0!(S9=0)
SET S8=""
SET S9=""
+3 IF S6=0!(S7=0)
SET S6=S8
SET S7=S9
SET S8=""
SET S9=""
+4 SET $PIECE(TRNODE(3),"^",6,9)=S6_"^"_S7_"^"_S8_"^"_S9
KILL S6,S7,S8,S9
QUIT
+5 ;
SC ;DISPLAY SCREEN
+1 WRITE @IOF,!?15,"1358 TRANSACTION - ",IOINHI,$PIECE(TRNODE(0),"^"),IOINLOW
+2 WRITE !!," COST CENTER: ",IOINHI,+$PIECE(TRNODE(3),"^",3),IOINLOW,?IOM-4\2,"AMOUNT: ",IOINHI,"$ ",$JUSTIFY($PIECE(TRNODE(4),"^"),0,2)
+3 WRITE !!,IOINLOW,"BOC #1: ",IOINHI,+$PIECE(TRNODE(3),"^",6),IOINLOW,?IOM-10\2,"AMOUNT #1: ",IOINHI,"$ "_$JUSTIFY($PIECE(TRNODE(3),"^",7),0,2)
+4 IF $PIECE(TRNODE(3),"^",8,9)'="^"
WRITE !!,IOINLOW,"BOC #2: ",IOINHI,+$PIECE(TRNODE(3),"^",8),?IOM-10\2,IOINLOW,"AMOUNT #2: ",IOINHI,"$ "_$JUSTIFY($PIECE(TRNODE(3),"^",9),0,2)
+5 WRITE !!,IOINLOW,"AUTHORITY: ",IOINHI,$PIECE($GET(^PRCS(410.9,+$PIECE($GET(TRNODE(11)),"^",4),0)),"^")," ",$PIECE($GET(^(0)),"^",2)
+6 if $PIECE($GET(TRNODE(11)),"^",5)
WRITE !,IOINLOW,"SUB: ",IOINHI,$PIECE($GET(^PRCS(410.9,+$PIECE($GET(TRNODE(11)),"^",5),0)),"^")," ",$PIECE($GET(^(0)),"^",2)
+7 ;PRC*5.1*196
WRITE !,IOINLOW,"DATE REQUIRED: ",IOINHI,$$FMTE^XLFDT($PIECE($GET(TRNODE(1)),"^",4))
+8 ;PRC*5.1*196
WRITE !,IOINLOW,"DATE COMMITTED: ",IOINHI,$$FMTE^XLFDT($PIECE($GET(TRNODE(4)),"^",2))
+9 WRITE !,IOINLOW,"SERVICE START DATE: ",IOINHI,$$FMTE^XLFDT($PIECE($GET(TRNODE(1)),"^",6))
+10 WRITE !,IOINLOW,"SERVICE END DATE: ",IOINHI,$$FMTE^XLFDT($PIECE($GET(TRNODE(1)),"^",7))
+11 WRITE IOINORM
if '$DATA(^PRCS(410,PRCFA("TRDA"),8,0))#2
QUIT
WRITE !!,IOINHI
KILL ^UTILITY($JOB,"W")
SET DIWF="W"
SET DIWL=1
SET DIWR=IOM*.75\1
SET N=0
FOR I=1:1
SET N=$ORDER(^PRCS(410,PRCFA("TRDA"),8,N))
if 'N
QUIT
SET X=^(N,0)
DO DIWP^PRCUTL($GET(DA))
+12 DO ^DIWW
DO DIWKILL^PRCFQ
WRITE IOINORM
QUIT
+13 SET $PIECE(^PRC(424,DA,0),"^",2,14)=X
SET DIK="^PRC(424,"
DO IX1^DIK
KILL DIK
SET %=1
QUIT
