IBCU64 ;ALB/ARH - AUTOMATED BILLER (INPT CONT) ;8/6/93
;;2.0;INTEGRATED BILLING;**14,80,130,51,137,400**;21-MAR-94;Build 52
;;Per VHA Directive 2004-038, this routine should not be modified.
; DBIA REFERENCE TO ^DGPM, DGPM("AMV1" , "ATID1", "APTF" = DBIA419
; DBIA REFERENCE TO PLASIH^DGUTL2 = DBIA421
; DBIA REFERENCE TO APLD^DGUTL2 =
;
LOS1(IFN,IBDTS) ; returns length of stay for a bill's date range
; If actual leave dates needed, pass IBDTS by reference
; Returns IBDTS(begin leave dt)=end leave dt)
N X,Y,DFN,IBADM,IBPMCA S (X,IBPMCA)=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),IBADM=+$P(Y,U,3) I 'IBADM Q
. S IBPMCA=$O(^DGPM("AMV1",+IBADM,+DFN,0))
S X=$G(^DGCR(399,+IFN,"U"))
S X=$$LOS($P(X,U,1),$P(X,U,2),$P(Y,U,6),IBPMCA,.IBDTS)
LOS1Q Q X
;
AD(IBPMCA) ; 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(IBPMCA) G ADQ
S Y=$G(^DGPM(+IBPMCA,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(IBBDT,IBEDT,BTF,IBPMCA,IBDTS) ; 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
; Array returned (if passed by reference) IBDTS=# of leave days
; IBDTS(begin date)=end date for all leave periods
N X,IBX,IBY,IBDISDT,IBADM,DFN,IBA S IBX=0 I '$G(IBBDT)!'$G(IBEDT) G LOSQ
I IBBDT=IBEDT!($G(BTF)=2)!($G(BTF)=3) S IBEDT=$$FMADD^XLFDT(IBEDT,1) ; inclusive if interim continuous or first
S IBX=$$FMDIFF^XLFDT(IBEDT,IBBDT,1) ; difference between begin and end date
I +$G(IBPMCA) S IBY=$$AD(IBPMCA) I +IBY S IBADM=+IBY\1,IBDISDT=$P(IBY,U,2)\1,DFN=$P(IBY,U,3) D
. ; maximum date range is the admit thru discharge range
. S:IBBDT<IBADM IBBDT=IBADM I +IBDISDT&(IBEDT>IBDISDT) S IBEDT=IBDISDT
. S IBX=$$FMDIFF^XLFDT(IBEDT,IBBDT,1) I (IBBDT\1)=(IBEDT\1) S IBX=1
. S IBX=IBX-$$NONCOV(IBBDT,IBEDT,IBPMCA,.IBDTS) ; 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 Admission and Discharge Dates for a patient on IBDT (or now) if any, 0 otherwise
;returns 'Adm Dt^Disch Dt^PM ptr^PTF ptr' if patient was admitted at any time during IBDT or before discharge date and time
N IBNDT,IBINPT,IBADM,IBADT1,IBADT2,IBDIS,IBNOW,%,X,Y S IBNOW=$$NOW^XLFDT
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)),IBDIS=IBADT2
. I $P(IBADT2,".",2)="" S $P(IBADT2,".",2)=999999
. I (+IBADT1\1)'>(IBDT\1),(IBADT2'<IBDT!((+IBADT1\1)=(+IBDT\1))) S IBINPT=+IBADT1_U_+IBDIS_U_IBADM_U_$P(IBADT1,U,16)
ADME Q IBINPT
;
PTFADM(PTF) ; given a PTF #, return the Patient Movement Admission entry pointer (405)
N IBX S IBX="" I +$G(PTF) S IBX=$O(^DGPM("APTF",+PTF,0))
Q IBX
;
NONCOV(IBBDT,IBEDT,IBPMCA,IBDTS) ; Determine the total # of non billable
; days in an inpt date range
; variables are input to DGUTL2 call
; Array IBDTS(movement from date)=movement to date is returned if passed
; by reference
;
N Z,IBZ
S Z=+$$APLD^DGUTL2(IBPMCA,.IBZ,IBBDT,IBEDT,"B")
I Z>0,$G(IBZ(0))>0 S IBDTS=+IBZ(0) D
. S Z=0 F S Z=$O(IBZ(Z)) Q:'Z S IBDTS(+$P(IBZ(Z),U))=$P(IBZ(Z),U,2)
Q +$G(IBZ(0))
;
PPS(IBIFN,IBPTF) ; Calculate the claim's default PPS - prospective payment system code.
; Also known as the DRG - diagnosis-related group.
; This field is a trigger from the .08 field PTF entry# to field# 170 for the PPS.
; IB*2*400 addition
; Input - IBIFN - ien to file 399
; IBPTF - ien to file 45 - value of the .08 field
NEW PPS S PPS=""
I '$$INPAT^IBCEF(IBIFN) G PPSX ; pps field is for inpatients only
I $$FT^IBCEF(IBIFN)'=3 G PPSX ; pps field is for UB claims only
S PPS=+$$GET1^DIQ(45,+$G(IBPTF)_",",9,"") ; value of the discharge DRG from PTF
I $$DRGTD^IBACSV(PPS,$$BDATE^IBACSV(IBIFN))="" S PPS="" ; make sure DRG description exists
PPSX ;
Q PPS
;
PPSC(IBIFN) ; Trigger condition for setting the PPS field (field# 170)
; Function value=1 if it is OK to fire the trigger
N OK S OK=0
I +$P($G(^DGCR(399,IBIFN,"U1")),U,15) G PPSCX ; pps value already on file
I '$$INPAT^IBCEF(IBIFN) G PPSCX ; must be an inpatient claim
I $$FT^IBCEF(IBIFN)'=3 G PPSCX ; must be a UB claim
S OK=1
PPSCX ;
Q OK
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCU64 6851 printed Apr 09, 2024@21:21:29 Page 2
IBCU64 ;ALB/ARH - AUTOMATED BILLER (INPT CONT) ;8/6/93
+1 ;;2.0;INTEGRATED BILLING;**14,80,130,51,137,400**;21-MAR-94;Build 52
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ; DBIA REFERENCE TO ^DGPM, DGPM("AMV1" , "ATID1", "APTF" = DBIA419
+4 ; DBIA REFERENCE TO PLASIH^DGUTL2 = DBIA421
+5 ; DBIA REFERENCE TO APLD^DGUTL2 =
+6 ;
LOS1(IFN,IBDTS) ; returns length of stay for a bill's date range
+1 ; If actual leave dates needed, pass IBDTS by reference
+2 ; Returns IBDTS(begin leave dt)=end leave dt)
+3 NEW X,Y,DFN,IBADM,IBPMCA
SET (X,IBPMCA)=0
SET Y=$GET(^DGCR(399,+$GET(IFN),0))
if Y=""
GOTO LOS1Q
IF $PIECE(Y,U,8)'=""
Begin DoDot:1
+4 ; find patient movement, based on admit date and DFN from PTF
+5 SET DFN=+$PIECE(Y,U,2)
SET IBADM=+$PIECE(Y,U,3)
IF 'IBADM
QUIT
+6 SET IBPMCA=$ORDER(^DGPM("AMV1",+IBADM,+DFN,0))
End DoDot:1
+7 SET X=$GET(^DGCR(399,+IFN,"U"))
+8 SET X=$$LOS($PIECE(X,U,1),$PIECE(X,U,2),$PIECE(Y,U,6),IBPMCA,.IBDTS)
LOS1Q QUIT X
+1 ;
AD(IBPMCA) ; 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(IBPMCA)
GOTO ADQ
+2 ; get patient movement data
SET Y=$GET(^DGPM(+IBPMCA,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(IBBDT,IBEDT,BTF,IBPMCA,IBDTS) ; 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 ; Array returned (if passed by reference) IBDTS=# of leave days
+7 ; IBDTS(begin date)=end date for all leave periods
+8 NEW X,IBX,IBY,IBDISDT,IBADM,DFN,IBA
SET IBX=0
IF '$GET(IBBDT)!'$GET(IBEDT)
GOTO LOSQ
+9 ; inclusive if interim continuous or first
IF IBBDT=IBEDT!($GET(BTF)=2)!($GET(BTF)=3)
SET IBEDT=$$FMADD^XLFDT(IBEDT,1)
+10 ; difference between begin and end date
SET IBX=$$FMDIFF^XLFDT(IBEDT,IBBDT,1)
+11 IF +$GET(IBPMCA)
SET IBY=$$AD(IBPMCA)
IF +IBY
SET IBADM=+IBY\1
SET IBDISDT=$PIECE(IBY,U,2)\1
SET DFN=$PIECE(IBY,U,3)
Begin DoDot:1
+12 ; maximum date range is the admit thru discharge range
+13 if IBBDT<IBADM
SET IBBDT=IBADM
IF +IBDISDT&(IBEDT>IBDISDT)
SET IBEDT=IBDISDT
+14 SET IBX=$$FMDIFF^XLFDT(IBEDT,IBBDT,1)
IF (IBBDT\1)=(IBEDT\1)
SET IBX=1
+15 ; subtract days absent or on pass
SET IBX=IBX-$$NONCOV(IBBDT,IBEDT,IBPMCA,.IBDTS)
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 Admission and Discharge Dates for a patient on IBDT (or now) if any, 0 otherwise
+1 ;returns 'Adm Dt^Disch Dt^PM ptr^PTF ptr' if patient was admitted at any time during IBDT or before discharge date and time
+2 NEW IBNDT,IBINPT,IBADM,IBADT1,IBADT2,IBDIS,IBNOW,%,X,Y
SET IBNOW=$$NOW^XLFDT
+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))
SET IBDIS=IBADT2
+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_U_+IBDIS_U_IBADM_U_$PIECE(IBADT1,U,16)
End DoDot:1
if +IBINPT
QUIT
ADME QUIT IBINPT
+1 ;
PTFADM(PTF) ; given a PTF #, return the Patient Movement Admission entry pointer (405)
+1 NEW IBX
SET IBX=""
IF +$GET(PTF)
SET IBX=$ORDER(^DGPM("APTF",+PTF,0))
+2 QUIT IBX
+3 ;
NONCOV(IBBDT,IBEDT,IBPMCA,IBDTS) ; Determine the total # of non billable
+1 ; days in an inpt date range
+2 ; variables are input to DGUTL2 call
+3 ; Array IBDTS(movement from date)=movement to date is returned if passed
+4 ; by reference
+5 ;
+6 NEW Z,IBZ
+7 SET Z=+$$APLD^DGUTL2(IBPMCA,.IBZ,IBBDT,IBEDT,"B")
+8 IF Z>0
IF $GET(IBZ(0))>0
SET IBDTS=+IBZ(0)
Begin DoDot:1
+9 SET Z=0
FOR
SET Z=$ORDER(IBZ(Z))
if 'Z
QUIT
SET IBDTS(+$PIECE(IBZ(Z),U))=$PIECE(IBZ(Z),U,2)
End DoDot:1
+10 QUIT +$GET(IBZ(0))
+11 ;
PPS(IBIFN,IBPTF) ; Calculate the claim's default PPS - prospective payment system code.
+1 ; Also known as the DRG - diagnosis-related group.
+2 ; This field is a trigger from the .08 field PTF entry# to field# 170 for the PPS.
+3 ; IB*2*400 addition
+4 ; Input - IBIFN - ien to file 399
+5 ; IBPTF - ien to file 45 - value of the .08 field
+6 NEW PPS
SET PPS=""
+7 ; pps field is for inpatients only
IF '$$INPAT^IBCEF(IBIFN)
GOTO PPSX
+8 ; pps field is for UB claims only
IF $$FT^IBCEF(IBIFN)'=3
GOTO PPSX
+9 ; value of the discharge DRG from PTF
SET PPS=+$$GET1^DIQ(45,+$GET(IBPTF)_",",9,"")
+10 ; make sure DRG description exists
IF $$DRGTD^IBACSV(PPS,$$BDATE^IBACSV(IBIFN))=""
SET PPS=""
PPSX ;
+1 QUIT PPS
+2 ;
PPSC(IBIFN) ; Trigger condition for setting the PPS field (field# 170)
+1 ; Function value=1 if it is OK to fire the trigger
+2 NEW OK
SET OK=0
+3 ; pps value already on file
IF +$PIECE($GET(^DGCR(399,IBIFN,"U1")),U,15)
GOTO PPSCX
+4 ; must be an inpatient claim
IF '$$INPAT^IBCEF(IBIFN)
GOTO PPSCX
+5 ; must be a UB claim
IF $$FT^IBCEF(IBIFN)'=3
GOTO PPSCX
+6 SET OK=1
PPSCX ;
+1 QUIT OK
+2 ;
