IBCU71 ;ALB/AAS - INTERCEPT SCREEN INPUT OF PROCEDURE CODES ;29-OCT-91
;;2.0;INTEGRATED BILLING;**41,60,91,106,125,138,210,245,349,432**;21-MAR-94;Build 192
;;Per VHA Directive 2004-038, this routine should not be modified.
;
;MAP TO DGCRU71
;
ADDCPT ; - store cpt codes in visits file
Q:$D(DGCPT)'>9
N DA,DIC,DR,DIE,DIRUT,DUOUT,DTOUT,DIROUT,VADM
S DIR(0)="Y",DIR("A")="OK to add CPT codes to Visits file",DIR("B")="Y" D ^DIR K DIR Q:'Y!$D(DIRUT)
N IBPKG,IBCLIN,IBVDATE,IBPROC,IBK,IBCOUNT,IBRESULT,IBOTH
S IBPKG=$O(^DIC(9.4,"C","IB",0)) Q:'IBPKG
W !!,"Adding Procedures to PCE..."
S IBCLIN=0 F S IBCLIN=$O(DGCPT(IBCLIN)) Q:'IBCLIN D
.;
.K ^TMP("IBPXAPI",$J)
.;
.; - set up encounter data
.S IBVDATE=DGPROCDT D VISDT
.S ^TMP("IBPXAPI",$J,"ENCOUNTER",1,"ENC D/T")=IBVDATE,^("PATIENT")=DFN,^("HOS LOC")=IBCLIN,^("SERVICE CATEGORY")="X",^("ENCOUNTER TYPE")="A"
.;
.; - set up procedure and diagnosis data
.S IBK=0,IBPROC=0 F S IBPROC=$O(DGCPT(IBCLIN,IBPROC)) Q:'IBPROC D
..S IBOTH="" F S IBOTH=$O(DGCPT(IBCLIN,IBPROC,IBOTH)) Q:IBOTH="" D
...S IBK=IBK+1
...;
...; - load first procedure diagnosis as visit diagnosis
...I +$P(IBOTH,U,2) S ^TMP("IBPXAPI",$J,"DX/PL",IBK,"DIAGNOSIS")=+$P(IBOTH,U,2)
...;
...; - count number of times procedure performed
...S (X,IBCOUNT)=0 F S X=$O(DGCPT(IBCLIN,IBPROC,IBOTH,X)) Q:'X S IBCOUNT=IBCOUNT+1
...;
...; - load procedure information
...S ^TMP("IBPXAPI",$J,"PROCEDURE",IBK,"PROCEDURE")=IBPROC,^("QTY")=IBCOUNT,^("EVENT D/T")=IBVDATE
...I +$P(IBOTH,U,1) S ^TMP("IBPXAPI",$J,"PROCEDURE",IBK,"ENC PROVIDER")=+$P(IBOTH,U,1)
...I +$P(IBOTH,U,3) S ^TMP("IBPXAPI",$J,"PROCEDURE",IBK,"MODIFIERS",$P($$MOD^ICPTMOD(+$P(IBOTH,U,3),"I"),U,2))=""
.;
.; - call the PCE interface
.Q:'$D(^TMP("IBPXAPI",$J,"PROCEDURE"))
.;
.S IBRESULT=$$DATA2PCE^PXAPI("^TMP(""IBPXAPI"",$J)",IBPKG,"IB DATA",,DUZ,0)
.W !," Procedures in ",$P(^SC(IBCLIN,0),"^")," "
.I IBRESULT>0 W "were added okay." Q
.W "were not added - error code is ",IBRESULT
;
K ^TMP("IBPXAPI",$J)
Q
;
;
DISPDX ; - display diagnosis codes available for associated dx (CMS-1500) NO LONGER USED?
N I,J,X,IBDX,IBDXL,IBDATE
S IBDATE=$$BDATE^IBACSV(IBIFN)
F I=1:1:4 S IBDX=$P($G(^DGCR(399,IBIFN,"C")),"^",(I+13)),X=$$ICD9^IBACSV(+IBDX,IBDATE) I X'="" S IBDXL(I)=IBDX_"^"_X
I '$D(IBDXL) W !!,"Bill has no ICD DIAGNOSIS." Q
W !!,?24,"<<<ASSOCIATED ICD-9 DIAGNOSIS>>>",!!
F I=1,2 W ! S X=0 F J=0,2 I $D(IBDXL(I+J)) S IBDX=IBDXL(I+J) D S X=40
. W ?X," ",$P(IBDX,"^",2),?(X+13),$E($P(IBDX,"^",4),1,28)
W !
Q
;
SCREEN(X,Y) ; -- screen logic for active procs or surgeries - OBSOLETE
; -- input x = date to check, y = procedure
; -- output 0 if not active for billing or amb proc on date, 1 if either active
;
Q 0
;
VISDT ; Find the actual encounter for the visit; update visit date/time
; input DGPROCDT, DFN, IBCLIN
N IBD,IBF,IBOEN,IBEVT,IBVAL,IBCBK,IBFILTER
S IBF=0,IBD=DGPROCDT-.1
S IBVAL("DFN")=DFN,IBVAL("BDT")=DGPROCDT-.1,IBVAL("EDT")=DGPROCDT\1_".99"
S IBFILTER=""
S IBCBK="I IBCLIN=$P(Y0,U,4) S IBVDATE=+Y0,SDSTOP=1"
D SCAN^IBSDU("PATIENT/DATE",.IBVAL,IBFILTER,IBCBK,1)
Q
;
PRCDT(IBIFN,ARR) ; return array of bill's procedures in date then code order
; returns ARR(DATE, NAME, CPIFN) = 399.0304 node
N IBI,IBX,IBNAME K ARR
S IBI=0 F S IBI=$O(^DGCR(399,+$G(IBIFN),"CP",IBI)) Q:'IBI D
. S IBX=$G(^DGCR(399,IBIFN,"CP",IBI,0))
. S IBNAME=$P($$PRCNM^IBCSCH1($P(IBX,U,1)),U,1)_" "
. S ARR($P(IBX,U,2),IBNAME,IBI)=IBX
Q
;
PRCDIV(IBIFN) ; change Bills Default Division (399,.22) to reflect care provided
; - set Bill Division to the first Procedures Division (399,304,5), if defined
; - or else if bill is an inpatient bill then get the Division of the Ward the patient was Admitted to
; return null if no change or 'new division ifn^message'
;
N IB0,IBCPT,IBPDIV,IBWRD,IBX,DIC,DIE,DA,DR,X,Y,IBCPT0 S IBX="",IBPDIV=0
S IB0=$G(^DGCR(399,+$G(IBIFN),0))
; if OP, Institutional claim and any CP entry has the Main Division, set default = to main
I +$G(IBIFN),'$$INPAT^IBCEF(IBIFN),$$INSPRF^IBCEF(IBIFN) S IBCPT="" F S IBCPT=$O(^DGCR(399,IBIFN,"CP",IBCPT)) Q:'IBCPT!(IBPDIV>0) D
.S IBCPT0=$G(^DGCR(399,IBIFN,"CP",IBCPT,0))
.;check to see if Procedure division was Main division on procedure date
.I $P(IBCPT0,U,6)=$$PRIM^VASITE($P(IBCPT0,U,2)) S IBPDIV=$P(IBCPT0,U,6)
;
;I +$G(IBIFN) S IBCPT=$O(^DGCR(399,IBIFN,"CP",0)) I +IBCPT D ; if CPT division defined, use it
; if CPT division defined and Proc Div not already set from above, use it
I +$G(IBIFN),'IBPDIV S IBCPT=$O(^DGCR(399,IBIFN,"CP",0)) I +IBCPT D
. S IBCPT=$G(^DGCR(399,IBIFN,"CP",IBCPT,0)) S IBPDIV=+$P(IBCPT,U,6)
;
I 'IBPDIV,+$P(IB0,U,8) D ; for inpatient, get Ward Division
. S IBWRD=$G(^DGPT(+$P(IB0,U,8),535,1,0)) S IBPDIV=+$P($G(^DIC(42,+$P(IBWRD,U,6),0)),U,11)
;
I +IBPDIV,+$P(IB0,U,22)'=+IBPDIV D
. S DIE="^DGCR(399,",DA=IBIFN,DR=".22////"_+IBPDIV D ^DIE K DIE,DR,DA,X,Y
. S IBX=+IBPDIV_"^Bill Division Changed to "_$P($G(^DG(40.8,+IBPDIV,0)),U,1)
Q IBX
;
DVTYP(IBIFN) ; reset Bill Charge Type (399, .27) based on Bill Division (399, .22)
; if bill division is type 3 - Freestanding then reset Charge Type to 2 - Professional
; with RC 2.0+ Type 3 sites have only professional charges, start date of bill must be on/after beginning of RC 2.0
N IB0,IBDV,IBCHGTYP,IBDVTYP,DIC,DIE,DA,DR,X,Y
S IB0=$G(^DGCR(399,+$G(IBIFN),0)),IBDV=$P(IB0,U,22),IBCHGTYP=$P(IB0,U,27)
I +$G(^DGCR(399,+$G(IBIFN),"U"))<$$VERSDT^IBCRU8(2) G DVTYPQ
I +IBDV,+IBCHGTYP S IBDVTYP=$$RCDV^IBCRU8(+IBDV) I +$P(IBDVTYP,U,3)=3,IBCHGTYP'=2 D
. S DIE="^DGCR(399,",DA=IBIFN,DR=".27////"_2 D ^DIE K DIE,DR,DA,X,Y
. S IBCHGTYP="2^Bill Charge Type Changed to Professional"
DVTYPQ Q IBCHGTYP
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCU71 5835 printed Apr 09, 2024@21:06:18 Page 2
IBCU71 ;ALB/AAS - INTERCEPT SCREEN INPUT OF PROCEDURE CODES ;29-OCT-91
+1 ;;2.0;INTEGRATED BILLING;**41,60,91,106,125,138,210,245,349,432**;21-MAR-94;Build 192
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;MAP TO DGCRU71
+5 ;
ADDCPT ; - store cpt codes in visits file
+1 if $DATA(DGCPT)'>9
QUIT
+2 NEW DA,DIC,DR,DIE,DIRUT,DUOUT,DTOUT,DIROUT,VADM
+3 SET DIR(0)="Y"
SET DIR("A")="OK to add CPT codes to Visits file"
SET DIR("B")="Y"
DO ^DIR
KILL DIR
if 'Y!$DATA(DIRUT)
QUIT
+4 NEW IBPKG,IBCLIN,IBVDATE,IBPROC,IBK,IBCOUNT,IBRESULT,IBOTH
+5 SET IBPKG=$ORDER(^DIC(9.4,"C","IB",0))
if 'IBPKG
QUIT
+6 WRITE !!,"Adding Procedures to PCE..."
+7 SET IBCLIN=0
FOR
SET IBCLIN=$ORDER(DGCPT(IBCLIN))
if 'IBCLIN
QUIT
Begin DoDot:1
+8 ;
+9 KILL ^TMP("IBPXAPI",$JOB)
+10 ;
+11 ; - set up encounter data
+12 SET IBVDATE=DGPROCDT
DO VISDT
+13 SET ^TMP("IBPXAPI",$JOB,"ENCOUNTER",1,"ENC D/T")=IBVDATE
SET ^("PATIENT")=DFN
SET ^("HOS LOC")=IBCLIN
SET ^("SERVICE CATEGORY")="X"
SET ^("ENCOUNTER TYPE")="A"
+14 ;
+15 ; - set up procedure and diagnosis data
+16 SET IBK=0
SET IBPROC=0
FOR
SET IBPROC=$ORDER(DGCPT(IBCLIN,IBPROC))
if 'IBPROC
QUIT
Begin DoDot:2
+17 SET IBOTH=""
FOR
SET IBOTH=$ORDER(DGCPT(IBCLIN,IBPROC,IBOTH))
if IBOTH=""
QUIT
Begin DoDot:3
+18 SET IBK=IBK+1
+19 ;
+20 ; - load first procedure diagnosis as visit diagnosis
+21 IF +$PIECE(IBOTH,U,2)
SET ^TMP("IBPXAPI",$JOB,"DX/PL",IBK,"DIAGNOSIS")=+$PIECE(IBOTH,U,2)
+22 ;
+23 ; - count number of times procedure performed
+24 SET (X,IBCOUNT)=0
FOR
SET X=$ORDER(DGCPT(IBCLIN,IBPROC,IBOTH,X))
if 'X
QUIT
SET IBCOUNT=IBCOUNT+1
+25 ;
+26 ; - load procedure information
+27 SET ^TMP("IBPXAPI",$JOB,"PROCEDURE",IBK,"PROCEDURE")=IBPROC
SET ^("QTY")=IBCOUNT
SET ^("EVENT D/T")=IBVDATE
+28 IF +$PIECE(IBOTH,U,1)
SET ^TMP("IBPXAPI",$JOB,"PROCEDURE",IBK,"ENC PROVIDER")=+$PIECE(IBOTH,U,1)
+29 IF +$PIECE(IBOTH,U,3)
SET ^TMP("IBPXAPI",$JOB,"PROCEDURE",IBK,"MODIFIERS",$PIECE($$MOD^ICPTMOD(+$PIECE(IBOTH,U,3),"I"),U,2))=""
End DoDot:3
End DoDot:2
+30 ;
+31 ; - call the PCE interface
+32 if '$DATA(^TMP("IBPXAPI",$JOB,"PROCEDURE"))
QUIT
+33 ;
+34 SET IBRESULT=$$DATA2PCE^PXAPI("^TMP(""IBPXAPI"",$J)",IBPKG,"IB DATA",,DUZ,0)
+35 WRITE !," Procedures in ",$PIECE(^SC(IBCLIN,0),"^")," "
+36 IF IBRESULT>0
WRITE "were added okay."
QUIT
+37 WRITE "were not added - error code is ",IBRESULT
End DoDot:1
+38 ;
+39 KILL ^TMP("IBPXAPI",$JOB)
+40 QUIT
+41 ;
+42 ;
DISPDX ; - display diagnosis codes available for associated dx (CMS-1500) NO LONGER USED?
+1 NEW I,J,X,IBDX,IBDXL,IBDATE
+2 SET IBDATE=$$BDATE^IBACSV(IBIFN)
+3 FOR I=1:1:4
SET IBDX=$PIECE($GET(^DGCR(399,IBIFN,"C")),"^",(I+13))
SET X=$$ICD9^IBACSV(+IBDX,IBDATE)
IF X'=""
SET IBDXL(I)=IBDX_"^"_X
+4 IF '$DATA(IBDXL)
WRITE !!,"Bill has no ICD DIAGNOSIS."
QUIT
+5 WRITE !!,?24,"<<<ASSOCIATED ICD-9 DIAGNOSIS>>>",!!
+6 FOR I=1,2
WRITE !
SET X=0
FOR J=0,2
IF $DATA(IBDXL(I+J))
SET IBDX=IBDXL(I+J)
Begin DoDot:1
+7 WRITE ?X," ",$PIECE(IBDX,"^",2),?(X+13),$EXTRACT($PIECE(IBDX,"^",4),1,28)
End DoDot:1
SET X=40
+8 WRITE !
+9 QUIT
+10 ;
SCREEN(X,Y) ; -- screen logic for active procs or surgeries - OBSOLETE
+1 ; -- input x = date to check, y = procedure
+2 ; -- output 0 if not active for billing or amb proc on date, 1 if either active
+3 ;
+4 QUIT 0
+5 ;
VISDT ; Find the actual encounter for the visit; update visit date/time
+1 ; input DGPROCDT, DFN, IBCLIN
+2 NEW IBD,IBF,IBOEN,IBEVT,IBVAL,IBCBK,IBFILTER
+3 SET IBF=0
SET IBD=DGPROCDT-.1
+4 SET IBVAL("DFN")=DFN
SET IBVAL("BDT")=DGPROCDT-.1
SET IBVAL("EDT")=DGPROCDT\1_".99"
+5 SET IBFILTER=""
+6 SET IBCBK="I IBCLIN=$P(Y0,U,4) S IBVDATE=+Y0,SDSTOP=1"
+7 DO SCAN^IBSDU("PATIENT/DATE",.IBVAL,IBFILTER,IBCBK,1)
+8 QUIT
+9 ;
PRCDT(IBIFN,ARR) ; return array of bill's procedures in date then code order
+1 ; returns ARR(DATE, NAME, CPIFN) = 399.0304 node
+2 NEW IBI,IBX,IBNAME
KILL ARR
+3 SET IBI=0
FOR
SET IBI=$ORDER(^DGCR(399,+$GET(IBIFN),"CP",IBI))
if 'IBI
QUIT
Begin DoDot:1
+4 SET IBX=$GET(^DGCR(399,IBIFN,"CP",IBI,0))
+5 SET IBNAME=$PIECE($$PRCNM^IBCSCH1($PIECE(IBX,U,1)),U,1)_" "
+6 SET ARR($PIECE(IBX,U,2),IBNAME,IBI)=IBX
End DoDot:1
+7 QUIT
+8 ;
PRCDIV(IBIFN) ; change Bills Default Division (399,.22) to reflect care provided
+1 ; - set Bill Division to the first Procedures Division (399,304,5), if defined
+2 ; - or else if bill is an inpatient bill then get the Division of the Ward the patient was Admitted to
+3 ; return null if no change or 'new division ifn^message'
+4 ;
+5 NEW IB0,IBCPT,IBPDIV,IBWRD,IBX,DIC,DIE,DA,DR,X,Y,IBCPT0
SET IBX=""
SET IBPDIV=0
+6 SET IB0=$GET(^DGCR(399,+$GET(IBIFN),0))
+7 ; if OP, Institutional claim and any CP entry has the Main Division, set default = to main
+8 IF +$GET(IBIFN)
IF '$$INPAT^IBCEF(IBIFN)
IF $$INSPRF^IBCEF(IBIFN)
SET IBCPT=""
FOR
SET IBCPT=$ORDER(^DGCR(399,IBIFN,"CP",IBCPT))
if 'IBCPT!(IBPDIV>0)
QUIT
Begin DoDot:1
+9 SET IBCPT0=$GET(^DGCR(399,IBIFN,"CP",IBCPT,0))
+10 ;check to see if Procedure division was Main division on procedure date
+11 IF $PIECE(IBCPT0,U,6)=$$PRIM^VASITE($PIECE(IBCPT0,U,2))
SET IBPDIV=$PIECE(IBCPT0,U,6)
End DoDot:1
+12 ;
+13 ;I +$G(IBIFN) S IBCPT=$O(^DGCR(399,IBIFN,"CP",0)) I +IBCPT D ; if CPT division defined, use it
+14 ; if CPT division defined and Proc Div not already set from above, use it
+15 IF +$GET(IBIFN)
IF 'IBPDIV
SET IBCPT=$ORDER(^DGCR(399,IBIFN,"CP",0))
IF +IBCPT
Begin DoDot:1
+16 SET IBCPT=$GET(^DGCR(399,IBIFN,"CP",IBCPT,0))
SET IBPDIV=+$PIECE(IBCPT,U,6)
End DoDot:1
+17 ;
+18 ; for inpatient, get Ward Division
IF 'IBPDIV
IF +$PIECE(IB0,U,8)
Begin DoDot:1
+19 SET IBWRD=$GET(^DGPT(+$PIECE(IB0,U,8),535,1,0))
SET IBPDIV=+$PIECE($GET(^DIC(42,+$PIECE(IBWRD,U,6),0)),U,11)
End DoDot:1
+20 ;
+21 IF +IBPDIV
IF +$PIECE(IB0,U,22)'=+IBPDIV
Begin DoDot:1
+22 SET DIE="^DGCR(399,"
SET DA=IBIFN
SET DR=".22////"_+IBPDIV
DO ^DIE
KILL DIE,DR,DA,X,Y
+23 SET IBX=+IBPDIV_"^Bill Division Changed to "_$PIECE($GET(^DG(40.8,+IBPDIV,0)),U,1)
End DoDot:1
+24 QUIT IBX
+25 ;
DVTYP(IBIFN) ; reset Bill Charge Type (399, .27) based on Bill Division (399, .22)
+1 ; if bill division is type 3 - Freestanding then reset Charge Type to 2 - Professional
+2 ; with RC 2.0+ Type 3 sites have only professional charges, start date of bill must be on/after beginning of RC 2.0
+3 NEW IB0,IBDV,IBCHGTYP,IBDVTYP,DIC,DIE,DA,DR,X,Y
+4 SET IB0=$GET(^DGCR(399,+$GET(IBIFN),0))
SET IBDV=$PIECE(IB0,U,22)
SET IBCHGTYP=$PIECE(IB0,U,27)
+5 IF +$GET(^DGCR(399,+$GET(IBIFN),"U"))<$$VERSDT^IBCRU8(2)
GOTO DVTYPQ
+6 IF +IBDV
IF +IBCHGTYP
SET IBDVTYP=$$RCDV^IBCRU8(+IBDV)
IF +$PIECE(IBDVTYP,U,3)=3
IF IBCHGTYP'=2
Begin DoDot:1
+7 SET DIE="^DGCR(399,"
SET DA=IBIFN
SET DR=".27////"_2
DO ^DIE
KILL DIE,DR,DA,X,Y
+8 SET IBCHGTYP="2^Bill Charge Type Changed to Professional"
End DoDot:1
DVTYPQ QUIT IBCHGTYP
