RCRCUTL ;ALB/CMS - RC REFERRAL UTILITY PROGRAM ; 16-JUN-00
V ;;4.5;Accounts Receivable;**63,159,327**;Mar 20, 1995;Build 7
;;Per VA Directive 6402, this routine should not be modified.
;
;PRCA*4.5*327 Remove defunct mail address: OGCNASRI@MAIL.DOMAIN.EXT^OGCRegion8DeathNotification@mail.domain.ext
;
Q
;
BN ;User Select an AR Bill No.
;Returns PRCABN if exists
N DIC,DA,X,Y,%Y
BNA S DIC="^PRCA(430,",DIC(0)="AEQMZ"
S DIC("S")="I $P(^(0),U,8)=16,$P($G(^PRCA(430.2,+$P(^(0),U,2),0)),U,6)=""T"""
D ^DIC S PRCABN=+Y
I $G(PRCABN)<0 K PRCABN
BNQ Q
;
BNVAR(PRCABN) ;Set PRCA( array with bill information
;Returns PRCA(
N PRCABN0
I '$G(PRCABN) G BNVARQ
S PRCABN0=$G(^PRCA(430,PRCABN,0))
S PRCA("BNAME")=$P(PRCABN0,U,1)
S PRCA("CAT")=$P(PRCABN0,U,2)_"^"_$P($G(^PRCA(430.2,+$P(PRCABN0,U,2),0)),U,1,2)
S PRCA("STATUS")=$P(PRCABN0,U,8)_"^"_$P($G(^PRCA(430.3,+$P(PRCABN0,U,8),0)),U,1,2)
BNVARQ Q
;
DEBT(PRCABN) ;Get Debtor Name and Address
;Send Bill Number
;Return PRCA( array nodes: DEBTNM, DEBTOR, DEBTCT, DEBTZIP, DEBTST,
; DEBTAD1, DEBTAD2, DEBTADD
N PRCACT,PRCAKP,PRCAST,PRCAST1,PRCAST2,X,Y,%Y
K PRCA("DEBTNM"),PRCA("DEBTOR"),PRCA("DEBTCT"),PRCA("DEBTZIP")
K PRCA("DEBTST"),PRCA("DEBTAD1"),PRCA("DEBTAD2"),PRCA("DEBTADD")
I '$G(PRCABN) G DEBTQ
D DEBTOR^PRCAUTL
I $G(PRCA("DEBTNM"))="" G DEBTQ
S PRCA("DEBTCT")=$G(PRCACT,"UNK")
S PRCA("DEBTZIP")=$G(PRCAKP,"UNK")
S PRCA("DEBTST")=$G(PRCAST,"UNK")
S PRCA("DEBTAD1")=$G(PRCAST1)
S PRCA("DEBTAD2")=$G(PRCAST2)
S PRCA("DEBTADD")=$G(X)
DEBTQ Q
;
PT(DFN) ;Get Patient information
;Return values in arrays: VA(, VADM(, VAPD(
K VA,VADM,VAPD
I '$D(^DPT(+$G(DFN),0)) G PTQ
D DEM^VADPT,ADD^VADPT
PTQ Q
;
RCDOM() ;Get supporting RC Domain
;Returns Domain Name
N X
;S X=$O(RCDIV(0))
;I +X S X=$P($G(RCDIV(+X)),U,6)
;I X]"" G RCDOMQ
S X=$O(^RCT(349.1,"B","RC",0))
S X=$P($G(^RCT(349.1,+X,3)),U,4)
RCDOMQ Q X
;
RCCAT(ARRAY) ;Get array of valid AR/RC Bill Categories
;Send back ARRAY(IEN)=x^AR Category Name
; x = 1 = Reconciliation, Referral and Follow-up
; x = 2 = Reconciliation Only
S ARRAY(6)="2^"_$P(^PRCA(430.2,6,0),U,1)
S ARRAY(7)="2^"_$P(^PRCA(430.2,7,0),U,1)
S ARRAY(9)="1^"_$P(^PRCA(430.2,9,0),U,1)
S ARRAY(10)="2^"_$P(^PRCA(430.2,10,0),U,1)
RCCATQ Q
;
REFST(PRCABN) ;Referral Status
;Return: If Referred date^code^amount
; If not Referred 0
N X S X=0
I $P($G(^PRCA(430,PRCABN,0)),U,8)'=16 G REFSTQ
S X=$P($G(^PRCA(430,PRCABN,6)),U,4,6)
I 'X S X=0
REFSTQ Q X
;
RETN(PRCABN) ;Returned from RC/DOJ
;Return: If Return Date send Date
; If not send 0
N X S X=+$P($G(^PRCA(430,PRCABN,6)),U,11)
Q X
;
ACTDT(PRCABN) ;Date account activated
;Return: Date account activated
N X S X=0
I '$G(PRCABN) G ACTDTQ
S X=+$P($G(^PRCA(430,PRCABN,6)),"^",21) I X G ACTDTQ
S X=+$P($G(^PRCA(430,PRCABN,9)),"^",3) I X G ACTDTQ
S X=+$P($G(^PRCA(430,PRCABN,0)),"^",10)
ACTDTQ Q X
;
AEOB ;File 433 Cross-Ref on Transaction Type
; -used to alert pending EOB processing when Payment in Part
; transaction is created
N PRCABN,RCAT
I (X'=2)!(+$G(DA)<1) G AEOBQ
S PRCABN=+$P($G(^PRCA(433,DA,0)),U,2) I 'PRCABN G AEOBQ
I +$P($G(^PRCA(430,PRCABN,0)),U,2)'=9 G AEOBQ
I $$REFST(PRCABN)=0 G AEOBQ
S ^PRCA(433,"AEOB",PRCABN,DA)=""
AEOBQ Q
;
ECHK ;Check to see if pending EOB Code Processing exists
I $O(^PRCA(433,"AEOB",0)) W !!,*7,"*** You have Referred TP Bills pending EOB Code processing ***"
ECHKQ Q
;
ADDR ;Regional Counsel Addresses and Death Notification addresses.
;;OGCBOSRI@MAIL.DOMAIN.EXT^OGCRegion1DeathNotification@mail.domain.ext
;;OGCNYNRI@MAIL.DOMAIN.EXT^OGCRegion2DeathNotification@mail.domain.ext
;;OGCBALRI@MAIL.DOMAIN.EXT^OGCRegion3DeathNotification@mail.domain.ext
;;OGCPHIRI@MAIL.DOMAIN.EXT^OGCRegion4DeathNotification@mail.domain.ext
;;OGCATLRI@MAIL.DOMAIN.EXT^OGCRegion5DeathNotification@mail.domain.ext
;;OGCBAYRI@MAIL.DOMAIN.EXT^OGCRegion6DeathNotification@mail.domain.ext
;;OGCCLERI@MAIL.DOMAIN.EXT^OGCRegion7DeathNotification@mail.domain.ext
;;OGCJACRI@MAIL.DOMAIN.EXT^OGCRegion9DeathNotification@mail.domain.ext
;;OGCCHIRI@MAIL.DOMAIN.EXT^OGCRegion10DeathNotification@mail.domain.ext
;;OGCDETRI@MAIL.DOMAIN.EXT^OGCRegion11DeathNotification@mail.domain.ext
;;OGCSTLRI@MAIL.DOMAIN.EXT^OGCRegion12DeathNotification@mail.domain.ext
;;OGCWACRI@MAIL.DOMAIN.EXT^OGCRegion13DeathNotification@mail.domain.ext
;;OGCHOURI@MAIL.DOMAIN.EXT^OGCRegion14DeathNotification@mail.domain.ext
;;OGCMINRI@MAIL.DOMAIN.EXT^OGCRegion15DeathNotification@mail.domain.ext
;;OGCDENRI@MAIL.DOMAIN.EXT^OGCRegion16DeathNotification@mail.domain.ext
;;OGCLOSRI@MAIL.DOMAIN.EXT^OGCRegion17DeathNotification@mail.domain.ext
;;OGCSFCRI@MAIL.DOMAIN.EXT^OGCRegion18DeathNotification@mail.domain.ext
;;OGCPHORI@MAIL.DOMAIN.EXT^OGCRegion19DeathNotification@mail.domain.ext
;;OGCPORRI@MAIL.DOMAIN.EXT^OGCRegion20DeathNotification@mail.domain.ext
;;OGCBUFRI@MAIL.DOMAIN.EXT^OGCRegion21DeathNotification@mail.domain.ext
;;OGCINDRI@MAIL.DOMAIN.EXT^OGCRegion22DeathNotification@mail.domain.ext
;;OGCWINRI@MAIL.DOMAIN.EXT^OGCRegion23DeathNotification@mail.domain.ext
;;END
;RCRCUTL
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCRCUTL 5259 printed Dec 13, 2024@01:47:50 Page 2
RCRCUTL ;ALB/CMS - RC REFERRAL UTILITY PROGRAM ; 16-JUN-00
V ;;4.5;Accounts Receivable;**63,159,327**;Mar 20, 1995;Build 7
+1 ;;Per VA Directive 6402, this routine should not be modified.
+2 ;
+3 ;PRCA*4.5*327 Remove defunct mail address: OGCNASRI@MAIL.DOMAIN.EXT^OGCRegion8DeathNotification@mail.domain.ext
+4 ;
+5 QUIT
+6 ;
BN ;User Select an AR Bill No.
+1 ;Returns PRCABN if exists
+2 NEW DIC,DA,X,Y,%Y
BNA SET DIC="^PRCA(430,"
SET DIC(0)="AEQMZ"
+1 SET DIC("S")="I $P(^(0),U,8)=16,$P($G(^PRCA(430.2,+$P(^(0),U,2),0)),U,6)=""T"""
+2 DO ^DIC
SET PRCABN=+Y
+3 IF $GET(PRCABN)<0
KILL PRCABN
BNQ QUIT
+1 ;
BNVAR(PRCABN) ;Set PRCA( array with bill information
+1 ;Returns PRCA(
+2 NEW PRCABN0
+3 IF '$GET(PRCABN)
GOTO BNVARQ
+4 SET PRCABN0=$GET(^PRCA(430,PRCABN,0))
+5 SET PRCA("BNAME")=$PIECE(PRCABN0,U,1)
+6 SET PRCA("CAT")=$PIECE(PRCABN0,U,2)_"^"_$PIECE($GET(^PRCA(430.2,+$PIECE(PRCABN0,U,2),0)),U,1,2)
+7 SET PRCA("STATUS")=$PIECE(PRCABN0,U,8)_"^"_$PIECE($GET(^PRCA(430.3,+$PIECE(PRCABN0,U,8),0)),U,1,2)
BNVARQ QUIT
+1 ;
DEBT(PRCABN) ;Get Debtor Name and Address
+1 ;Send Bill Number
+2 ;Return PRCA( array nodes: DEBTNM, DEBTOR, DEBTCT, DEBTZIP, DEBTST,
+3 ; DEBTAD1, DEBTAD2, DEBTADD
+4 NEW PRCACT,PRCAKP,PRCAST,PRCAST1,PRCAST2,X,Y,%Y
+5 KILL PRCA("DEBTNM"),PRCA("DEBTOR"),PRCA("DEBTCT"),PRCA("DEBTZIP")
+6 KILL PRCA("DEBTST"),PRCA("DEBTAD1"),PRCA("DEBTAD2"),PRCA("DEBTADD")
+7 IF '$GET(PRCABN)
GOTO DEBTQ
+8 DO DEBTOR^PRCAUTL
+9 IF $GET(PRCA("DEBTNM"))=""
GOTO DEBTQ
+10 SET PRCA("DEBTCT")=$GET(PRCACT,"UNK")
+11 SET PRCA("DEBTZIP")=$GET(PRCAKP,"UNK")
+12 SET PRCA("DEBTST")=$GET(PRCAST,"UNK")
+13 SET PRCA("DEBTAD1")=$GET(PRCAST1)
+14 SET PRCA("DEBTAD2")=$GET(PRCAST2)
+15 SET PRCA("DEBTADD")=$GET(X)
DEBTQ QUIT
+1 ;
PT(DFN) ;Get Patient information
+1 ;Return values in arrays: VA(, VADM(, VAPD(
+2 KILL VA,VADM,VAPD
+3 IF '$DATA(^DPT(+$GET(DFN),0))
GOTO PTQ
+4 DO DEM^VADPT
DO ADD^VADPT
PTQ QUIT
+1 ;
RCDOM() ;Get supporting RC Domain
+1 ;Returns Domain Name
+2 NEW X
+3 ;S X=$O(RCDIV(0))
+4 ;I +X S X=$P($G(RCDIV(+X)),U,6)
+5 ;I X]"" G RCDOMQ
+6 SET X=$ORDER(^RCT(349.1,"B","RC",0))
+7 SET X=$PIECE($GET(^RCT(349.1,+X,3)),U,4)
RCDOMQ QUIT X
+1 ;
RCCAT(ARRAY) ;Get array of valid AR/RC Bill Categories
+1 ;Send back ARRAY(IEN)=x^AR Category Name
+2 ; x = 1 = Reconciliation, Referral and Follow-up
+3 ; x = 2 = Reconciliation Only
+4 SET ARRAY(6)="2^"_$PIECE(^PRCA(430.2,6,0),U,1)
+5 SET ARRAY(7)="2^"_$PIECE(^PRCA(430.2,7,0),U,1)
+6 SET ARRAY(9)="1^"_$PIECE(^PRCA(430.2,9,0),U,1)
+7 SET ARRAY(10)="2^"_$PIECE(^PRCA(430.2,10,0),U,1)
RCCATQ QUIT
+1 ;
REFST(PRCABN) ;Referral Status
+1 ;Return: If Referred date^code^amount
+2 ; If not Referred 0
+3 NEW X
SET X=0
+4 IF $PIECE($GET(^PRCA(430,PRCABN,0)),U,8)'=16
GOTO REFSTQ
+5 SET X=$PIECE($GET(^PRCA(430,PRCABN,6)),U,4,6)
+6 IF 'X
SET X=0
REFSTQ QUIT X
+1 ;
RETN(PRCABN) ;Returned from RC/DOJ
+1 ;Return: If Return Date send Date
+2 ; If not send 0
+3 NEW X
SET X=+$PIECE($GET(^PRCA(430,PRCABN,6)),U,11)
+4 QUIT X
+5 ;
ACTDT(PRCABN) ;Date account activated
+1 ;Return: Date account activated
+2 NEW X
SET X=0
+3 IF '$GET(PRCABN)
GOTO ACTDTQ
+4 SET X=+$PIECE($GET(^PRCA(430,PRCABN,6)),"^",21)
IF X
GOTO ACTDTQ
+5 SET X=+$PIECE($GET(^PRCA(430,PRCABN,9)),"^",3)
IF X
GOTO ACTDTQ
+6 SET X=+$PIECE($GET(^PRCA(430,PRCABN,0)),"^",10)
ACTDTQ QUIT X
+1 ;
AEOB ;File 433 Cross-Ref on Transaction Type
+1 ; -used to alert pending EOB processing when Payment in Part
+2 ; transaction is created
+3 NEW PRCABN,RCAT
+4 IF (X'=2)!(+$GET(DA)<1)
GOTO AEOBQ
+5 SET PRCABN=+$PIECE($GET(^PRCA(433,DA,0)),U,2)
IF 'PRCABN
GOTO AEOBQ
+6 IF +$PIECE($GET(^PRCA(430,PRCABN,0)),U,2)'=9
GOTO AEOBQ
+7 IF $$REFST(PRCABN)=0
GOTO AEOBQ
+8 SET ^PRCA(433,"AEOB",PRCABN,DA)=""
AEOBQ QUIT
+1 ;
ECHK ;Check to see if pending EOB Code Processing exists
+1 IF $ORDER(^PRCA(433,"AEOB",0))
WRITE !!,*7,"*** You have Referred TP Bills pending EOB Code processing ***"
ECHKQ QUIT
+1 ;
ADDR ;Regional Counsel Addresses and Death Notification addresses.
+1 ;;OGCBOSRI@MAIL.DOMAIN.EXT^OGCRegion1DeathNotification@mail.domain.ext
+2 ;;OGCNYNRI@MAIL.DOMAIN.EXT^OGCRegion2DeathNotification@mail.domain.ext
+3 ;;OGCBALRI@MAIL.DOMAIN.EXT^OGCRegion3DeathNotification@mail.domain.ext
+4 ;;OGCPHIRI@MAIL.DOMAIN.EXT^OGCRegion4DeathNotification@mail.domain.ext
+5 ;;OGCATLRI@MAIL.DOMAIN.EXT^OGCRegion5DeathNotification@mail.domain.ext
+6 ;;OGCBAYRI@MAIL.DOMAIN.EXT^OGCRegion6DeathNotification@mail.domain.ext
+7 ;;OGCCLERI@MAIL.DOMAIN.EXT^OGCRegion7DeathNotification@mail.domain.ext
+8 ;;OGCJACRI@MAIL.DOMAIN.EXT^OGCRegion9DeathNotification@mail.domain.ext
+9 ;;OGCCHIRI@MAIL.DOMAIN.EXT^OGCRegion10DeathNotification@mail.domain.ext
+10 ;;OGCDETRI@MAIL.DOMAIN.EXT^OGCRegion11DeathNotification@mail.domain.ext
+11 ;;OGCSTLRI@MAIL.DOMAIN.EXT^OGCRegion12DeathNotification@mail.domain.ext
+12 ;;OGCWACRI@MAIL.DOMAIN.EXT^OGCRegion13DeathNotification@mail.domain.ext
+13 ;;OGCHOURI@MAIL.DOMAIN.EXT^OGCRegion14DeathNotification@mail.domain.ext
+14 ;;OGCMINRI@MAIL.DOMAIN.EXT^OGCRegion15DeathNotification@mail.domain.ext
+15 ;;OGCDENRI@MAIL.DOMAIN.EXT^OGCRegion16DeathNotification@mail.domain.ext
+16 ;;OGCLOSRI@MAIL.DOMAIN.EXT^OGCRegion17DeathNotification@mail.domain.ext
+17 ;;OGCSFCRI@MAIL.DOMAIN.EXT^OGCRegion18DeathNotification@mail.domain.ext
+18 ;;OGCPHORI@MAIL.DOMAIN.EXT^OGCRegion19DeathNotification@mail.domain.ext
+19 ;;OGCPORRI@MAIL.DOMAIN.EXT^OGCRegion20DeathNotification@mail.domain.ext
+20 ;;OGCBUFRI@MAIL.DOMAIN.EXT^OGCRegion21DeathNotification@mail.domain.ext
+21 ;;OGCINDRI@MAIL.DOMAIN.EXT^OGCRegion22DeathNotification@mail.domain.ext
+22 ;;OGCWINRI@MAIL.DOMAIN.EXT^OGCRegion23DeathNotification@mail.domain.ext
+23 ;;END
+24 ;RCRCUTL
