IBCU7U ;ALB/ARH - BILL PROCEDURE UTILITIES ; 10-OCT-03
;;2.0;INTEGRATED BILLING;**245**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
; basic bill procedure utilities
;
DELCPT(IBIFN,OLDDA) ; delete a CPT code from a bill
; Input: OLDDA = ifn of cpt in bill cpt multiple to be deleted
N DA,DIK,DIC,DIE,X,Y,IBFND S IBFND=0,DA(1)=+$G(IBIFN),DA=+$G(OLDDA)
I $D(^DGCR(399,DA(1),"CP",DA,0)) S DIK="^DGCR(399,"_DA(1)_",""CP""," D ^DIK S IBFND=1
Q IBFND
;
EDITCPT(IBIFN,OLDDA,NEWCPT) ; replace a CPT code on the bill with another CPT code
; Input: OLDDA = ifn of cpt in bill cpt multiple to be replaced
; NEWCPT = ifn of cpt code to be added
N DA,DR,DIE,DIC,IBFND,X,Y S IBFND=0,DA(1)=+$G(IBIFN),DA=+$G(OLDDA),NEWCPT=+$G(NEWCPT)
I NEWCPT,$D(^DGCR(399,DA(1),"CP",DA,0)) S DIE="^DGCR(399,"_DA(1)_",""CP"",",DR=".01///`"_NEWCPT D ^DIE S IBFND=1
Q IBFND
;
COPYCPT(IBIFN,OLDDA,NEWCPT) ; add a new CPT and populate date fields with data from an existing bill cpt
; Input: OLDDA = ifn of cpt in bill cpt multiple to be copied
; NEWCPT = ifn of cpt code to be added
N DLAYGO,DIC,DIE,DA,DR,DD,DO,IBNEWDA,IBODA,IBNDA,IBXDA,IBSFILE,IBX,IBY,IBOLD,IBNEW,IBFND,X,Y S IBFND=0
;
I '$D(^DGCR(399,+$G(IBIFN),"CP",+$G(OLDDA),0)) G COPYCPQ
I '$G(NEWCPT) G COPYCPQ
;
; add new procedure entry to bill
S DLAYGO=399,DA(1)=IBIFN,DIC="^DGCR(399,"_DA(1)_",""CP"",",DIC(0)="L",X=+NEWCPT_";ICPT(" K DD,DO D FILE^DICN K DO,DD,DIC,DIE
S (DA,IBNEWDA,IBFND)=+Y I IBNEWDA<1 S IBFND=0 G COPYCPQ
;
; copy data from existing procedure to new procedure on bill
S IBODA=OLDDA_","_IBIFN_","
S IBNDA=IBNEWDA_","_IBIFN_","
D GETS^DIQ(399.0304,IBODA,"*","IN","IBOLD")
S IBSFILE=0 F S IBSFILE=$O(IBOLD(IBSFILE)) Q:'IBSFILE D
. S IBXDA="" F S IBXDA=$O(IBOLD(IBSFILE,IBXDA)) Q:IBXDA="" D
.. S IBX=0 F S IBX=$O(IBOLD(IBSFILE,IBXDA,IBX)) Q:'IBX D
... I IBXDA=IBODA,",.01,2,3,4,7,14,20,"[(","_IBX_",") Q
... S IBNEW(IBSFILE,IBNDA,IBX)=IBOLD(IBSFILE,IBXDA,IBX,"I")
I $O(IBNEW(0)) D FILE^DIE("","IBNEW") K DA,DR,DA,DO,DIE,DIC
;
; copy modifiers from existing procedure to new procedure on bill
S IBX=0 F S IBX=$O(^DGCR(399,IBIFN,"CP",OLDDA,"MOD",IBX)) Q:'IBX D
. S IBY=$G(^DGCR(399,IBIFN,"CP",OLDDA,"MOD",IBX,0)) Q:IBY=""
. S:'$D(^DGCR(399,IBIFN,"CP",IBNEWDA,"MOD")) DIC("P")=$$GETSPEC^IBEFUNC(399.0304,16)
. S DIC(0)="L",DIC="^DGCR(399,"_IBIFN_",""CP"","_+IBNEWDA_",""MOD"",",DLAYGO=399.30416
. S DA(2)=IBIFN,DA(1)=IBNEWDA,X=+IBY,DIC("DR")=".02////"_$P(IBY,U,2) D FILE^DICN K DIC,DO,DD
;
COPYCPQ Q IBFND
;
ADDCPT(IBIFN,SDLN) ; add a new CPT code to a bill and populate it's data based on clinical data
; Input: SDLN - data line from ^UTILITY($J,"CPT-CNT" created in VST^IBCCPT
; ^utility($j,cpt-cnt,count)=code^date^on bill^is BASC^divis^nb^nb mess^provider^clinic^mod,mod^Opt Enc Ptr
N DLAYGO,DIC,DIE,DA,DR,DD,DO,DINUM,IBNEWDA,IBFND,X,Y S IBFND=0
;
I '$D(^DGCR(399,+$G(IBIFN),0)) G ADDCPTQ
I '$G(SDLN) G ADDCPTQ
I +$P(SDLN,U,6) G ADDCPTQ
;
I '$D(^DGCR(399,IBIFN,"CP")) S DIC("P")=$$GETSPEC^IBEFUNC(399,304)
S DLAYGO=399,DA(1)=IBIFN,DIC="^DGCR(399,"_DA(1)_",""CP"",",DIC(0)="L",X=+SDLN_";ICPT(" K DD,DO D FILE^DICN K DO,DD,DIC("P")
S (DA,IBNEWDA,IBFND)=+Y I IBNEWDA<1 S IBFND=0 G ADDCPTQ
;
S DR="1////"_$P(SDLN,U,2)_$S(+$P(SDLN,U,8):";18////"_+$P(SDLN,U,8),1:"")
S DR=DR_$S(+$P(SDLN,U,9):";6////"_+$P(SDLN,U,9),1:"")_$S(+$P(SDLN,U,5):";5////"_+$P(SDLN,U,5),1:"")
S DR=DR_$S(+$P(SDLN,U,11):";20////"_+$P(SDLN,U,11),1:"")
S DIE=DIC,DA=+IBNEWDA D ^DIE K DIE,DIC,DA,DINUM,DO,DD
;
I $P(SDLN,U,10) D ADDMOD^IBCCPT(IBIFN,IBNEWDA,$P(SDLN,U,10)) ;Modifiers
;
ADDCPTQ Q IBFND
;
GETSD(IBIFN) ; get the procedures from the clinical data covered by the bill
; Output: ^UTILITY($J,"CPT-CNT",X)= ... (from VST^IBCCPT)
; ^UTILITY($J,"CPT-CLN",CPT,EVDT)= ...
N SDCNT,SDQDATA,SDQUERY,V,X,IBQUERY,IBOPV1,IBOPV2,DGCNT,DFN,IBX,IBY K ^UTILITY($J)
S DFN=$P($G(^DGCR(399,+$G(IBIFN),0)),U,2) Q:'DFN
D VST^IBCCPT(.IBQUERY)
S IBX=0 F S IBX=$O(^UTILITY($J,"CPT-CNT",IBX)) Q:'IBX D
. S IBY=^UTILITY($J,"CPT-CNT",IBX)
. S ^UTILITY($J,"CPT-CLN",$P(IBY,U,1),$P(IBY,U,2))=IBY
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCU7U 4214 printed Apr 09, 2024@21:31:12 Page 2
IBCU7U ;ALB/ARH - BILL PROCEDURE UTILITIES ; 10-OCT-03
+1 ;;2.0;INTEGRATED BILLING;**245**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ; basic bill procedure utilities
+5 ;
DELCPT(IBIFN,OLDDA) ; delete a CPT code from a bill
+1 ; Input: OLDDA = ifn of cpt in bill cpt multiple to be deleted
+2 NEW DA,DIK,DIC,DIE,X,Y,IBFND
SET IBFND=0
SET DA(1)=+$GET(IBIFN)
SET DA=+$GET(OLDDA)
+3 IF $DATA(^DGCR(399,DA(1),"CP",DA,0))
SET DIK="^DGCR(399,"_DA(1)_",""CP"","
DO ^DIK
SET IBFND=1
+4 QUIT IBFND
+5 ;
EDITCPT(IBIFN,OLDDA,NEWCPT) ; replace a CPT code on the bill with another CPT code
+1 ; Input: OLDDA = ifn of cpt in bill cpt multiple to be replaced
+2 ; NEWCPT = ifn of cpt code to be added
+3 NEW DA,DR,DIE,DIC,IBFND,X,Y
SET IBFND=0
SET DA(1)=+$GET(IBIFN)
SET DA=+$GET(OLDDA)
SET NEWCPT=+$GET(NEWCPT)
+4 IF NEWCPT
IF $DATA(^DGCR(399,DA(1),"CP",DA,0))
SET DIE="^DGCR(399,"_DA(1)_",""CP"","
SET DR=".01///`"_NEWCPT
DO ^DIE
SET IBFND=1
+5 QUIT IBFND
+6 ;
COPYCPT(IBIFN,OLDDA,NEWCPT) ; add a new CPT and populate date fields with data from an existing bill cpt
+1 ; Input: OLDDA = ifn of cpt in bill cpt multiple to be copied
+2 ; NEWCPT = ifn of cpt code to be added
+3 NEW DLAYGO,DIC,DIE,DA,DR,DD,DO,IBNEWDA,IBODA,IBNDA,IBXDA,IBSFILE,IBX,IBY,IBOLD,IBNEW,IBFND,X,Y
SET IBFND=0
+4 ;
+5 IF '$DATA(^DGCR(399,+$GET(IBIFN),"CP",+$GET(OLDDA),0))
GOTO COPYCPQ
+6 IF '$GET(NEWCPT)
GOTO COPYCPQ
+7 ;
+8 ; add new procedure entry to bill
+9 SET DLAYGO=399
SET DA(1)=IBIFN
SET DIC="^DGCR(399,"_DA(1)_",""CP"","
SET DIC(0)="L"
SET X=+NEWCPT_";ICPT("
KILL DD,DO
DO FILE^DICN
KILL DO,DD,DIC,DIE
+10 SET (DA,IBNEWDA,IBFND)=+Y
IF IBNEWDA<1
SET IBFND=0
GOTO COPYCPQ
+11 ;
+12 ; copy data from existing procedure to new procedure on bill
+13 SET IBODA=OLDDA_","_IBIFN_","
+14 SET IBNDA=IBNEWDA_","_IBIFN_","
+15 DO GETS^DIQ(399.0304,IBODA,"*","IN","IBOLD")
+16 SET IBSFILE=0
FOR
SET IBSFILE=$ORDER(IBOLD(IBSFILE))
if 'IBSFILE
QUIT
Begin DoDot:1
+17 SET IBXDA=""
FOR
SET IBXDA=$ORDER(IBOLD(IBSFILE,IBXDA))
if IBXDA=""
QUIT
Begin DoDot:2
+18 SET IBX=0
FOR
SET IBX=$ORDER(IBOLD(IBSFILE,IBXDA,IBX))
if 'IBX
QUIT
Begin DoDot:3
+19 IF IBXDA=IBODA
IF ",.01,2,3,4,7,14,20,"[(","_IBX_",")
QUIT
+20 SET IBNEW(IBSFILE,IBNDA,IBX)=IBOLD(IBSFILE,IBXDA,IBX,"I")
End DoDot:3
End DoDot:2
End DoDot:1
+21 IF $ORDER(IBNEW(0))
DO FILE^DIE("","IBNEW")
KILL DA,DR,DA,DO,DIE,DIC
+22 ;
+23 ; copy modifiers from existing procedure to new procedure on bill
+24 SET IBX=0
FOR
SET IBX=$ORDER(^DGCR(399,IBIFN,"CP",OLDDA,"MOD",IBX))
if 'IBX
QUIT
Begin DoDot:1
+25 SET IBY=$GET(^DGCR(399,IBIFN,"CP",OLDDA,"MOD",IBX,0))
if IBY=""
QUIT
+26 if '$DATA(^DGCR(399,IBIFN,"CP",IBNEWDA,"MOD"))
SET DIC("P")=$$GETSPEC^IBEFUNC(399.0304,16)
+27 SET DIC(0)="L"
SET DIC="^DGCR(399,"_IBIFN_",""CP"","_+IBNEWDA_",""MOD"","
SET DLAYGO=399.30416
+28 SET DA(2)=IBIFN
SET DA(1)=IBNEWDA
SET X=+IBY
SET DIC("DR")=".02////"_$PIECE(IBY,U,2)
DO FILE^DICN
KILL DIC,DO,DD
End DoDot:1
+29 ;
COPYCPQ QUIT IBFND
+1 ;
ADDCPT(IBIFN,SDLN) ; add a new CPT code to a bill and populate it's data based on clinical data
+1 ; Input: SDLN - data line from ^UTILITY($J,"CPT-CNT" created in VST^IBCCPT
+2 ; ^utility($j,cpt-cnt,count)=code^date^on bill^is BASC^divis^nb^nb mess^provider^clinic^mod,mod^Opt Enc Ptr
+3 NEW DLAYGO,DIC,DIE,DA,DR,DD,DO,DINUM,IBNEWDA,IBFND,X,Y
SET IBFND=0
+4 ;
+5 IF '$DATA(^DGCR(399,+$GET(IBIFN),0))
GOTO ADDCPTQ
+6 IF '$GET(SDLN)
GOTO ADDCPTQ
+7 IF +$PIECE(SDLN,U,6)
GOTO ADDCPTQ
+8 ;
+9 IF '$DATA(^DGCR(399,IBIFN,"CP"))
SET DIC("P")=$$GETSPEC^IBEFUNC(399,304)
+10 SET DLAYGO=399
SET DA(1)=IBIFN
SET DIC="^DGCR(399,"_DA(1)_",""CP"","
SET DIC(0)="L"
SET X=+SDLN_";ICPT("
KILL DD,DO
DO FILE^DICN
KILL DO,DD,DIC("P")
+11 SET (DA,IBNEWDA,IBFND)=+Y
IF IBNEWDA<1
SET IBFND=0
GOTO ADDCPTQ
+12 ;
+13 SET DR="1////"_$PIECE(SDLN,U,2)_$SELECT(+$PIECE(SDLN,U,8):";18////"_+$PIECE(SDLN,U,8),1:"")
+14 SET DR=DR_$SELECT(+$PIECE(SDLN,U,9):";6////"_+$PIECE(SDLN,U,9),1:"")_$SELECT(+$PIECE(SDLN,U,5):";5////"_+$PIECE(SDLN,U,5),1:"")
+15 SET DR=DR_$SELECT(+$PIECE(SDLN,U,11):";20////"_+$PIECE(SDLN,U,11),1:"")
+16 SET DIE=DIC
SET DA=+IBNEWDA
DO ^DIE
KILL DIE,DIC,DA,DINUM,DO,DD
+17 ;
+18 ;Modifiers
IF $PIECE(SDLN,U,10)
DO ADDMOD^IBCCPT(IBIFN,IBNEWDA,$PIECE(SDLN,U,10))
+19 ;
ADDCPTQ QUIT IBFND
+1 ;
GETSD(IBIFN) ; get the procedures from the clinical data covered by the bill
+1 ; Output: ^UTILITY($J,"CPT-CNT",X)= ... (from VST^IBCCPT)
+2 ; ^UTILITY($J,"CPT-CLN",CPT,EVDT)= ...
+3 NEW SDCNT,SDQDATA,SDQUERY,V,X,IBQUERY,IBOPV1,IBOPV2,DGCNT,DFN,IBX,IBY
KILL ^UTILITY($JOB)
+4 SET DFN=$PIECE($GET(^DGCR(399,+$GET(IBIFN),0)),U,2)
if 'DFN
QUIT
+5 DO VST^IBCCPT(.IBQUERY)
+6 SET IBX=0
FOR
SET IBX=$ORDER(^UTILITY($JOB,"CPT-CNT",IBX))
if 'IBX
QUIT
Begin DoDot:1
+7 SET IBY=^UTILITY($JOB,"CPT-CNT",IBX)
+8 SET ^UTILITY($JOB,"CPT-CLN",$PIECE(IBY,U,1),$PIECE(IBY,U,2))=IBY
End DoDot:1
+9 QUIT
