PRCARFD2.m

PRCARFD2 ;WASH-ISC@ALTOONA,PA/LDB-GENERATE FMS DOC ;10/19/94  3:36 PM

V ;;4.5;Accounts Receivable;**204,198**;Mar 20, 1995

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

 ;;

TRANS ;TRANSMIT A REFUND (OVERCOLLECTION) DOC

 N DIC,PRCABN,PRCABN0,REF,U,REFMS

 N DPTNOFZY,DPTNOFZK S (DPTNOFZY,DPTNOFZK)=1

 S U="^",REF=$O(^PRCA(430.3,"AC",120,0))

 S D0=+$O(^PRCA(430.2,"AC",33,0)),D0(1)=$P(^PRCA(430.2,+D0,0),U)

 S DIC="^PRCA(430,",DIC("S")="I $P(^(0),U,2)="_D0_",$P(^(0),U,8)="_REF,DIC(0)="AEQMZ" D ^DIC Q:Y<0  S PRCABN=+Y

 I $P(^PRCA(430,PRCABN,9),U,2)="" W !,"THIS BILL HAS NOT BEEN APPROVED!" Q

 I '$D(^PRCA(430,+$G(PRCABN),0)) W !,"THIS BILL NUMBER ENTRY IN FILE 430 IS CORRUPTED",!,"NO PROCESSING CAN CONTINUE - SEE IRM" Q

 S PRCABN0=^(0),PRCANM=$P($G(^PRCA(430,+PRCABN,0)),U)

 S STAT=$$GSTAT^RCFMFN02("B"_PRCABN)

 I STAT<0 W !,"THIS DOCUMENT IS EITHER NOT READY FOR FMS OR HAS ALREADY BEEN ACCEPTED." Q

 I STAT'=3 W !!,*7,"THIS DOCUMENT SEEMS TO HAVE ALREADY BEEN SENT TO FMS-",!,"IT CANNOT BE RESENT UNLESS FMS REJECTS IT." Q

 D DEL^RCFMFN02("B"_PRCABN) S REFMS=1 D FMS^PRCARFD1

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PRCARFD2   1123     printed  Apr 09, 2024@20:45:32                                                                                                                                                                                                    Page 2

PRCARFD2  ;WASH-ISC@ALTOONA,PA/LDB-GENERATE FMS DOC ;10/19/94  3:36 PM

V         ;;4.5;Accounts Receivable;**204,198**;Mar 20, 1995

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

 +2       ;;

TRANS     ;TRANSMIT A REFUND (OVERCOLLECTION) DOC

 +1        NEW DIC,PRCABN,PRCABN0,REF,U,REFMS

 +2        NEW DPTNOFZY,DPTNOFZK

           SET (DPTNOFZY,DPTNOFZK)=1

 +3        SET U="^"

           SET REF=$ORDER(^PRCA(430.3,"AC",120,0))

 +4        SET D0=+$ORDER(^PRCA(430.2,"AC",33,0))

           SET D0(1)=$PIECE(^PRCA(430.2,+D0,0),U)

 +5        SET DIC="^PRCA(430,"

           SET DIC("S")="I $P(^(0),U,2)="_D0_",$P(^(0),U,8)="_REF

           SET DIC(0)="AEQMZ"

           DO ^DIC

           if Y<0

               QUIT 

           SET PRCABN=+Y

 +6        IF $PIECE(^PRCA(430,PRCABN,9),U,2)=""

               WRITE !,"THIS BILL HAS NOT BEEN APPROVED!"

               QUIT 

 +7        IF '$DATA(^PRCA(430,+$GET(PRCABN),0))

               WRITE !,"THIS BILL NUMBER ENTRY IN FILE 430 IS CORRUPTED",!,"NO PROCESSING CAN CONTINUE - SEE IRM"

               QUIT 

 +8        SET PRCABN0=^(0)

           SET PRCANM=$PIECE($GET(^PRCA(430,+PRCABN,0)),U)

 +9        SET STAT=$$GSTAT^RCFMFN02("B"_PRCABN)

 +10       IF STAT<0

               WRITE !,"THIS DOCUMENT IS EITHER NOT READY FOR FMS OR HAS ALREADY BEEN ACCEPTED."

               QUIT 

 +11       IF STAT'=3

               WRITE !!,*7,"THIS DOCUMENT SEEMS TO HAVE ALREADY BEEN SENT TO FMS-",!,"IT CANNOT BE RESENT UNLESS FMS REJECTS IT."

               QUIT 

 +12       DO DEL^RCFMFN02("B"_PRCABN)

           SET REFMS=1

           DO FMS^PRCARFD1

 +13       QUIT