RCXFMSUR ;WISC/RFJ-revenue source codes ;10/19/10 1:47pm
;;4.5;Accounts Receivable;**90,101,170,203,173,220,231,273,310,315,338,360,435**;Mar 20, 1995;Build 3
;;Per VA Directive 6402, this routine should not be modified.
;Read ^DGCR(399) via IA 3820
Q
;
;
CALCRSC(BILLDA,RCEFT) ; calculate the revenue source code for a bill
; rceft = 1 if processing an EFT deposit
; returns the 4 column (character) rsc
N CATEGDA,COLUMN1,COLUMN2,COLUMN3,COLUMN4,RSC
; if rsc already calculated, return it
I $G(RCEFT)=1 S RSC="8NZZ" Q RSC
S RSC=$P($G(^PRCA(430,BILLDA,11)),"^",23)
I $L(RSC)=4,RSC'="ARRV" Q RSC
;
; calculate it and store it
S CATEGDA=+$P($G(^PRCA(430,BILLDA,0)),"^",2)
;
;PRCA$4.5*338 If a Community Care Category, retrieve RSC, store it and exit.
I CATEGDA>47,(CATEGDA<75) D Q RSC
. S RSC=$$GETCCRSC(CATEGDA,BILLDA)
. D STORE(BILLDA,RSC)
I CATEGDA>80,(CATEGDA<86) D Q RSC ; prca*4.5*360 added CC UC
. S RSC=$$GETCCRSC(CATEGDA,BILLDA)
. D STORE(BILLDA,RSC)
;
; if prepayment, send ARRV
I CATEGDA=26 D STORE(BILLDA,"ARRV") Q "ARRV"
;
S COLUMN1=$$COLUMN1
;
; check for 3rd party RX bills after 4/27/2011 for col 2
N RX3P S RX3P=0
I ("PH"=$$TYP^IBRFN(BILLDA)) D
. S RX3P=$$CHECKRXS^RCXFMSUF(BILLDA)
;
S COLUMN2=$$COLUMN2
;
; if column2 cannot be determined, return the rsc of ARRV
I COLUMN2="" D STORE(BILLDA,"ARRV") Q "ARRV"
;
; if column2 is not a 5 for reimbursable health insurance, or category not 45 (FEE REIMB INS)
; return ZZ in columns 3 and 4
I COLUMN2'=5,CATEGDA'=45 D STORE(BILLDA,COLUMN1_COLUMN2_"ZZ") Q COLUMN1_COLUMN2_"ZZ"
;
; for reimbursable health insurance, compute columns 3 and 4
S COLUMN3=$$COLUMN3
S COLUMN4=$$COLUMN4
;
D STORE(BILLDA,COLUMN1_COLUMN2_COLUMN3_COLUMN4)
Q COLUMN1_COLUMN2_COLUMN3_COLUMN4
;
;
STORE(DA,RSC,FUND) ; store the revenue source code or fund in the file
I $G(^PRCA(430,DA,0))="" Q
N D,D0,DI,DIC,DIE,DQ,DR,X,Y
S DR=""
I $G(RSC)'="" S DR="255.1////"_RSC_";"
I $G(FUND)'="" S DR=DR_"203////"_FUND_";"
S (DIC,DIE)="^PRCA(430,"
D ^DIE
Q
;
;
COLUMN1() ; return column 1 number
Q 8
;
;
COLUMN2() ; return column 2 number
I CATEGDA=5 Q 1 ; hospital care (nsc)
I CATEGDA=4 Q 2 ; outpatient care (nsc)
I CATEGDA=3 Q 3 ; nursing home care (nsc)
I CATEGDA=1 Q 4 ; ineligible hospital
I CATEGDA=9&$G(RX3P) Q "R" ; pharmacy reimbursable health insurance
I CATEGDA=9 Q 5 ; reimbursable health insurance
I CATEGDA=10&$G(RX3P) Q "S" ; pharmacy tort feasor
I CATEGDA=10 Q 6 ; tort feasor
I CATEGDA=6&$G(RX3P) Q "T" ;pharmacy workman's comp
I CATEGDA=6 Q 7 ; workmans comp
I CATEGDA=18 Q 8 ; c (means test)
I CATEGDA=2 Q 9 ; emergency/humanitarian
I CATEGDA=7&$G(RX3P) Q "Q" ;pharmacy no fault auto acc
I CATEGDA=7 Q "A" ; no fault auto accident
I CATEGDA=22 Q "B" ; rx copay/sc vet
I CATEGDA=23 Q "C" ; rx copay/nsc vet
I CATEGDA=24 Q "D" ; nursing home care per diem
I CATEGDA=25 Q "E" ; hospital care per diem
I CATEGDA=21 Q "F" ; medicare
I CATEGDA=33 Q "G" ; adult day health care
I CATEGDA=34 Q "H" ; domiciliary
I CATEGDA=35 Q "I" ; respite care - institutional
I CATEGDA=36 Q "J" ; respite care - non-institutional
I CATEGDA=37 Q "K" ; geriatric evaluation - institutional
I CATEGDA=38 Q "L" ; geriatric evaluation - non-institutional
I CATEGDA=39 Q "M" ; nursing home care - ltc
I CATEGDA=45 Q "F" ; Fee Basis
I CATEGDA=46 D Q COLUMN2
. N COL
. D DIQ399(BILLDA)
. S COL=$G(IBCNDATA(399,BILLDA,.05,"I"))
. S COLUMN2=$S(COL=1:"U",COL=2:"U",COL=3:"V",1:"V")
Q ""
;
;
COLUMN3() ; return the column 3 number
N AGE,DECIMAL,DFN,IBCNDATA,TYPEAGE,TYPECARE,TYPEMEAN,TYPESERV,VA,VADM,VAERR
;
D DIQ399(BILLDA)
;
; PRCA*4.5*310/DRF
; for Fee Basis, column3 = 1 (inpatient) or 2 (outpatient)
I CATEGDA=45 S COLUMN3=$S($G(IBCNDATA(399,BILLDA,.05,"I"))=1:1,$G(IBCNDATA(399,BILLDA,.05,"I"))=2:2,1:2) Q COLUMN3
;
D TYPECARE
;
; compute service connected at time of care (1 digit binary)
; type of service connected is set as follows:
; 0 = SC Vet 1 = NSC Vet
S TYPESERV=1
; service connected at time of care (.18) = yes (1)
I $G(IBCNDATA(399,BILLDA,.18,"I"))=1 S TYPESERV=0
;
S DFN=$P($G(^PRCA(430,BILLDA,0)),"^",7)
D DEM^VADPT
;
; compute means test at time of care (1 digit binary)
; type of means test is set as follows:
; 0 = Cat A 1 = Cat C
S TYPEMEAN=0
I $$BIL^DGMTUB(DFN,$G(IBCNDATA(399,BILLDA,151,"I")))=1 S TYPEMEAN=1
;
; compute patient age at time of care (1 digit binary)
; type of age is set as follows:
; 0 = under 65 1 = 65 and older
S AGE=$$FMDIFF^XLFDT($G(IBCNDATA(399,BILLDA,151,"I")),$P($G(VADM(3)),"^"))\365.25
S TYPEAGE=1
I AGE<65 S TYPEAGE=0
;
; convert to decimal typecare typeserv typemean typeage
; binary= 1 1 1 1 1
; decimal= 16 + 8 + 4 + 2 + 1
S DECIMAL=$S(TYPECARE="11":24,TYPECARE="10":16,TYPECARE="01":8,1:0)
I TYPESERV S DECIMAL=DECIMAL+4
I TYPEMEAN S DECIMAL=DECIMAL+2
I TYPEAGE S DECIMAL=DECIMAL+1
I DECIMAL<10 Q DECIMAL
Q $C(65+DECIMAL-10)
;
;
COLUMN4() ; return the column 4 number (reserved for future expansion)
Q "Z"
;
;
DIQ399(DA) ; get data from file 399
N D0,DIC,DIQ,DIQ2,DR
K IBCNDATA
S DIQ(0)="IE",DIC="^DGCR(399,",DIQ="IBCNDATA",DR=".04;.05;.18;151;" D EN^DIQ1
Q
;
;
TYPECARE ; compute type of care (2 digit binary)
; type of care is set as follows:
; 00 = inpatient (hospital) 01 = outpatient
; 10 = nursing home 11 = other
; default is other if it cannot be computed
S TYPECARE="11"
; bill classification (.05) = outpatient (3) or human.emerg(opt) (4)
I $G(IBCNDATA(399,BILLDA,.05,"I"))=3!($G(IBCNDATA(399,BILLDA,.05,"I"))=4) S TYPECARE="01" Q
; location of care (.04) = hospital inpt or outpt (1)
I $G(IBCNDATA(399,BILLDA,.04,"I"))=1 S TYPECARE="00" Q
; location of care (.04) = skilled nursing (nhcu) (2)
I $G(IBCNDATA(399,BILLDA,.04,"I"))=2 S TYPECARE="10"
Q
;
;
ADDEDIT ; enter/edit revenue source codes for fund 0160A1 bills. These
; bills have the rsc entered by the user. The user can select
; from rscs in file 347.3
W !!,"This option should be used with CAUTION. This option will allow the"
W !,"user owning the PRCASVC supervisor security key, to add or edit the"
W !,"Revenue Source Codes selectable for non MCCF bills. If an invalid"
W !,"Revenue Source Code is entered or changed, all code sheets sent to"
W !,"FMS referencing the invalid Revenue Source Code will reject. Be"
W !,"cautious when entering new Revenue Source Codes or editing existing"
W !,"Revenue Source Codes. New Revenue Source Codes should only be added"
W !,"after they have been added in FMS."
;
I '$D(^XUSEC("PRCASVC",DUZ)) W !!,"You are not an owner of the PRCASVC security key." Q
;
N %,%Y,C,D,D0,DA,DI,DIC,DIE,DLAYGO,DQ,DR,RCRJFLAG,X,X1,X2,X3,Y
;
F D Q:$G(RCRJFLAG)
. S (DIC,DIE)="^RC(347.3,",DIC(0)="QEL",DLAYGO=347.3
. R !!,"Select REVENUE SOURCE CODE: ",X:DTIME
. S X1=X,X=$$UPPER^VALM1(X)
. I $E(X)="?",X?."?" D ^DIC Q:Y<1
. I X=""!($E(X)=U) S RCRJFLAG=1 Q
. I $D(^RC(347.3,"B",X)) S Y=+$O(^(X,0)) W " ",X," ",$P($G(^RC(347.3,Y,0)),U,2) W:$P(^(0),U,3) " INACTIVE" D UPD Q
. S X2=$L(X1),X3=$C($A($E(X1,X2))-1),X3=$E(X1,1,X2-1)_X3,X3=$O(^RC(347.3,"C",X3)) I $E(X3,1,X2)=X1 S X=X1
. S D="C" D IX^DIC Q:Y<1 D UPD Q
Q
UPD S DIE="^RC(347.3,",DA=+Y,DR=".02;.03" D ^DIE
Q
;
;
RSC ;revenue code (#430/255)
I $P($G(^RC(347.3,X,0)),"^",3) D EN^DDIOL("THIS REVENUE SOURCE CODE IS INACTIVE.") K X Q
S X=$P(^RC(347.3,X,0),"^")
Q
;
SHOW ; show/calculate revenue source code for a selected bill
W !!,"This option will show the calculated Revenue Source Code for a selected"
W !,"bill. The Revenue Source Code is only calculated for accrued bills in"
I DT'<$$ADDPTEDT^PRCAACC() W !,"funds 528701,528703,528704,528709/4032,528711,528713,528714"
I DT<$$ADDPTEDT^PRCAACC() W !,"funds 5287.1,5287.3,5287.4,4032"
;
N %,%Y,BILLDA,C,DIC,FUND,I,RCRJFLAG,RSC,X,Y
N CATEG ;PRCA*4.5*435 Temporary fix
;
F D Q:$G(RCRJFLAG)
. S DIC="^PRCA(430,",DIC(0)="QEAM"
. W ! D ^DIC
. I Y<1 S RCRJFLAG=1 Q
. S BILLDA=+Y
. ;PRCA*4.5*338 - prevent Non-accrued funds from recalculating Fund Number)
. ; look for an existing fund number
. S FUND=$P($G(^PRCA(430,BILLDA,11)),"^",17)
. ; only recalculate fund number if Accrued fund
. I $$PTACCT^PRCAACC(FUND) S FUND=$$GETFUNDB^RCXFMSUF(BILLDA,1)
. ;end PRCA*4.5*338
. ;
. ;PRCA*4.5*435 - Temporary fix for Manual BOCs (cat = 18,22,23) that may not have a fund
. ;A permanent fix for both the fund and RSC will occur as a future enhancement
. I $G(FUND)="" D
. . S CATEG=+$P($G(^PRCA(430,BILLDA,0)),"^",2)
. . ;Valid categories are: 18 - C (MEANS TEST), 22 - RX CO-PAYMENT/SC VET, 23 - RX CO-PAYMENT/NSC VET
. . I CATEG'=18&(CATEG'=22)&(CATEG'=23) Q
. . ;Calculate and store the fund
. . S FUND=$$GETFUNDB^RCXFMSUF(BILLDA)
. ;end PRCA*4.5*435
. ;
. W !!," Bill Number: ",$P($G(^PRCA(430,BILLDA,0)),"^")
. W !," Fund: ",FUND
. I '$$PTACCT^PRCAACC(FUND),FUND'=4032 D Q
. . W !," The Revenue Source Code cannot be calculated for non-accrued bills."
. . W !," The Revenue Source Code for non-accrued bills are input by the user."
. . W !," The Revenue Source Code is currently entered as: "
. . S RSC=$P($G(^PRCA(430,BILLDA,11)),"^",6)
. . W $S(RSC="":"<not entered>",1:RSC)
. ;
. S RSC=$$CALCRSC(BILLDA)
. W !,"Revenue Source Code: ",RSC
Q
;
;PRCA*4.5*338
GETCCRSC(CATEGDA,BILLDA) ;Retrieve the RSC for Community Care Categories
N RCRSC,IBCNDATA,RCIOPFLG,RX3P
S RCRSC=""
Q:CATEGDA=52 "84CC" ;Choice No-Fault Auto AR Category
Q:CATEGDA=53 "85CC" ;Choice TORT Feasor AR Category
Q:CATEGDA=60 "86CC" ;Choice Workers' Comp AR Category
Q:CATEGDA=54 "8CNW" ;CCN Workers' Comp AR Category
Q:CATEGDA=56 "8CN9" ;CCN TORT Feasor AR Category
Q:CATEGDA=55 "8CN8" ;CCN No-Fault Auto AR Category
Q:CATEGDA=57 "8C6C" ;CC Workers' Comp AR Category
Q:CATEGDA=59 "8C5C" ;CC TORT Feasor AR Category
Q:CATEGDA=58 "8C4C" ;CC No-Fault Auto AR Category
Q:CATEGDA=61 "8CC5" ;CHOICE Inpatient Copay
Q:CATEGDA=62 "8CC7" ;CHOICE RX CO-PAYMENT Copay
Q:CATEGDA=63 "8CC1" ;CC Inpatient Copay
Q:CATEGDA=64 "8CC3" ;CC RX CO-PAYMENT
Q:CATEGDA=65 "8CN1" ;CCN Inpatient Copay
Q:CATEGDA=66 "8CN3" ;CCN RX CO-PAYMENT
Q:CATEGDA=67 "8CD1" ;CC MTF C (MEANS TEST)
Q:CATEGDA=68 "8CD3" ;CC MTF RX CO-PAYMENT
Q:CATEGDA=69 "8CC4" ;CC NURSING HOME CARE - LTC
Q:CATEGDA=70 "8CC4" ;CC RESPITE CARE
Q:CATEGDA=71 "8CN4" ;CCN NURSING HOME CARE - LTC
Q:CATEGDA=72 "8CN4" ;CCN RESPITE CARE
Q:CATEGDA=73 "8CC8" ;CHOICE NURSING HOME CARE - LTC
Q:CATEGDA=74 "8CC8" ;CHOICE RESPITE CARE
Q:CATEGDA=81 "8CC6" ;CHOICE OPT
Q:CATEGDA=82 "8CC2" ;CC OPT
Q:CATEGDA=83 "8CN2" ;CCN OPT
Q:CATEGDA=84 "8CD2" ;CC MTF OPT
Q:CATEGDA=85 "8CCU" ;CC URGENT CARE prca*4.5*360
I (CATEGDA>47),(CATEGDA<52) D Q RCRSC
. S RCIOPFLG=""
. S RX3P=0
. I ("PH"=$$TYP^IBRFN(BILLDA)) D
. . S RX3P=$$CHECKRXS^RCXFMSUF(BILLDA)
. D DIQ399(BILLDA)
. ; for Community Care, 1 (inpatient) or 2 (outpatient -everything else)
. S RCIOPFLG=$S($G(IBCNDATA(399,BILLDA,.05,"I"))=1:1,1:2)
. I (CATEGDA=48),RX3P S RCRSC="83CC" Q ;CHOICE INS RX
. I (CATEGDA=48),(RCIOPFLG=1) S RCRSC="81CC" Q ;CHOICE INS INPATIENT
. I (CATEGDA=48),(RCIOPFLG=2) S RCRSC="82CC" Q ;CHOICE INS OUTPATIENT
. I (CATEGDA=49),RX3P S RCRSC="8C3C" Q ;CC INS RX
. I (CATEGDA=49),(RCIOPFLG=1) S RCRSC="8C1C" Q ;CC INS INPATIENT
. I (CATEGDA=49),(RCIOPFLG=2) S RCRSC="8C2C" Q ;CC INS OUTPATIENT
. I (CATEGDA=50),RX3P S RCRSC="8CN7" Q ;CCN INS RX
. I (CATEGDA=50),(RCIOPFLG=1) S RCRSC="8CN5" Q ;CCN INS INPATIENT
. I (CATEGDA=50),(RCIOPFLG=2) S RCRSC="8CN6" Q ;CCN INS OUTPATIENT
. I (CATEGDA=51),RX3P S RCRSC="8CD6" Q ;CC MTF INS RX
. I (CATEGDA=51),(RCIOPFLG=1) S RCRSC="8CD4" Q ;CC MTF INS INPATIENT
. I (CATEGDA=51),(RCIOPFLG=2) S RCRSC="8CD5" Q ;CC MTF INS OUTPATIENT
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCXFMSUR 12517 printed Dec 13, 2024@01:49:22 Page 2
RCXFMSUR ;WISC/RFJ-revenue source codes ;10/19/10 1:47pm
+1 ;;4.5;Accounts Receivable;**90,101,170,203,173,220,231,273,310,315,338,360,435**;Mar 20, 1995;Build 3
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;Read ^DGCR(399) via IA 3820
+4 QUIT
+5 ;
+6 ;
CALCRSC(BILLDA,RCEFT) ; calculate the revenue source code for a bill
+1 ; rceft = 1 if processing an EFT deposit
+2 ; returns the 4 column (character) rsc
+3 NEW CATEGDA,COLUMN1,COLUMN2,COLUMN3,COLUMN4,RSC
+4 ; if rsc already calculated, return it
+5 IF $GET(RCEFT)=1
SET RSC="8NZZ"
QUIT RSC
+6 SET RSC=$PIECE($GET(^PRCA(430,BILLDA,11)),"^",23)
+7 IF $LENGTH(RSC)=4
IF RSC'="ARRV"
QUIT RSC
+8 ;
+9 ; calculate it and store it
+10 SET CATEGDA=+$PIECE($GET(^PRCA(430,BILLDA,0)),"^",2)
+11 ;
+12 ;PRCA$4.5*338 If a Community Care Category, retrieve RSC, store it and exit.
+13 IF CATEGDA>47
IF (CATEGDA<75)
Begin DoDot:1
+14 SET RSC=$$GETCCRSC(CATEGDA,BILLDA)
+15 DO STORE(BILLDA,RSC)
End DoDot:1
QUIT RSC
+16 ; prca*4.5*360 added CC UC
IF CATEGDA>80
IF (CATEGDA<86)
Begin DoDot:1
+17 SET RSC=$$GETCCRSC(CATEGDA,BILLDA)
+18 DO STORE(BILLDA,RSC)
End DoDot:1
QUIT RSC
+19 ;
+20 ; if prepayment, send ARRV
+21 IF CATEGDA=26
DO STORE(BILLDA,"ARRV")
QUIT "ARRV"
+22 ;
+23 SET COLUMN1=$$COLUMN1
+24 ;
+25 ; check for 3rd party RX bills after 4/27/2011 for col 2
+26 NEW RX3P
SET RX3P=0
+27 IF ("PH"=$$TYP^IBRFN(BILLDA))
Begin DoDot:1
+28 SET RX3P=$$CHECKRXS^RCXFMSUF(BILLDA)
End DoDot:1
+29 ;
+30 SET COLUMN2=$$COLUMN2
+31 ;
+32 ; if column2 cannot be determined, return the rsc of ARRV
+33 IF COLUMN2=""
DO STORE(BILLDA,"ARRV")
QUIT "ARRV"
+34 ;
+35 ; if column2 is not a 5 for reimbursable health insurance, or category not 45 (FEE REIMB INS)
+36 ; return ZZ in columns 3 and 4
+37 IF COLUMN2'=5
IF CATEGDA'=45
DO STORE(BILLDA,COLUMN1_COLUMN2_"ZZ")
QUIT COLUMN1_COLUMN2_"ZZ"
+38 ;
+39 ; for reimbursable health insurance, compute columns 3 and 4
+40 SET COLUMN3=$$COLUMN3
+41 SET COLUMN4=$$COLUMN4
+42 ;
+43 DO STORE(BILLDA,COLUMN1_COLUMN2_COLUMN3_COLUMN4)
+44 QUIT COLUMN1_COLUMN2_COLUMN3_COLUMN4
+45 ;
+46 ;
STORE(DA,RSC,FUND) ; store the revenue source code or fund in the file
+1 IF $GET(^PRCA(430,DA,0))=""
QUIT
+2 NEW D,D0,DI,DIC,DIE,DQ,DR,X,Y
+3 SET DR=""
+4 IF $GET(RSC)'=""
SET DR="255.1////"_RSC_";"
+5 IF $GET(FUND)'=""
SET DR=DR_"203////"_FUND_";"
+6 SET (DIC,DIE)="^PRCA(430,"
+7 DO ^DIE
+8 QUIT
+9 ;
+10 ;
COLUMN1() ; return column 1 number
+1 QUIT 8
+2 ;
+3 ;
COLUMN2() ; return column 2 number
+1 ; hospital care (nsc)
IF CATEGDA=5
QUIT 1
+2 ; outpatient care (nsc)
IF CATEGDA=4
QUIT 2
+3 ; nursing home care (nsc)
IF CATEGDA=3
QUIT 3
+4 ; ineligible hospital
IF CATEGDA=1
QUIT 4
+5 ; pharmacy reimbursable health insurance
IF CATEGDA=9&$GET(RX3P)
QUIT "R"
+6 ; reimbursable health insurance
IF CATEGDA=9
QUIT 5
+7 ; pharmacy tort feasor
IF CATEGDA=10&$GET(RX3P)
QUIT "S"
+8 ; tort feasor
IF CATEGDA=10
QUIT 6
+9 ;pharmacy workman's comp
IF CATEGDA=6&$GET(RX3P)
QUIT "T"
+10 ; workmans comp
IF CATEGDA=6
QUIT 7
+11 ; c (means test)
IF CATEGDA=18
QUIT 8
+12 ; emergency/humanitarian
IF CATEGDA=2
QUIT 9
+13 ;pharmacy no fault auto acc
IF CATEGDA=7&$GET(RX3P)
QUIT "Q"
+14 ; no fault auto accident
IF CATEGDA=7
QUIT "A"
+15 ; rx copay/sc vet
IF CATEGDA=22
QUIT "B"
+16 ; rx copay/nsc vet
IF CATEGDA=23
QUIT "C"
+17 ; nursing home care per diem
IF CATEGDA=24
QUIT "D"
+18 ; hospital care per diem
IF CATEGDA=25
QUIT "E"
+19 ; medicare
IF CATEGDA=21
QUIT "F"
+20 ; adult day health care
IF CATEGDA=33
QUIT "G"
+21 ; domiciliary
IF CATEGDA=34
QUIT "H"
+22 ; respite care - institutional
IF CATEGDA=35
QUIT "I"
+23 ; respite care - non-institutional
IF CATEGDA=36
QUIT "J"
+24 ; geriatric evaluation - institutional
IF CATEGDA=37
QUIT "K"
+25 ; geriatric evaluation - non-institutional
IF CATEGDA=38
QUIT "L"
+26 ; nursing home care - ltc
IF CATEGDA=39
QUIT "M"
+27 ; Fee Basis
IF CATEGDA=45
QUIT "F"
+28 IF CATEGDA=46
Begin DoDot:1
+29 NEW COL
+30 DO DIQ399(BILLDA)
+31 SET COL=$GET(IBCNDATA(399,BILLDA,.05,"I"))
+32 SET COLUMN2=$SELECT(COL=1:"U",COL=2:"U",COL=3:"V",1:"V")
End DoDot:1
QUIT COLUMN2
+33 QUIT ""
+34 ;
+35 ;
COLUMN3() ; return the column 3 number
+1 NEW AGE,DECIMAL,DFN,IBCNDATA,TYPEAGE,TYPECARE,TYPEMEAN,TYPESERV,VA,VADM,VAERR
+2 ;
+3 DO DIQ399(BILLDA)
+4 ;
+5 ; PRCA*4.5*310/DRF
+6 ; for Fee Basis, column3 = 1 (inpatient) or 2 (outpatient)
+7 IF CATEGDA=45
SET COLUMN3=$SELECT($GET(IBCNDATA(399,BILLDA,.05,"I"))=1:1,$GET(IBCNDATA(399,BILLDA,.05,"I"))=2:2,1:2)
QUIT COLUMN3
+8 ;
+9 DO TYPECARE
+10 ;
+11 ; compute service connected at time of care (1 digit binary)
+12 ; type of service connected is set as follows:
+13 ; 0 = SC Vet 1 = NSC Vet
+14 SET TYPESERV=1
+15 ; service connected at time of care (.18) = yes (1)
+16 IF $GET(IBCNDATA(399,BILLDA,.18,"I"))=1
SET TYPESERV=0
+17 ;
+18 SET DFN=$PIECE($GET(^PRCA(430,BILLDA,0)),"^",7)
+19 DO DEM^VADPT
+20 ;
+21 ; compute means test at time of care (1 digit binary)
+22 ; type of means test is set as follows:
+23 ; 0 = Cat A 1 = Cat C
+24 SET TYPEMEAN=0
+25 IF $$BIL^DGMTUB(DFN,$GET(IBCNDATA(399,BILLDA,151,"I")))=1
SET TYPEMEAN=1
+26 ;
+27 ; compute patient age at time of care (1 digit binary)
+28 ; type of age is set as follows:
+29 ; 0 = under 65 1 = 65 and older
+30 SET AGE=$$FMDIFF^XLFDT($GET(IBCNDATA(399,BILLDA,151,"I")),$PIECE($GET(VADM(3)),"^"))\365.25
+31 SET TYPEAGE=1
+32 IF AGE<65
SET TYPEAGE=0
+33 ;
+34 ; convert to decimal typecare typeserv typemean typeage
+35 ; binary= 1 1 1 1 1
+36 ; decimal= 16 + 8 + 4 + 2 + 1
+37 SET DECIMAL=$SELECT(TYPECARE="11":24,TYPECARE="10":16,TYPECARE="01":8,1:0)
+38 IF TYPESERV
SET DECIMAL=DECIMAL+4
+39 IF TYPEMEAN
SET DECIMAL=DECIMAL+2
+40 IF TYPEAGE
SET DECIMAL=DECIMAL+1
+41 IF DECIMAL<10
QUIT DECIMAL
+42 QUIT $CHAR(65+DECIMAL-10)
+43 ;
+44 ;
COLUMN4() ; return the column 4 number (reserved for future expansion)
+1 QUIT "Z"
+2 ;
+3 ;
DIQ399(DA) ; get data from file 399
+1 NEW D0,DIC,DIQ,DIQ2,DR
+2 KILL IBCNDATA
+3 SET DIQ(0)="IE"
SET DIC="^DGCR(399,"
SET DIQ="IBCNDATA"
SET DR=".04;.05;.18;151;"
DO EN^DIQ1
+4 QUIT
+5 ;
+6 ;
TYPECARE ; compute type of care (2 digit binary)
+1 ; type of care is set as follows:
+2 ; 00 = inpatient (hospital) 01 = outpatient
+3 ; 10 = nursing home 11 = other
+4 ; default is other if it cannot be computed
+5 SET TYPECARE="11"
+6 ; bill classification (.05) = outpatient (3) or human.emerg(opt) (4)
+7 IF $GET(IBCNDATA(399,BILLDA,.05,"I"))=3!($GET(IBCNDATA(399,BILLDA,.05,"I"))=4)
SET TYPECARE="01"
QUIT
+8 ; location of care (.04) = hospital inpt or outpt (1)
+9 IF $GET(IBCNDATA(399,BILLDA,.04,"I"))=1
SET TYPECARE="00"
QUIT
+10 ; location of care (.04) = skilled nursing (nhcu) (2)
+11 IF $GET(IBCNDATA(399,BILLDA,.04,"I"))=2
SET TYPECARE="10"
+12 QUIT
+13 ;
+14 ;
ADDEDIT ; enter/edit revenue source codes for fund 0160A1 bills. These
+1 ; bills have the rsc entered by the user. The user can select
+2 ; from rscs in file 347.3
+3 WRITE !!,"This option should be used with CAUTION. This option will allow the"
+4 WRITE !,"user owning the PRCASVC supervisor security key, to add or edit the"
+5 WRITE !,"Revenue Source Codes selectable for non MCCF bills. If an invalid"
+6 WRITE !,"Revenue Source Code is entered or changed, all code sheets sent to"
+7 WRITE !,"FMS referencing the invalid Revenue Source Code will reject. Be"
+8 WRITE !,"cautious when entering new Revenue Source Codes or editing existing"
+9 WRITE !,"Revenue Source Codes. New Revenue Source Codes should only be added"
+10 WRITE !,"after they have been added in FMS."
+11 ;
+12 IF '$DATA(^XUSEC("PRCASVC",DUZ))
WRITE !!,"You are not an owner of the PRCASVC security key."
QUIT
+13 ;
+14 NEW %,%Y,C,D,D0,DA,DI,DIC,DIE,DLAYGO,DQ,DR,RCRJFLAG,X,X1,X2,X3,Y
+15 ;
+16 FOR
Begin DoDot:1
+17 SET (DIC,DIE)="^RC(347.3,"
SET DIC(0)="QEL"
SET DLAYGO=347.3
+18 READ !!,"Select REVENUE SOURCE CODE: ",X:DTIME
+19 SET X1=X
SET X=$$UPPER^VALM1(X)
+20 IF $EXTRACT(X)="?"
IF X?."?"
DO ^DIC
if Y<1
QUIT
+21 IF X=""!($EXTRACT(X)=U)
SET RCRJFLAG=1
QUIT
+22 IF $DATA(^RC(347.3,"B",X))
SET Y=+$ORDER(^(X,0))
WRITE " ",X," ",$PIECE($GET(^RC(347.3,Y,0)),U,2)
if $PIECE(^(0),U,3)
WRITE " INACTIVE"
DO UPD
QUIT
+23 SET X2=$LENGTH(X1)
SET X3=$CHAR($ASCII($EXTRACT(X1,X2))-1)
SET X3=$EXTRACT(X1,1,X2-1)_X3
SET X3=$ORDER(^RC(347.3,"C",X3))
IF $EXTRACT(X3,1,X2)=X1
SET X=X1
+24 SET D="C"
DO IX^DIC
if Y<1
QUIT
DO UPD
QUIT
End DoDot:1
if $GET(RCRJFLAG)
QUIT
+25 QUIT
UPD SET DIE="^RC(347.3,"
SET DA=+Y
SET DR=".02;.03"
DO ^DIE
+1 QUIT
+2 ;
+3 ;
RSC ;revenue code (#430/255)
+1 IF $PIECE($GET(^RC(347.3,X,0)),"^",3)
DO EN^DDIOL("THIS REVENUE SOURCE CODE IS INACTIVE.")
KILL X
QUIT
+2 SET X=$PIECE(^RC(347.3,X,0),"^")
+3 QUIT
+4 ;
SHOW ; show/calculate revenue source code for a selected bill
+1 WRITE !!,"This option will show the calculated Revenue Source Code for a selected"
+2 WRITE !,"bill. The Revenue Source Code is only calculated for accrued bills in"
+3 IF DT'<$$ADDPTEDT^PRCAACC()
WRITE !,"funds 528701,528703,528704,528709/4032,528711,528713,528714"
+4 IF DT<$$ADDPTEDT^PRCAACC()
WRITE !,"funds 5287.1,5287.3,5287.4,4032"
+5 ;
+6 NEW %,%Y,BILLDA,C,DIC,FUND,I,RCRJFLAG,RSC,X,Y
+7 ;PRCA*4.5*435 Temporary fix
NEW CATEG
+8 ;
+9 FOR
Begin DoDot:1
+10 SET DIC="^PRCA(430,"
SET DIC(0)="QEAM"
+11 WRITE !
DO ^DIC
+12 IF Y<1
SET RCRJFLAG=1
QUIT
+13 SET BILLDA=+Y
+14 ;PRCA*4.5*338 - prevent Non-accrued funds from recalculating Fund Number)
+15 ; look for an existing fund number
+16 SET FUND=$PIECE($GET(^PRCA(430,BILLDA,11)),"^",17)
+17 ; only recalculate fund number if Accrued fund
+18 IF $$PTACCT^PRCAACC(FUND)
SET FUND=$$GETFUNDB^RCXFMSUF(BILLDA,1)
+19 ;end PRCA*4.5*338
+20 ;
+21 ;PRCA*4.5*435 - Temporary fix for Manual BOCs (cat = 18,22,23) that may not have a fund
+22 ;A permanent fix for both the fund and RSC will occur as a future enhancement
+23 IF $GET(FUND)=""
Begin DoDot:2
+24 SET CATEG=+$PIECE($GET(^PRCA(430,BILLDA,0)),"^",2)
+25 ;Valid categories are: 18 - C (MEANS TEST), 22 - RX CO-PAYMENT/SC VET, 23 - RX CO-PAYMENT/NSC VET
+26 IF CATEG'=18&(CATEG'=22)&(CATEG'=23)
QUIT
+27 ;Calculate and store the fund
+28 SET FUND=$$GETFUNDB^RCXFMSUF(BILLDA)
End DoDot:2
+29 ;end PRCA*4.5*435
+30 ;
+31 WRITE !!," Bill Number: ",$PIECE($GET(^PRCA(430,BILLDA,0)),"^")
+32 WRITE !," Fund: ",FUND
+33 IF '$$PTACCT^PRCAACC(FUND)
IF FUND'=4032
Begin DoDot:2
+34 WRITE !," The Revenue Source Code cannot be calculated for non-accrued bills."
+35 WRITE !," The Revenue Source Code for non-accrued bills are input by the user."
+36 WRITE !," The Revenue Source Code is currently entered as: "
+37 SET RSC=$PIECE($GET(^PRCA(430,BILLDA,11)),"^",6)
+38 WRITE $SELECT(RSC="":"<not entered>",1:RSC)
End DoDot:2
QUIT
+39 ;
+40 SET RSC=$$CALCRSC(BILLDA)
+41 WRITE !,"Revenue Source Code: ",RSC
End DoDot:1
if $GET(RCRJFLAG)
QUIT
+42 QUIT
+43 ;
+44 ;PRCA*4.5*338
GETCCRSC(CATEGDA,BILLDA) ;Retrieve the RSC for Community Care Categories
+1 NEW RCRSC,IBCNDATA,RCIOPFLG,RX3P
+2 SET RCRSC=""
+3 ;Choice No-Fault Auto AR Category
if CATEGDA=52
QUIT "84CC"
+4 ;Choice TORT Feasor AR Category
if CATEGDA=53
QUIT "85CC"
+5 ;Choice Workers' Comp AR Category
if CATEGDA=60
QUIT "86CC"
+6 ;CCN Workers' Comp AR Category
if CATEGDA=54
QUIT "8CNW"
+7 ;CCN TORT Feasor AR Category
if CATEGDA=56
QUIT "8CN9"
+8 ;CCN No-Fault Auto AR Category
if CATEGDA=55
QUIT "8CN8"
+9 ;CC Workers' Comp AR Category
if CATEGDA=57
QUIT "8C6C"
+10 ;CC TORT Feasor AR Category
if CATEGDA=59
QUIT "8C5C"
+11 ;CC No-Fault Auto AR Category
if CATEGDA=58
QUIT "8C4C"
+12 ;CHOICE Inpatient Copay
if CATEGDA=61
QUIT "8CC5"
+13 ;CHOICE RX CO-PAYMENT Copay
if CATEGDA=62
QUIT "8CC7"
+14 ;CC Inpatient Copay
if CATEGDA=63
QUIT "8CC1"
+15 ;CC RX CO-PAYMENT
if CATEGDA=64
QUIT "8CC3"
+16 ;CCN Inpatient Copay
if CATEGDA=65
QUIT "8CN1"
+17 ;CCN RX CO-PAYMENT
if CATEGDA=66
QUIT "8CN3"
+18 ;CC MTF C (MEANS TEST)
if CATEGDA=67
QUIT "8CD1"
+19 ;CC MTF RX CO-PAYMENT
if CATEGDA=68
QUIT "8CD3"
+20 ;CC NURSING HOME CARE - LTC
if CATEGDA=69
QUIT "8CC4"
+21 ;CC RESPITE CARE
if CATEGDA=70
QUIT "8CC4"
+22 ;CCN NURSING HOME CARE - LTC
if CATEGDA=71
QUIT "8CN4"
+23 ;CCN RESPITE CARE
if CATEGDA=72
QUIT "8CN4"
+24 ;CHOICE NURSING HOME CARE - LTC
if CATEGDA=73
QUIT "8CC8"
+25 ;CHOICE RESPITE CARE
if CATEGDA=74
QUIT "8CC8"
+26 ;CHOICE OPT
if CATEGDA=81
QUIT "8CC6"
+27 ;CC OPT
if CATEGDA=82
QUIT "8CC2"
+28 ;CCN OPT
if CATEGDA=83
QUIT "8CN2"
+29 ;CC MTF OPT
if CATEGDA=84
QUIT "8CD2"
+30 ;CC URGENT CARE prca*4.5*360
if CATEGDA=85
QUIT "8CCU"
+31 IF (CATEGDA>47)
IF (CATEGDA<52)
Begin DoDot:1
+32 SET RCIOPFLG=""
+33 SET RX3P=0
+34 IF ("PH"=$$TYP^IBRFN(BILLDA))
Begin DoDot:2
+35 SET RX3P=$$CHECKRXS^RCXFMSUF(BILLDA)
End DoDot:2
+36 DO DIQ399(BILLDA)
+37 ; for Community Care, 1 (inpatient) or 2 (outpatient -everything else)
+38 SET RCIOPFLG=$SELECT($GET(IBCNDATA(399,BILLDA,.05,"I"))=1:1,1:2)
+39 ;CHOICE INS RX
IF (CATEGDA=48)
IF RX3P
SET RCRSC="83CC"
QUIT
+40 ;CHOICE INS INPATIENT
IF (CATEGDA=48)
IF (RCIOPFLG=1)
SET RCRSC="81CC"
QUIT
+41 ;CHOICE INS OUTPATIENT
IF (CATEGDA=48)
IF (RCIOPFLG=2)
SET RCRSC="82CC"
QUIT
+42 ;CC INS RX
IF (CATEGDA=49)
IF RX3P
SET RCRSC="8C3C"
QUIT
+43 ;CC INS INPATIENT
IF (CATEGDA=49)
IF (RCIOPFLG=1)
SET RCRSC="8C1C"
QUIT
+44 ;CC INS OUTPATIENT
IF (CATEGDA=49)
IF (RCIOPFLG=2)
SET RCRSC="8C2C"
QUIT
+45 ;CCN INS RX
IF (CATEGDA=50)
IF RX3P
SET RCRSC="8CN7"
QUIT
+46 ;CCN INS INPATIENT
IF (CATEGDA=50)
IF (RCIOPFLG=1)
SET RCRSC="8CN5"
QUIT
+47 ;CCN INS OUTPATIENT
IF (CATEGDA=50)
IF (RCIOPFLG=2)
SET RCRSC="8CN6"
QUIT
+48 ;CC MTF INS RX
IF (CATEGDA=51)
IF RX3P
SET RCRSC="8CD6"
QUIT
+49 ;CC MTF INS INPATIENT
IF (CATEGDA=51)
IF (RCIOPFLG=1)
SET RCRSC="8CD4"
QUIT
+50 ;CC MTF INS OUTPATIENT
IF (CATEGDA=51)
IF (RCIOPFLG=2)
SET RCRSC="8CD5"
QUIT
End DoDot:1
QUIT RCRSC
+51 QUIT 0
