PRCASER.m

PRCASER ;WASH-ISC@ALTOONA,PA/RGY-Accept bill from billing engine ;2/23/95  2:40 PM

V ;;4.5;Accounts Receivable;**90,153,203,211,345**;Mar 20, 1995;Build 34

  ;Per VA Directive 6402, this routine should not be modified.

 NEW PRCAX,PRCASV,PRCAEN,PRCASEG

 S PRCAX=X,Y=0 F X="SITE","SER","CAT","DEBTOR","FY","AMT","APR","BDT" S Y=Y+1,PRCASV(X)=$P(PRCAX,"^",Y)

 L +^RCD(340,PRCASV("DEBTOR"),"PRCASER"):30 I '$T S Y="-1^PRCA004^AR Package 'busy' while trying to add transaction." G Q1

 I ",3,4,5,24,25,"[(","_PRCASV("CAT")_",") S PRCASV("CARE")=PRCASV("CAT"),PRCASV("CAT")=18

 S PRCASV("FY")=PRCASV("FY")_"^"_PRCASV("AMT")

 I '$D(PRCASV("PAT")) S PRCASV("PAT")=PRCASV("DEBTOR")

 S X=$O(^RCD(340,"B",PRCASV("DEBTOR"),0)) ; PRCA*4.5*345 Removed check for existing AR

 D ^PRCASVC3 I PRCASV("ARREC")<0,$P(PRCASV("ARREC"),"^",2)]"" S Y=PRCASV("ARREC") G Q

 I PRCASV("ARBIL")<0 S Y=PRCASV("ARBIL") G Q

 S $P(PRCASV("FY"),"^",2)=0 D REL^PRCASVC S $P(PRCASV("FY"),"^",2)=PRCASV("AMT") I $D(PRCAERR) S Y=PRCAERR G Q

 S PRCASEG=$S($D(PRCASV("CARE")):PRCASV("CARE"),$D(PRCASV("CAT")):PRCASV("CAT"),1:0) S:PRCASEG>1 PRCASEG=$P(^PRCA(430.2,PRCASEG,0),"^",3)

 S DR="8////^S X="_$O(^PRCA(430.3,"AC",112,0))_";20.1////^S X="_PRCASEG

 S DR=DR_";203////^S X="_$$GETFUNDB^RCXFMSUF(PRCASV("ARREC"),1)

 I $D(PRCASV("CARE")) S DR=DR_";15.1////^S X="_PRCASV("CARE")

 S DA=PRCASV("ARREC"),DIE="^PRCA(430," D ^DIE D:PRCASV("AMT")>0 TRAN

 S Y=PRCASV("ARREC")_"^"_PRCASV("ARBIL")_"^"_$S($D(PRCAEN):PRCAEN,1:"")

Q L -^RCD(340,PRCASV("DEBTOR"),"PRCASER")

Q1 S X=PRCAX K PRCAERR Q

