- 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 Feb 18, 2025@23:27:55 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