- IBCU63 ;ALB/AAS - BILLING UTILITY TO SET AMB SURG REV CODES ; 20-NOV-91
- ;;2.0;INTEGRATED BILLING;**21,133,349**;21-MAR-94;Build 46
- ;;Per VHA Directive 2004-038, this routine should not be modified.
- ;
- ;MAP TO DGCRU63
- % ; BASC
- Q:IBIDS(.11)'="i"
- K ^UTILITY($J,"IB-ASC")
- S DGRVCOD=$S($P($G(DGINPAR),"^",4):$P(DGINPAR,"^",4),$P($G(^IBE(350.9,1,1)),"^",18):$P(^(1),"^",18),1:"") Q:DGRVCOD=""
- ;
- BLD S DGASC=0 F S DGASC=$O(^DGCR(399,IBIFN,"CP","ASC",1,DGASC)) Q:'DGASC S DGPROC=$G(^DGCR(399,IBIFN,"CP",DGASC,0)) I DGPROC D
- .S DGDIV=$P(DGPROC,"^",6),DGDAT=$P(DGPROC,"^",2)
- .Q:'DGDIV
- .Q:DGDAT+.9<$$STDATE
- .S:'$D(^UTILITY($J,"IB-ASC",+DGPROC,+DGDAT,+DGDIV)) ^(+DGDIV)=0
- .S ^(+DGDIV)=^UTILITY($J,"IB-ASC",+DGPROC,+DGDAT,+DGDIV)+1
- ;
- STORREV ;build revenue codes in bill
- I '$D(^DGCR(399,IBIFN,"RC",0)) S ^DGCR(399,IBIFN,"RC",0)="^399.042PA"
- S DGPROC=0 F S DGPROC=$O(^UTILITY($J,"IB-ASC",DGPROC)) Q:'DGPROC S DGDAT=0 F S DGDAT=$O(^UTILITY($J,"IB-ASC",DGPROC,DGDAT)) Q:'DGDAT S DGDIV=0 F S DGDIV=$O(^UTILITY($J,"IB-ASC",DGPROC,DGDAT,DGDIV)) Q:'DGDIV S DGBSLOS=^(DGDIV) D
- .S X=DGDAT_"^"_DGDIV_"^"_DGPROC D ^IBAUTL1 S DGAMNT=Y Q:Y<1
- .S X=DGRVCOD,DGBSI=$O(^DGCR(399.1,"B",DGBILLBS,0))
- .D FILE
- .Q
- K DGDAT,DGPROC,DGDIV,DGRVCOD,DGASC
- Q
- ;
- FILE ;
- S DA(1)=IBIFN
- D FILE^IBCU62
- W:'$G(IBAUTO) !,"Adding",?12,$E(00_DGRVCOD,($L(DGRVCOD)-1),($L(DGRVCOD)+1)),?24,DGBSLOS,?31,"$",$J(DGAMNT,8,2),?44,DGBILLBS I +$G(DGPROC) W ?65,$P($$CPT^ICPTCOD(+DGPROC),"^",2)
- Q
- ;
- STDATE() ; -start date for basc billing
- Q $S($P($G(^IBE(350.9,1,1)),"^",24):$P(^(1),"^",24),1:9999999)
- ;
- RX ;add rx refill charges (adds default rx cpt for cms-1500)
- ;tries to use ins rx rev code, then site rx rev code finally standard revcode all with $20
- I '$D(^DGCR(399,IBIFN,"RC",0)) S ^DGCR(399,IBIFN,"RC",0)="^399.042PA"
- S DGBSLOS=IBCNT
- S DGBS="PRESCRIPTION",DGBSI=$O(^DGCR(399.1,"B",DGBS,0)) Q:'DGBSI
- I $$FT^IBCU3(IBIFN)=2 S DGPROC=$P($G(^IBE(350.9,1,1)),"^",30),DGDIV=""
- S DGRVCOD=$P($G(DGINPAR),"^",10) ; ins rev cd
- I DGRVCOD="" S DGRVCOD=$P($G(^IBE(350.9,1,1)),"^",28) ; site rev cd
- I DGRVCOD="" D SETREV^IBCU62 G END ; standard rev cd
- S DGAMNT=$$CHG(DGBSI,IBIDS(151),DGRVCOD) Q:'DGAMNT S X=DGRVCOD
- D FILE
- END K DGPROC,DGDIV,DGRVCOD
- Q
- ;MAP TO DGCRU61
- ;
- ALL ;delete all revenue codes that may have been set up automatically
- ;ie = $d(^IB(399.5,"d",code ifn))
- K DA S DA(1)=IBIFN,DA=0 I '$G(IBAUTO) W !,"Removing old Revenue Codes."
- F DGII=0:0 S DA=$O(^DGCR(399,IBIFN,"RC",DA)) Q:DA<1 S X=$G(^DGCR(399,IBIFN,"RC",DA,0)) D
- . ;remove revenue codes pre-defined for automatic use AND revenue codes for BASC charges (are automatically created)
- . W:'$G(IBAUTO) "." D DEL
- Q
- DEL S DIK="^DGCR(399,"_DA(1)_",""RC""," D ^DIK L ^DGCR(399,IBIFN):1
- Q
- ;
- ;
- CHG(IBSI,IBDT,IBRVCD) ; returns charge for bedsection and date, rev cd optional
- N IBAMNT,IBACTDT,IBRC,IBDA,IBRT,IBQUIT,X S IBAMNT=0
- ;
- S IBACTDT=-(IBDT+.01) F S IBACTDT=$O(^DGCR(399.5,"AIVDT",+IBSI,IBACTDT)) Q:'IBACTDT!+IBAMNT D
- . S IBRC=+IBRVCD,IBDA=0 F S IBDA=$O(^DGCR(399.5,"AIVDT",+IBSI,IBACTDT,IBRC,IBDA)) Q:'IBDA!+IBAMNT D
- .. S IBRT=$G(^DGCR(399.5,+IBDA,0))
- .. I $P(IBRT,U,6)["i",+$P(IBRT,U,5) S IBAMNT=$P(IBRT,U,4)
- ;
- I 'IBAMNT S IBACTDT=-(IBDT+.01) F S IBACTDT=$O(^DGCR(399.5,"AIVDT",+IBSI,IBACTDT)) Q:'IBACTDT!+IBAMNT D
- . S IBRC="" F S IBRC=$O(^DGCR(399.5,"AIVDT",+IBSI,IBACTDT,IBRC)) Q:'IBRC!+IBAMNT D
- .. S IBDA=0 F S IBDA=$O(^DGCR(399.5,"AIVDT",+IBSI,IBACTDT,IBRC,IBDA)) Q:'IBDA!+IBAMNT D
- ... S IBRT=$G(^DGCR(399.5,+IBDA,0))
- ... I $P(IBRT,U,6)["i",+$P(IBRT,U,5) S IBAMNT=$P(IBRT,U,4)
- Q IBAMNT
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCU63 3643 printed Feb 18, 2025@23:47:08 Page 2
- IBCU63 ;ALB/AAS - BILLING UTILITY TO SET AMB SURG REV CODES ; 20-NOV-91
- +1 ;;2.0;INTEGRATED BILLING;**21,133,349**;21-MAR-94;Build 46
- +2 ;;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ;
- +4 ;MAP TO DGCRU63
- % ; BASC
- +1 if IBIDS(.11)'="i"
- QUIT
- +2 KILL ^UTILITY($JOB,"IB-ASC")
- +3 SET DGRVCOD=$SELECT($PIECE($GET(DGINPAR),"^",4):$PIECE(DGINPAR,"^",4),$PIECE($GET(^IBE(350.9,1,1)),"^",18):$PIECE(^(1),"^",18),1:"")
- if DGRVCOD=""
- QUIT
- +4 ;
- BLD SET DGASC=0
- FOR
- SET DGASC=$ORDER(^DGCR(399,IBIFN,"CP","ASC",1,DGASC))
- if 'DGASC
- QUIT
- SET DGPROC=$GET(^DGCR(399,IBIFN,"CP",DGASC,0))
- IF DGPROC
- Begin DoDot:1
- +1 SET DGDIV=$PIECE(DGPROC,"^",6)
- SET DGDAT=$PIECE(DGPROC,"^",2)
- +2 if 'DGDIV
- QUIT
- +3 if DGDAT+.9<$$STDATE
- QUIT
- +4 if '$DATA(^UTILITY($JOB,"IB-ASC",+DGPROC,+DGDAT,+DGDIV))
- SET ^(+DGDIV)=0
- +5 SET ^(+DGDIV)=^UTILITY($JOB,"IB-ASC",+DGPROC,+DGDAT,+DGDIV)+1
- End DoDot:1
- +6 ;
- STORREV ;build revenue codes in bill
- +1 IF '$DATA(^DGCR(399,IBIFN,"RC",0))
- SET ^DGCR(399,IBIFN,"RC",0)="^399.042PA"
- +2 SET DGPROC=0
- FOR
- SET DGPROC=$ORDER(^UTILITY($JOB,"IB-ASC",DGPROC))
- if 'DGPROC
- QUIT
- SET DGDAT=0
- FOR
- SET DGDAT=$ORDER(^UTILITY($JOB,"IB-ASC",DGPROC,DGDAT))
- if 'DGDAT
- QUIT
- SET DGDIV=0
- FOR
- SET DGDIV=$ORDER(^UTILITY($JOB,"IB-ASC",DGPROC,DGDAT,DGDIV))
- if 'DGDIV
- QUIT
- SET DGBSLOS=^(DGDIV)
- Begin DoDot:1
- +3 SET X=DGDAT_"^"_DGDIV_"^"_DGPROC
- DO ^IBAUTL1
- SET DGAMNT=Y
- if Y<1
- QUIT
- +4 SET X=DGRVCOD
- SET DGBSI=$ORDER(^DGCR(399.1,"B",DGBILLBS,0))
- +5 DO FILE
- +6 QUIT
- End DoDot:1
- +7 KILL DGDAT,DGPROC,DGDIV,DGRVCOD,DGASC
- +8 QUIT
- +9 ;
- FILE ;
- +1 SET DA(1)=IBIFN
- +2 DO FILE^IBCU62
- +3 if '$GET(IBAUTO)
- WRITE !,"Adding",?12,$EXTRACT(00_DGRVCOD,($LENGTH(DGRVCOD)-1),($LENGTH(DGRVCOD)+1)),?24,DGBSLOS,?31,"$",$JUSTIFY(DGAMNT,8,2),?44,DGBILLBS
- IF +$GET(DGPROC)
- WRITE ?65,$PIECE($$CPT^ICPTCOD(+DGPROC),"^",2)
- +4 QUIT
- +5 ;
- STDATE() ; -start date for basc billing
- +1 QUIT $SELECT($PIECE($GET(^IBE(350.9,1,1)),"^",24):$PIECE(^(1),"^",24),1:9999999)
- +2 ;
- RX ;add rx refill charges (adds default rx cpt for cms-1500)
- +1 ;tries to use ins rx rev code, then site rx rev code finally standard revcode all with $20
- +2 IF '$DATA(^DGCR(399,IBIFN,"RC",0))
- SET ^DGCR(399,IBIFN,"RC",0)="^399.042PA"
- +3 SET DGBSLOS=IBCNT
- +4 SET DGBS="PRESCRIPTION"
- SET DGBSI=$ORDER(^DGCR(399.1,"B",DGBS,0))
- if 'DGBSI
- QUIT
- +5 IF $$FT^IBCU3(IBIFN)=2
- SET DGPROC=$PIECE($GET(^IBE(350.9,1,1)),"^",30)
- SET DGDIV=""
- +6 ; ins rev cd
- SET DGRVCOD=$PIECE($GET(DGINPAR),"^",10)
- +7 ; site rev cd
- IF DGRVCOD=""
- SET DGRVCOD=$PIECE($GET(^IBE(350.9,1,1)),"^",28)
- +8 ; standard rev cd
- IF DGRVCOD=""
- DO SETREV^IBCU62
- GOTO END
- +9 SET DGAMNT=$$CHG(DGBSI,IBIDS(151),DGRVCOD)
- if 'DGAMNT
- QUIT
- SET X=DGRVCOD
- +10 DO FILE
- END KILL DGPROC,DGDIV,DGRVCOD
- +1 QUIT
- +2 ;MAP TO DGCRU61
- +3 ;
- ALL ;delete all revenue codes that may have been set up automatically
- +1 ;ie = $d(^IB(399.5,"d",code ifn))
- +2 KILL DA
- SET DA(1)=IBIFN
- SET DA=0
- IF '$GET(IBAUTO)
- WRITE !,"Removing old Revenue Codes."
- +3 FOR DGII=0:0
- SET DA=$ORDER(^DGCR(399,IBIFN,"RC",DA))
- if DA<1
- QUIT
- SET X=$GET(^DGCR(399,IBIFN,"RC",DA,0))
- Begin DoDot:1
- +4 ;remove revenue codes pre-defined for automatic use AND revenue codes for BASC charges (are automatically created)
- +5 if '$GET(IBAUTO)
- WRITE "."
- DO DEL
- End DoDot:1
- +6 QUIT
- DEL SET DIK="^DGCR(399,"_DA(1)_",""RC"","
- DO ^DIK
- LOCK ^DGCR(399,IBIFN):1
- +1 QUIT
- +2 ;
- +3 ;
- CHG(IBSI,IBDT,IBRVCD) ; returns charge for bedsection and date, rev cd optional
- +1 NEW IBAMNT,IBACTDT,IBRC,IBDA,IBRT,IBQUIT,X
- SET IBAMNT=0
- +2 ;
- +3 SET IBACTDT=-(IBDT+.01)
- FOR
- SET IBACTDT=$ORDER(^DGCR(399.5,"AIVDT",+IBSI,IBACTDT))
- if 'IBACTDT!+IBAMNT
- QUIT
- Begin DoDot:1
- +4 SET IBRC=+IBRVCD
- SET IBDA=0
- FOR
- SET IBDA=$ORDER(^DGCR(399.5,"AIVDT",+IBSI,IBACTDT,IBRC,IBDA))
- if 'IBDA!+IBAMNT
- QUIT
- Begin DoDot:2
- +5 SET IBRT=$GET(^DGCR(399.5,+IBDA,0))
- +6 IF $PIECE(IBRT,U,6)["i"
- IF +$PIECE(IBRT,U,5)
- SET IBAMNT=$PIECE(IBRT,U,4)
- End DoDot:2
- End DoDot:1
- +7 ;
- +8 IF 'IBAMNT
- SET IBACTDT=-(IBDT+.01)
- FOR
- SET IBACTDT=$ORDER(^DGCR(399.5,"AIVDT",+IBSI,IBACTDT))
- if 'IBACTDT!+IBAMNT
- QUIT
- Begin DoDot:1
- +9 SET IBRC=""
- FOR
- SET IBRC=$ORDER(^DGCR(399.5,"AIVDT",+IBSI,IBACTDT,IBRC))
- if 'IBRC!+IBAMNT
- QUIT
- Begin DoDot:2
- +10 SET IBDA=0
- FOR
- SET IBDA=$ORDER(^DGCR(399.5,"AIVDT",+IBSI,IBACTDT,IBRC,IBDA))
- if 'IBDA!+IBAMNT
- QUIT
- Begin DoDot:3
- +11 SET IBRT=$GET(^DGCR(399.5,+IBDA,0))
- +12 IF $PIECE(IBRT,U,6)["i"
- IF +$PIECE(IBRT,U,5)
- SET IBAMNT=$PIECE(IBRT,U,4)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +13 QUIT IBAMNT
