- IBCU64 ;ALB/ARH - AUTOMATED BILLER (INPT CONT) ; 8/6/93
- ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- ;
- LOS1(IFN) ; returns length of stay for a bill's date range
- N X,Y,DFN,DGADM,DGPMCA S (X,DGPMCA)=0,Y=$G(^DGCR(399,+$G(IFN),0)) G:Y="" LOS1Q I $P(Y,U,8)'="" D
- . ; find patient movement, based on admit date and DFN from PTF
- . S DFN=+$P(Y,U,2),DGADM=$P($G(^DGPT(+$P(Y,U,8),0)),U,2) I 'DGADM Q
- . S DGADM=$O(^DGPM("AMV1",+$P(DGADM,"."))),DGPMCA=$O(^DGPM("AMV1",+DGADM,+DFN,0))
- S X=$G(^DGCR(399,+IFN,"U"))
- S X=$$LOS($P(X,U,1),$P(X,U,2),$P(Y,U,6),DGPMCA)
- LOS1Q Q X
- ;
- AD(DGPMCA) ; returns inpatient admit and discharge date, DFN, PTF, Facility Treating Specialty, if one/both don't exist "0^0"
- N X,Y S X="0^0" I '$G(DGPMCA) G ADQ
- S Y=$G(^DGPM(+DGPMCA,0)) ; get patient movement data
- S X=+Y_"^"_+$G(^DGPM(+$P(Y,U,17),0))_"^"_$P(Y,U,3)_"^"_$P(Y,U,16)_"^"_$P(Y,U,9)
- ADQ Q X
- ;
- LOS(DGBDT,DGEDT,BTF,DGPMCA) ; calculate the inpatient length of stay for a given time period
- ;parameters are input variables into DGUTL2, which calculates days absent or on pass
- ;if the pat movment IFN is not available then can't check of absence or pass days
- ;LOS: discharge date is not added except for inpt interim first and continuous where discharge date is added,
- ; absent or pass days not added,
- ; admission and discharge on same day has LOS=1, discharge date=admission date+1 also has an LOS=1
- N X,IBX,IBY,DGREC,IBDISDT,DGMVTP,DGADM,DFN,DGA S IBX=0 I '$G(DGBDT)!'$G(DGEDT) G LOSQ
- I DGBDT=DGEDT!($G(BTF)=2)!($G(BTF)=3) S DGEDT=$$FMADD^XLFDT(DGEDT,1) ; inclusive if interim continuous or first
- S IBX=$$FMDIFF^XLFDT(DGEDT,DGBDT,1) ; difference between begin and end date
- I +$G(DGPMCA) S IBY=$$AD(DGPMCA) I +IBY S DGADM=+IBY\1,IBDISDT=$P(IBY,U,2)\1,DFN=$P(IBY,U,3) D
- . ; maximum date range is the admit thru discharge range
- . S:DGBDT<DGADM DGBDT=DGADM I +IBDISDT&(DGEDT>IBDISDT) S DGEDT=IBDISDT
- . S IBX=$$FMDIFF^XLFDT(DGEDT,DGBDT,1) I (DGBDT\1)=(DGEDT\1) S IBX=1
- . D PLASIH^DGUTL2 S IBX=IBX-DGREC ; subtract days absent or on pass
- LOSQ Q $S(IBX>0:IBX,1:0)
- ;
- DUPCHKI(DT1,DT2,PTF,RTG,DISP,IFN) ;Check for duplicate billing of inpt admission - checks for overlapping date range on other
- ;bills with the same rate type and that have not been cancelled
- ;input: DT1 - beginning of date range to check
- ; DT2 - ending of date range to check
- ; PTF - ptr to PTF record
- ; DISP - true if error message should be printed before exit, if any
- ; RTG - rate group to check for, if no rate group (0 passed and/or no IFN) then any bill found for
- ; visit date will cause error message
- ; IFN - existing bill to check against, if passed will use variables from this bill if they are not passed in
- ;returns: 0 - if another bill was not found for this admission with this date range, patient, and rate type
- ; (dup IFN)_"^error message" - if duplicate date found, same rate group then IFN of bill
- N IFN2,Y,X,X1 S Y=0,(X,X1)="",IFN=+$G(IFN) I +IFN S X=$G(^DGCR(399,IFN,0)),X1=$G(^DGCR(399,IFN,"U"))
- S RTG=$S($G(RTG)'="":+RTG,1:+$P(X,U,7)),PTF=$S(+$G(PTF):+PTF,1:+$P(X,U,8)) G:'PTF DCIQ
- S DT1=$S(+$G(DT1):+DT1,1:$P(X1,U,1)),DT2=$S(+$G(DT2):+DT2,1:$P(X1,U,2)) G:'DT1!'DT2 DCIQ
- S DT1=DT1\1,DT2=DT2\1 I (DT1>DT2)!('$D(^DGCR(399,"APTF",PTF))) G DCIQ
- S IFN2=0 F S IFN2=$O(^DGCR(399,"APTF",PTF,IFN2)) Q:'IFN2 I IFN'=IFN2 D Q:+Y
- . S X1=$G(^DGCR(399,IFN2,0)) I $P(X1,U,13)=7 Q ; bill cancelled
- . I +RTG,$P(X1,U,7)'=RTG Q ; different rate group
- . S X=$G(^DGCR(399,IFN2,"U")) I (DT2<+X)!(DT1>+$P(X,U,2)) Q
- . S Y=IFN2_"^A "_$P($G(^DGCR(399.3,+$P(X1,U,7),0)),U,1)_" bill ("_$P(X1,U,1)_") exists overlapping this date range."
- DCIQ I +$G(DISP),+Y W !,?10,$P(Y,U,2)
- Q Y
- ;
- ADM(DFN,IBDT) ; -- send back adm dt for dfn on vaindt (or now) if any, 0 otherwise
- ;returns adm if patient was admitted at any time during IBDT or before dischrge date and time
- N IBNDT,IBINPT,IBADM,IBADT1,IBADT2,IBDIS,IBNOW,%,X,Y D NOW^%DTC S IBNOW=%
- S IBINPT=0,IBDT=$G(IBDT) G:'$D(^DPT(+$G(DFN),0)) ADME I 'IBDT S IBDT=IBNOW
- S IBNDT=9999999.999999-((IBDT\1)+.99999),IBADT2=IBNOW
- F S IBNDT=$O(^DGPM("ATID1",DFN,IBNDT)) Q:'IBNDT D Q:+IBINPT
- . S IBADM=+$O(^DGPM("ATID1",DFN,IBNDT,0)),IBADT1=$G(^DGPM(+IBADM,0)) Q:IBADT1=""
- . S IBDIS=$P(IBADT1,U,17) I +IBDIS S IBADT2=+$G(^DGPM(+IBDIS,0))
- . I $P(IBADT2,".",2)="" S $P(IBADT2,".",2)=999999
- . I (+IBADT1\1)'>(IBDT\1),(IBADT2'<IBDT!((+IBADT1\1)=(+IBDT\1))) S IBINPT=+IBADT1
- ADME Q IBINPT
- IBCU64 ;ALB/ARH - AUTOMATED BILLER (INPT CONT) ; 8/6/93
- +1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 ;
- +4 ;
- LOS1(IFN) ; returns length of stay for a bill's date range
- +1 NEW X,Y,DFN,DGADM,DGPMCA
- SET (X,DGPMCA)=0
- SET Y=$GET(^DGCR(399,+$GET(IFN),0))
- IF Y=""
- GOTO LOS1Q
- IF $PIECE(Y,U,8)'=""
- Begin DoDot:1
- +2 ; find patient movement, based on admit date and DFN from PTF
- +3 SET DFN=+$PIECE(Y,U,2)
- SET DGADM=$PIECE($GET(^DGPT(+$PIECE(Y,U,8),0)),U,2)
- IF 'DGADM
- QUIT
- +4 SET DGADM=$ORDER(^DGPM("AMV1",+$PIECE(DGADM,".")))
- SET DGPMCA=$ORDER(^DGPM("AMV1",+DGADM,+DFN,0))
- End DoDot:1
- +5 SET X=$GET(^DGCR(399,+IFN,"U"))
- +6 SET X=$$LOS($PIECE(X,U,1),$PIECE(X,U,2),$PIECE(Y,U,6),DGPMCA)
- LOS1Q QUIT X
- +1 ;
- AD(DGPMCA) ; returns inpatient admit and discharge date, DFN, PTF, Facility Treating Specialty, if one/both don't exist "0^0"
- +1 NEW X,Y
- SET X="0^0"
- IF '$GET(DGPMCA)
- GOTO ADQ
- +2 ; get patient movement data
- SET Y=$GET(^DGPM(+DGPMCA,0))
- +3 SET X=+Y_"^"_+$GET(^DGPM(+$PIECE(Y,U,17),0))_"^"_$PIECE(Y,U,3)_"^"_$PIECE(Y,U,16)_"^"_$PIECE(Y,U,9)
- ADQ QUIT X
- +1 ;
- LOS(DGBDT,DGEDT,BTF,DGPMCA) ; calculate the inpatient length of stay for a given time period
- +1 ;parameters are input variables into DGUTL2, which calculates days absent or on pass
- +2 ;if the pat movment IFN is not available then can't check of absence or pass days
- +3 ;LOS: discharge date is not added except for inpt interim first and continuous where discharge date is added,
- +4 ; absent or pass days not added,
- +5 ; admission and discharge on same day has LOS=1, discharge date=admission date+1 also has an LOS=1
- +6 NEW X,IBX,IBY,DGREC,IBDISDT,DGMVTP,DGADM,DFN,DGA
- SET IBX=0
- IF '$GET(DGBDT)!'$GET(DGEDT)
- GOTO LOSQ
- +7 ; inclusive if interim continuous or first
- IF DGBDT=DGEDT!($GET(BTF)=2)!($GET(BTF)=3)
- SET DGEDT=$$FMADD^XLFDT(DGEDT,1)
- +8 ; difference between begin and end date
- SET IBX=$$FMDIFF^XLFDT(DGEDT,DGBDT,1)
- +9 IF +$GET(DGPMCA)
- SET IBY=$$AD(DGPMCA)
- IF +IBY
- SET DGADM=+IBY\1
- SET IBDISDT=$PIECE(IBY,U,2)\1
- SET DFN=$PIECE(IBY,U,3)
- Begin DoDot:1
- +10 ; maximum date range is the admit thru discharge range
- +11 IF DGBDT<DGADM
- SET DGBDT=DGADM
- IF +IBDISDT&(DGEDT>IBDISDT)
- SET DGEDT=IBDISDT
- +12 SET IBX=$$FMDIFF^XLFDT(DGEDT,DGBDT,1)
- IF (DGBDT\1)=(DGEDT\1)
- SET IBX=1
- +13 ; subtract days absent or on pass
- DO PLASIH^DGUTL2
- SET IBX=IBX-DGREC
- End DoDot:1
- LOSQ QUIT $SELECT(IBX>0:IBX,1:0)
- +1 ;
- DUPCHKI(DT1,DT2,PTF,RTG,DISP,IFN) ;Check for duplicate billing of inpt admission - checks for overlapping date range on other
- +1 ;bills with the same rate type and that have not been cancelled
- +2 ;input: DT1 - beginning of date range to check
- +3 ; DT2 - ending of date range to check
- +4 ; PTF - ptr to PTF record
- +5 ; DISP - true if error message should be printed before exit, if any
- +6 ; RTG - rate group to check for, if no rate group (0 passed and/or no IFN) then any bill found for
- +7 ; visit date will cause error message
- +8 ; IFN - existing bill to check against, if passed will use variables from this bill if they are not passed in
- +9 ;returns: 0 - if another bill was not found for this admission with this date range, patient, and rate type
- +10 ; (dup IFN)_"^error message" - if duplicate date found, same rate group then IFN of bill
- +11 NEW IFN2,Y,X,X1
- SET Y=0
- SET (X,X1)=""
- SET IFN=+$GET(IFN)
- IF +IFN
- SET X=$GET(^DGCR(399,IFN,0))
- SET X1=$GET(^DGCR(399,IFN,"U"))
- +12 SET RTG=$SELECT($GET(RTG)'="":+RTG,1:+$PIECE(X,U,7))
- SET PTF=$SELECT(+$GET(PTF):+PTF,1:+$PIECE(X,U,8))
- IF 'PTF
- GOTO DCIQ
- +13 SET DT1=$SELECT(+$GET(DT1):+DT1,1:$PIECE(X1,U,1))
- SET DT2=$SELECT(+$GET(DT2):+DT2,1:$PIECE(X1,U,2))
- IF 'DT1!'DT2
- GOTO DCIQ
- +14 SET DT1=DT1\1
- SET DT2=DT2\1
- IF (DT1>DT2)!('$DATA(^DGCR(399,"APTF",PTF)))
- GOTO DCIQ
- +15 SET IFN2=0
- FOR
- SET IFN2=$ORDER(^DGCR(399,"APTF",PTF,IFN2))
- IF 'IFN2
- QUIT
- IF IFN'=IFN2
- Begin DoDot:1
- +16 ; bill cancelled
- SET X1=$GET(^DGCR(399,IFN2,0))
- IF $PIECE(X1,U,13)=7
- QUIT
- +17 ; different rate group
- IF +RTG
- IF $PIECE(X1,U,7)'=RTG
- QUIT
- +18 SET X=$GET(^DGCR(399,IFN2,"U"))
- IF (DT2<+X)!(DT1>+$PIECE(X,U,2))
- QUIT
- +19 SET Y=IFN2_"^A "_$PIECE($GET(^DGCR(399.3,+$PIECE(X1,U,7),0)),U,1)_" bill ("_$PIECE(X1,U,1)_") exists overlapping this date range."
- End DoDot:1
- IF +Y
- QUIT
- DCIQ IF +$GET(DISP)
- IF +Y
- WRITE !,?10,$PIECE(Y,U,2)
- +1 QUIT Y
- +2 ;
- ADM(DFN,IBDT) ; -- send back adm dt for dfn on vaindt (or now) if any, 0 otherwise
- +1 ;returns adm if patient was admitted at any time during IBDT or before dischrge date and time
- +2 NEW IBNDT,IBINPT,IBADM,IBADT1,IBADT2,IBDIS,IBNOW,%,X,Y
- DO NOW^%DTC
- SET IBNOW=%
- +3 SET IBINPT=0
- SET IBDT=$GET(IBDT)
- IF '$DATA(^DPT(+$GET(DFN),0))
- GOTO ADME
- IF 'IBDT
- SET IBDT=IBNOW
- +4 SET IBNDT=9999999.999999-((IBDT\1)+.99999)
- SET IBADT2=IBNOW
- +5 FOR
- SET IBNDT=$ORDER(^DGPM("ATID1",DFN,IBNDT))
- IF 'IBNDT
- QUIT
- Begin DoDot:1
- +6 SET IBADM=+$ORDER(^DGPM("ATID1",DFN,IBNDT,0))
- SET IBADT1=$GET(^DGPM(+IBADM,0))
- IF IBADT1=""
- QUIT
- +7 SET IBDIS=$PIECE(IBADT1,U,17)
- IF +IBDIS
- SET IBADT2=+$GET(^DGPM(+IBDIS,0))
- +8 IF $PIECE(IBADT2,".",2)=""
- SET $PIECE(IBADT2,".",2)=999999
- +9 IF (+IBADT1\1)'>(IBDT\1)
- IF (IBADT2'<IBDT!((+IBADT1\1)=(+IBDT\1)))
- SET IBINPT=+IBADT1
- End DoDot:1
- IF +IBINPT
- QUIT
- ADME QUIT IBINPT
