- PRCFDA ;WISC@ALTOONA/CTB-PROCESS PAYMENT IN ACCTG ;2/9/96 15:58 [2/1/99 2:26pm]
- V ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- N PRCFCIDA,PRCFFLG K ^TMP("PRCFDA",$J,"LIQ")
- Q:$D(PRCFA("ERROR PROCESSING")) S PRCF("X")="AS" D ^PRCFSITE Q:'%
- S DIC("S")="S ZX=^(0),ZX2=$G(^(2)) I $P(ZX2,U)=15,$P(ZX,U,15)]"""""
- S DIC=421.5,DIC(0)="AEMNZ" D ^DIC K DIC,ZX2,ZX
- I Y<1!$D(DTOUT)!$D(DUOUT) K PRC,C,PRCRI,X,Y,% G:$$NUMSTA>1&'$D(DTOUT)&'$D(DUOUT) PRCFDA K DTOUT,DUOUT Q
- EN S (PRCF("CIDA"),PRCFDICA)=+Y,PRC("SITE")=$P(^PRCF(421.5,PRCF("CIDA"),1),U,2)
- G:$D(PRCFA("ERROR PROCESSING")) B
- L +^PRCF(421.5,PRCF("CIDA")):5 E W !,"This invoice is being edited by someone else, please try later!" G EX^PRCFDA2
- S:$P($G(^PRCF(421.5,PRCF("CIDA"),1)),U,7)]"" PRCFA("ERROR PROCESSING")=2
- I '$D(PRCFA("ERROR PROCESSING")),$$CLSD1358^PRCFDE2($P(Y(0),U,7),1) D G:%'=1 EX^PRCFDA2
- . W ! S %A="Do you wish to continue processing this invoice now"
- . S %B="",%=2 D ^PRCFYN
- S DIR(0)="YA",DIR("A")="Do you wish to view current information for this invoice? "
- S DIR("B")="NO" D ^DIR K DIR I $D(DIRUT)!$D(DIROUT)!$D(DUOUT) G EX^PRCFDA2
- I Y=1 D I Y'=1!$D(DIRUT)!$D(DIROUT)!$D(DUOUT) G EX^PRCFDA2
- . N PRCRI,RECORD,RECORD1,DR,DIQ,DA,DIC,DIR
- . S DA=PRCF("CIDA"),DIC="^PRCF(421.5,",DIQ(0)="C",PRCF("VIEW")="" W @IOF
- . D EN^DIQ K PRCF("VIEW")
- . S DIR(0)="YA",DIR("A")="Is this the correct invoice? ",DIR("B")="YES" D ^DIR
- B I $P(^PRCF(421.5,PRCF("CIDA"),0),U,6)="X" D G:Y<0 EX^PRCFDA2
- . S %A="This invoice is flagged as MONEY MANAGEMENT EXEMPT. Return to Voucher Audit for review/correction"
- . S %B="",%=1 D ^PRCFYN Q:%=2
- . I %=1 S X=0 D STATUS^PRCFDE1
- . S Y=-1 Q
- ;GET AMOUNT CERTIFIED
- S PRCFD("CAMT")=$P(^PRCF(421.5,PRCF("CIDA"),0),U,15)
- S PRCF("PODA")=$P(^PRCF(421.5,PRCF("CIDA"),0),U,7)
- I PRCF("PODA")]"" D
- . S PRCFD("PAYMENT")="",PRCFA("PODA")=PRCF("PODA")
- . S PRCFA("REF")=$P($G(^PRCF(421.5,PRCF("CIDA"),2)),U,2)
- . S PRCFA("LIQAMT")=PRCFD("CAMT")/100
- . S PRCFX("SITE")=PRC("SITE"),PRCFX("PER")=PRC("PER")
- . S PRCFX("FY")=PRC("FY"),PRCFX("PARAM")=PRC("PARAM")
- . D:'$D(PRCFA("ERROR PROCESSING")) ^PRCEFIS4 I '$D(PRC("SITE")) D
- . . S PRC("SITE")=PRCFX("SITE"),PRC("PER")=PRCFX("PER")
- . . S PRC("FY")=PRCFX("FY"),PRC("PARAM")=PRCFX("PARAM")
- . . Q
- . K PO,PODA,PRCFD("PAYMENT"),PRCFA("PODA"),PRCFA("REF"),PRCFA("LIQAMT")
- . ; Build table of FMS Line Nos. & Obligation Amts. by BOCs:
- . K PRCFX N BOC,FMSLN,IEN S BOC=""
- . F S BOC=$O(^PRC(442,PRCF("PODA"),22,"B",BOC)) Q:BOC="" S IEN="" D
- . . I BOC>0 F S IEN=$O(^PRC(442,PRCF("PODA"),22,"B",BOC,IEN)) Q:IEN="" D
- . . . S FMSLN=$P($G(^PRC(442,PRCF("PODA"),22,IEN,0)),U,2,3)
- . . . S PRCFX("SA",BOC,IEN)=FMSLN
- . . . Q
- . . Q
- . S PRCFX("SHBOC")=+$G(^PRC(442,PRCF("PODA"),23))
- . S PRCFX("SHAMT")=+$P(^PRC(442,PRCF("PODA"),0),U,13)
- . I PRCFX("SHBOC") S I="" F S I=$O(PRCFX("SA",PRCFX("SHBOC"),I)) Q:I="" I $P(PRCFX("SA",PRCFX("SHBOC"),I),U,2)=991 S $P(PRCFX("SA",PRCFX("SHBOC"),I),U,3)=PRCFX("SHAMT")
- . Q
- S PRCF("CAMT")=$P(^PRCF(421.5,PRCF("CIDA"),0),U,15)
- D SUMM
- BOC ; Ask for BOC
- N CNT,CNT1,PRCFEEE,PRCFEX,PRCFEXIT,PRCFN,PRCFNO
- S PRCFNO="",CNT1=0
- F S PRCFNO=$O(PRCFX("SA",PRCFNO)) Q:PRCFNO="" S CNT1=CNT1+1,BOC=PRCFNO
- I CNT1=1 D ASK2^PRCFDA2 Q:$D(DIRUT) S DA=$G(PRCFNUM) G:$G(PRCFEXIT)&($G(PRCFFLG)) DOC G:'$G(PRCFFLG) EXIT
- I CNT1<1 W !!?5,"There are no BOCs on this obligation, processing terminated." G EX^PRCFDA2
- I CNT1>1 D ASK^PRCFDA2 Q:$D(DIRUT) S DA=$G(PRCFNUM) G:$G(PRCFEX)&($G(PRCFFLG)) DOC G:'$G(PRCFFLG) EXIT
- I $G(PRCFCIDA)']"",($G(PRCF("CIDA"))']"") W !!?15,"Exiting." Q
- I $G(PRCF("CIDA"))']"" S PRCF("CIDA")=PRCFCIDA
- I '$D(^PRCF(421.5,PRCF("CIDA"),5,0)) S ^PRCF(421.5,PRCF("CIDA"),5,0)="^"_$P(^DD(421.5,41,0),U,2)
- I '$D(^PRCF(421.5,PRCF("CIDA"),5,$G(PRCFNUM),0)) D
- . S ^PRCF(421.5,PRCF("CIDA"),5,"B",BOC,PRCFNUM)=""
- . S $P(^PRCF(421.5,PRCF("CIDA"),5,0),U,3)=PRCFNUM
- . S $P(^PRCF(421.5,PRCF("CIDA"),5,0),U,4)=$P(^PRCF(421.5,PRCF("CIDA"),5,0),U,4)+1
- . S ^PRCF(421.5,PRCF("CIDA"),5,PRCFNUM,0)=BOC
- S DA(1)=PRCF("CIDA")
- S DIE="^PRCF(421.5,"_DA(1)_",5,"
- S DR=".01///^S X=BOC;4///^S X=$P(PRCFX(""SA"",BOC,PRCFNUM),U,2)"
- ; if one BOC has goods/serv and shipping, stuff corrected amt in
- ; accouting line amount
- I CNT1=1 D
- . S PRCFEEE=0 S PRCFEEE=$O(PRCFX("SA",BOC,PRCFEEE)) I PRCFEEE]"",($O(PRCFX("SA",BOC,PRCFEEE))]"") D
- . . I $P(PRCFX("SA",BOC,PRCFNUM),U,2)'=991 S PRCFN=PRCF("CAMT")-$P(^PRCF(421.5,PRCF("CIDA"),0),U,14)
- . . I $P(PRCFX("SA",BOC,PRCFNUM),U,2)=991 S PRCFN=$P(^PRCF(421.5,PRCF("CIDA"),0),U,14)
- . . S DR=DR_";1///^S X=$G(PRCFN)/100"
- . . Q
- . Q
- D ^DIE I $D(Y)!$D(DTOUT) G OT
- K DA,DIE,DR
- EDIT ; edit the FMS line entry in 421.5
- S DA=PRCFNUM
- S DA(1)=PRCF("CIDA")
- S DIE="^PRCF(421.5,"_DA(1)_",5,"
- S PRCFA("LNO")=+$P(PRCFX("SA",BOC,PRCFNUM),U,2)
- W !,"FMS Line # ",PRCFA("LNO")
- S PRCFA("AMT")=$FN($P(PRCFX("SA",BOC,PRCFNUM),U),"",2)
- W !,"OBLIGATION AMOUNT: ",PRCFA("AMT")
- S DR="1//^S X=$S($G(PRCF(""CAMT""))/100>PRCFA(""AMT""):PRCFA(""AMT""),1:$G(PRCF(""CAMT""))/100)"
- D ^DIE K DR I $D(Y)!$D(DTOUT) G OT
- S X=$FN(X,"",2)
- S PRCFA("LAMT")=X
- D DISC^PRCFDT
- I PRCFA("LIQ")>PRCFA("AMT") W !,"Warning - Computed Liquidation amt of $",$FN(PRCFA("LIQ"),"",2)," exceeds",!?5,"total obligated amt of $",$FN(PRCFA("AMT"),"",2)," for BOC ",BOC," on ",$P($G(^PRCF(421.5,PRCF("CIDA"),1)),U,3),"."
- I PRCFA("LIQ")'=PRCFA("AMT") S DR="2////@" D ^DIE K DR
- S DR="2//^S X=$G(PRCFA(""LIQ""))" D ^DIE K DR I $D(Y)!$D(DTOUT) G OT
- S PRCFA("LIQ")=X,PRCFA("PF")=""
- I +PRCFA("AMT")=+PRCFA("LIQ") S PRCFA("PF")="F"
- I +PRCFA("AMT")>+PRCFA("LIQ") S PRCFA("PF")="P"
- S DR="3//^S X=$G(PRCFA(""PF""))" D ^DIE K DR I $D(Y)!$D(DTOUT) G OT
- D SUM^PRCFDT I '$G(OK) W !!?2,"****WARNING**** - Certified Invoice total $",$FN(PRCF("CAMT")/100,"",2)," does not match sum of",!,"Line Amounts: $",$FN(PRCF("TAMT"),"",2)
- I '$G(OK) W !?7,"If you believe that the Total Invoice Amount Certified for",!,"payment is incorrect, the invoice should be returned to voucher audit",!,"for review." G BOC
- I +PRCF("TAMT")=0 W !?2,"There are no Line Amounts - FMS will not accept this!"
- G DOC
- DOC ;PROCESS FMS DOC
- I '$$OBLIG^PRCFDT(.PRC10DA) D G EX^PRCFDA2
- . I '$D(PRCF("PO")) S PRCF("PO")=$P($G(^PRC(442,PRCF("PODA"),0)),U,1)
- . S X=" An original FMS SO or MO document could not be found for "
- . S X=X_PRCF("PO")_".*" D MSG^PRCFQ
- . S X=" Please review obligation history for this Purchase Order.*"
- . D MSG^PRCFQ,PAUSE^PRCFDPVU
- . Q
- ;D AUTOACCR^PRCFDA4 G:$D(Y)!$D(DTOUT) EX^PRCFDA2 ;per Lyford SOAR
- K %A,%B S %A="OK to process this payment to FMS",%B="",%=2
- D ^PRCFYN G OT:%<1
- I %=2,($G(PRCFFLG)=2) G OT
- I %=2 G BOC
- G ^PRCFDA2
- SUMM ; Display Accounting Summary - Entry Point from Input Template
- D:$D(PRCFX("SA"))
- . N BOC,I,J,SHIP,SUBTOT
- . W !,"Unliquidated obligation amounts and BOCs on this order are:"
- . I $G(PRCUNLIQ)]"" D
- . . S SUBTOT=PRCUNLIQ
- . . S BOC=$O(PRCFX("SA",0)) S BOC=$P($G(^PRCD(420.2,+BOC,0)),U)
- . . W:$G(SUBTOT)]"" !,$J("$"_$FN(SUBTOT,",",2),10) S SUBTOT=0
- . . W:$G(BOC)]"" ?12,BOC
- . . Q
- . I $G(PRCUNLIQ)']"" S I="",SUBTOT=0 F S I=$O(PRCFX("SA",I)) Q:I="" D
- . . S J="" F S J=$O(PRCFX("SA",I,J)) Q:J="" D
- . . . S SUBTOT=SUBTOT+$P(PRCFX("SA",I,J),U)
- . . . S BOC=$P($G(^PRCD(420.2,+I,0)),U),SHIP=$P(PRCFX("SA",I,J),U,3)
- . . W:I !,$J("$"_$FN(SUBTOT,",",2),10) S SUBTOT=0
- . . S:SHIP BOC=$E(BOC,1,30) W ?12,BOC
- . . W:SHIP ?40," **(Includes $",$FN(PRCFX("SHAMT"),",",2)
- . . W:SHIP " shipping.)"
- . . Q
- . K PRCUNLIQ
- . W !,"Total Invoice Amount Certified for Payment=$"
- . W $J(PRCF("CAMT")/100,0,2)
- . Q
- Q
- OT D UNP K ^TMP("PRCFDA",$J,"LIQ")
- S X=" <Option Terminated.>*" D MSG^PRCFQ G EX^PRCFDA2
- NUMSTA() ;Determine number of unique stations in IFCAP system
- N X,I S X="",I=0
- F S X=$O(^PRC(411,"B",X)) Q:X'?1.N S I=I+1
- Q I
- EXIT ; IF NO fms line BOC chosen,display message and exit
- W ! D G EX^PRCFDA2
- . S X=" Edit exited abnormally. Action terminated.*" D MSG^PRCFQ
- . S %A="Do you want to return this invoice to Voucher Audit"
- . S %B="",%=2 D ^PRCFYN I %=1 S X=10 D STATUS^PRCFDE1
- . Q
- Q
- UNP ; Check for posted liquidation amounts and unpost
- S X=$G(^TMP("PRCFDA",$J,"LIQ"))
- Q:X="" N DA,DIK,LAMT,PO,PRCFA,ZX1
- S LAMT=$P(X,U,1),PRCFA("PODA")=$P(X,U,2),ZX1=$P(X,U,3),DA=$P(X,U,4)
- S DIK="^PRC(424," D ^DIK
- D POST^PRCH58LQ(.PRCFA,.LAMT,.PO)
- W !!,"Liquidation # ",ZX1," for ",$FN(LAMT,",",2)," has been deleted and unposted."
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFDA 8566 printed Mar 13, 2025@21:07:32 Page 2
- PRCFDA ;WISC@ALTOONA/CTB-PROCESS PAYMENT IN ACCTG ;2/9/96 15:58 [2/1/99 2:26pm]
- V ;;5.1;IFCAP;;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 NEW PRCFCIDA,PRCFFLG
- KILL ^TMP("PRCFDA",$JOB,"LIQ")
- +3 if $DATA(PRCFA("ERROR PROCESSING"))
- QUIT
- SET PRCF("X")="AS"
- DO ^PRCFSITE
- if '%
- QUIT
- +4 SET DIC("S")="S ZX=^(0),ZX2=$G(^(2)) I $P(ZX2,U)=15,$P(ZX,U,15)]"""""
- +5 SET DIC=421.5
- SET DIC(0)="AEMNZ"
- DO ^DIC
- KILL DIC,ZX2,ZX
- +6 IF Y<1!$DATA(DTOUT)!$DATA(DUOUT)
- KILL PRC,C,PRCRI,X,Y,%
- if $$NUMSTA>1&'$D(DTOUT)&'$DATA(DUOUT)
- GOTO PRCFDA
- KILL DTOUT,DUOUT
- QUIT
- EN SET (PRCF("CIDA"),PRCFDICA)=+Y
- SET PRC("SITE")=$PIECE(^PRCF(421.5,PRCF("CIDA"),1),U,2)
- +1 if $DATA(PRCFA("ERROR PROCESSING"))
- GOTO B
- +2 LOCK +^PRCF(421.5,PRCF("CIDA")):5
- IF '$TEST
- WRITE !,"This invoice is being edited by someone else, please try later!"
- GOTO EX^PRCFDA2
- +3 if $PIECE($GET(^PRCF(421.5,PRCF("CIDA"),1)),U,7)]""
- SET PRCFA("ERROR PROCESSING")=2
- +4 IF '$DATA(PRCFA("ERROR PROCESSING"))
- IF $$CLSD1358^PRCFDE2($PIECE(Y(0),U,7),1)
- Begin DoDot:1
- +5 WRITE !
- SET %A="Do you wish to continue processing this invoice now"
- +6 SET %B=""
- SET %=2
- DO ^PRCFYN
- End DoDot:1
- if %'=1
- GOTO EX^PRCFDA2
- +7 SET DIR(0)="YA"
- SET DIR("A")="Do you wish to view current information for this invoice? "
- +8 SET DIR("B")="NO"
- DO ^DIR
- KILL DIR
- IF $DATA(DIRUT)!$DATA(DIROUT)!$DATA(DUOUT)
- GOTO EX^PRCFDA2
- +9 IF Y=1
- Begin DoDot:1
- +10 NEW PRCRI,RECORD,RECORD1,DR,DIQ,DA,DIC,DIR
- +11 SET DA=PRCF("CIDA")
- SET DIC="^PRCF(421.5,"
- SET DIQ(0)="C"
- SET PRCF("VIEW")=""
- WRITE @IOF
- +12 DO EN^DIQ
- KILL PRCF("VIEW")
- +13 SET DIR(0)="YA"
- SET DIR("A")="Is this the correct invoice? "
- SET DIR("B")="YES"
- DO ^DIR
- End DoDot:1
- IF Y'=1!$DATA(DIRUT)!$DATA(DIROUT)!$DATA(DUOUT)
- GOTO EX^PRCFDA2
- B IF $PIECE(^PRCF(421.5,PRCF("CIDA"),0),U,6)="X"
- Begin DoDot:1
- +1 SET %A="This invoice is flagged as MONEY MANAGEMENT EXEMPT. Return to Voucher Audit for review/correction"
- +2 SET %B=""
- SET %=1
- DO ^PRCFYN
- if %=2
- QUIT
- +3 IF %=1
- SET X=0
- DO STATUS^PRCFDE1
- +4 SET Y=-1
- QUIT
- End DoDot:1
- if Y<0
- GOTO EX^PRCFDA2
- +5 ;GET AMOUNT CERTIFIED
- +6 SET PRCFD("CAMT")=$PIECE(^PRCF(421.5,PRCF("CIDA"),0),U,15)
- +7 SET PRCF("PODA")=$PIECE(^PRCF(421.5,PRCF("CIDA"),0),U,7)
- +8 IF PRCF("PODA")]""
- Begin DoDot:1
- +9 SET PRCFD("PAYMENT")=""
- SET PRCFA("PODA")=PRCF("PODA")
- +10 SET PRCFA("REF")=$PIECE($GET(^PRCF(421.5,PRCF("CIDA"),2)),U,2)
- +11 SET PRCFA("LIQAMT")=PRCFD("CAMT")/100
- +12 SET PRCFX("SITE")=PRC("SITE")
- SET PRCFX("PER")=PRC("PER")
- +13 SET PRCFX("FY")=PRC("FY")
- SET PRCFX("PARAM")=PRC("PARAM")
- +14 if '$DATA(PRCFA("ERROR PROCESSING"))
- DO ^PRCEFIS4
- IF '$DATA(PRC("SITE"))
- Begin DoDot:2
- +15 SET PRC("SITE")=PRCFX("SITE")
- SET PRC("PER")=PRCFX("PER")
- +16 SET PRC("FY")=PRCFX("FY")
- SET PRC("PARAM")=PRCFX("PARAM")
- +17 QUIT
- End DoDot:2
- +18 KILL PO,PODA,PRCFD("PAYMENT"),PRCFA("PODA"),PRCFA("REF"),PRCFA("LIQAMT")
- +19 ; Build table of FMS Line Nos. & Obligation Amts. by BOCs:
- +20 KILL PRCFX
- NEW BOC,FMSLN,IEN
- SET BOC=""
- +21 FOR
- SET BOC=$ORDER(^PRC(442,PRCF("PODA"),22,"B",BOC))
- if BOC=""
- QUIT
- SET IEN=""
- Begin DoDot:2
- +22 IF BOC>0
- FOR
- SET IEN=$ORDER(^PRC(442,PRCF("PODA"),22,"B",BOC,IEN))
- if IEN=""
- QUIT
- Begin DoDot:3
- +23 SET FMSLN=$PIECE($GET(^PRC(442,PRCF("PODA"),22,IEN,0)),U,2,3)
- +24 SET PRCFX("SA",BOC,IEN)=FMSLN
- +25 QUIT
- End DoDot:3
- +26 QUIT
- End DoDot:2
- +27 SET PRCFX("SHBOC")=+$GET(^PRC(442,PRCF("PODA"),23))
- +28 SET PRCFX("SHAMT")=+$PIECE(^PRC(442,PRCF("PODA"),0),U,13)
- +29 IF PRCFX("SHBOC")
- SET I=""
- FOR
- SET I=$ORDER(PRCFX("SA",PRCFX("SHBOC"),I))
- if I=""
- QUIT
- IF $PIECE(PRCFX("SA",PRCFX("SHBOC"),I),U,2)=991
- SET $PIECE(PRCFX("SA",PRCFX("SHBOC"),I),U,3)=PRCFX("SHAMT")
- +30 QUIT
- End DoDot:1
- +31 SET PRCF("CAMT")=$PIECE(^PRCF(421.5,PRCF("CIDA"),0),U,15)
- +32 DO SUMM
- BOC ; Ask for BOC
- +1 NEW CNT,CNT1,PRCFEEE,PRCFEX,PRCFEXIT,PRCFN,PRCFNO
- +2 SET PRCFNO=""
- SET CNT1=0
- +3 FOR
- SET PRCFNO=$ORDER(PRCFX("SA",PRCFNO))
- if PRCFNO=""
- QUIT
- SET CNT1=CNT1+1
- SET BOC=PRCFNO
- +4 IF CNT1=1
- DO ASK2^PRCFDA2
- if $DATA(DIRUT)
- QUIT
- SET DA=$GET(PRCFNUM)
- if $GET(PRCFEXIT)&($GET(PRCFFLG))
- GOTO DOC
- if '$GET(PRCFFLG)
- GOTO EXIT
- +5 IF CNT1<1
- WRITE !!?5,"There are no BOCs on this obligation, processing terminated."
- GOTO EX^PRCFDA2
- +6 IF CNT1>1
- DO ASK^PRCFDA2
- if $DATA(DIRUT)
- QUIT
- SET DA=$GET(PRCFNUM)
- if $GET(PRCFEX)&($GET(PRCFFLG))
- GOTO DOC
- if '$GET(PRCFFLG)
- GOTO EXIT
- +7 IF $GET(PRCFCIDA)']""
- IF ($GET(PRCF("CIDA"))']"")
- WRITE !!?15,"Exiting."
- QUIT
- +8 IF $GET(PRCF("CIDA"))']""
- SET PRCF("CIDA")=PRCFCIDA
- +9 IF '$DATA(^PRCF(421.5,PRCF("CIDA"),5,0))
- SET ^PRCF(421.5,PRCF("CIDA"),5,0)="^"_$PIECE(^DD(421.5,41,0),U,2)
- +10 IF '$DATA(^PRCF(421.5,PRCF("CIDA"),5,$GET(PRCFNUM),0))
- Begin DoDot:1
- +11 SET ^PRCF(421.5,PRCF("CIDA"),5,"B",BOC,PRCFNUM)=""
- +12 SET $PIECE(^PRCF(421.5,PRCF("CIDA"),5,0),U,3)=PRCFNUM
- +13 SET $PIECE(^PRCF(421.5,PRCF("CIDA"),5,0),U,4)=$PIECE(^PRCF(421.5,PRCF("CIDA"),5,0),U,4)+1
- +14 SET ^PRCF(421.5,PRCF("CIDA"),5,PRCFNUM,0)=BOC
- End DoDot:1
- +15 SET DA(1)=PRCF("CIDA")
- +16 SET DIE="^PRCF(421.5,"_DA(1)_",5,"
- +17 SET DR=".01///^S X=BOC;4///^S X=$P(PRCFX(""SA"",BOC,PRCFNUM),U,2)"
- +18 ; if one BOC has goods/serv and shipping, stuff corrected amt in
- +19 ; accouting line amount
- +20 IF CNT1=1
- Begin DoDot:1
- +21 SET PRCFEEE=0
- SET PRCFEEE=$ORDER(PRCFX("SA",BOC,PRCFEEE))
- IF PRCFEEE]""
- IF ($ORDER(PRCFX("SA",BOC,PRCFEEE))]"")
- Begin DoDot:2
- +22 IF $PIECE(PRCFX("SA",BOC,PRCFNUM),U,2)'=991
- SET PRCFN=PRCF("CAMT")-$PIECE(^PRCF(421.5,PRCF("CIDA"),0),U,14)
- +23 IF $PIECE(PRCFX("SA",BOC,PRCFNUM),U,2)=991
- SET PRCFN=$PIECE(^PRCF(421.5,PRCF("CIDA"),0),U,14)
- +24 SET DR=DR_";1///^S X=$G(PRCFN)/100"
- +25 QUIT
- End DoDot:2
- +26 QUIT
- End DoDot:1
- +27 DO ^DIE
- IF $DATA(Y)!$DATA(DTOUT)
- GOTO OT
- +28 KILL DA,DIE,DR
- EDIT ; edit the FMS line entry in 421.5
- +1 SET DA=PRCFNUM
- +2 SET DA(1)=PRCF("CIDA")
- +3 SET DIE="^PRCF(421.5,"_DA(1)_",5,"
- +4 SET PRCFA("LNO")=+$PIECE(PRCFX("SA",BOC,PRCFNUM),U,2)
- +5 WRITE !,"FMS Line # ",PRCFA("LNO")
- +6 SET PRCFA("AMT")=$FNUMBER($PIECE(PRCFX("SA",BOC,PRCFNUM),U),"",2)
- +7 WRITE !,"OBLIGATION AMOUNT: ",PRCFA("AMT")
- +8 SET DR="1//^S X=$S($G(PRCF(""CAMT""))/100>PRCFA(""AMT""):PRCFA(""AMT""),1:$G(PRCF(""CAMT""))/100)"
- +9 DO ^DIE
- KILL DR
- IF $DATA(Y)!$DATA(DTOUT)
- GOTO OT
- +10 SET X=$FNUMBER(X,"",2)
- +11 SET PRCFA("LAMT")=X
- +12 DO DISC^PRCFDT
- +13 IF PRCFA("LIQ")>PRCFA("AMT")
- WRITE !,"Warning - Computed Liquidation amt of $",$FNUMBER(PRCFA("LIQ"),"",2)," exceeds",!?5,"total obligated amt of $",$FNUMBER(PRCFA("AMT"),"",2)," for BOC ",BOC," on ",$PIECE($GET(^PRCF(421.5,PRCF("CIDA"),1)),U,3),"."
- +14 IF PRCFA("LIQ")'=PRCFA("AMT")
- SET DR="2////@"
- DO ^DIE
- KILL DR
- +15 SET DR="2//^S X=$G(PRCFA(""LIQ""))"
- DO ^DIE
- KILL DR
- IF $DATA(Y)!$DATA(DTOUT)
- GOTO OT
- +16 SET PRCFA("LIQ")=X
- SET PRCFA("PF")=""
- +17 IF +PRCFA("AMT")=+PRCFA("LIQ")
- SET PRCFA("PF")="F"
- +18 IF +PRCFA("AMT")>+PRCFA("LIQ")
- SET PRCFA("PF")="P"
- +19 SET DR="3//^S X=$G(PRCFA(""PF""))"
- DO ^DIE
- KILL DR
- IF $DATA(Y)!$DATA(DTOUT)
- GOTO OT
- +20 DO SUM^PRCFDT
- IF '$GET(OK)
- WRITE !!?2,"****WARNING**** - Certified Invoice total $",$FNUMBER(PRCF("CAMT")/100,"",2)," does not match sum of",!,"Line Amounts: $",$FNUMBER(PRCF("TAMT"),"",2)
- +21 IF '$GET(OK)
- WRITE !?7,"If you believe that the Total Invoice Amount Certified for",!,"payment is incorrect, the invoice should be returned to voucher audit",!,"for review."
- GOTO BOC
- +22 IF +PRCF("TAMT")=0
- WRITE !?2,"There are no Line Amounts - FMS will not accept this!"
- +23 GOTO DOC
- DOC ;PROCESS FMS DOC
- +1 IF '$$OBLIG^PRCFDT(.PRC10DA)
- Begin DoDot:1
- +2 IF '$DATA(PRCF("PO"))
- SET PRCF("PO")=$PIECE($GET(^PRC(442,PRCF("PODA"),0)),U,1)
- +3 SET X=" An original FMS SO or MO document could not be found for "
- +4 SET X=X_PRCF("PO")_".*"
- DO MSG^PRCFQ
- +5 SET X=" Please review obligation history for this Purchase Order.*"
- +6 DO MSG^PRCFQ
- DO PAUSE^PRCFDPVU
- +7 QUIT
- End DoDot:1
- GOTO EX^PRCFDA2
- +8 ;D AUTOACCR^PRCFDA4 G:$D(Y)!$D(DTOUT) EX^PRCFDA2 ;per Lyford SOAR
- +9 KILL %A,%B
- SET %A="OK to process this payment to FMS"
- SET %B=""
- SET %=2
- +10 DO ^PRCFYN
- if %<1
- GOTO OT
- +11 IF %=2
- IF ($GET(PRCFFLG)=2)
- GOTO OT
- +12 IF %=2
- GOTO BOC
- +13 GOTO ^PRCFDA2
- SUMM ; Display Accounting Summary - Entry Point from Input Template
- +1 if $DATA(PRCFX("SA"))
- Begin DoDot:1
- +2 NEW BOC,I,J,SHIP,SUBTOT
- +3 WRITE !,"Unliquidated obligation amounts and BOCs on this order are:"
- +4 IF $GET(PRCUNLIQ)]""
- Begin DoDot:2
- +5 SET SUBTOT=PRCUNLIQ
- +6 SET BOC=$ORDER(PRCFX("SA",0))
- SET BOC=$PIECE($GET(^PRCD(420.2,+BOC,0)),U)
- +7 if $GET(SUBTOT)]""
- WRITE !,$JUSTIFY("$"_$FNUMBER(SUBTOT,",",2),10)
- SET SUBTOT=0
- +8 if $GET(BOC)]""
- WRITE ?12,BOC
- +9 QUIT
- End DoDot:2
- +10 IF $GET(PRCUNLIQ)']""
- SET I=""
- SET SUBTOT=0
- FOR
- SET I=$ORDER(PRCFX("SA",I))
- if I=""
- QUIT
- Begin DoDot:2
- +11 SET J=""
- FOR
- SET J=$ORDER(PRCFX("SA",I,J))
- if J=""
- QUIT
- Begin DoDot:3
- +12 SET SUBTOT=SUBTOT+$PIECE(PRCFX("SA",I,J),U)
- +13 SET BOC=$PIECE($GET(^PRCD(420.2,+I,0)),U)
- SET SHIP=$PIECE(PRCFX("SA",I,J),U,3)
- End DoDot:3
- +14 if I
- WRITE !,$JUSTIFY("$"_$FNUMBER(SUBTOT,",",2),10)
- SET SUBTOT=0
- +15 if SHIP
- SET BOC=$EXTRACT(BOC,1,30)
- WRITE ?12,BOC
- +16 if SHIP
- WRITE ?40," **(Includes $",$FNUMBER(PRCFX("SHAMT"),",",2)
- +17 if SHIP
- WRITE " shipping.)"
- +18 QUIT
- End DoDot:2
- +19 KILL PRCUNLIQ
- +20 WRITE !,"Total Invoice Amount Certified for Payment=$"
- +21 WRITE $JUSTIFY(PRCF("CAMT")/100,0,2)
- +22 QUIT
- End DoDot:1
- +23 QUIT
- OT DO UNP
- KILL ^TMP("PRCFDA",$JOB,"LIQ")
- +1 SET X=" <Option Terminated.>*"
- DO MSG^PRCFQ
- GOTO EX^PRCFDA2
- NUMSTA() ;Determine number of unique stations in IFCAP system
- +1 NEW X,I
- SET X=""
- SET I=0
- +2 FOR
- SET X=$ORDER(^PRC(411,"B",X))
- if X'?1.N
- QUIT
- SET I=I+1
- +3 QUIT I
- EXIT ; IF NO fms line BOC chosen,display message and exit
- +1 WRITE !
- Begin DoDot:1
- +2 SET X=" Edit exited abnormally. Action terminated.*"
- DO MSG^PRCFQ
- +3 SET %A="Do you want to return this invoice to Voucher Audit"
- +4 SET %B=""
- SET %=2
- DO ^PRCFYN
- IF %=1
- SET X=10
- DO STATUS^PRCFDE1
- +5 QUIT
- End DoDot:1
- GOTO EX^PRCFDA2
- +6 QUIT
- UNP ; Check for posted liquidation amounts and unpost
- +1 SET X=$GET(^TMP("PRCFDA",$JOB,"LIQ"))
- +2 if X=""
- QUIT
- NEW DA,DIK,LAMT,PO,PRCFA,ZX1
- +3 SET LAMT=$PIECE(X,U,1)
- SET PRCFA("PODA")=$PIECE(X,U,2)
- SET ZX1=$PIECE(X,U,3)
- SET DA=$PIECE(X,U,4)
- +4 SET DIK="^PRC(424,"
- DO ^DIK
- +5 DO POST^PRCH58LQ(.PRCFA,.LAMT,.PO)
- +6 WRITE !!,"Liquidation # ",ZX1," for ",$FNUMBER(LAMT,",",2)," has been deleted and unposted."
- +7 QUIT
