- IBCU63 ;ALB/AAS - BILLING UTILITY TO SET AMB SURG REV CODES ; 20-NOV-91
- ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
- ;;Per VHA Directive 10-93-142, 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,?65,$P($G(^ICPT(+$G(DGPROC),0)),"^")
- 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 hcfa 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=20,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
- IBCU63 ;ALB/AAS - BILLING UTILITY TO SET AMB SURG REV CODES ; 20-NOV-91
- +1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
- +2 ;;Per VHA Directive 10-93-142, 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,?65,$PIECE($GET(^ICPT(+$GET(DGPROC),0)),"^")
- +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 hcfa 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=20
- 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
