- 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 Jan 18, 2025@02:49:03 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