- PRCELIQ ;WISC/CLH/CTB-LIQUIDATE 1358 ;9/14/95 11:40 [1/27/99 3:19pm]
- V ;;5.1;IFCAP;**180**;Oct 20, 2000;Build 5
- ;Per VHA Directive 2004-038, this routine should not be modified.
- ;
- ;PRC*5.1*180 RGB 10/22/12 Added switch PRCE424 coming from 1358 processing
- ;to insure new entry check (EN1^PRCSUT3) uses file 424, not file 410.
- ;
- EN K PO,PRCFA,PRC,X,X1,%,ER,Y,Z,CNT,IOINHI,IOINLOW,IOINORM,LD,LAMT,DIC,DIE,DR,DA
- S PRCF("X")="AS" D ^PRCFSITE Q:'%
- D LIQ^PRCH58LQ(.PRCFA,.Y,.ER,.PO)
- I 'ER G EXIT
- EN1 ;entry point when obligation number defined
- K ^TMP($J,"PRCE","LIQ")
- EN2 D SCREEN G EXIT:$D(OUT) S DIR("A")="Ok to post liquidation",DIR("B")="Yes",DIR(0)="YO" D ^DIR K DIR G:'Y EXIT
- S (X,Z)=$P(PO(0),"^") I '$D(^PRC(424,"C",PRCFA("PODA"))) W $C(7),!!,"This obligation has not yet established in the 1358 file." H 2 G EXIT
- S PRCE424=1 D EN1^PRCSUT3 K PRCE424 I $D(MSG),MSG'="" W !!,MSG K MSG G EXIT ;PRC*5.1*180
- S X1=X,DLAYGO=424,DIC="^PRC(424,",DIC(0)="LXZ" D ^DIC K DLAYGO I Y<0 W !!,"YOU DO NOT HAVE THE RIGHT SECURITY ACCESS CODE FOR THIS FILE!!",$C(7) H 3 G EXIT
- W !!,"This 1358 Liquidation entry is assigned entry number ",X1,"."
- S ZX1=X1,DA=+Y
- S DIR(0)="D^"_$E($P($G(PO(12)),U,5),1,7)_":"_DT_".235959"_":EST",DIR("A")="LIQUIDATION DATE",DIR("?")="Enter liquidation date or '^' to quit "
- S DIR("B")=$$DATE^PRCH58 D ^DIR K DIR I $D(DIRUT) D DEL G OUT
- S LD=Y
- R S DIR(0)="N^-999999999.99:999999999.99:2",DIR("A")="LIQUIDATION AMOUNT",DIR("?")="Enter the amount of this liquidation or '^' to QUIT"
- I $G(PRCFA("LIQAMT"))]"",+PRCFA("LIQAMT")'=0 S DIR("B")=PRCFA("LIQAMT")
- D ^DIR K DIR I $D(DIRUT) D DEL G OUT
- S LAMT=Y W " $",$FN(LAMT,",",2)
- I ($P(PO(8),U,2)+LAMT)>+PO(8) D OVER G R
- I '$D(Y) S DIR(0)="Y",DIR("A")="OK to Post",DIR("B")="Yes",DIR("?")="Enter 'Yes' to POST, 'No' or an '^' to DELETE and quit" D ^DIR K DIR I $D(DIRUT)!('Y) D DEL G OUT
- S DIE="^PRC(424,",DR=".1;1.1;.02////^S X=PRCFA(""PODA"");.03////^S X=""L"";.04////^S X=LAMT;.07////^S X=LD;.08////^S X=DUZ;.15////^S X=$G(PRCFA(""TRDA""))" D ^DIE
- D WAIT^PRCFYN,POST^PRCH58LQ(.PRCFA,LAMT,.PO) S ^TMP($J,"PRCE","LIQ",ZX1)=LAMT,X=" ---POSTED---" D MSG^PRCFQ
- I $D(PRCFD("PAYMENT")) S ^TMP("PRCFDA",$J,"LIQ")=-LAMT_U_PRCFA("PODA")_U_ZX1_U_DA
- OUT G:$D(PRCFD("PAYMENT")) EXIT W ! S DIR("A")="Would you like to enter another Liquidation for THIS OBLIGATION",DIR(0)="YO",DIR("B")="No"
- S DIR("?",1)="If you want to make further liquidations on this obligation",DIR("?")="enter (Y)es, <RETURN> or '^' to quit" D ^DIR K DIR I Y G EN2
- D SHOW
- S DIR("A")="Would you like to select another 1358 (obligation number)",DIR(0)="YO",DIR("?",1)="Enter yes to make liquidations on a different 1358 obligation"
- S DIR("?")="<RETURN> or '^' to quit",DIR("B")="Yes" D ^DIR K DIR I Y G EN
- EXIT K DIRUT,DTOUT,DUOUT,DIRUT,DIROUT,%,^TMP($J,"PRCE","LIQ"),ZX1
- Q
- SCREEN ;display balance data prior to posting
- K OUT S:'$D(CNT) CNT=0
- D HILO^PRCFQ W @IOF,IOINHI,"Post Liquidation to 1358",IOINLOW,?40,"Obligation #: ",IOINHI,$P(PO(0),"^")
- W !?20,IOINLOW,"Status: ",IOINHI,$S(+$P(PO(7),"^")>0:$P(^PRCD(442.3,$P(PO(7),"^"),0),"^"),1:"Unknown"),!!,IOINLOW,"Current amount obligated: ",IOINHI,"$ "_$FN($P(PO(8),U),",",2),IOINLOW
- W ?40," Authorization Balance: ",IOINHI,"$ "_$FN(+PO(8)-$P(PO(8),"^",3),",",2),IOINLOW,!!?41,"Unliquidated Balance: ",IOINHI,"$ "_$FN(+PO(8)-$P(PO(8),"^",2),",",2),IOINORM,!!
- S PRCUNLIQ=+PO(8)-(+$P(PO(8),U,2))
- S DIR(0)="YO",DIR("B")="No",DIR("A")="Do you wish to display/print the entire 1358"_$S($G(PRCOUNT)="":"",1:" again") D ^DIR K DIR I 'Y K PRCOUNT S OUT=""
- I Y S PRCSQ=1,DA=$P(PO(0),"^",12) D @$S($D(PRCFD("PAYMENT")):"EN1^PRCEFIS5",1:"^PRCEFIS5") K PRCSQ S PRCOUNT=1 G SCREEN
- K OUT
- Q
- OVER ;over drawn notice
- N X
- S X=LAMT+$P(PO(8),U,2)-PO(8)
- W !,$C(7),"This amount EXCEEDS available funds by $ ",$FN(X,",",2),".",!
- S X="Liquidating an amount this large CANNOT occur until the responsible service has submitted and Fiscal obligates an increase adjustment." D MSG^PRCFQ
- Q:$P($G(PO(0)),U,3)="" N MSG,XMSUB,XMDUZ,XMTEXT,CP,ZX S CP=+$P(PO(0),U,3)
- W !! S X="Control point being notified...." D MSG^PRCFQ W !!
- S MSG(1)=" *** NOTICE ***",MSG(2)=" ",MSG(3)="On "_$E(LD,4,5)_"/"_$E(LD,6,7)_"/"_$E(LD,2,3)_" Fiscal Service attempted to process a payment against"
- S MSG(4)="PAT#: "_$P($G(PO(0)),U)_" for $ "_$FN(LAMT,",",2)_". The payment WAS NOT processed due to",MSG(5)="INSUFFICIENT FUNDS on the obligation."
- S MSG(6)=" ",MSG(7)="Review and take appropriate action on the above PAT Reference Number."
- S MSG(8)="Payment CANNOT be processed until action has been taken."
- S XMTEXT="MSG(",XMSUB="1358 PAYMENT NOT PROCESSED"
- S ZX=0 F S ZX=$O(^PRC(420,PRC("SITE"),1,CP,1,ZX)) Q:'ZX I $P($G(^(ZX,0)),U,2)<3 S XMY(ZX)="",XMY(ZX,1)="I"
- D:$O(XMY(0)) ^XMD
- Q
- DEL S DIK="^PRC(424," D WAIT^PRCFYN,^DIK K DIK S X="Liquidation entry deleted*" D MSG^PRCFQ G EXIT
- ;
- SHOW ;show all transactions posted
- N ZDA,ZTOT
- Q:'$D(^TMP($J,"PRCE","LIQ"))
- S ZTOT=0 W:$D(IOF) @IOF,!!,?27,"Obligation #: ",$P(PO(0),"^")
- W !!,"Sequence #",?40,"Amount",!! S ZDA="" F S ZDA=$O(^TMP($J,"PRCE","LIQ",ZDA)) Q:'ZDA W ?6,$P(ZDA,"-",3),?36,$J(^TMP($J,"PRCE","LIQ",ZDA),10,2),! S ZTOT=ZTOT+^TMP($J,"PRCE","LIQ",ZDA)
- W !!,?29,"Total: ",$J(ZTOT,10,2),!!
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCELIQ 5310 printed Feb 18, 2025@23:27:51 Page 2
- PRCELIQ ;WISC/CLH/CTB-LIQUIDATE 1358 ;9/14/95 11:40 [1/27/99 3:19pm]
- V ;;5.1;IFCAP;**180**;Oct 20, 2000;Build 5
- +1 ;Per VHA Directive 2004-038, this routine should not be modified.
- +2 ;
- +3 ;PRC*5.1*180 RGB 10/22/12 Added switch PRCE424 coming from 1358 processing
- +4 ;to insure new entry check (EN1^PRCSUT3) uses file 424, not file 410.
- +5 ;
- EN KILL PO,PRCFA,PRC,X,X1,%,ER,Y,Z,CNT,IOINHI,IOINLOW,IOINORM,LD,LAMT,DIC,DIE,DR,DA
- +1 SET PRCF("X")="AS"
- DO ^PRCFSITE
- if '%
- QUIT
- +2 DO LIQ^PRCH58LQ(.PRCFA,.Y,.ER,.PO)
- +3 IF 'ER
- GOTO EXIT
- EN1 ;entry point when obligation number defined
- +1 KILL ^TMP($JOB,"PRCE","LIQ")
- EN2 DO SCREEN
- if $DATA(OUT)
- GOTO EXIT
- SET DIR("A")="Ok to post liquidation"
- SET DIR("B")="Yes"
- SET DIR(0)="YO"
- DO ^DIR
- KILL DIR
- if 'Y
- GOTO EXIT
- +1 SET (X,Z)=$PIECE(PO(0),"^")
- IF '$DATA(^PRC(424,"C",PRCFA("PODA")))
- WRITE $CHAR(7),!!,"This obligation has not yet established in the 1358 file."
- HANG 2
- GOTO EXIT
- +2 ;PRC*5.1*180
- SET PRCE424=1
- DO EN1^PRCSUT3
- KILL PRCE424
- IF $DATA(MSG)
- IF MSG'=""
- WRITE !!,MSG
- KILL MSG
- GOTO EXIT
- +3 SET X1=X
- SET DLAYGO=424
- SET DIC="^PRC(424,"
- SET DIC(0)="LXZ"
- DO ^DIC
- KILL DLAYGO
- IF Y<0
- WRITE !!,"YOU DO NOT HAVE THE RIGHT SECURITY ACCESS CODE FOR THIS FILE!!",$CHAR(7)
- HANG 3
- GOTO EXIT
- +4 WRITE !!,"This 1358 Liquidation entry is assigned entry number ",X1,"."
- +5 SET ZX1=X1
- SET DA=+Y
- +6 SET DIR(0)="D^"_$EXTRACT($PIECE($GET(PO(12)),U,5),1,7)_":"_DT_".235959"_":EST"
- SET DIR("A")="LIQUIDATION DATE"
- SET DIR("?")="Enter liquidation date or '^' to quit "
- +7 SET DIR("B")=$$DATE^PRCH58
- DO ^DIR
- KILL DIR
- IF $DATA(DIRUT)
- DO DEL
- GOTO OUT
- +8 SET LD=Y
- R SET DIR(0)="N^-999999999.99:999999999.99:2"
- SET DIR("A")="LIQUIDATION AMOUNT"
- SET DIR("?")="Enter the amount of this liquidation or '^' to QUIT"
- +1 IF $GET(PRCFA("LIQAMT"))]""
- IF +PRCFA("LIQAMT")'=0
- SET DIR("B")=PRCFA("LIQAMT")
- +2 DO ^DIR
- KILL DIR
- IF $DATA(DIRUT)
- DO DEL
- GOTO OUT
- +3 SET LAMT=Y
- WRITE " $",$FNUMBER(LAMT,",",2)
- +4 IF ($PIECE(PO(8),U,2)+LAMT)>+PO(8)
- DO OVER
- GOTO R
- +5 IF '$DATA(Y)
- SET DIR(0)="Y"
- SET DIR("A")="OK to Post"
- SET DIR("B")="Yes"
- SET DIR("?")="Enter 'Yes' to POST, 'No' or an '^' to DELETE and quit"
- DO ^DIR
- KILL DIR
- IF $DATA(DIRUT)!('Y)
- DO DEL
- GOTO OUT
- +6 SET DIE="^PRC(424,"
- SET DR=".1;1.1;.02////^S X=PRCFA(""PODA"");.03////^S X=""L"";.04////^S X=LAMT;.07////^S X=LD;.08////^S X=DUZ;.15////^S X=$G(PRCFA(""TRDA""))"
- DO ^DIE
- +7 DO WAIT^PRCFYN
- DO POST^PRCH58LQ(.PRCFA,LAMT,.PO)
- SET ^TMP($JOB,"PRCE","LIQ",ZX1)=LAMT
- SET X=" ---POSTED---"
- DO MSG^PRCFQ
- +8 IF $DATA(PRCFD("PAYMENT"))
- SET ^TMP("PRCFDA",$JOB,"LIQ")=-LAMT_U_PRCFA("PODA")_U_ZX1_U_DA
- OUT if $DATA(PRCFD("PAYMENT"))
- GOTO EXIT
- WRITE !
- SET DIR("A")="Would you like to enter another Liquidation for THIS OBLIGATION"
- SET DIR(0)="YO"
- SET DIR("B")="No"
- +1 SET DIR("?",1)="If you want to make further liquidations on this obligation"
- SET DIR("?")="enter (Y)es, <RETURN> or '^' to quit"
- DO ^DIR
- KILL DIR
- IF Y
- GOTO EN2
- +2 DO SHOW
- +3 SET DIR("A")="Would you like to select another 1358 (obligation number)"
- SET DIR(0)="YO"
- SET DIR("?",1)="Enter yes to make liquidations on a different 1358 obligation"
- +4 SET DIR("?")="<RETURN> or '^' to quit"
- SET DIR("B")="Yes"
- DO ^DIR
- KILL DIR
- IF Y
- GOTO EN
- EXIT KILL DIRUT,DTOUT,DUOUT,DIRUT,DIROUT,%,^TMP($JOB,"PRCE","LIQ"),ZX1
- +1 QUIT
- SCREEN ;display balance data prior to posting
- +1 KILL OUT
- if '$DATA(CNT)
- SET CNT=0
- +2 DO HILO^PRCFQ
- WRITE @IOF,IOINHI,"Post Liquidation to 1358",IOINLOW,?40,"Obligation #: ",IOINHI,$PIECE(PO(0),"^")
- +3 WRITE !?20,IOINLOW,"Status: ",IOINHI,$SELECT(+$PIECE(PO(7),"^")>0:$PIECE(^PRCD(442.3,$PIECE(PO(7),"^"),0),"^"),1:"Unknown"),!!,IOINLOW,"Current amount obligated: ",IOINHI,"$ "_$FNUMBER($PIECE(PO(8),U),",",2),IOINLOW
- +4 WRITE ?40," Authorization Balance: ",IOINHI,"$ "_$FNUMBER(+PO(8)-$PIECE(PO(8),"^",3),",",2),IOINLOW,!!?41,"Unliquidated Balance: ",IOINHI,"$ "_$FNUMBER(+PO(8)-$PIECE(PO(8),"^",2),",",2),IOINORM,!!
- +5 SET PRCUNLIQ=+PO(8)-(+$PIECE(PO(8),U,2))
- +6 SET DIR(0)="YO"
- SET DIR("B")="No"
- SET DIR("A")="Do you wish to display/print the entire 1358"_$SELECT($GET(PRCOUNT)="":"",1:" again")
- DO ^DIR
- KILL DIR
- IF 'Y
- KILL PRCOUNT
- SET OUT=""
- +7 IF Y
- SET PRCSQ=1
- SET DA=$PIECE(PO(0),"^",12)
- DO @$SELECT($DATA(PRCFD("PAYMENT")):"EN1^PRCEFIS5",1:"^PRCEFIS5")
- KILL PRCSQ
- SET PRCOUNT=1
- GOTO SCREEN
- +8 KILL OUT
- +9 QUIT
- OVER ;over drawn notice
- +1 NEW X
- +2 SET X=LAMT+$PIECE(PO(8),U,2)-PO(8)
- +3 WRITE !,$CHAR(7),"This amount EXCEEDS available funds by $ ",$FNUMBER(X,",",2),".",!
- +4 SET X="Liquidating an amount this large CANNOT occur until the responsible service has submitted and Fiscal obligates an increase adjustment."
- DO MSG^PRCFQ
- +5 if $PIECE($GET(PO(0)),U,3)=""
- QUIT
- NEW MSG,XMSUB,XMDUZ,XMTEXT,CP,ZX
- SET CP=+$PIECE(PO(0),U,3)
- +6 WRITE !!
- SET X="Control point being notified...."
- DO MSG^PRCFQ
- WRITE !!
- +7 SET MSG(1)=" *** NOTICE ***"
- SET MSG(2)=" "
- SET MSG(3)="On "_$EXTRACT(LD,4,5)_"/"_$EXTRACT(LD,6,7)_"/"_$EXTRACT(LD,2,3)_" Fiscal Service attempted to process a payment against"
- +8 SET MSG(4)="PAT#: "_$PIECE($GET(PO(0)),U)_" for $ "_$FNUMBER(LAMT,",",2)_". The payment WAS NOT processed due to"
- SET MSG(5)="INSUFFICIENT FUNDS on the obligation."
- +9 SET MSG(6)=" "
- SET MSG(7)="Review and take appropriate action on the above PAT Reference Number."
- +10 SET MSG(8)="Payment CANNOT be processed until action has been taken."
- +11 SET XMTEXT="MSG("
- SET XMSUB="1358 PAYMENT NOT PROCESSED"
- +12 SET ZX=0
- FOR
- SET ZX=$ORDER(^PRC(420,PRC("SITE"),1,CP,1,ZX))
- if 'ZX
- QUIT
- IF $PIECE($GET(^(ZX,0)),U,2)<3
- SET XMY(ZX)=""
- SET XMY(ZX,1)="I"
- +13 if $ORDER(XMY(0))
- DO ^XMD
- +14 QUIT
- DEL SET DIK="^PRC(424,"
- DO WAIT^PRCFYN
- DO ^DIK
- KILL DIK
- SET X="Liquidation entry deleted*"
- DO MSG^PRCFQ
- GOTO EXIT
- +1 ;
- SHOW ;show all transactions posted
- +1 NEW ZDA,ZTOT
- +2 if '$DATA(^TMP($JOB,"PRCE","LIQ"))
- QUIT
- +3 SET ZTOT=0
- if $DATA(IOF)
- WRITE @IOF,!!,?27,"Obligation #: ",$PIECE(PO(0),"^")
- +4 WRITE !!,"Sequence #",?40,"Amount",!!
- SET ZDA=""
- FOR
- SET ZDA=$ORDER(^TMP($JOB,"PRCE","LIQ",ZDA))
- if 'ZDA
- QUIT
- WRITE ?6,$PIECE(ZDA,"-",3),?36,$JUSTIFY(^TMP($JOB,"PRCE","LIQ",ZDA),10,2),!
- SET ZTOT=ZTOT+^TMP($JOB,"PRCE","LIQ",ZDA)
- +5 WRITE !!,?29,"Total: ",$JUSTIFY(ZTOT,10,2),!!
- +6 QUIT