PRCFFU11.m

PRCFFU11 ;WISC/SJG-ADJUST FCP BALANCES ;

V ;;5.1;IFCAP;;Oct 20, 2000

 ;Per VHA Directive 10-93-142, this routine should not be modified.

 ;

 QUIT

 ; No top level entry

 ; Called when PO amendment is cancelled by Authority E

 ;

 ; The following lines commented out by patch 172 but

 ; if reinstated, conditionalize CPB update on PRCFA("NEW410") existence

 ; PRCFA("NEW410") is set when the CPB is updated - see field25,file410

 ; This field is set in PRC0F which is called by NEW410^PRCFFUD

 ;

 ; Q:'$D(PRCOAMT)  Q:'$D(PRCFMO)

 ; N TRDA,Z,AMT,DEL,X,TIME,DA

 ; S TRDA=$P(^PRC(442,PRCFA("PODA"),0),"^",12),AMT=$P(^(0),"^",$P(PRCFMO,"^",12)="N"+15),DEL=$P(^(0),"^",10)

 ; D NOW^%DTC S TIME=X

 ; D GENDIQ^PRCFFU7(442,PRCFA("PODA"),.5,"I","")

 ; S POSTAT=PRCTMP(442,PRCFA("PODA"),.5,"I") K PRCTMP(442,PRCFA("PODA"),.5,"I")

 ; W !!,"...now updating Control Point balances..."

 ; Adjust FCP Committed and Obligated Balances

 ; I TRDA="" D  QUIT

 ; .N A

 ; .S A=$$DATE^PRC0C($P(PRCOAMT,"^",3),"I"),$P(PRCOAMT,"^",3,4)=$E(A,3,4)_"^"_$P(A,"^",2)

 ; .D EBAL^PRCSEZ(PRCOAMT,"C")

 ; .D:$G(MTOPDA)="" EBAL^PRCSEZ(PRCOAMT,"O")

 ; .QUIT

FCP N DA,MESSAGE

 S DA=$P(^PRC(442,PRCFA("PODA"),0),"^",12)

 I DA="" Q

 I '$D(^PRCS(410,DA,4)) Q

 S $P(^PRCS(410,DA,9),"^",2)=$P(^PRC(442,PRCFA("PODA"),0),"^",10) ; delivery date

 D REMOVE^PRCSC2(DA),ENCODE^PRCSC2(DA,DUZ,.MESSAGE) ; signatures

 QUIT

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PRCFFU11   1404     printed  Apr 09, 2024@21:20:45                                                                                                                                                                                                    Page 2

PRCFFU11  ;WISC/SJG-ADJUST FCP BALANCES ;

V         ;;5.1;IFCAP;;Oct 20, 2000

 +1       ;Per VHA Directive 10-93-142, this routine should not be modified.

 +2       ;

 +3        QUIT 

 +4       ; No top level entry

 +5       ; Called when PO amendment is cancelled by Authority E

 +6       ;

 +7       ; The following lines commented out by patch 172 but

 +8       ; if reinstated, conditionalize CPB update on PRCFA("NEW410") existence

 +9       ; PRCFA("NEW410") is set when the CPB is updated - see field25,file410

 +10      ; This field is set in PRC0F which is called by NEW410^PRCFFUD

 +11      ;

 +12      ; Q:'$D(PRCOAMT)  Q:'$D(PRCFMO)

 +13      ; N TRDA,Z,AMT,DEL,X,TIME,DA

 +14      ; S TRDA=$P(^PRC(442,PRCFA("PODA"),0),"^",12),AMT=$P(^(0),"^",$P(PRCFMO,"^",12)="N"+15),DEL=$P(^(0),"^",10)

 +15      ; D NOW^%DTC S TIME=X

 +16      ; D GENDIQ^PRCFFU7(442,PRCFA("PODA"),.5,"I","")

 +17      ; S POSTAT=PRCTMP(442,PRCFA("PODA"),.5,"I") K PRCTMP(442,PRCFA("PODA"),.5,"I")

 +18      ; W !!,"...now updating Control Point balances..."

 +19      ; Adjust FCP Committed and Obligated Balances

 +20      ; I TRDA="" D  QUIT

 +21      ; .N A

 +22      ; .S A=$$DATE^PRC0C($P(PRCOAMT,"^",3),"I"),$P(PRCOAMT,"^",3,4)=$E(A,3,4)_"^"_$P(A,"^",2)

 +23      ; .D EBAL^PRCSEZ(PRCOAMT,"C")

 +24      ; .D:$G(MTOPDA)="" EBAL^PRCSEZ(PRCOAMT,"O")

 +25      ; .QUIT

FCP        NEW DA,MESSAGE

 +1        SET DA=$PIECE(^PRC(442,PRCFA("PODA"),0),"^",12)

 +2        IF DA=""

               QUIT 

 +3        IF '$DATA(^PRCS(410,DA,4))

               QUIT 

 +4       ; delivery date

           SET $PIECE(^PRCS(410,DA,9),"^",2)=$PIECE(^PRC(442,PRCFA("PODA"),0),"^",10)

 +5       ; signatures

           DO REMOVE^PRCSC2(DA)

           DO ENCODE^PRCSC2(DA,DUZ,.MESSAGE)

 +6        QUIT