PRCACLM ;SF-ISC/YJK-CALM CODE SHEET GENERATOR ;9/10/93 10:59 AM
V ;;4.5;Accounts Receivable;**371**;Mar 20, 1995;Build 29
;;Per VHA Directive 6402, this routine should not be modified.
EN1 ;CREATE NEW CODE SHEET OF ANY TYPE
G:'$D(PRC("SITE")) OUT S PRCFA("ARCS")=""
AM ;
I ",22,23,26,"[(","_$P(^PRCA(430,PRCABN,0),"^",2)_",") D TT
I +$P($G(^PRCA(433,+$G(PRCAEN),8)),U,8) W !!,"* This is flagged as a Contractual Adjustment. Tran. Type should be 934.24 *",!
D TT^PRCFAC G OUT:'% D NEWCS^PRCFAC G:'$D(DA) OUT S DIE="^PRCF(423,"
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")
S:PRCFA("TT")'[934.24 $P(^PRCF(423,DA,1),"^",15)=$P(^PRCA(430.2,+$P(^PRCA(430,PRCABN,0),"^",2),0),"^",8)
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)="$"
I $P(^PRCA(430,PRCABN,0),U,2)=$O(^PRCA(430.2,"AC",33,0)) D REF
K Y I ",22,23,26,"'[(","_$P(^PRCA(430,PRCABN,0),"^",2)_",") S DR=PRCFA("EDIT") D ^DIE
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
D DEL^PRCFACXM,OUT1 Q
TT G:'$D(PRCAEN) TTQ I ",1,35,"'[","_$P(^PRCA(433,PRCAEN,1),U,2)_"," Q
I PRCFA("ALD")["7.1.8" S PRCFA("TTF")=$S($P(^PRCA(433,PRCAEN,1),U,2)=35:93031,1:93030) G TTQ
S PRCFA("TTF")=$S($P(^PRCA(433,PRCAEN,1),U,2)=35:93931,1:93930)
TTQ I '$G(PRCFA("TTF")),$P(^PRCA(430,PRCABN,0),U,2)=$O(^PRCA(430.2,"AC",33,0)) S PRCFA("TTF")=97213
S PRCFASYS="CLM",PRCHAUTO=1 Q
OUT1 K %,%DT,%TG,%X,%Y,A,B,C,DIG,DIH,DIU,DIV,DIW,DIK,DQ,I,M,N,X1,PRCFA("ARCS") Q
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
PH ;
NEW PRCAFY,PRCAAP
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
S PRCAAP=$S($D(^PRCD(420.3,+$P(^PRCA(430.2,+$P(^PRCA(430,PRCABN,0),"^",2),0),"^",5),0)):$P(^(0),"^",3),1:"")
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
Q
REF ;
N DFN,VAERR,VA,VADM,VAPA
S DFN=+^RCD(340,+$P(^PRCA(430,PRCABN,0),U,9),0) Q:'DFN
D DEM^VADPT,ADD^VADPT
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)
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"
S $P(^PRCF(423,DA,1),U,8)="0245",$P(^(1),U,10)=3012
Q
TREF ;
N DIE,DR,CDI,PRCA,PRCAA2,PRCAEN,PRCAMT,PRCASV,PRCFDA Q:$D(PRCFDEL) S CDI=DA
I $P($G(^PRCF(423,CDI,8)),U,16)']"" W !!,"NO ELECTRONIC SIGNATURE!" D DEL Q
D SETTR^PRCAUTL I '$G(PRCAEN) W !!,"COULD NOT SET UP A REFUND TRANSACTION!" D DEL Q
W !!,"Creating a REFUND Transaction....."
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)
S DIE="^PRCA(433,",DR="[PRCA FY ADJ2 BATCH]",DA=PRCAEN D ^DIE
S PRCAMT=-$G(PRCAMT),PRCAA2=$P(^PRCA(433,PRCAEN,4,0),U,3)
D UPFY^PRCADJ,TRANUP^PRCAUTL
; PRCA*4.5*371 - Replace direct global sets in 7 node with FileMan calls so indexes get updated
S PRCFDA(430,PRCABN_",",71)=$G(^PRCA(430,PRCABN,7))+PRCAMT,PRCA("STATUS")=$O(^PRCA(430.3,"AC",120,0)) D FILE^DIE(,"PRCFDA"),UPSTATS^PRCAUT2
Q
DEL ;
N DA,DIK
S PRCFDEL=1,DA=CDI,DIK="^PRCF(423," D ^DIK
W *7," <Code Sheet Deleted>"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCACLM 3678 printed Apr 09, 2024@20:48:30 Page 2
PRCACLM ;SF-ISC/YJK-CALM CODE SHEET GENERATOR ;9/10/93 10:59 AM
V ;;4.5;Accounts Receivable;**371**;Mar 20, 1995;Build 29
+1 ;;Per VHA Directive 6402, this routine should not be modified.
EN1 ;CREATE NEW CODE SHEET OF ANY TYPE
+1 if '$DATA(PRC("SITE"))
GOTO OUT
SET PRCFA("ARCS")=""
AM ;
+1 IF ",22,23,26,"[(","_$PIECE(^PRCA(430,PRCABN,0),"^",2)_",")
DO TT
+2 IF +$PIECE($GET(^PRCA(433,+$GET(PRCAEN),8)),U,8)
WRITE !!,"* This is flagged as a Contractual Adjustment. Tran. Type should be 934.24 *",!
+3 DO TT^PRCFAC
if '%
GOTO OUT
DO NEWCS^PRCFAC
if '$DATA(DA)
GOTO OUT
SET DIE="^PRCF(423,"
+4 if PRCFA("AMT")<0
SET PRCFA("AMT")=-PRCFA("AMT")
SET ^PRCF(423,DA,1)=PRCFA("ALD")_U_U_U_U_U_U_U_U_PRCFA("AMT")
+5 if PRCFA("TT")'[934.24
SET $PIECE(^PRCF(423,DA,1),"^",15)=$PIECE(^PRCA(430.2,+$PIECE(^PRCA(430,PRCABN,0),"^",2),0),"^",8)
+6 IF ",22,23,26,"[(","_$PIECE(^PRCA(430,PRCABN,0),"^",2)_",")
SET $PIECE(^PRCF(423,DA,6),"^",30)=PRCFA("ALD")
SET $PIECE(^PRCF(423,DA,1),"^",16)="$"
+7 IF $PIECE(^PRCA(430,PRCABN,0),U,2)=$ORDER(^PRCA(430.2,"AC",33,0))
DO REF
+8 KILL Y
IF ",22,23,26,"'[(","_$PIECE(^PRCA(430,PRCABN,0),"^",2)_",")
SET DR=PRCFA("EDIT")
DO ^DIE
+9 IF $DATA(Y)=0
DO ^PRCFACXM
if $PIECE(^PRCA(430,PRCABN,0),U,2)=$ORDER(^PRCA(430.2,"AC",33,0))
DO TREF
if '$DATA(PRCFDEL)
SET PRCALM=2
QUIT
+10 DO DEL^PRCFACXM
DO OUT1
QUIT
TT if '$DATA(PRCAEN)
GOTO TTQ
IF ",1,35,"'[","_$PIECE(^PRCA(433,PRCAEN,1),U,2)_","
QUIT
+1 IF PRCFA("ALD")["7.1.8"
SET PRCFA("TTF")=$SELECT($PIECE(^PRCA(433,PRCAEN,1),U,2)=35:93031,1:93030)
GOTO TTQ
+2 SET PRCFA("TTF")=$SELECT($PIECE(^PRCA(433,PRCAEN,1),U,2)=35:93931,1:93930)
TTQ IF '$GET(PRCFA("TTF"))
IF $PIECE(^PRCA(430,PRCABN,0),U,2)=$ORDER(^PRCA(430.2,"AC",33,0))
SET PRCFA("TTF")=97213
+1 SET PRCFASYS="CLM"
SET PRCHAUTO=1
QUIT
OUT1 KILL %,%DT,%TG,%X,%Y,A,B,C,DIG,DIH,DIU,DIV,DIW,DIK,DQ,I,M,N,X1,PRCFA("ARCS")
QUIT
OUT KILL %,%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
QUIT
PH ;
+1 NEW PRCAFY,PRCAAP
+2 IF $PIECE(^PRCA(430,PRCABN,0),"^",4)=""
SET DR="4////^S X="_$PIECE(^PRCA(430.2,+$PIECE(^(0),"^",2),0),"^",4)
SET DA=PRCABN
SET DIE="^PRCA(430,"
DO ^DIE
+3 SET PRCAAP=$SELECT($DATA(^PRCD(420.3,+$PIECE(^PRCA(430.2,+$PIECE(^PRCA(430,PRCABN,0),"^",2),0),"^",5),0)):$PIECE(^(0),"^",3),1:"")
+4 IF PRCAAP]""
FOR PRCAFY=0:0
SET PRCAFY=$ORDER(^PRCA(430,PRCABN,2,PRCAFY))
if 'PRCAFY
QUIT
IF $PIECE(^(PRCAFY,0),"^",4)=""
SET DIE="^PRCA(430,"_PRCABN_",2,"
SET DA(1)=PRCABN
SET DA=PRCAFY
SET DR="3///^S X="""_PRCAAP_""""
DO ^DIE
+5 QUIT
REF ;
+1 NEW DFN,VAERR,VA,VADM,VAPA
+2 SET DFN=+^RCD(340,+$PIECE(^PRCA(430,PRCABN,0),U,9),0)
if 'DFN
QUIT
+3 DO DEM^VADPT
DO ADD^VADPT
+4 SET $PIECE(^PRCF(423,DA,6),U,7,10)=$PIECE(VADM(2),U)_U_1_U_$EXTRACT($TRANSLATE($PIECE($GET(VADM(1)),",",2),".")_" "_$TRANSLATE($PIECE($GET(VADM(1)),",",1),"."),1,23)_U_$EXTRACT($TRANSLATE($GET(VAPA(1)),"."),1,23)
+5 SET $PIECE(^PRCF(423,DA,6),U,11,15)=$EXTRACT($TRANSLATE($GET(VAPA(2)),"."),1,23)_U_$EXTRACT($TRANSLATE($GET(VAPA(4)),"."),1,13)_U_$EXTRACT($TRANSLATE($PIECE($GET(^DIC(5,+$GET(VAPA(5)),0)),U,2),"."),1,2)_U_$EXTRACT(...
... $TRANSLATE($GET(VAPA(6)),"-"),1,9)_"^OVERPAYMENT"
+6 SET $PIECE(^PRCF(423,DA,1),U,8)="0245"
SET $PIECE(^(1),U,10)=3012
+7 QUIT
TREF ;
+1 NEW DIE,DR,CDI,PRCA,PRCAA2,PRCAEN,PRCAMT,PRCASV,PRCFDA
if $DATA(PRCFDEL)
QUIT
SET CDI=DA
+2 IF $PIECE($GET(^PRCF(423,CDI,8)),U,16)']""
WRITE !!,"NO ELECTRONIC SIGNATURE!"
DO DEL
QUIT
+3 DO SETTR^PRCAUTL
IF '$GET(PRCAEN)
WRITE !!,"COULD NOT SET UP A REFUND TRANSACTION!"
DO DEL
QUIT
+4 WRITE !!,"Creating a REFUND Transaction....."
+5 DO PATTR^PRCAUTL
SET PRCA("ADJ")=$ORDER(^PRCA(430.3,"AC",120,0))
SET PRCASV("BDT")=$GET(DT)
SET PRCASV("APR")=DUZ
SET PRCASV("FY")="^"_+$PIECE($GET(^PRCA(430,PRCABN,7)),U,18)
+6 SET DIE="^PRCA(433,"
SET DR="[PRCA FY ADJ2 BATCH]"
SET DA=PRCAEN
DO ^DIE
+7 SET PRCAMT=-$GET(PRCAMT)
SET PRCAA2=$PIECE(^PRCA(433,PRCAEN,4,0),U,3)
+8 DO UPFY^PRCADJ
DO TRANUP^PRCAUTL
+9 ; PRCA*4.5*371 - Replace direct global sets in 7 node with FileMan calls so indexes get updated
+10 SET PRCFDA(430,PRCABN_",",71)=$GET(^PRCA(430,PRCABN,7))+PRCAMT
SET PRCA("STATUS")=$ORDER(^PRCA(430.3,"AC",120,0))
DO FILE^DIE(,"PRCFDA")
DO UPSTATS^PRCAUT2
+11 QUIT
DEL ;
+1 NEW DA,DIK
+2 SET PRCFDEL=1
SET DA=CDI
SET DIK="^PRCF(423,"
DO ^DIK
+3 WRITE *7," <Code Sheet Deleted>"
+4 QUIT
