- IBCOPV2 ;ALB/LDB - ROUTINE TO LIST PATIENT VISITS ;30 APR 90
- ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
- ;
- ;MAP TO DGCROPV2
- ;
- ELIG Q:$D(DGNO) S DGCOD=$S(DGFIL=2:$P(^SC(+DGNOD,0),"^",7),DGFIL=409.5:+DGNOD,DGFIL=2.101:"ADMITTING/SCREENING",1:"") I $D(^DIC(40.7,+DGCOD,0)) S:+DGCOD DGCOD=$P(^DIC(40.7,+DGCOD,0),"^")
- I +DGNOD,DGFIL=409.5,$P(^DIC(40.7,+DGNOD,0),"^",2)>899&($P(^DIC(40.7,+DGNOD,0),"^",2)<999) S DGCOD=$P(DGNOD,"^",3) S:$D(^SC(+DGCOD,0)) DGCOD=$P(^(0),"^",7) S:$D(^DIC(40.7,+DGCOD,0)) DGCOD=$P(^(0),"^")
- I (DGTYP="")!(DGTYP=9) S DGTYP=$S($D(^DPT(DFN,.36)):^(.36),1:"") S:DGTYP DGTYP=$E(^DIC(8,+DGTYP,0),1,3)
- I DGTYP'="NSC" S DGMT="" Q
- MT ;S (DGMT,DGMT1)=0 I $D(^DG(41.3,DFN)) F DGMT1=9999999-(I+1):0 S DGMT1=$O(^DG(41.3,DFN,2,DGMT1)) Q:'DGMT1 I $P($P(^(DGMT1,0),"^",7),".")'>I S DGMT=$P(^(0),"^",2) Q
- ;S:'DGMT1 DGMT="A"
- S DGMT=$P($$LST^DGMTU(DFN,$P(I,".",1)),"^",4)
- Q
- CHG S (DGREV,DGBR)=0,DGACTDT=-DGDT,DGBSI=$O(^DGCR(399.1,"B","OUTPATIENT VISIT",0)) Q:'DGBSI K IBCHG
- S IBIDS(.11)=$P(^DGCR(399,IBIFN,0),"^",11) D CAT^IBCU61
- F DGJJ=0:0 S DGACTDT=$O(^DGCR(399.5,"AIVDT",DGBSI,DGACTDT)) Q:'DGACTDT!($D(IBCHG)) F DGLL=0:0 S DGREV=$O(^DGCR(399.5,"AIVDT",DGBSI,DGACTDT,DGREV)) Q:'DGREV!($D(IBCHG)) D 1
- Q
- 1 F DGKK=0:0 S DGBR=$O(^DGCR(399.5,"AIVDT",DGBSI,DGACTDT,DGREV,DGBR)) Q:'DGBR!($D(IBCHG)) D CHKREV
- Q
- CHKREV S DGBRN=^DGCR(399.5,DGBR,0)
- Q:'$P(DGBRN,"^",5)!('$P(DGBRN,"^",4))!($P(DGBRN,"^",7))!($P(DGBRN,"^",6)'[IBIDS(.11))
- S IBCHG="$"_$P($P(DGBRN,"^",4),".")_"."_$E($P($P(DGBRN,"^",4),".",2)_"00",1,2),$P(^UTILITY($J,"OPV","AP",DGCNT),"^",2)=IBCHG
- Q
- PROD F P=2:1 S DGCPT2=$P(^UTILITY($J,"CPT1",I7),"^",P) Q:DGCPT2="" D PROD3,PROD1:$D(^DGCR(399,IBIFN,"CP","B",DGCPT2_";ICPT("))
- Q
- PROD1 F DGCPT0=0:0 S DGCPT0=$O(^DGCR(399,IBIFN,"CP","B",DGCPT2_";ICPT(",DGCPT0)) Q:'DGCPT0 D PROD2
- Q
- PROD2 S $P(^UTILITY($J,"CPT1",I7),"^",P)=$S(^UTILITY($J,"CPT1",I7)'[(DGCPT2_"~"_DGCPT0):(DGCPT2_"~"_DGCPT0),1:$P(^UTILITY($J,"CPT",I7),"^",P))
- Q
- PROD3 I $P(^DGCR(399,IBIFN,0),"^",9)=4 F I8=1:1:3 I $D(^DGCR(399,IBIFN,"C")),$P(^("C"),"^",I8)=$P(^UTILITY($J,"CPT1",I7),"^",P) S $P(^UTILITY($J,"CPT1",I7),"^",P)=$P(^UTILITY($J,"CPT1",I7),"^",P)_"~0"
- Q
- IBCOPV2 ;ALB/LDB - ROUTINE TO LIST PATIENT VISITS ;30 APR 90
- +1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
- +2 ;
- +3 ;MAP TO DGCROPV2
- +4 ;
- ELIG IF $DATA(DGNO)
- QUIT
- SET DGCOD=$SELECT(DGFIL=2:$PIECE(^SC(+DGNOD,0),"^",7),DGFIL=409.5:+DGNOD,DGFIL=2.101:"ADMITTING/SCREENING",1:"")
- IF $DATA(^DIC(40.7,+DGCOD,0))
- IF +DGCOD
- SET DGCOD=$PIECE(^DIC(40.7,+DGCOD,0),"^")
- +1 IF +DGNOD
- IF DGFIL=409.5
- IF $PIECE(^DIC(40.7,+DGNOD,0),"^",2)>899&($PIECE(^DIC(40.7,+DGNOD,0),"^",2)<999)
- SET DGCOD=$PIECE(DGNOD,"^",3)
- IF $DATA(^SC(+DGCOD,0))
- SET DGCOD=$PIECE(^(0),"^",7)
- IF $DATA(^DIC(40.7,+DGCOD,0))
- SET DGCOD=$PIECE(^(0),"^")
- +2 IF (DGTYP="")!(DGTYP=9)
- SET DGTYP=$SELECT($DATA(^DPT(DFN,.36)):^(.36),1:"")
- IF DGTYP
- SET DGTYP=$EXTRACT(^DIC(8,+DGTYP,0),1,3)
- +3 IF DGTYP'="NSC"
- SET DGMT=""
- QUIT
- MT ;S (DGMT,DGMT1)=0 I $D(^DG(41.3,DFN)) F DGMT1=9999999-(I+1):0 S DGMT1=$O(^DG(41.3,DFN,2,DGMT1)) Q:'DGMT1 I $P($P(^(DGMT1,0),"^",7),".")'>I S DGMT=$P(^(0),"^",2) Q
- +1 ;S:'DGMT1 DGMT="A"
- +2 SET DGMT=$PIECE($$LST^DGMTU(DFN,$PIECE(I,".",1)),"^",4)
- +3 QUIT
- CHG SET (DGREV,DGBR)=0
- SET DGACTDT=-DGDT
- SET DGBSI=$ORDER(^DGCR(399.1,"B","OUTPATIENT VISIT",0))
- IF 'DGBSI
- QUIT
- KILL IBCHG
- +1 SET IBIDS(.11)=$PIECE(^DGCR(399,IBIFN,0),"^",11)
- DO CAT^IBCU61
- +2 FOR DGJJ=0:0
- SET DGACTDT=$ORDER(^DGCR(399.5,"AIVDT",DGBSI,DGACTDT))
- IF 'DGACTDT!($DATA(IBCHG))
- QUIT
- FOR DGLL=0:0
- SET DGREV=$ORDER(^DGCR(399.5,"AIVDT",DGBSI,DGACTDT,DGREV))
- IF 'DGREV!($DATA(IBCHG))
- QUIT
- DO 1
- +3 QUIT
- 1 FOR DGKK=0:0
- SET DGBR=$ORDER(^DGCR(399.5,"AIVDT",DGBSI,DGACTDT,DGREV,DGBR))
- IF 'DGBR!($DATA(IBCHG))
- QUIT
- DO CHKREV
- +1 QUIT
- CHKREV SET DGBRN=^DGCR(399.5,DGBR,0)
- +1 IF '$PIECE(DGBRN,"^",5)!('$PIECE(DGBRN,"^",4))!($PIECE(DGBRN,"^",7))!($PIECE(DGBRN,"^",6)'[IBIDS(.11))
- QUIT
- +2 SET IBCHG="$"_$PIECE($PIECE(DGBRN,"^",4),".")_"."_$EXTRACT($PIECE($PIECE(DGBRN,"^",4),".",2)_"00",1,2)
- SET $PIECE(^UTILITY($JOB,"OPV","AP",DGCNT),"^",2)=IBCHG
- +3 QUIT
- PROD FOR P=2:1
- SET DGCPT2=$PIECE(^UTILITY($JOB,"CPT1",I7),"^",P)
- IF DGCPT2=""
- QUIT
- DO PROD3
- IF $DATA(^DGCR(399,IBIFN,"CP","B",DGCPT2_";ICPT("))
- DO PROD1
- +1 QUIT
- PROD1 FOR DGCPT0=0:0
- SET DGCPT0=$ORDER(^DGCR(399,IBIFN,"CP","B",DGCPT2_";ICPT(",DGCPT0))
- IF 'DGCPT0
- QUIT
- DO PROD2
- +1 QUIT
- PROD2 SET $PIECE(^UTILITY($JOB,"CPT1",I7),"^",P)=$SELECT(^UTILITY($JOB,"CPT1",I7)'[(DGCPT2_"~"_DGCPT0):(DGCPT2_"~"_DGCPT0),1:$PIECE(^UTILITY($JOB,"CPT",I7),"^",P))
- +1 QUIT
- PROD3 IF $PIECE(^DGCR(399,IBIFN,0),"^",9)=4
- FOR I8=1:1:3
- IF $DATA(^DGCR(399,IBIFN,"C"))
- IF $PIECE(^("C"),"^",I8)=$PIECE(^UTILITY($JOB,"CPT1",I7),"^",P)
- SET $PIECE(^UTILITY($JOB,"CPT1",I7),"^",P)=$PIECE(^UTILITY($JOB,"CPT1",I7),"^",P)_"~0"
- +1 QUIT
