- RCRCRT1 ;ALB/CMS - RC AND DOJ TRANSACTION ROU 1 ;8/14/97
- V ;;4.5;Accounts Receivable;**63,198**;Mar 20, 1995
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- Q
- EN(PRCATYPE) ;Enter here from Options
- ;Refer Accounts receivable to RC/DOJ option enter PRCATYPE=34
- ; (3 - RC, 4 - DOJ)
- ;Re-Refer to RC/DOJ option enter PRCATYPE=5
- ;Return by RC/DOJ option enter PRCATYPE=6
- I 'PRCATYPE G ENQ
- ;
- N C,D,DA,DIC,D0,I,RCOUT,RCCAT,X,Y,%
- N PRCA,PRCAAB,PRCABN,PRCABN0,PRCABN6,PRCABN7,PRCACAT,PRCACC,PRCACODE,PRCACURB,PRCADT,PRCAEN
- N PRCAD,PRCAIB,PRCAMF,PRCAPB,PRCAPROC,PRCARAMT,PRCAS,PRCATEMP,PRCATY
- ;
- GET D BILL I $G(PRCABN)<1 G ENQ
- S DA=PRCABN,DIC="^PRCA(430," D LCK^PRCAUPD I '$D(DA) G GET
- S PRCACAT=$P(PRCABN0,U,2)
- S PRCABN6=$G(^PRCA(430,PRCABN,6)),PRCADT=+$P(PRCABN6,U,4)
- I 'PRCADT,PRCATYPE'=34 W !!,"This Bill was not referred to RC/DOJ !",! G GET
- S PRCARAMT=$P(PRCABN6,U,6),PRCACODE=$P(PRCABN6,U,5),PRCAPROC=""
- I PRCACODE="DC" S PRCACODE="RC"
- S PRCABN7=$G(^PRCA(430,PRCABN,7))
- S PRCAPB=$P(PRCABN7,U,1),PRCAIB=$P(PRCABN7,U,2),PRCAAB=$P(PRCABN7,U,3)
- S PRCAMF=$P(PRCABN7,U,4),PRCACC=$P(PRCABN7,U,5)
- S PRCACURB=0 F I=1:1:5 S PRCACURB=PRCACURB+$P(PRCABN7,U,I)
- ;
- D WRREF^RCRCRT2 I $G(RCOUT)=1 G ENQ
- I PRCADT,PRCATYPE=34 D CAN^RCRCRT2 G ENQ
- I PRCATYPE=34 D REF
- I PRCATYPE=0 W !,"The Principal Balance is less than the Minimum set for Referral" G ENQ
- I (PRCATYPE=3)!(PRCATYPE=4) S PRCATEMP="[PRCAC DCDOJ REFER]"
- I PRCATYPE=5 S PRCATEMP="[PRCAC DCDOJ REREFER]"
- I PRCATYPE=6 S PRCATEMP="[PRCAC DCDOJ RETN]"
- D PROC
- ;
- ENQ I $G(PRCABN)>0 L -^PRCA(430,+PRCABN)
- K PRCATYPE
- Q
- ;
- PROC ;Create Transaction and Update Bill
- N DA,DIE,DR,PRCAOK,PRCATOT
- D SETTR^PRCAUTL,PATTR^PRCAUTL
- I '$D(PRCAEN) W !!,"*Could not create Transaction at this time. Try again." G PROCQ
- D SETEN
- I 'PRCATOT W !!,"No Referral Action taken.",! G PROCQ
- I PRCATYPE=6 S (PRCACODE,PRCATOT)="@"
- S DR="64///"_$S(PRCATYPE=6:"@",1:PRCADT)_";65///"_PRCACODE_";66///"_PRCATOT
- I PRCATYPE=6 S DR=DR_";68.3///"_PRCADT
- I PRCATYPE=5 S DR=DR_";68.2///"_PRCADT
- S DA=PRCABN,DIE="^PRCA(430," D ^DIE
- W !!,"Referral Action taken.",!
- PROCQ Q
- ;
- REF ;Check Group File for RC or DOJ based on amount
- N MAX,MIN,PRCAGRP,PRCAMAX,PRCAMIN
- I $P($G(^PRCA(430.2,+PRCACAT,0)),U,6)="T" S PRCACODE="RC",PRCATYPE=3 G REFQ
- S PRCAMAX=5000,PRCAMIN=1,PRCATYPE=3
- S PRCAGRP=$O(^RC(342.2,"B","REGIONAL COUNSEL",0)) I PRCAGRP="" G REFQ
- S PRCAGRP=$O(^RC(342.1,"AC",PRCAGRP,0))
- S MIN=$P($G(^RC(342.1,+PRCAGRP,2)),"^"),MAX=$P($G(^(2)),U,2)
- S PRCAMIN=$S(+MIN>0:MIN,1:PRCAMIN),PRCAMAX=$S(+MAX>0:MAX,1:PRCAMAX)
- S PRCATYPE=$S(PRCAPB<PRCAMIN:0,PRCAPB<PRCAMAX:3,1:4)
- S PRCACODE=$S(PRCATYPE=3:"RC",1:"DOJ")
- REFQ Q
- ;
- SETEN ;record the Referral action transaction in the #433.
- N DR,DIE,DIC,DA,D0,PRCAOK,X,Y
- N PRCAEDIT,PRCAEN1,PRCAEN8,PRCAKDT,PRCAKTY
- EDT S DIE="^PRCA(433,",DR=PRCATEMP,DA=PRCAEN D ^DIE
- S DR="41" D ^DIE
- S PRCAEN8=$G(^PRCA(433,PRCAEN,8))
- S PRCAPB=+$P(PRCAEN8,U,1),PRCAIB=+$P(PRCAEN8,U,2),PRCAAB=+$P(PRCAEN8,U,3)
- S PRCAMF=+$P(PRCAEN8,U,4),PRCACC=+$P(PRCAEN8,U,5)
- S PRCATOT=PRCAPB+PRCAIB+PRCAAB+PRCAMF+PRCACC
- S $P(^PRCA(433,PRCAEN,1),U,5)=PRCATOT
- S PRCAEN1=$G(^PRCA(433,PRCAEN,1)),PRCADT=$P(PRCAEN1,U,1)
- S PRCAKTY=$S($P(PRCAEN1,U,2)'="":$P(^PRCA(430.3,$P(PRCAEN1,U,2),0),U,1),1:"")
- S PRCAKDT=""
- I PRCADT S Y=PRCADT D D^DIQ S PRCAKDT=Y
- I PRCATOT>0 D WRDATA^RCRCRT2
- I 'PRCATOT W !!,"**TRANSACTION TOTAL IS ZERO",! D ASKED I $D(PRCAEDIT) G EDT
- I 'PRCATOT,'$D(PRCAEDIT) D DEL G SETENQ
- I $G(RCCAT(PRCACAT)),PRCACURB'=PRCATOT W !!,"**TRANSACTION TOTAL MUST EQUAL THE CURRENT BILL BALANCE $"_PRCACURB D ASKED I $D(PRCAEDIT) G EDT
- I $G(RCCAT(PRCACAT)),PRCACURB'=PRCATOT,'$D(PRCAEDIT) D DEL G SETENQ
- D ASKOK I $D(PRCAOK) G SETENQ
- I $D(PRCAEDIT) G EDT
- D DEL
- SETENQ Q
- ;
- ASKOK K PRCAOK S %=2 W !,"IS THIS CORRECT " D YN^DICN I %=1 S PRCAOK="" Q
- I %=0 D M1^PRCAMESG G ASKOK
- Q:%<0
- ASKED K PRCAEDIT S %=2 W !!,"DO YOU WANT TO EDIT " D YN^DICN Q:%<0
- I %=0 D M2^PRCAMESG G ASKED
- S:%=1 PRCAEDIT=""
- Q
- DEL ;delete the entry.
- N PRCACOMM
- W !!,"* Deleting Transaction ......",!
- S PRCACOMM="USER CANCELED REFERRAL ACTION"
- D DELETE^PRCAWO1 S PRCATOT=0
- Q
- BILL ;Get Active Bill that is not a TP Electronic Refer Type
- ;Return PRCABN=Y,PRCABN(0)=Y(0)
- N DA,DIC,X,Y,%Y W !
- N DPTNOFZY,DPTNOFZK S (DPTNOFZY,DPTNOFZK)=1
- D RCCAT^RCRCUTL(.RCCAT)
- S DIC="^PRCA(430,",DIC(0)="AEQMZ"
- S DIC("S")="I $P(^(0),U,8)=16,+$G(RCCAT(+$P(^(0),U,2)))'=1"
- D ^DIC S PRCABN=+Y,PRCABN0=$G(Y(0))
- Q
- ;RCRCRT1
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCRCRT1 4594 printed Jan 18, 2025@02:49 Page 2
- RCRCRT1 ;ALB/CMS - RC AND DOJ TRANSACTION ROU 1 ;8/14/97
- V ;;4.5;Accounts Receivable;**63,198**;Mar 20, 1995
- +1 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 QUIT
- EN(PRCATYPE) ;Enter here from Options
- +1 ;Refer Accounts receivable to RC/DOJ option enter PRCATYPE=34
- +2 ; (3 - RC, 4 - DOJ)
- +3 ;Re-Refer to RC/DOJ option enter PRCATYPE=5
- +4 ;Return by RC/DOJ option enter PRCATYPE=6
- +5 IF 'PRCATYPE
- GOTO ENQ
- +6 ;
- +7 NEW C,D,DA,DIC,D0,I,RCOUT,RCCAT,X,Y,%
- +8 NEW PRCA,PRCAAB,PRCABN,PRCABN0,PRCABN6,PRCABN7,PRCACAT,PRCACC,PRCACODE,PRCACURB,PRCADT,PRCAEN
- +9 NEW PRCAD,PRCAIB,PRCAMF,PRCAPB,PRCAPROC,PRCARAMT,PRCAS,PRCATEMP,PRCATY
- +10 ;
- GET DO BILL
- IF $GET(PRCABN)<1
- GOTO ENQ
- +1 SET DA=PRCABN
- SET DIC="^PRCA(430,"
- DO LCK^PRCAUPD
- IF '$DATA(DA)
- GOTO GET
- +2 SET PRCACAT=$PIECE(PRCABN0,U,2)
- +3 SET PRCABN6=$GET(^PRCA(430,PRCABN,6))
- SET PRCADT=+$PIECE(PRCABN6,U,4)
- +4 IF 'PRCADT
- IF PRCATYPE'=34
- WRITE !!,"This Bill was not referred to RC/DOJ !",!
- GOTO GET
- +5 SET PRCARAMT=$PIECE(PRCABN6,U,6)
- SET PRCACODE=$PIECE(PRCABN6,U,5)
- SET PRCAPROC=""
- +6 IF PRCACODE="DC"
- SET PRCACODE="RC"
- +7 SET PRCABN7=$GET(^PRCA(430,PRCABN,7))
- +8 SET PRCAPB=$PIECE(PRCABN7,U,1)
- SET PRCAIB=$PIECE(PRCABN7,U,2)
- SET PRCAAB=$PIECE(PRCABN7,U,3)
- +9 SET PRCAMF=$PIECE(PRCABN7,U,4)
- SET PRCACC=$PIECE(PRCABN7,U,5)
- +10 SET PRCACURB=0
- FOR I=1:1:5
- SET PRCACURB=PRCACURB+$PIECE(PRCABN7,U,I)
- +11 ;
- +12 DO WRREF^RCRCRT2
- IF $GET(RCOUT)=1
- GOTO ENQ
- +13 IF PRCADT
- IF PRCATYPE=34
- DO CAN^RCRCRT2
- GOTO ENQ
- +14 IF PRCATYPE=34
- DO REF
- +15 IF PRCATYPE=0
- WRITE !,"The Principal Balance is less than the Minimum set for Referral"
- GOTO ENQ
- +16 IF (PRCATYPE=3)!(PRCATYPE=4)
- SET PRCATEMP="[PRCAC DCDOJ REFER]"
- +17 IF PRCATYPE=5
- SET PRCATEMP="[PRCAC DCDOJ REREFER]"
- +18 IF PRCATYPE=6
- SET PRCATEMP="[PRCAC DCDOJ RETN]"
- +19 DO PROC
- +20 ;
- ENQ IF $GET(PRCABN)>0
- LOCK -^PRCA(430,+PRCABN)
- +1 KILL PRCATYPE
- +2 QUIT
- +3 ;
- PROC ;Create Transaction and Update Bill
- +1 NEW DA,DIE,DR,PRCAOK,PRCATOT
- +2 DO SETTR^PRCAUTL
- DO PATTR^PRCAUTL
- +3 IF '$DATA(PRCAEN)
- WRITE !!,"*Could not create Transaction at this time. Try again."
- GOTO PROCQ
- +4 DO SETEN
- +5 IF 'PRCATOT
- WRITE !!,"No Referral Action taken.",!
- GOTO PROCQ
- +6 IF PRCATYPE=6
- SET (PRCACODE,PRCATOT)="@"
- +7 SET DR="64///"_$SELECT(PRCATYPE=6:"@",1:PRCADT)_";65///"_PRCACODE_";66///"_PRCATOT
- +8 IF PRCATYPE=6
- SET DR=DR_";68.3///"_PRCADT
- +9 IF PRCATYPE=5
- SET DR=DR_";68.2///"_PRCADT
- +10 SET DA=PRCABN
- SET DIE="^PRCA(430,"
- DO ^DIE
- +11 WRITE !!,"Referral Action taken.",!
- PROCQ QUIT
- +1 ;
- REF ;Check Group File for RC or DOJ based on amount
- +1 NEW MAX,MIN,PRCAGRP,PRCAMAX,PRCAMIN
- +2 IF $PIECE($GET(^PRCA(430.2,+PRCACAT,0)),U,6)="T"
- SET PRCACODE="RC"
- SET PRCATYPE=3
- GOTO REFQ
- +3 SET PRCAMAX=5000
- SET PRCAMIN=1
- SET PRCATYPE=3
- +4 SET PRCAGRP=$ORDER(^RC(342.2,"B","REGIONAL COUNSEL",0))
- IF PRCAGRP=""
- GOTO REFQ
- +5 SET PRCAGRP=$ORDER(^RC(342.1,"AC",PRCAGRP,0))
- +6 SET MIN=$PIECE($GET(^RC(342.1,+PRCAGRP,2)),"^")
- SET MAX=$PIECE($GET(^(2)),U,2)
- +7 SET PRCAMIN=$SELECT(+MIN>0:MIN,1:PRCAMIN)
- SET PRCAMAX=$SELECT(+MAX>0:MAX,1:PRCAMAX)
- +8 SET PRCATYPE=$SELECT(PRCAPB<PRCAMIN:0,PRCAPB<PRCAMAX:3,1:4)
- +9 SET PRCACODE=$SELECT(PRCATYPE=3:"RC",1:"DOJ")
- REFQ QUIT
- +1 ;
- SETEN ;record the Referral action transaction in the #433.
- +1 NEW DR,DIE,DIC,DA,D0,PRCAOK,X,Y
- +2 NEW PRCAEDIT,PRCAEN1,PRCAEN8,PRCAKDT,PRCAKTY
- EDT SET DIE="^PRCA(433,"
- SET DR=PRCATEMP
- SET DA=PRCAEN
- DO ^DIE
- +1 SET DR="41"
- DO ^DIE
- +2 SET PRCAEN8=$GET(^PRCA(433,PRCAEN,8))
- +3 SET PRCAPB=+$PIECE(PRCAEN8,U,1)
- SET PRCAIB=+$PIECE(PRCAEN8,U,2)
- SET PRCAAB=+$PIECE(PRCAEN8,U,3)
- +4 SET PRCAMF=+$PIECE(PRCAEN8,U,4)
- SET PRCACC=+$PIECE(PRCAEN8,U,5)
- +5 SET PRCATOT=PRCAPB+PRCAIB+PRCAAB+PRCAMF+PRCACC
- +6 SET $PIECE(^PRCA(433,PRCAEN,1),U,5)=PRCATOT
- +7 SET PRCAEN1=$GET(^PRCA(433,PRCAEN,1))
- SET PRCADT=$PIECE(PRCAEN1,U,1)
- +8 SET PRCAKTY=$SELECT($PIECE(PRCAEN1,U,2)'="":$PIECE(^PRCA(430.3,$PIECE(PRCAEN1,U,2),0),U,1),1:"")
- +9 SET PRCAKDT=""
- +10 IF PRCADT
- SET Y=PRCADT
- DO D^DIQ
- SET PRCAKDT=Y
- +11 IF PRCATOT>0
- DO WRDATA^RCRCRT2
- +12 IF 'PRCATOT
- WRITE !!,"**TRANSACTION TOTAL IS ZERO",!
- DO ASKED
- IF $DATA(PRCAEDIT)
- GOTO EDT
- +13 IF 'PRCATOT
- IF '$DATA(PRCAEDIT)
- DO DEL
- GOTO SETENQ
- +14 IF $GET(RCCAT(PRCACAT))
- IF PRCACURB'=PRCATOT
- WRITE !!,"**TRANSACTION TOTAL MUST EQUAL THE CURRENT BILL BALANCE $"_PRCACURB
- DO ASKED
- IF $DATA(PRCAEDIT)
- GOTO EDT
- +15 IF $GET(RCCAT(PRCACAT))
- IF PRCACURB'=PRCATOT
- IF '$DATA(PRCAEDIT)
- DO DEL
- GOTO SETENQ
- +16 DO ASKOK
- IF $DATA(PRCAOK)
- GOTO SETENQ
- +17 IF $DATA(PRCAEDIT)
- GOTO EDT
- +18 DO DEL
- SETENQ QUIT
- +1 ;
- ASKOK KILL PRCAOK
- SET %=2
- WRITE !,"IS THIS CORRECT "
- DO YN^DICN
- IF %=1
- SET PRCAOK=""
- QUIT
- +1 IF %=0
- DO M1^PRCAMESG
- GOTO ASKOK
- +2 if %<0
- QUIT
- ASKED KILL PRCAEDIT
- SET %=2
- WRITE !!,"DO YOU WANT TO EDIT "
- DO YN^DICN
- if %<0
- QUIT
- +1 IF %=0
- DO M2^PRCAMESG
- GOTO ASKED
- +2 if %=1
- SET PRCAEDIT=""
- +3 QUIT
- DEL ;delete the entry.
- +1 NEW PRCACOMM
- +2 WRITE !!,"* Deleting Transaction ......",!
- +3 SET PRCACOMM="USER CANCELED REFERRAL ACTION"
- +4 DO DELETE^PRCAWO1
- SET PRCATOT=0
- +5 QUIT
- BILL ;Get Active Bill that is not a TP Electronic Refer Type
- +1 ;Return PRCABN=Y,PRCABN(0)=Y(0)
- +2 NEW DA,DIC,X,Y,%Y
- WRITE !
- +3 NEW DPTNOFZY,DPTNOFZK
- SET (DPTNOFZY,DPTNOFZK)=1
- +4 DO RCCAT^RCRCUTL(.RCCAT)
- +5 SET DIC="^PRCA(430,"
- SET DIC(0)="AEQMZ"
- +6 SET DIC("S")="I $P(^(0),U,8)=16,+$G(RCCAT(+$P(^(0),U,2)))'=1"
- +7 DO ^DIC
- SET PRCABN=+Y
- SET PRCABN0=$GET(Y(0))
- +8 QUIT
- +9 ;RCRCRT1