PRCEADJ1 ;WISC/CLH/LDB/SJG-FISCAL 1358 ADJUSTMENTS ; 04/21/93 4:20 PM
V ;;5.1;IFCAP;**23,176**;Oct 20, 2000;Build 11
;Per VHA Directive 2004-038, this routine should not be modified
; Adjustment processing FISCAL
N PRC410,PRC442,DA,I,PO,PRC,PRCB,PRCF,PRCFA,DIC,TRNODE,X,Y,FSO,PX,TRDA,X1,PODA,NOGO
V1 D OUT S PRCF("X")="AB" D ^PRCFSITE Q:'%
D LU^PRCS58OB(.Y,.PRC,.PRCF) G:Y<0 OUT
S PRCFA("RETRAN")=0
RETRAN ; Entry point for rebuild/transmit
W !,"...retrieving 1358 information...",! D WAIT^DICD
S (DA,TRDA)=+Y
D NODE^PRCS58OB(DA,.TRNODE)
S (X,X1)=$P(TRNODE(4),U,5) D VER^PRCH58OB(.PRC,.X)
I X="" W !!,"Unable to Process due to lack of Obligation Number." G OUT
S PODA=X,PRC410=TRDA,PRC442=X,NOGO="" D OB1^PRCS58OB(TRDA,X)
D PO^PRCH58OB(PODA,.PO) S PO=PODA
D HILO^PRCFQ
FMSCHK ;
; Patch 23, disable obligation process for SO with "Q" & "T" status
I $D(PRCFA("RETRAN")),PRCFA("RETRAN")=0 D FMSTAT I $D(SOSTAT),("^Q^T^R^E^")[$E(SOSTAT,1),SOSTAT'="CALM" D G V1
.W !! K MSG S MSG(1)=" One of the previous documents has not been accepted in FMS."
.S MSG(2)=" The adjustment to this 1358 cannot be obligated at this time."
.S MSG(3)=" In order for the obligation of this adjustment to proceed, the"
.S MSG(4)=" previous document cannot have a status of 'REJECTED', 'ERROR"
.S MSG(5)=" IN TRANSMISSION', 'QUEUED FOR TRANSMISSION', or 'TRANSMITTED'.",MSG(6)=" "
.S MSG(7)=" FMS Document: "_SODOC,MSG(8)=" Status: "_SOSTAT,MSG(9)=" "
.S MSG(10)=" No further action is being taken on this obligation."
.D EN^DDIOL(.MSG) K MSG W !
.Q
SC W:$D(IOF) @IOF W "PROCESS 1358 ADJUSTMENT",?40,"Obligation #: ",IOINHI,$P(PO(0),"^")
W !!,IOINLOW," Service Balance: $ ",IOINHI,$FN(+PO(8)-$P(PO(8),"^",3),"P,",2)
W !,IOINLOW," Fiscal Balance: $ ",IOINHI,$FN(+PO(8)-$P(PO(8),"^",2),"P,",2)
W !,IOINLOW,"Amount of Adjustment: $ ",IOINHI,$FN($P(TRNODE(4),"^",8),",P",2)
W !!,IOINLOW,?20,"ORIGINAL",?45,"ADJUSTMENT"
W !!,IOINLOW," COST CENTER: ",?21,IOINHI,+$P(PO(0),"^",5),?48,+$P(TRNODE(3),"^",3) I +$P(PO(0),"^",5)'=+$P(TRNODE(3),"^",3) S NOGO=NOGO_3 W $C(7),?60,"*****"
W !!,IOINLOW,?10,"BOC #1:",?22,IOINHI,$P($P(PO(0),"^",6)," "),?49,$P($P(TRNODE(3),"^",6)," ") I +$P(PO(0),"^",6)'=+$P(TRNODE(3),"^",6) W $C(7),?60,"*****" S NOGO=NOGO_2
I +$P(PO(0),"^",8)>0!(+$P(TRNODE(3),"^",8)>0) W !,IOINLOW,?10,"BOC #2:",?22,IOINHI,$P($P(PO(0),"^",8)," "),?49,$P($P(TRNODE(3),"^",8)," ") I +$P(PO(0),"^",8)'=+$P(TRNODE(3),"^",8) W $C(7),?60,"*****" S NOGO=NOGO_2
W IOINORM
I NOGO[2 D SUB G OUT ;G:'Y V D SAEDIT^PRCS58OB(.PO,TRDA) S I=4
I NOGO[3 D CC G OUT
CHECK ; Check adjustment amount with obligation/liquidation/authorization amounts
I PRC442,+$G(PRCFA("RETRAN"))=0,$$EN1^PRCE0A(PRC410,PRC442,1) W !,$C(7),"Send 1358 adjustment back to service.",! G OUT
S PRCFA("MOD")="M^1^Modification Entry"
W ! D VENCONM^PRCFFU15(+PO)
D EN^PRCFFU14(TRDA) I ACCEDIT G SC
D AUTACC^PRCFFU6 S PRCFA("ACCEDIT")=1
N Y S PRCFA("IDES")="1358 Obligation Adjustment" W ! D OKAY^PRCFFU
; Patch 23, fix Y undef error
;I Y K DIR,Y D ^PRCESOM I $D(PRCFA("RETRAN")),PRCFA("RETRAN")=0 G V1
I Y K DIR,Y D ^PRCESOM G:'$G(PRCFA("RETRAN")) V1 S Y=0 ; patch 23
I 'Y!($D(DIRUT)) W ! D EN^DDIOL("No further processing is being taken on this adjustment.")
OUT K DTOUT,DIR,DUOUT,DIRUT,DIROUT
I $G(PRC410) L -^PRCS(410,PRC410) ;Unlock when exiting opiton, PRC*5.1*176
OUT1 K DA,D0,ACCEDIT,BBFY,BEGDATE,CONT,CONTEND,CONTIEN,ENDDATE,ESIGMSG,EXIT
K FMSMOD,FMSVENID,GECSFMS,I,NEWACC,NEWDATE,NOGO
K NUMB,OB,PARAM1,PO,PODA,PODATE,POIEN,PRC410,PRC442,PRCCC,PRCCCC,PRCCSCC
K PRCCP,PRCFA,PRCFMO,PRCREQST,PRCSTA,PRCSTR,PRCTMP,SODOC,SOSTAT
K STR2,TMP410,TMP442,TRDA,TRNODE,VENCONT,X,X1
Q
FMSTAT ; Check status of prior FMS Documments
D FMSTAT^PRCEADJ(+PO,.SODOC,.SOSTAT)
Q
SUB ; Check BOCs (subaccounts)
K MSG W !!
S MSG(1)=" BOCs on the adjustment are not the same as on the original obligation."
S MSG(2)=" Processing cannot continue - please return to the Service for correction.",MSG(3)=" "
S MSG(4)=" No further processing is being taken on this adjustment."
D MSG(.MSG)
Q
CC ; Check Cost Centers
K MSG W !!
S MSG(1)=" Cost Center on the adjustment is not the same as on the original"
S MSG(2)=" obligation. Processing cannot continue - please return to the"
S MSG(3)=" Service for correction.",MSG(4)=" "
S MSG(5)=" No further processing is being taken on this adjustment."
D MSG(.MSG)
Q
MSG(X) ; Display message
Q:'$D(MSG)
D EN^DDIOL(.MSG),ENCON^PRCFQ
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCEADJ1 4580 printed Oct 16, 2024@18:01:59 Page 2
PRCEADJ1 ;WISC/CLH/LDB/SJG-FISCAL 1358 ADJUSTMENTS ; 04/21/93 4:20 PM
V ;;5.1;IFCAP;**23,176**;Oct 20, 2000;Build 11
+1 ;Per VHA Directive 2004-038, this routine should not be modified
+2 ; Adjustment processing FISCAL
+3 NEW PRC410,PRC442,DA,I,PO,PRC,PRCB,PRCF,PRCFA,DIC,TRNODE,X,Y,FSO,PX,TRDA,X1,PODA,NOGO
V1 DO OUT
SET PRCF("X")="AB"
DO ^PRCFSITE
if '%
QUIT
+1 DO LU^PRCS58OB(.Y,.PRC,.PRCF)
if Y<0
GOTO OUT
+2 SET PRCFA("RETRAN")=0
RETRAN ; Entry point for rebuild/transmit
+1 WRITE !,"...retrieving 1358 information...",!
DO WAIT^DICD
+2 SET (DA,TRDA)=+Y
+3 DO NODE^PRCS58OB(DA,.TRNODE)
+4 SET (X,X1)=$PIECE(TRNODE(4),U,5)
DO VER^PRCH58OB(.PRC,.X)
+5 IF X=""
WRITE !!,"Unable to Process due to lack of Obligation Number."
GOTO OUT
+6 SET PODA=X
SET PRC410=TRDA
SET PRC442=X
SET NOGO=""
DO OB1^PRCS58OB(TRDA,X)
+7 DO PO^PRCH58OB(PODA,.PO)
SET PO=PODA
+8 DO HILO^PRCFQ
FMSCHK ;
+1 ; Patch 23, disable obligation process for SO with "Q" & "T" status
+2 IF $DATA(PRCFA("RETRAN"))
IF PRCFA("RETRAN")=0
DO FMSTAT
IF $DATA(SOSTAT)
IF ("^Q^T^R^E^")[$EXTRACT(SOSTAT,1)
IF SOSTAT'="CALM"
Begin DoDot:1
+3 WRITE !!
KILL MSG
SET MSG(1)=" One of the previous documents has not been accepted in FMS."
+4 SET MSG(2)=" The adjustment to this 1358 cannot be obligated at this time."
+5 SET MSG(3)=" In order for the obligation of this adjustment to proceed, the"
+6 SET MSG(4)=" previous document cannot have a status of 'REJECTED', 'ERROR"
+7 SET MSG(5)=" IN TRANSMISSION', 'QUEUED FOR TRANSMISSION', or 'TRANSMITTED'."
SET MSG(6)=" "
+8 SET MSG(7)=" FMS Document: "_SODOC
SET MSG(8)=" Status: "_SOSTAT
SET MSG(9)=" "
+9 SET MSG(10)=" No further action is being taken on this obligation."
+10 DO EN^DDIOL(.MSG)
KILL MSG
WRITE !
+11 QUIT
End DoDot:1
GOTO V1
SC if $DATA(IOF)
WRITE @IOF
WRITE "PROCESS 1358 ADJUSTMENT",?40,"Obligation #: ",IOINHI,$PIECE(PO(0),"^")
+1 WRITE !!,IOINLOW," Service Balance: $ ",IOINHI,$FNUMBER(+PO(8)-$PIECE(PO(8),"^",3),"P,",2)
+2 WRITE !,IOINLOW," Fiscal Balance: $ ",IOINHI,$FNUMBER(+PO(8)-$PIECE(PO(8),"^",2),"P,",2)
+3 WRITE !,IOINLOW,"Amount of Adjustment: $ ",IOINHI,$FNUMBER($PIECE(TRNODE(4),"^",8),",P",2)
+4 WRITE !!,IOINLOW,?20,"ORIGINAL",?45,"ADJUSTMENT"
+5 WRITE !!,IOINLOW," COST CENTER: ",?21,IOINHI,+$PIECE(PO(0),"^",5),?48,+$PIECE(TRNODE(3),"^",3)
IF +$PIECE(PO(0),"^",5)'=+$PIECE(TRNODE(3),"^",3)
SET NOGO=NOGO_3
WRITE $CHAR(7),?60,"*****"
+6 WRITE !!,IOINLOW,?10,"BOC #1:",?22,IOINHI,$PIECE($PIECE(PO(0),"^",6)," "),?49,$PIECE($PIECE(TRNODE(3),"^",6)," ")
IF +$PIECE(PO(0),"^",6)'=+$PIECE(TRNODE(3),"^",6)
WRITE $CHAR(7),?60,"*****"
SET NOGO=NOGO_2
+7 IF +$PIECE(PO(0),"^",8)>0!(+$PIECE(TRNODE(3),"^",8)>0)
WRITE !,IOINLOW,?10,"BOC #2:",?22,IOINHI,$PIECE($PIECE(PO(0),"^",8)," "),?49,$PIECE($PIECE(TRNODE(3),"^",8)," ")
IF +$PIECE(PO(0),"^",8)'=+$PIECE(TRNODE(3),"^",8)
WRITE $CHAR(7),?60,"*****"
SET NOGO=NOGO_2
+8 WRITE IOINORM
+9 ;G:'Y V D SAEDIT^PRCS58OB(.PO,TRDA) S I=4
IF NOGO[2
DO SUB
GOTO OUT
+10 IF NOGO[3
DO CC
GOTO OUT
CHECK ; Check adjustment amount with obligation/liquidation/authorization amounts
+1 IF PRC442
IF +$GET(PRCFA("RETRAN"))=0
IF $$EN1^PRCE0A(PRC410,PRC442,1)
WRITE !,$CHAR(7),"Send 1358 adjustment back to service.",!
GOTO OUT
+2 SET PRCFA("MOD")="M^1^Modification Entry"
+3 WRITE !
DO VENCONM^PRCFFU15(+PO)
+4 DO EN^PRCFFU14(TRDA)
IF ACCEDIT
GOTO SC
+5 DO AUTACC^PRCFFU6
SET PRCFA("ACCEDIT")=1
+6 NEW Y
SET PRCFA("IDES")="1358 Obligation Adjustment"
WRITE !
DO OKAY^PRCFFU
+7 ; Patch 23, fix Y undef error
+8 ;I Y K DIR,Y D ^PRCESOM I $D(PRCFA("RETRAN")),PRCFA("RETRAN")=0 G V1
+9 ; patch 23
IF Y
KILL DIR,Y
DO ^PRCESOM
if '$GET(PRCFA("RETRAN"))
GOTO V1
SET Y=0
+10 IF 'Y!($DATA(DIRUT))
WRITE !
DO EN^DDIOL("No further processing is being taken on this adjustment.")
OUT KILL DTOUT,DIR,DUOUT,DIRUT,DIROUT
+1 ;Unlock when exiting opiton, PRC*5.1*176
IF $GET(PRC410)
LOCK -^PRCS(410,PRC410)
OUT1 KILL DA,D0,ACCEDIT,BBFY,BEGDATE,CONT,CONTEND,CONTIEN,ENDDATE,ESIGMSG,EXIT
+1 KILL FMSMOD,FMSVENID,GECSFMS,I,NEWACC,NEWDATE,NOGO
+2 KILL NUMB,OB,PARAM1,PO,PODA,PODATE,POIEN,PRC410,PRC442,PRCCC,PRCCCC,PRCCSCC
+3 KILL PRCCP,PRCFA,PRCFMO,PRCREQST,PRCSTA,PRCSTR,PRCTMP,SODOC,SOSTAT
+4 KILL STR2,TMP410,TMP442,TRDA,TRNODE,VENCONT,X,X1
+5 QUIT
FMSTAT ; Check status of prior FMS Documments
+1 DO FMSTAT^PRCEADJ(+PO,.SODOC,.SOSTAT)
+2 QUIT
SUB ; Check BOCs (subaccounts)
+1 KILL MSG
WRITE !!
+2 SET MSG(1)=" BOCs on the adjustment are not the same as on the original obligation."
+3 SET MSG(2)=" Processing cannot continue - please return to the Service for correction."
SET MSG(3)=" "
+4 SET MSG(4)=" No further processing is being taken on this adjustment."
+5 DO MSG(.MSG)
+6 QUIT
CC ; Check Cost Centers
+1 KILL MSG
WRITE !!
+2 SET MSG(1)=" Cost Center on the adjustment is not the same as on the original"
+3 SET MSG(2)=" obligation. Processing cannot continue - please return to the"
+4 SET MSG(3)=" Service for correction."
SET MSG(4)=" "
+5 SET MSG(5)=" No further processing is being taken on this adjustment."
+6 DO MSG(.MSG)
+7 QUIT
MSG(X) ; Display message
+1 if '$DATA(MSG)
QUIT
+2 DO EN^DDIOL(.MSG)
DO ENCON^PRCFQ
+3 QUIT
