| 1 | PRCACLM ;SF-ISC/YJK-CALM CODE SHEET GENERATOR ;9/10/93 10:59 AM
|
---|
| 2 | V ;;4.5;Accounts Receivable;;Mar 20, 1995
|
---|
| 3 | ;;Per VHA Directive 10-93-142, this routine should not be modified.
|
---|
| 4 | EN1 ;CREATE NEW CODE SHEET OF ANY TYPE
|
---|
| 5 | G:'$D(PRC("SITE")) OUT S PRCFA("ARCS")=""
|
---|
| 6 | AM ;
|
---|
| 7 | I ",22,23,26,"[(","_$P(^PRCA(430,PRCABN,0),"^",2)_",") D TT
|
---|
| 8 | I +$P($G(^PRCA(433,+$G(PRCAEN),8)),U,8) W !!,"* This is flagged as a Contractual Adjustment. Tran. Type should be 934.24 *",!
|
---|
| 9 | D TT^PRCFAC G OUT:'% D NEWCS^PRCFAC G:'$D(DA) OUT S DIE="^PRCF(423,"
|
---|
| 10 | S:PRCFA("AMT")<0 PRCFA("AMT")=-PRCFA("AMT") S ^PRCF(423,DA,1)=PRCFA("ALD")_U_U_U_U_U_U_U_U_PRCFA("AMT")
|
---|
| 11 | S:PRCFA("TT")'[934.24 $P(^PRCF(423,DA,1),"^",15)=$P(^PRCA(430.2,+$P(^PRCA(430,PRCABN,0),"^",2),0),"^",8)
|
---|
| 12 | I ",22,23,26,"[(","_$P(^PRCA(430,PRCABN,0),"^",2)_",") S $P(^PRCF(423,DA,6),"^",30)=PRCFA("ALD"),$P(^PRCF(423,DA,1),"^",16)="$"
|
---|
| 13 | I $P(^PRCA(430,PRCABN,0),U,2)=$O(^PRCA(430.2,"AC",33,0)) D REF
|
---|
| 14 | K Y I ",22,23,26,"'[(","_$P(^PRCA(430,PRCABN,0),"^",2)_",") S DR=PRCFA("EDIT") D ^DIE
|
---|
| 15 | I $D(Y)=0 D ^PRCFACXM D:$P(^PRCA(430,PRCABN,0),U,2)=$O(^PRCA(430.2,"AC",33,0)) TREF S:'$D(PRCFDEL) PRCALM=2 Q
|
---|
| 16 | D DEL^PRCFACXM,OUT1 Q
|
---|
| 17 | TT G:'$D(PRCAEN) TTQ I ",1,35,"'[","_$P(^PRCA(433,PRCAEN,1),U,2)_"," Q
|
---|
| 18 | I PRCFA("ALD")["7.1.8" S PRCFA("TTF")=$S($P(^PRCA(433,PRCAEN,1),U,2)=35:93031,1:93030) G TTQ
|
---|
| 19 | S PRCFA("TTF")=$S($P(^PRCA(433,PRCAEN,1),U,2)=35:93931,1:93930)
|
---|
| 20 | TTQ I '$G(PRCFA("TTF")),$P(^PRCA(430,PRCABN,0),U,2)=$O(^PRCA(430.2,"AC",33,0)) S PRCFA("TTF")=97213
|
---|
| 21 | S PRCFASYS="CLM",PRCHAUTO=1 Q
|
---|
| 22 | OUT1 K %,%DT,%TG,%X,%Y,A,B,C,DIG,DIH,DIU,DIV,DIW,DIK,DQ,I,M,N,X1,PRCFA("ARCS") Q
|
---|
| 23 | OUT K %,%X,%Y,%XX,PRCFA("ARCS"),B,D,D0,DG,DIC,DIE,DIG,DIH,DIV,DIW,DLAYGO,DQ,DR,I,J,K,M,M,PRCFA,Q,Q1,S,X,Y,Z Q
|
---|
| 24 | PH ;
|
---|
| 25 | NEW PRCAFY,PRCAAP
|
---|
| 26 | I $P(^PRCA(430,PRCABN,0),"^",4)="" S DR="4////^S X="_$P(^PRCA(430.2,+$P(^(0),"^",2),0),"^",4),DA=PRCABN,DIE="^PRCA(430," D ^DIE
|
---|
| 27 | S PRCAAP=$S($D(^PRCD(420.3,+$P(^PRCA(430.2,+$P(^PRCA(430,PRCABN,0),"^",2),0),"^",5),0)):$P(^(0),"^",3),1:"")
|
---|
| 28 | I PRCAAP]"" F PRCAFY=0:0 S PRCAFY=$O(^PRCA(430,PRCABN,2,PRCAFY)) Q:'PRCAFY I $P(^(PRCAFY,0),"^",4)="" S DIE="^PRCA(430,"_PRCABN_",2,",DA(1)=PRCABN,DA=PRCAFY,DR="3///^S X="""_PRCAAP_"""" D ^DIE
|
---|
| 29 | Q
|
---|
| 30 | REF ;
|
---|
| 31 | N DFN,VAERR,VA,VADM,VAPA
|
---|
| 32 | S DFN=+^RCD(340,+$P(^PRCA(430,PRCABN,0),U,9),0) Q:'DFN
|
---|
| 33 | D DEM^VADPT,ADD^VADPT
|
---|
| 34 | S $P(^PRCF(423,DA,6),U,7,10)=$P(VADM(2),U)_U_1_U_$E($TR($P($G(VADM(1)),",",2),".")_" "_$TR($P($G(VADM(1)),",",1),"."),1,23)_U_$E($TR($G(VAPA(1)),"."),1,23)
|
---|
| 35 | S $P(^PRCF(423,DA,6),U,11,15)=$E($TR($G(VAPA(2)),"."),1,23)_U_$E($TR($G(VAPA(4)),"."),1,13)_U_$E($TR($P($G(^DIC(5,+$G(VAPA(5)),0)),U,2),"."),1,2)_U_$E($TR($G(VAPA(6)),"-"),1,9)_"^OVERPAYMENT"
|
---|
| 36 | S $P(^PRCF(423,DA,1),U,8)="0245",$P(^(1),U,10)=3012
|
---|
| 37 | Q
|
---|
| 38 | TREF ;
|
---|
| 39 | N DIE,DR,CDI,PRCA,PRCAA2,PRCAEN,PRCAMT,PRCASV Q:$D(PRCFDEL) S CDI=DA
|
---|
| 40 | I $P($G(^PRCF(423,CDI,8)),U,16)']"" W !!,"NO ELECTRONIC SIGNATURE!" D DEL Q
|
---|
| 41 | D SETTR^PRCAUTL I '$G(PRCAEN) W !!,"COULD NOT SET UP A REFUND TRANSACTION!" D DEL Q
|
---|
| 42 | W !!,"Creating a REFUND Transaction....."
|
---|
| 43 | D PATTR^PRCAUTL S PRCA("ADJ")=$O(^PRCA(430.3,"AC",120,0)),PRCASV("BDT")=$G(DT),PRCASV("APR")=DUZ,PRCASV("FY")="^"_+$P($G(^PRCA(430,PRCABN,7)),U,18)
|
---|
| 44 | S DIE="^PRCA(433,",DR="[PRCA FY ADJ2 BATCH]",DA=PRCAEN D ^DIE
|
---|
| 45 | S PRCAMT=-$G(PRCAMT),PRCAA2=$P(^PRCA(433,PRCAEN,4,0),U,3)
|
---|
| 46 | D UPFY^PRCADJ,TRANUP^PRCAUTL
|
---|
| 47 | S $P(^PRCA(430,PRCABN,7),U,1)=$G(^PRCA(430,PRCABN,7))+PRCAMT,PRCA("STATUS")=$O(^PRCA(430.3,"AC",120,0)) D UPSTATS^PRCAUT2
|
---|
| 48 | Q
|
---|
| 49 | DEL ;
|
---|
| 50 | N DA,DIK
|
---|
| 51 | S PRCFDEL=1,DA=CDI,DIK="^PRCF(423," D ^DIK
|
---|
| 52 | W *7," <Code Sheet Deleted>"
|
---|
| 53 | Q
|
---|