CHKAO ;

 F Y=0:0 S Y=$O(^PRCA(430,"AS",X,$O(^PRCA(430.3,"AC",112,0)),Y)) Q:'Y  D

 .I $P(^PRCA(430,Y,0),"^",2)=PRCASV("CAT"),$S(PRCASV("CAT")'=$O(^PRCA(430.2,"AC",24,0)):1,$P(^PRCA(430,Y,0),"^",16)=PRCASV("CARE"):1,1:0) S PRCASV("ARREC")=Y,PRCASV("ARBIL")=$P(^PRCA(430,Y,0),"^")

 .QUIT

 Q

TRAN ;

 NEW PRCABN,PRCA,PRCAMT,PRCAA2

 D SETTR^PRCAUTL S PRCABN=PRCASV("ARREC") D PATTR^PRCAUTL

 S PRCA("ADJ")=$O(^PRCA(430.3,"AC",1,0)),DIE="^PRCA(433,",DR="[PRCA FY ADJ2 BATCH]",DA=PRCAEN D ^DIE S PRCAA2=$P(^PRCA(433,PRCAEN,4,0),"^",3) D UPFY^PRCADJ,TRANUP^PRCAUTL,UPPRIN^PRCADJ

 D PREPAY^RCBEPAYP(PRCABN,0)

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PRCASER   2178     printed  Apr 09, 2024@20:53:23                                                                                                                                                                                                     Page 2

PRCASER   ;WASH-ISC@ALTOONA,PA/RGY-Accept bill from billing engine ;2/23/95  2:40 PM

V         ;;4.5;Accounts Receivable;**90,153,203,211,345**;Mar 20, 1995;Build 34

 +1       ;Per VA Directive 6402, this routine should not be modified.

 +2        NEW PRCAX,PRCASV,PRCAEN,PRCASEG

 +3        SET PRCAX=X

           SET Y=0

           FOR X="SITE","SER","CAT","DEBTOR","FY","AMT","APR","BDT"

               SET Y=Y+1

               SET PRCASV(X)=$PIECE(PRCAX,"^",Y)

 +4        LOCK +^RCD(340,PRCASV("DEBTOR"),"PRCASER"):30

           IF '$TEST

               SET Y="-1^PRCA004^AR Package 'busy' while trying to add transaction."

               GOTO Q1

 +5        IF ",3,4,5,24,25,"[(","_PRCASV("CAT")_",")

               SET PRCASV("CARE")=PRCASV("CAT")

               SET PRCASV("CAT")=18

 +6        SET PRCASV("FY")=PRCASV("FY")_"^"_PRCASV("AMT")

 +7        IF '$DATA(PRCASV("PAT"))

               SET PRCASV("PAT")=PRCASV("DEBTOR")

 +8       ; PRCA*4.5*345 Removed check for existing AR

           SET X=$ORDER(^RCD(340,"B",PRCASV("DEBTOR"),0))

 +9        DO ^PRCASVC3

           IF PRCASV("ARREC")<0

               IF $PIECE(PRCASV("ARREC"),"^",2)]""

                   SET Y=PRCASV("ARREC")

                   GOTO Q

 +10       IF PRCASV("ARBIL")<0

               SET Y=PRCASV("ARBIL")

               GOTO Q

 +11       SET $PIECE(PRCASV("FY"),"^",2)=0

           DO REL^PRCASVC

           SET $PIECE(PRCASV("FY"),"^",2)=PRCASV("AMT")

           IF $DATA(PRCAERR)

               SET Y=PRCAERR

               GOTO Q

 +12       SET PRCASEG=$SELECT($DATA(PRCASV("CARE")):PRCASV("CARE"),$DATA(PRCASV("CAT")):PRCASV("CAT"),1:0)

           if PRCASEG>1

               SET PRCASEG=$PIECE(^PRCA(430.2,PRCASEG,0),"^",3)

 +13       SET DR="8////^S X="_$ORDER(^PRCA(430.3,"AC",112,0))_";20.1////^S X="_PRCASEG

 +14       SET DR=DR_";203////^S X="_$$GETFUNDB^RCXFMSUF(PRCASV("ARREC"),1)

 +15       IF $DATA(PRCASV("CARE"))

               SET DR=DR_";15.1////^S X="_PRCASV("CARE")

 +16       SET DA=PRCASV("ARREC")

           SET DIE="^PRCA(430,"

           DO ^DIE

           if PRCASV("AMT")>0

               DO TRAN

 +17       SET Y=PRCASV("ARREC")_"^"_PRCASV("ARBIL")_"^"_$SELECT($DATA(PRCAEN):PRCAEN,1:"")

Q          LOCK -^RCD(340,PRCASV("DEBTOR"),"PRCASER")

Q1         SET X=PRCAX

           KILL PRCAERR

           QUIT 

CHKAO     ;

 +1        FOR Y=0:0

               SET Y=$ORDER(^PRCA(430,"AS",X,$ORDER(^PRCA(430.3,"AC",112,0)),Y))

               if 'Y

                   QUIT 

               Begin DoDot:1

 +2                IF $PIECE(^PRCA(430,Y,0),"^",2)=PRCASV("CAT")

                       IF $SELECT(PRCASV("CAT")'=$ORDER(^PRCA(430.2,"AC",24,0)):1,$PIECE(^PRCA(430,Y,0),"^",16)=PRCASV("CARE"):1,1:0)

                           SET PRCASV("ARREC")=Y

                           SET PRCASV("ARBIL")=$PIECE(^PRCA(430,Y,0),"^")

 +3                QUIT 

               End DoDot:1

 +4        QUIT 

TRAN      ;

 +1        NEW PRCABN,PRCA,PRCAMT,PRCAA2

 +2        DO SETTR^PRCAUTL

           SET PRCABN=PRCASV("ARREC")

           DO PATTR^PRCAUTL

 +3        SET PRCA("ADJ")=$ORDER(^PRCA(430.3,"AC",1,0))

           SET DIE="^PRCA(433,"

           SET DR="[PRCA FY ADJ2 BATCH]"

           SET DA=PRCAEN

           DO ^DIE

           SET PRCAA2=$PIECE(^PRCA(433,PRCAEN,4,0),"^",3)

           DO UPFY^PRCADJ

           DO TRANUP^PRCAUTL

           DO UPPRIN^PRCADJ

 +4        DO PREPAY^RCBEPAYP(PRCABN,0)

 +5        QUIT