- 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 ---[H[J[2J[HPRCASER 2178 printed Feb 18, 2025@23:07:42 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