- IBCU6 ;ALB/AAS - UTILITY ROUTINE TO SET BEDSECTIONS/REVENUE CODES FROM PTF DATA ; 25 MAY 90
- ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- ;MAP TO DGCRU6
- ;
- % ;setup variables - needs IBifn
- Q:'$D(^DGCR(399,IBIFN,0)) N IBQUIT S IBQUIT=0 K ^UTILITY($J) D GVAR^IBCU61 Q:IBQUIT
- I '$D(DFN) S DFN=$P(^DGCR(399,IBIFN,0),"^",2)
- I IBIDS(.05)<3 S PTF=$P(^DGCR(399,IBIFN,0),"^",8) Q:PTF']"" Q:'$D(^DGPT(PTF,0)) I '$P(^DGPT(PTF,0),"^",6),'$P(^(0),"^",4),'$D(DGPTUPDT) D UPDT^DGPTUTL S DGPTUPDT=""
- S DGADM=IBIDS(.03),DGPMCA=$O(^DGPM("AMV1",DGADM,DFN,0)) ;find corresponding admission
- D:$O(^DGCR(399,IBIFN,"RC",0)) ALL^IBCU61
- ;
- OPT ;I IBIDS(.05)>2 S DGBILLBS="OUTPATIENT VISIT",DGVISCNT=$S($D(^DGCR(399,IBIFN,"OP",0)):$P(^(0),U,4),1:""),^UTILITY($J,"IB-BS",DGBILLBS)=DGVISCNT G END:DGVISCNT<1 D G END:IBQUIT,3
- ;.I $D(^DGCR(399,IBIFN,"CP","ASC",1)) D ^IBCU63
- ;.;I $D(^UTILITY($J,"IB-ASC")) S IBQUIT=1
- I IBIDS(.05)>2 D G END:(DGVISCNT<1)!IBQUIT,3
- . S DGBILLBS="OUTPATIENT VISIT",DGVISCNT=$S($D(^DGCR(399,IBIFN,"OP",0)):$P(^(0),U,4),1:""),^UTILITY($J,"IB-BS",DGBILLBS)=DGVISCNT ; visit
- . I DGVISCNT>0,$D(^DGCR(399,IBIFN,"CP","ASC",1)) D ^IBCU63 ; basc
- . D SET^IBCSC5A(IBIFN,.IBX) S IBCNT=+$P(IBX,U,2) K IBX I +IBCNT D RX^IBCU63 ; rx refills
- ;
- 1 ;build array of movement dates, billable bedsections
- S DGMOVE=0 F DGII=0:0 S DGMOVE=$O(^DGPT(PTF,"M",DGMOVE)) Q:'DGMOVE D SETU
- ;
- 2 ;build array of billable bedsections = los in bedsection
- ;start with statement covers from date, end with statement covers to date
- S (DGMVDT,DGMVDTP)=$S($D(IBIDS(151)):IBIDS(151),1:IBIDS(.03)),(DGBS,DGBS1)=""
- S DGMVDT=DGMVDT-.01 F DGII=0:0 S DGMVDT=$O(^UTILITY($J,"IB-PTF",DGMVDT)) Q:'DGMVDT!(DGMVDTP\1>IBIDS(152)) D SETU1 S DGMVDTP=DGMVDT
- ;
- 3 ;find revenue codes and set up in file.
- S DGBS=0 I '$D(^DGCR(399,IBIFN,"RC",0)) S ^DGCR(399,IBIFN,"RC",0)="^399.042PA"
- F DGII=0:0 S DGBS=$O(^UTILITY($J,"IB-BS",DGBS)) Q:DGBS']""!(IBQUIT) S DGBSLOS=^(DGBS),DGBSI=$O(^DGCR(399.1,"B",DGBS,0)) I DGBSI,$D(^DGCR(399.1,DGBSI,0)) D SETREV^IBCU62
- G END
- ;
- SETU ;utility array of all movements by date, billing bedsection
- ;non-billable bs's must be added to array so their days will not be added to a billable bs
- S X=^DGPT(PTF,"M",DGMOVE,0)
- S DGBILLBS=$P($G(^DIC(42.4,+$P(X,U,2),0)),U,5) I DGBILLBS="" S DGBILLBS="UNKNOWN"
- ;S DGBILLBS=$S('$P(X,U,2):"UNKNOWN",$D(^DIC(42.4,$P(X,U,2),0)):$P(^(0),U,5),1:"UNKNOWN") Q:DGBILLBS=""
- S ^UTILITY($J,"IB-PTF",$S($P(X,U,10)]"":$P(X,U,10),1:DT),DGBILLBS)=($P(X,U,3)+$P(X,U,4))_"^"_$P(X,U,18)
- Q
- ;
- SETU1 ;determine los - set utility=los
- S DGBS=$O(^UTILITY($J,"IB-PTF",DGMVDT,0)) Q:DGBS="UNKNOWN" S:DGBS1="" DGBS1=DGBS
- S DGEDT=$S(DGMVDT<IBIDS(152):DGMVDT,1:IBIDS(152)),DGBDT=$S(IBIDS(151)>DGMVDTP:IBIDS(151),1:DGMVDTP)
- S IBTF=$S(IBIDS(152)<(DGMVDT\1):IBIDS(.06),1:1)
- S X=$$LOS^IBCU64(DGBDT,DGEDT,IBTF,DGPMCA) Q:'X
- I $D(DGINPAR),$P(DGINPAR,"^")=0,(DGBS1'=DGBS) Q ;only one bedsection allowed by ins co
- I IBIDS(.11)="c",(DGBS1'=DGBS) Q
- I $P(^UTILITY($J,"IB-PTF",DGMVDT,DGBS),U,2)=1 Q ;treatment for sc condition
- S ^UTILITY($J,"IB-BS",DGBS)=+$G(^UTILITY($J,"IB-BS",DGBS))+X
- Q
- END I IBIDS(.11)="c" S IBIDS(.11)="p"
- K ^UTILITY($J),DGMOVE,DGMVDT,DGMVDTP,DGBS,DGBSLOS,DGBSI,DGBILLBS,DGBR,DGREC,DGII,DGJJ,DGKK,DGREVHDR,DGAMNT,DGREV,DGBS1,X,X1,X2,Y,Z,DGINPAR,DR,DIK,DGVISCNT,DGBRN,DGFUNC,DGACTDT,DGRVRCAL,DA,IBIDS,DGREV00
- K DGLL,DGFND,IBND0,IBNDU,DGPMCA,DGADM,DGEDT,DGBDT,DGMVTP,DGMVT,DGDC,DGNEXT,DGX,DGIFN,IBTF,IBCNT,IBCHK
- Q
- IBCU6 ;ALB/AAS - UTILITY ROUTINE TO SET BEDSECTIONS/REVENUE CODES FROM PTF DATA ; 25 MAY 90
- +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 DGCRU6
- +5 ;
- % ;setup variables - needs IBifn
- +1 IF '$DATA(^DGCR(399,IBIFN,0))
- QUIT
- NEW IBQUIT
- SET IBQUIT=0
- KILL ^UTILITY($JOB)
- DO GVAR^IBCU61
- IF IBQUIT
- QUIT
- +2 IF '$DATA(DFN)
- SET DFN=$PIECE(^DGCR(399,IBIFN,0),"^",2)
- +3 IF IBIDS(.05)<3
- SET PTF=$PIECE(^DGCR(399,IBIFN,0),"^",8)
- IF PTF']""
- QUIT
- IF '$DATA(^DGPT(PTF,0))
- QUIT
- IF '$PIECE(^DGPT(PTF,0),"^",6)
- IF '$PIECE(^(0),"^",4)
- IF '$DATA(DGPTUPDT)
- DO UPDT^DGPTUTL
- SET DGPTUPDT=""
- +4 ;find corresponding admission
- SET DGADM=IBIDS(.03)
- SET DGPMCA=$ORDER(^DGPM("AMV1",DGADM,DFN,0))
- +5 IF $ORDER(^DGCR(399,IBIFN,"RC",0))
- DO ALL^IBCU61
- +6 ;
- OPT ;I IBIDS(.05)>2 S DGBILLBS="OUTPATIENT VISIT",DGVISCNT=$S($D(^DGCR(399,IBIFN,"OP",0)):$P(^(0),U,4),1:""),^UTILITY($J,"IB-BS",DGBILLBS)=DGVISCNT G END:DGVISCNT<1 D G END:IBQUIT,3
- +1 ;.I $D(^DGCR(399,IBIFN,"CP","ASC",1)) D ^IBCU63
- +2 ;.;I $D(^UTILITY($J,"IB-ASC")) S IBQUIT=1
- +3 IF IBIDS(.05)>2
- Begin DoDot:1
- +4 ; visit
- SET DGBILLBS="OUTPATIENT VISIT"
- SET DGVISCNT=$SELECT($DATA(^DGCR(399,IBIFN,"OP",0)):$PIECE(^(0),U,4),1:"")
- SET ^UTILITY($JOB,"IB-BS",DGBILLBS)=DGVISCNT
- +5 ; basc
- IF DGVISCNT>0
- IF $DATA(^DGCR(399,IBIFN,"CP","ASC",1))
- DO ^IBCU63
- +6 ; rx refills
- DO SET^IBCSC5A(IBIFN,.IBX)
- SET IBCNT=+$PIECE(IBX,U,2)
- KILL IBX
- IF +IBCNT
- DO RX^IBCU63
- End DoDot:1
- IF (DGVISCNT<1)!IBQUIT
- GOTO END
- GOTO 3
- +7 ;
- 1 ;build array of movement dates, billable bedsections
- +1 SET DGMOVE=0
- FOR DGII=0:0
- SET DGMOVE=$ORDER(^DGPT(PTF,"M",DGMOVE))
- IF 'DGMOVE
- QUIT
- DO SETU
- +2 ;
- 2 ;build array of billable bedsections = los in bedsection
- +1 ;start with statement covers from date, end with statement covers to date
- +2 SET (DGMVDT,DGMVDTP)=$SELECT($DATA(IBIDS(151)):IBIDS(151),1:IBIDS(.03))
- SET (DGBS,DGBS1)=""
- +3 SET DGMVDT=DGMVDT-.01
- FOR DGII=0:0
- SET DGMVDT=$ORDER(^UTILITY($JOB,"IB-PTF",DGMVDT))
- IF 'DGMVDT!(DGMVDTP\1>IBIDS(152))
- QUIT
- DO SETU1
- SET DGMVDTP=DGMVDT
- +4 ;
- 3 ;find revenue codes and set up in file.
- +1 SET DGBS=0
- IF '$DATA(^DGCR(399,IBIFN,"RC",0))
- SET ^DGCR(399,IBIFN,"RC",0)="^399.042PA"
- +2 FOR DGII=0:0
- SET DGBS=$ORDER(^UTILITY($JOB,"IB-BS",DGBS))
- IF DGBS']""!(IBQUIT)
- QUIT
- SET DGBSLOS=^(DGBS)
- SET DGBSI=$ORDER(^DGCR(399.1,"B",DGBS,0))
- IF DGBSI
- IF $DATA(^DGCR(399.1,DGBSI,0))
- DO SETREV^IBCU62
- +3 GOTO END
- +4 ;
- SETU ;utility array of all movements by date, billing bedsection
- +1 ;non-billable bs's must be added to array so their days will not be added to a billable bs
- +2 SET X=^DGPT(PTF,"M",DGMOVE,0)
- +3 SET DGBILLBS=$PIECE($GET(^DIC(42.4,+$PIECE(X,U,2),0)),U,5)
- IF DGBILLBS=""
- SET DGBILLBS="UNKNOWN"
- +4 ;S DGBILLBS=$S('$P(X,U,2):"UNKNOWN",$D(^DIC(42.4,$P(X,U,2),0)):$P(^(0),U,5),1:"UNKNOWN") Q:DGBILLBS=""
- +5 SET ^UTILITY($JOB,"IB-PTF",$SELECT($PIECE(X,U,10)]"":$PIECE(X,U,10),1:DT),DGBILLBS)=($PIECE(X,U,3)+$PIECE(X,U,4))_"^"_$PIECE(X,U,18)
- +6 QUIT
- +7 ;
- SETU1 ;determine los - set utility=los
- +1 SET DGBS=$ORDER(^UTILITY($JOB,"IB-PTF",DGMVDT,0))
- IF DGBS="UNKNOWN"
- QUIT
- IF DGBS1=""
- SET DGBS1=DGBS
- +2 SET DGEDT=$SELECT(DGMVDT<IBIDS(152):DGMVDT,1:IBIDS(152))
- SET DGBDT=$SELECT(IBIDS(151)>DGMVDTP:IBIDS(151),1:DGMVDTP)
- +3 SET IBTF=$SELECT(IBIDS(152)<(DGMVDT\1):IBIDS(.06),1:1)
- +4 SET X=$$LOS^IBCU64(DGBDT,DGEDT,IBTF,DGPMCA)
- IF 'X
- QUIT
- +5 ;only one bedsection allowed by ins co
- IF $DATA(DGINPAR)
- IF $PIECE(DGINPAR,"^")=0
- IF (DGBS1'=DGBS)
- QUIT
- +6 IF IBIDS(.11)="c"
- IF (DGBS1'=DGBS)
- QUIT
- +7 ;treatment for sc condition
- IF $PIECE(^UTILITY($JOB,"IB-PTF",DGMVDT,DGBS),U,2)=1
- QUIT
- +8 SET ^UTILITY($JOB,"IB-BS",DGBS)=+$GET(^UTILITY($JOB,"IB-BS",DGBS))+X
- +9 QUIT
- END IF IBIDS(.11)="c"
- SET IBIDS(.11)="p"
- +1 KILL ^UTILITY($JOB),DGMOVE,DGMVDT,DGMVDTP,DGBS,DGBSLOS,DGBSI,DGBILLBS,DGBR,DGREC,DGII,DGJJ,DGKK,DGREVHDR,DGAMNT,DGREV,DGBS1,X,X1,X2,Y,Z,DGINPAR,DR,DIK,DGVISCNT,DGBRN,DGFUNC,DGACTDT,DGRVRCAL,DA,IBIDS,DGREV00
- +2 KILL DGLL,DGFND,IBND0,IBNDU,DGPMCA,DGADM,DGEDT,DGBDT,DGMVTP,DGMVT,DGDC,DGNEXT,DGX,DGIFN,IBTF,IBCNT,IBCHK
- +3 QUIT
