IBCCPT ;ALB/LDB - MCCR OUTPATIENT VISITS LISTING CONT. ;29 MAY 90
;;2.0;INTEGRATED BILLING;**55,62,52,91,106,125,51,148,174,182,245,266,260,339,432,592,742**;21-MAR-94;Build 36
;;Per VA Directive 6402, this routine should not be modified.
;
;MAP TO DGCRCPT
;
EN1(IBQUERY,IBHLP) ;
;JWS;IB*2.0*592;
N IBUSED
K DIR
EN D:$D(DIR) HLP W @IOF S DGU=0 K DGCPT,^UTILITY($J) D VST(.IBQUERY)
D CHDR,WRNO
N ICPTVDT S ICPTVDT=$$BDATE^IBACSV($G(IBIFN)) ; Code Text Version
S (DGCNT,DGCNT1)=0 F S DGCNT=$O(^UTILITY($J,"CPT-CNT",DGCNT)) Q:'DGCNT S DGNOD=^(DGCNT),DGCPT=+DGNOD,DGDAT=$P(DGNOD,"^",2),DGBIL=$P(DGNOD,"^",3),DGASC=$P(DGNOD,"^",4),DGDIV=$P(DGNOD,"^",5),DGCNT1=DGCNT1+1 D CPRT I DGU="^" S DGCNT=DGCNT-1 Q
I DGU'="^" F Y=$Y:1:IOSL-6 W !
OK1 K Y Q:'$D(^UTILITY($J,"CPT-CNT"))!($D(DIR))!($G(IBHLP))
OK S DIR(0)="LAO^1:"_DGCNT1_"^K:X[""."" X",DIR("?")="^N DIR D EN1^IBCCPT(.IBQUERY,1)",DIR("A")="SELECT CPT CODE(S) TO INCLUDE IN THIS BILL: "
D ^DIR K DIR I 'Y D Q1^IBCOPV1 Q
S IBFT=+$P(^DGCR(399,IBIFN,0),"^",19)
OK2 W !,"YOU HAVE SELECTED CPT CODE(S) NUMBERED-",$E(Y,1,$L(Y)-1),!,"IS THIS CORRECT" S %=1 D YN^DICN I %=-1 S IBOUT=1 D Q^IBCOPV1 Q
I +Y,'% W !,"Respond 'Y'es to include these codes in the bill.",!,"Respond 'N'o to reselect." G OK2
I +Y,%=2 G OK
;
FILE S DGCPT1=Y,(DGCNT,DGCNT2)=0
S DIE="^DGCR(399,",DA=IBIFN,DR=".09///5" D ^DIE K DR,DA,DIE
F I9=1:1 S I1=$P(DGCPT1,",",I9) Q:'I1 I $D(^UTILITY($J,"CPT-CNT",I1)) S DGNOD=^(I1),DGNOD("DX")=$G(^(I1,"DX")) D FILE1
D Q1^IBCOPV1 Q
;
FILE1 ; file procedures, if BASC, only for 1 visit date
;JWS;IB*2.0*592; additional Dental questions IOC issue - added NEW statement below
N IBTON,IBSURF,IBTSTAT,IBPSCDS,IBDENHD
N IBDICSAV ; IB*2.0*432 BI
K DGNOADD S (X,DINUM)=$P(DGNOD,"^",2) D VFILE1^IBCOPV1 K DINUM,X
N IBCPTNM S IBCPTNM=$$CPT^ICPTCOD(+DGNOD,+$P(DGNOD,U,2))
I $D(DGNOADD) W !?10,"Can't add Amb. Surg. ",$P(IBCPTNM,U,2)," without visit date!" Q ;don't add cpt for date that can't go on bill
I IBFT'=2,+$P(DGNOD,"^",4),$$TOMANY($P(DGNOD,"^",2)) W !?10,"Can't add Billable Amb. Surg. ",$P(IBCPTNM,U,2)," when more than one visit date!",*7 Q
D DSPPRC(IBCPTNM,DGNOD,$G(DGNOD("DX")))
;
S:'$D(^DGCR(399,IBIFN,"CP",0)) DIC("P")=$$GETSPEC^IBEFUNC(399,304)
; IB*2.0*432 BI
;S DLAYGO=399,DA(1)=IBIFN,DIC="^DGCR(399,"_DA(1)_",""CP"",",DIC(0)="L",X=+DGNOD_";ICPT(" K DD,DO D FILE^DICN S (DA,IBPROCP)=+Y K DO,DD,DLAYGO,DIC("P")
S DLAYGO=399,DA(1)=IBIFN,(DIC,IBDICSAV)="^DGCR(399,"_DA(1)_",""CP"",",DIC(0)="L",X=+DGNOD_";ICPT(" K DD,DO D FILE^DICN S (DA,IBPROCP)=+Y K DO,DD,DLAYGO,DIC("P")
S DR="1///"_$P(DGNOD,"^",2)
I +$P(DGNOD,"^",8) S DR=DR_";18///`"_+$P(DGNOD,"^",8)
I +$P(DGNOD,"^",9) S DR=DR_";6///`"_+$P(DGNOD,"^",9)
I +$P(DGNOD,"^",5) S DR=DR_";5////"_+$P(DGNOD,"^",5)
I +$P(DGNOD,"^",11) S DR=DR_";20////"_+$P(DGNOD,"^",11)
;
; file assoc dx if exists from pce
D:$G(DGNOD("DX")) ADDDX^IBCCPT1(IBIFN,IBPROCP,DGNOD("DX"),.DR)
;
S DIC=IBDICSAV ; IB*2.0*432 BI
S DIE=DIC D ^DIE
D:$P(DGNOD,U,10)'="" ADDMOD(IBIFN,IBPROCP,$P(DGNOD,U,10))
;
; (CPT MODIFIER SEQUENCE).
;K DR
;S DR="16"
;S DIC=IBDICSAV ; IB*2.0*432 BI
;S DIE=DIC D ^DIE ; DEM;432 - DR=16 (CPT MODIFIER SEQUENCE)
K DA
S DA(1)=IBIFN,DA=IBPROCP ;WCJ;IB*2.0*742;
D EN^IBCU7C(IBPROCP) ;WCJ;IB*2.0*742;
;
;JWS;IB*2.0*592; add Dental fields - IOC issue
I IBFT=7 D
. N IBDENH0,STOP,IBDENH,IBVST,IBPSC,IBPSC2,TARGET0
. ;JWS;IB*2.0*592;IOC additional fields
. S IBVST=$P(DGNOD,"^",15) ;DGNOD[15] = visit ien to ^AUPNVSIT to get dental data.
. ;IA# 2051, 6870, 6871
. ;S IBDENH=$$FIND1^DIC(228.1,,"QX",IBVST,"AV")
. D FIND^DIC(228.1,,"IX","QXP",IBVST,,"AV",,,"TARGET0")
. I +$G(TARGET0("DILIST",0)) S IBDENH0=0 F S IBDENH0=$O(TARGET0("DILIST",IBDENH0)) Q:'IBDENH0 D I $G(STOP) Q
.. S IBDENH=$P($G(TARGET0("DILIST",IBDENH0,0)),"^")
.. I IBDENH D
... N TARGET,TARGET1,IBDENHD0,IBPSCD0,IBPSCD S (IBDENHD0,STOP)=0
... ;IA# 2051, 6870, 6871
... D FIND^DIC(228.2,,"IX","QXP",IBDENH,,"AG",,,"TARGET")
... I +$G(TARGET("DILIST",0)) F S IBDENHD0=$O(TARGET("DILIST",IBDENHD0)) Q:'IBDENHD0 D I STOP Q
.... S IBDENHD=$P(TARGET("DILIST",IBDENHD0,0),"^")
.... ;IA# 2056, 6870, 6871
.... S IBPSC=$$GET1^DIQ(228.2,IBDENHD_",",.04)
.... ;;S IBPROV=$$GET1^DIQ(228.2,IBDENHD_",",.03,"I") ;provider linked to dental transaction
.... I IBPSC'=$$GET1^DIQ(81,$P(DGNOD,"^")_",",.01) Q
.... I $D(^DGCR(399,"ADT",IBDENHD)) Q
.... I $D(IBUSED("D",IBDENHD)) Q
.... S IBUSED("D",IBDENHD)=""
.... ;attempt to pull in the Not Otherwise Classified proc description from the Provider Narrative
.... ;IA# 2051
.... D FIND^DIC(9000010.18,,"IX","QXP",IBVST,,"AD",,,"TARGET1")
.... S IBPSCD0=0,IBPSCDS=""
.... ;IA# 2056
.... F S IBPSCD0=$O(TARGET1("DILIST",IBPSCD0)) Q:'IBPSCD0 S IBPSCD=$P(TARGET1("DILIST",IBPSCD0,0),"^") I $$GET1^DIQ(9000010.18,IBPSCD_",",.01)=IBPSC,'$D(IBUSED(IBPSCD)),$$CHECK(IBPSCD,DGNOD) D Q
..... S IBUSED(IBPSCD)="",IBPSCDS=$$GET1^DIQ(9000010.18,IBPSCD_",",.04,"E") Q
.... S IBPSC2=$$GET1^DIQ(399.0304,IBPROCP_","_IBIFN_",",.01,"I") I $$GET1^DIQ(81,$P(IBPSC2,";")_",",.01)'=IBPSC Q
.... S STOP=1
.... I '$$NOCPROC^IBCU7("^"_IBPSC2,IBPSC,IBDT) S IBPSCDS=""
.... ;IA# 2056, 6870, 6871
.... S IBTON=$$GET1^DIQ(228.2,IBDENHD_",",.15)
.... S IBSURF=$$GET1^DIQ(228.2,IBDENHD_",",.16)
.... S IBTSTAT=$$GET1^DIQ(228.2,IBDENHD_",",.09),IBTSTAT=$S(IBTSTAT="cndMissing":"M",1:"")
.... N I1 F I=1:1:5 S X=$E(IBSURF,I) Q:X="" I $F(",M,B,D,I,O,L,F,",","_X_",") S I1=$G(I1)+1,IBSURF(I1)=X
.... Q
... I '$G(STOP) S IBDENHD=""
... Q
.. Q
. I $G(IBPSC2)["ICPT",$$NOCPROC^IBCU7("^"_$G(IBPSC2),$G(IBPSC),$G(IBDT)) D
.. S DA=IBPROCP,DA(1)=IBIFN ; The line# on the bill/claim.
.. S DR="51//"_IBPSCDS ; Field# for PROCEDURE DESCRIPTION
.. D ^DIE
.. Q
. ;JWS;IB*2.0*592;end
K DR
S DR=""
Q:$D(^DGCR(399,DA(1),"CP",DA,"LNPRV","B","RENDERING")) ; DEM;432 - Quit if RENDERING PROVIDER already exist in 399.0404 for this procedure.
S IBLNPRV("IBCCPT")=$P($G(^VA(200,+$P(DGNOD,U,8),0)),U,1) ; DEM;432 - Flag for call to routine EN^IBCU7B.
D EN^IBCU7B ; DEM;432 - Call to line level provider user input.
K IBLNPRV("IBCCPT") ; DEM;432 - Kill flag after return from EN^IBCU7B.
S DA=IBPROCP ; DEM;432 - DA=IBPROCP before call to EN^IBCU7B.
K DR
;
I IBFT=3,'$$INPAT^IBCEF(IBIFN) D
. S DR=""
. D ATTACH^IBCU7
. K DR
;
S DR=""
I '$P(DGNOD,"^",8) S DR=$S(DR'="":DR_";18",1:18) ; DEM;432 - Added $SELECT since DR can equal field or NULL.
I '$P(DGNOD,"^",9) S DR=$S(DR'="":DR_";6",1:6) ; DEM;432 - Added $SELECT since DR can equal field or NULL.
I '$P(DGNOD,"^",5) S DR=$S(DR'="":DR_";5",1:5) ; DEM;432 - Added $SELECT since DR can equal field or NULL.
;
S:IBFT=2 DR=$S(DR'="":DR_";8;9;17//NO",1:"8;9;17//NO") ; DEM;432 - Added $SELECT since DR can equal field or NULL.
;JWS;IB*2.0*592;IOC change, prompt for POS, + dental fields.
I IBFT=7 S DR=$S(DR'="":DR_";6;5//"_$$DEFDIV^IBCU7(IBIFN)_";8;3",1:"6;5//"_$$DEFDIV^IBCU7(IBIFN)_";8;3")
S DIC=IBDICSAV ; IB*2.0*432 BI
I DR'="" S DIE=DIC D ^DIE ; DEM;432 - Added contion of DR'="".
S DR=$$SPCUNIT^IBCU7(IBIFN,IBPROCP) I DR'="" D ^DIE ; miles/minutes/hours
;
; DSS QuadraMed Interface: CPT Sequence and Diagnosis Linkage for Single CPT
I $$QMED^IBCU1("DX^VEJDIBE1",IBIFN) D DX^VEJDIBE1(IBIFN,IBPROCP)
;
Q:$D(Y)
;JWS;IB*2.0*592; IOC changes - prompt for diagnosis code links to procedure code
I IBFT=2!(IBFT=7) D DX^IBCU72(IBIFN,IBPROCP)
I IBFT=2 S X=$$ADDTNL^IBCU7(IBIFN,.DA)
;JWS;IB*2.0*592;IOC additional questions
I IBFT=7 D
. K DR S DR=""
. I $G(IBPSCDS)'="" S DR="51////"_IBPSCDS
. I DR'="" D ^DIE K DIE,DIC,DA,DINUM,DO,DD,DR
. ;JWS;IB*2.0*592;start;Add tooth # and surfaces to procedure line
. ;JWS;IB*2.0*592;allow for tooth # without surface
. I $G(IBTON)'="" K DA,DR,DIC,DLAYGO D
.. S DIC(0)="L",DIC="^DGCR(399,"_IBIFN_",""CP"","_IBPROCP_",""DEN1"",",DLAYGO=399.30491
.. S DA(2)=IBIFN,DA(1)=IBPROCP
.. S DIC("DR")=".01////"_IBTON_$S($D(IBSURF(1)):";.02////"_$G(IBSURF(1)),1:"")
.. S X=IBTON
.. I $D(IBSURF(2)) S DIC("DR")=DIC("DR")_";.03////"_IBSURF(2)
.. I $D(IBSURF(3)) S DIC("DR")=DIC("DR")_";.04////"_IBSURF(3)
.. I $D(IBSURF(4)) S DIC("DR")=DIC("DR")_";.05////"_IBSURF(4)
.. I $D(IBSURF(5)) S DIC("DR")=DIC("DR")_";.06////"_IBSURF(5)
.. I $G(IBDENHD) S DIC("DR")=DIC("DR")_";.07////"_IBDENHD
.. D FILE^DICN K DIC,DO,DD,DA,DR
.. Q
. I $G(IBTSTAT)'="",$G(IBTON) D
.. S DIC="^DGCR(399,"_IBIFN_",""DEN1"",",DIC(0)="L",DA(1)=IBIFN,X=IBTON,DLAYGO=399.096 K DD,DO D FILE^DICN K DO,DD,DLAYGO
.. S IBTNUM=+Y
.. S DR=".02////"_IBTSTAT
.. S DIE=DIC,DA=IBTNUM D ^DIE K DIE,DIC,DA,DINUM,DO,DD,DR
. ;JWS;IB*2.0*592;end
. S DA(1)=IBIFN,DA=IBPROCP,DIE="^DGCR(399,"_IBIFN_",""CP"","
. D ORAL^IBCU72 W !
L ^DGCR(399,IBIFN):1
K DIE,DIC,DR,DA,IBPROCP
Q
;
CPRT D:$Y+6>IOSL SCR Q:DGU="^"
N IBCPTNM,IBNBM,IBMODS,J,IBZ,IBDATE
S IBDATE=$$BDATE^IBACSV($G(IBIFN))
S IBNBM="",IBCPTNM=$$CPT^ICPTCOD(DGCPT,IBDATE) Q:IBCPTNM'>0
W !,DGCNT,")",?5,$P(IBCPTNM,U,2),?13,$E($P(IBCPTNM,U,3),1,24),?39,$E($P($G(^SC(+$P(DGNOD,U,9),0)),U,1),1,15),?56,$$FMTE^XLFDT(DGDAT,2)
I +DGBIL,+$P($G(DGNOD),U,6) S IBNBM=" *ON BILL/"_$E($P(DGNOD,U,7),1,4)_"*"
I IBNBM="",DGBIL S IBNBM=" *ON THIS BILL*"
I IBNBM="",+$P($G(DGNOD),U,6) S IBNBM=" "_$E($P(DGNOD,U,7),1,12)
W ?64,IBNBM
;
S IBMODS=$P($G(DGNOD),U,10) F J=1:1 S IBZ=$P(IBMODS,",",J) Q:IBZ="" S IBZ=$$MOD^ICPTMOD(IBZ,"I",IBDATE) W !,?13,$P(IBZ,U,2),?18,$P(IBZ,U,3)
Q
CHDR W @IOF,!,?15,"<<CURRENT PROCEDURAL TERMINOLOGY CODES>>",!!,?10,"LISTING FROM VISIT DATES WITH ASSOCIATED CPT CODES",!,?22,"IN OUTPT ENCOUNTERS FILE",!
K ^TMP("IBVIS",$J)
S L="",$P(L,"=",80)="" W !,L,!,"NO.",?5,"CODE",?13,"SHORT NAME",?39,"CLINIC",?56,"DATE",!,L,! K L
Q
ADDMOD(IBIFN,IBY,IBMOD) ; Add modifier(s) from PCE procedure to CPT code mult
N DIE,DR,DIC,DA,DO,DD,IBS,IBM
F IBS=1:1:$L(IBMOD,",") S DA(2)=IBIFN,DA(1)=IBY,X=$O(^DGCR(399,DA(2),"CP",DA(1),"MOD","B",""),-1)+1 S IBM=$P(IBMOD,",",IBS) I IBM'="" D
. S:'$D(^DGCR(399,DA(2),"CP",DA(1),"MOD")) DIC("P")=$$GETSPEC^IBEFUNC(399.0304,16)
. S DIC(0)="L",DIC="^DGCR(399,"_IBIFN_",""CP"","_IBY_",""MOD"",",DLAYGO=399.30416,DIC("DR")=".02////"_IBM
. D FILE^DICN K DIC,DO,DD
Q
;
DSPPRC(CPTNM,NOD,DX) ; display summary of procedure being added
N IBI,IBL,IBMODS,IBMOD,IBPRVTYP,IBPRV,IBDATE,IBP,IBDXT
I $G(CPTNM)=""!($G(NOD)="") Q
S IBMODS=$P(NOD,U,10),IBPRVTYP="",IBPRV=""
I +$P(NOD,U,8) S IBPRV=$P($G(^VA(200,+$P(NOD,U,8),0)),U,1),IBPRVTYP=$P($$PRVTYP^IBCRU6(+$P(NOD,U,8)),U,3) S IBL=$S(($L(IBPRVTYP)+$L(IBPRV))>32:"",1:" - ")
;
W !!?4,"Adding CPT Procedure: ",$P(CPTNM,U,2),?34,$P(CPTNM,U,3)
S IBDATE=$$BDATE^IBACSV($G(IBIFN))
I IBMODS'="" F IBI=1:1 S IBMOD=$P(IBMODS,",",IBI) Q:'IBMOD S IBMOD=$$MOD^ICPTMOD(IBMOD,"I",IBDATE) W !,?34,$P(IBMOD,U,2)," - ",$E($P(IBMOD,U,3),1,40)
W !,?34,"Visit: ",$$FMTE^XLFDT(+$P(NOD,U,2),2),", ",$E($P($G(^SC(+$P(NOD,U,9),0)),U,1),1,29)
I IBPRV'="" W !,?34,"Provider: ",$E(IBPRV,1,35) I IBPRVTYP'="" W:IBL="" !,?44 W IBL,IBPRVTYP
I DX F IBP=1:1 Q:'$P(DX,"^",IBP) S IBDXT=$$ICD9^IBACSV($P(DX,"^",IBP),+$P(NOD,U,2)) W !,?34,"Assoc Dx: ",$E($P(IBDXT,"^")_" "_$P(IBDXT,"^",3),1,35)
W !
Q
;
VST(IBQUERY) ;Procedures for outpatient visits ... If IBQUERY is defined
; on entry, the QUERY OBJECT defined by this value will be used for
; loop to extract procedures for visits, otherwise, a new QUERY will be opened
; If passed by reference, IBQUERY will be ret'd as the new QUERY ref #
S DGCNT=0 I $O(^DGCR(399,IBIFN,"OP",0)) F V=0:0 S V=$O(^DGCR(399,IBIFN,"OP",V)) Q:'V S (IBOPV1,IBOPV2)=V D PROC(.IBQUERY)
I $O(^DGCR(399,IBIFN,"OP",0)) K ^TMP("IBVIS",$J) G VSTQ
S IBOPV1=$P(^DGCR(399,IBIFN,"U"),"^"),IBOPV2=$P(^("U"),"^",2)
D PROC(.IBQUERY) K ^TMP("IBVIS",$J)
VSTQ Q
;
WRNO W:'$O(^UTILITY($J,"CPT-CNT",0)) !,"NO CPT CODES ON FILE FOR THE ",$S($O(^DGCR(399,IBIFN,"OP",0)):"VISIT DATES ON THIS BILL",1:"PERIOD THAT THIS STATEMENT COVERS")
Q
SCR Q:DGU="^" I $E(IOST,1,2)["C-",$Y+6>IOSL F Y=$Y:1:IOSL-5 W !
I R !,"Press return to continue or ""^"" to exit display ",DGU:DTIME D:DGU'="^" CHDR
Q
HLP W !!,"Enter a number between 1 and ",DGCNT1," or a range of numbers separated with commas",!,"or dashes, e.g., 1,3,5 or 2-4,8"
W !,"The number(s) must appear as a selectable number in the sequential list." R H:5 K H Q
CPT S DA(1)=IBIFN,IBCCPTZ=$P(^DGCR(399,DA(1),0),U,9),IBCCPTX=$S($D(^DGCR(399,DA(1),"C"))&IBCCPTZ:1,1:0)
K DIK,DGTE,I1 Q
;
PROC(IBQUERY) ; -find outpatient procedures, flag if billable
; - ^utility($j,cpt-cnt,count)=code^date^on bill^is BASC^divis^nb^nb mess^provider^clinic^mod,mod^Opt Enc Ptr
; - ^utility($j,cpt-cnt,count,"dx")=assoc dx(1)^assoc dx(2)^assoc dx(3)^assoc dx(4)
N IBVAL,IBCBK,IBFILTER
S IBVAL("DFN")=DFN,IBVAL("BDT")=IBOPV1,IBVAL("EDT")=(IBOPV2+.99)
; Must be a billable appt type and outpt enctr status of CHECKED OUT
S IBFILTER=""
S IBCBK="I '$P(Y0,U,6),$P(Y0,U,7),$$DSP^IBEFUNC($P(Y0,U,10),+Y0),'$D(^TMP(""IBVIS"",$J,+$P(Y0,U,5))) S ^TMP(""IBVIS"",$J,+$P(Y0,U,5))="""" D EXTPROC^IBCCPT(IBIFN,Y,Y0,.DGCNT)"
D SCAN^IBSDU("PATIENT/DATE",.IBVAL,IBFILTER,IBCBK,0,.IBQUERY) K ^TMP("DIERR",$J)
;
Q
EXTPROC(IBIFN,IBOE,IBOE0,IBCNT) ; Extract procedures for an encounter
; IBIFN = the ien of the bill
; IBOE0 = 0-node of the outpatient encounter file entry IBOE
; IBCNT extracted entry counter
N I2,I7,IBCPT,IBCPTS,IBDIV,IBOED,IBZERR,Z,IBCPTDAT,IBCPTPRV,IBCLINIC,IBZ,IBONBILL,IBMODS,IBARR,IBDT,DFN,IBEX,IBDX,IBOEDP
; make sure i have this variable
S:$G(IBOE0)="" IBOE0=$$SCE^IBSDU(+IBOE)
D GETCPT^SDOE(IBOE,"IBCPTS","IBZERR")
Q:'$O(IBCPTS(0)) ;No procedures for this encounter
I '$$BDSRC^IBEFUNC3($P($G(IBOE0),U,5)) Q ; non-billable visit data source
S IBOED=$$NBOE^IBCU81(IBOE,IBOE0)
S I7=IBOE0\1,IBDIV=$P(IBOE0,U,11)
S IBCLINIC="" I +$P(IBOE0,U,4),+$$CLNSCRN^IBCU(I7,+$P(IBOE0,U,4)) S IBCLINIC=+$P(IBOE0,U,4)
S I2=0 F S I2=$O(IBCPTS(I2)) Q:'I2 D
. S IBCPT=$P(IBCPTS(I2),U)
. S IBCPTPRV=$P($G(IBCPTS(I2,12)),U,4)
. S IBONBILL=0 S IBZ=0 F S IBZ=$O(^DGCR(399,IBIFN,"CP","B",IBCPT_";ICPT(",IBZ)) Q:'IBZ I $P($G(^DGCR(399,IBIFN,"CP",IBZ,0)),U,2)=I7 S IBONBILL=1
. S IBMODS="",IBZ=0 F S IBZ=$O(IBCPTS(I2,1,IBZ)) Q:'IBZ S IBMODS=IBMODS_$S(IBMODS="":"",1:",")_+$G(IBCPTS(I2,1,IBZ,0))
. ;
. ; look up of a procedure is non-billable and get assoc dx
. S IBOEDP=IBOED I IBOEDP="" S IBOEDP=$$NBOEP^IBCCPT1(IBOE0,IBCPT,.IBDX) I IBOEDP'="" S IBOEDP=4_U_IBOEDP
. S IBCPTDAT=IBCPT_U_I7_U_IBONBILL_U_0_U_IBDIV_U_$P(IBOEDP,U,1)_U_$P(IBOEDP,U,2)_U_IBCPTPRV_U_IBCLINIC_U_IBMODS_U_IBOE
. ;JWS;IB*2.0*592; IOC additional fields
. S $P(IBCPTDAT,U,15)=$P(IBOE0,U,5)
. F Z=1:1:$P(IBCPTS(I2),U,16) S IBCNT=IBCNT+1,^UTILITY($J,"CPT-CNT",IBCNT)=IBCPTDAT,^UTILITY($J,"CPT-CNT",IBCNT,"DX")=$G(IBDX)
. K IBDX
I $O(IBARR("CPT",0)),'$D(^UTILITY($J,"CPT",+IBOE0,0)) S ^(0)="Y"
Q
;
TOMANY(DATE) ; - returns 1 if more than 1 visit date on bill (for basc)
G TOMANYQ:'$D(DATE)
S DGVCNT=+$P($G(^DGCR(399,IBIFN,"OP",0)),"^",4)
I DGVCNT>1!(DGVCNT=1&('$D(^DGCR(399,IBIFN,"OP",DATE)))) K DGVCNT Q 1
TOMANYQ Q 0
;
CHECK(IBPSCD,DGNOD) ;
S RET=1
I $$GET1^DIQ(9000010.18,IBPSCD_",",1204,"I")'=$P(DGNOD,"^",8) S RET=0
Q RET
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCCPT 15376 printed Sep 02, 2024@18:54:22 Page 2
IBCCPT ;ALB/LDB - MCCR OUTPATIENT VISITS LISTING CONT. ;29 MAY 90
+1 ;;2.0;INTEGRATED BILLING;**55,62,52,91,106,125,51,148,174,182,245,266,260,339,432,592,742**;21-MAR-94;Build 36
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;MAP TO DGCRCPT
+5 ;
EN1(IBQUERY,IBHLP) ;
+1 ;JWS;IB*2.0*592;
+2 NEW IBUSED
+3 KILL DIR
EN if $DATA(DIR)
DO HLP
WRITE @IOF
SET DGU=0
KILL DGCPT,^UTILITY($JOB)
DO VST(.IBQUERY)
+1 DO CHDR
DO WRNO
+2 ; Code Text Version
NEW ICPTVDT
SET ICPTVDT=$$BDATE^IBACSV($GET(IBIFN))
+3 SET (DGCNT,DGCNT1)=0
FOR
SET DGCNT=$ORDER(^UTILITY($JOB,"CPT-CNT",DGCNT))
if 'DGCNT
QUIT
SET DGNOD=^(DGCNT)
SET DGCPT=+DGNOD
SET DGDAT=$PIECE(DGNOD,"^",2)
SET DGBIL=$PIECE(DGNOD,"^",3)
SET DGASC=$PIECE(DGNOD,"^",4)
SET DGDIV=$PIECE(DGNOD,"^",5)
SET DGCNT1=DGCNT1+1
DO CPRT
IF DGU="^"
SET DGCNT=DGCNT-1
QUIT
+4 IF DGU'="^"
FOR Y=$Y:1:IOSL-6
WRITE !
OK1 KILL Y
if '$DATA(^UTILITY($JOB,"CPT-CNT"))!($DATA(DIR))!($GET(IBHLP))
QUIT
OK SET DIR(0)="LAO^1:"_DGCNT1_"^K:X[""."" X"
SET DIR("?")="^N DIR D EN1^IBCCPT(.IBQUERY,1)"
SET DIR("A")="SELECT CPT CODE(S) TO INCLUDE IN THIS BILL: "
+1 DO ^DIR
KILL DIR
IF 'Y
DO Q1^IBCOPV1
QUIT
+2 SET IBFT=+$PIECE(^DGCR(399,IBIFN,0),"^",19)
OK2 WRITE !,"YOU HAVE SELECTED CPT CODE(S) NUMBERED-",$EXTRACT(Y,1,$LENGTH(Y)-1),!,"IS THIS CORRECT"
SET %=1
DO YN^DICN
IF %=-1
SET IBOUT=1
DO Q^IBCOPV1
QUIT
+1 IF +Y
IF '%
WRITE !,"Respond 'Y'es to include these codes in the bill.",!,"Respond 'N'o to reselect."
GOTO OK2
+2 IF +Y
IF %=2
GOTO OK
+3 ;
FILE SET DGCPT1=Y
SET (DGCNT,DGCNT2)=0
+1 SET DIE="^DGCR(399,"
SET DA=IBIFN
SET DR=".09///5"
DO ^DIE
KILL DR,DA,DIE
+2 FOR I9=1:1
SET I1=$PIECE(DGCPT1,",",I9)
if 'I1
QUIT
IF $DATA(^UTILITY($JOB,"CPT-CNT",I1))
SET DGNOD=^(I1)
SET DGNOD("DX")=$GET(^(I1,"DX"))
DO FILE1
+3 DO Q1^IBCOPV1
QUIT
+4 ;
FILE1 ; file procedures, if BASC, only for 1 visit date
+1 ;JWS;IB*2.0*592; additional Dental questions IOC issue - added NEW statement below
+2 NEW IBTON,IBSURF,IBTSTAT,IBPSCDS,IBDENHD
+3 ; IB*2.0*432 BI
NEW IBDICSAV
+4 KILL DGNOADD
SET (X,DINUM)=$PIECE(DGNOD,"^",2)
DO VFILE1^IBCOPV1
KILL DINUM,X
+5 NEW IBCPTNM
SET IBCPTNM=$$CPT^ICPTCOD(+DGNOD,+$PIECE(DGNOD,U,2))
+6 ;don't add cpt for date that can't go on bill
IF $DATA(DGNOADD)
WRITE !?10,"Can't add Amb. Surg. ",$PIECE(IBCPTNM,U,2)," without visit date!"
QUIT
+7 IF IBFT'=2
IF +$PIECE(DGNOD,"^",4)
IF $$TOMANY($PIECE(DGNOD,"^",2))
WRITE !?10,"Can't add Billable Amb. Surg. ",$PIECE(IBCPTNM,U,2)," when more than one visit date!",*7
QUIT
+8 DO DSPPRC(IBCPTNM,DGNOD,$GET(DGNOD("DX")))
+9 ;
+10 if '$DATA(^DGCR(399,IBIFN,"CP",0))
SET DIC("P")=$$GETSPEC^IBEFUNC(399,304)
+11 ; IB*2.0*432 BI
+12 ;S DLAYGO=399,DA(1)=IBIFN,DIC="^DGCR(399,"_DA(1)_",""CP"",",DIC(0)="L",X=+DGNOD_";ICPT(" K DD,DO D FILE^DICN S (DA,IBPROCP)=+Y K DO,DD,DLAYGO,DIC("P")
+13 SET DLAYGO=399
SET DA(1)=IBIFN
SET (DIC,IBDICSAV)="^DGCR(399,"_DA(1)_",""CP"","
SET DIC(0)="L"
SET X=+DGNOD_";ICPT("
KILL DD,DO
DO FILE^DICN
SET (DA,IBPROCP)=+Y
KILL DO,DD,DLAYGO,DIC("P")
+14 SET DR="1///"_$PIECE(DGNOD,"^",2)
+15 IF +$PIECE(DGNOD,"^",8)
SET DR=DR_";18///`"_+$PIECE(DGNOD,"^",8)
+16 IF +$PIECE(DGNOD,"^",9)
SET DR=DR_";6///`"_+$PIECE(DGNOD,"^",9)
+17 IF +$PIECE(DGNOD,"^",5)
SET DR=DR_";5////"_+$PIECE(DGNOD,"^",5)
+18 IF +$PIECE(DGNOD,"^",11)
SET DR=DR_";20////"_+$PIECE(DGNOD,"^",11)
+19 ;
+20 ; file assoc dx if exists from pce
+21 if $GET(DGNOD("DX"))
DO ADDDX^IBCCPT1(IBIFN,IBPROCP,DGNOD("DX"),.DR)
+22 ;
+23 ; IB*2.0*432 BI
SET DIC=IBDICSAV
+24 SET DIE=DIC
DO ^DIE
+25 if $PIECE(DGNOD,U,10)'=""
DO ADDMOD(IBIFN,IBPROCP,$PIECE(DGNOD,U,10))
+26 ;
+27 ; (CPT MODIFIER SEQUENCE).
+28 ;K DR
+29 ;S DR="16"
+30 ;S DIC=IBDICSAV ; IB*2.0*432 BI
+31 ;S DIE=DIC D ^DIE ; DEM;432 - DR=16 (CPT MODIFIER SEQUENCE)
+32 KILL DA
+33 ;WCJ;IB*2.0*742;
SET DA(1)=IBIFN
SET DA=IBPROCP
+34 ;WCJ;IB*2.0*742;
DO EN^IBCU7C(IBPROCP)
+35 ;
+36 ;JWS;IB*2.0*592; add Dental fields - IOC issue
+37 IF IBFT=7
Begin DoDot:1
+38 NEW IBDENH0,STOP,IBDENH,IBVST,IBPSC,IBPSC2,TARGET0
+39 ;JWS;IB*2.0*592;IOC additional fields
+40 ;DGNOD[15] = visit ien to ^AUPNVSIT to get dental data.
SET IBVST=$PIECE(DGNOD,"^",15)
+41 ;IA# 2051, 6870, 6871
+42 ;S IBDENH=$$FIND1^DIC(228.1,,"QX",IBVST,"AV")
+43 DO FIND^DIC(228.1,,"IX","QXP",IBVST,,"AV",,,"TARGET0")
+44 IF +$GET(TARGET0("DILIST",0))
SET IBDENH0=0
FOR
SET IBDENH0=$ORDER(TARGET0("DILIST",IBDENH0))
if 'IBDENH0
QUIT
Begin DoDot:2
+45 SET IBDENH=$PIECE($GET(TARGET0("DILIST",IBDENH0,0)),"^")
+46 IF IBDENH
Begin DoDot:3
+47 NEW TARGET,TARGET1,IBDENHD0,IBPSCD0,IBPSCD
SET (IBDENHD0,STOP)=0
+48 ;IA# 2051, 6870, 6871
+49 DO FIND^DIC(228.2,,"IX","QXP",IBDENH,,"AG",,,"TARGET")
+50 IF +$GET(TARGET("DILIST",0))
FOR
SET IBDENHD0=$ORDER(TARGET("DILIST",IBDENHD0))
if 'IBDENHD0
QUIT
Begin DoDot:4
+51 SET IBDENHD=$PIECE(TARGET("DILIST",IBDENHD0,0),"^")
+52 ;IA# 2056, 6870, 6871
+53 SET IBPSC=$$GET1^DIQ(228.2,IBDENHD_",",.04)
+54 ;;S IBPROV=$$GET1^DIQ(228.2,IBDENHD_",",.03,"I") ;provider linked to dental transaction
+55 IF IBPSC'=$$GET1^DIQ(81,$PIECE(DGNOD,"^")_",",.01)
QUIT
+56 IF $DATA(^DGCR(399,"ADT",IBDENHD))
QUIT
+57 IF $DATA(IBUSED("D",IBDENHD))
QUIT
+58 SET IBUSED("D",IBDENHD)=""
+59 ;attempt to pull in the Not Otherwise Classified proc description from the Provider Narrative
+60 ;IA# 2051
+61 DO FIND^DIC(9000010.18,,"IX","QXP",IBVST,,"AD",,,"TARGET1")
+62 SET IBPSCD0=0
SET IBPSCDS=""
+63 ;IA# 2056
+64 FOR
SET IBPSCD0=$ORDER(TARGET1("DILIST",IBPSCD0))
if 'IBPSCD0
QUIT
SET IBPSCD=$PIECE(TARGET1("DILIST",IBPSCD0,0),"^")
IF $$GET1^DIQ(9000010.18,IBPSCD_",",.01)=IBPSC
IF '$DATA(IBUSED(IBPSCD))
IF $$CHECK(IBPSCD,DGNOD)
Begin DoDot:5
+65 SET IBUSED(IBPSCD)=""
SET IBPSCDS=$$GET1^DIQ(9000010.18,IBPSCD_",",.04,"E")
QUIT
End DoDot:5
QUIT
+66 SET IBPSC2=$$GET1^DIQ(399.0304,IBPROCP_","_IBIFN_",",.01,"I")
IF $$GET1^DIQ(81,$PIECE(IBPSC2,";")_",",.01)'=IBPSC
QUIT
+67 SET STOP=1
+68 IF '$$NOCPROC^IBCU7("^"_IBPSC2,IBPSC,IBDT)
SET IBPSCDS=""
+69 ;IA# 2056, 6870, 6871
+70 SET IBTON=$$GET1^DIQ(228.2,IBDENHD_",",.15)
+71 SET IBSURF=$$GET1^DIQ(228.2,IBDENHD_",",.16)
+72 SET IBTSTAT=$$GET1^DIQ(228.2,IBDENHD_",",.09)
SET IBTSTAT=$SELECT(IBTSTAT="cndMissing":"M",1:"")
+73 NEW I1
FOR I=1:1:5
SET X=$EXTRACT(IBSURF,I)
if X=""
QUIT
IF $FIND(",M,B,D,I,O,L,F,",","_X_",")
SET I1=$GET(I1)+1
SET IBSURF(I1)=X
+74 QUIT
End DoDot:4
IF STOP
QUIT
+75 IF '$GET(STOP)
SET IBDENHD=""
+76 QUIT
End DoDot:3
+77 QUIT
End DoDot:2
IF $GET(STOP)
QUIT
+78 IF $GET(IBPSC2)["ICPT"
IF $$NOCPROC^IBCU7("^"_$GET(IBPSC2),$GET(IBPSC),$GET(IBDT))
Begin DoDot:2
+79 ; The line# on the bill/claim.
SET DA=IBPROCP
SET DA(1)=IBIFN
+80 ; Field# for PROCEDURE DESCRIPTION
SET DR="51//"_IBPSCDS
+81 DO ^DIE
+82 QUIT
End DoDot:2
+83 ;JWS;IB*2.0*592;end
End DoDot:1
+84 KILL DR
+85 SET DR=""
+86 ; DEM;432 - Quit if RENDERING PROVIDER already exist in 399.0404 for this procedure.
if $DATA(^DGCR(399,DA(1),"CP",DA,"LNPRV","B","RENDERING"))
QUIT
+87 ; DEM;432 - Flag for call to routine EN^IBCU7B.
SET IBLNPRV("IBCCPT")=$PIECE($GET(^VA(200,+$PIECE(DGNOD,U,8),0)),U,1)
+88 ; DEM;432 - Call to line level provider user input.
DO EN^IBCU7B
+89 ; DEM;432 - Kill flag after return from EN^IBCU7B.
KILL IBLNPRV("IBCCPT")
+90 ; DEM;432 - DA=IBPROCP before call to EN^IBCU7B.
SET DA=IBPROCP
+91 KILL DR
+92 ;
+93 IF IBFT=3
IF '$$INPAT^IBCEF(IBIFN)
Begin DoDot:1
+94 SET DR=""
+95 DO ATTACH^IBCU7
+96 KILL DR
End DoDot:1
+97 ;
+98 SET DR=""
+99 ; DEM;432 - Added $SELECT since DR can equal field or NULL.
IF '$PIECE(DGNOD,"^",8)
SET DR=$SELECT(DR'="":DR_";18",1:18)
+100 ; DEM;432 - Added $SELECT since DR can equal field or NULL.
IF '$PIECE(DGNOD,"^",9)
SET DR=$SELECT(DR'="":DR_";6",1:6)
+101 ; DEM;432 - Added $SELECT since DR can equal field or NULL.
IF '$PIECE(DGNOD,"^",5)
SET DR=$SELECT(DR'="":DR_";5",1:5)
+102 ;
+103 ; DEM;432 - Added $SELECT since DR can equal field or NULL.
if IBFT=2
SET DR=$SELECT(DR'="":DR_";8;9;17//NO",1:"8;9;17//NO")
+104 ;JWS;IB*2.0*592;IOC change, prompt for POS, + dental fields.
+105 IF IBFT=7
SET DR=$SELECT(DR'="":DR_";6;5//"_$$DEFDIV^IBCU7(IBIFN)_";8;3",1:"6;5//"_$$DEFDIV^IBCU7(IBIFN)_";8;3")
+106 ; IB*2.0*432 BI
SET DIC=IBDICSAV
+107 ; DEM;432 - Added contion of DR'="".
IF DR'=""
SET DIE=DIC
DO ^DIE
+108 ; miles/minutes/hours
SET DR=$$SPCUNIT^IBCU7(IBIFN,IBPROCP)
IF DR'=""
DO ^DIE
+109 ;
+110 ; DSS QuadraMed Interface: CPT Sequence and Diagnosis Linkage for Single CPT
+111 IF $$QMED^IBCU1("DX^VEJDIBE1",IBIFN)
DO DX^VEJDIBE1(IBIFN,IBPROCP)
+112 ;
+113 if $DATA(Y)
QUIT
+114 ;JWS;IB*2.0*592; IOC changes - prompt for diagnosis code links to procedure code
+115 IF IBFT=2!(IBFT=7)
DO DX^IBCU72(IBIFN,IBPROCP)
+116 IF IBFT=2
SET X=$$ADDTNL^IBCU7(IBIFN,.DA)
+117 ;JWS;IB*2.0*592;IOC additional questions
+118 IF IBFT=7
Begin DoDot:1
+119 KILL DR
SET DR=""
+120 IF $GET(IBPSCDS)'=""
SET DR="51////"_IBPSCDS
+121 IF DR'=""
DO ^DIE
KILL DIE,DIC,DA,DINUM,DO,DD,DR
+122 ;JWS;IB*2.0*592;start;Add tooth # and surfaces to procedure line
+123 ;JWS;IB*2.0*592;allow for tooth # without surface
+124 IF $GET(IBTON)'=""
KILL DA,DR,DIC,DLAYGO
Begin DoDot:2
+125 SET DIC(0)="L"
SET DIC="^DGCR(399,"_IBIFN_",""CP"","_IBPROCP_",""DEN1"","
SET DLAYGO=399.30491
+126 SET DA(2)=IBIFN
SET DA(1)=IBPROCP
+127 SET DIC("DR")=".01////"_IBTON_$SELECT($DATA(IBSURF(1)):";.02////"_$GET(IBSURF(1)),1:"")
+128 SET X=IBTON
+129 IF $DATA(IBSURF(2))
SET DIC("DR")=DIC("DR")_";.03////"_IBSURF(2)
+130 IF $DATA(IBSURF(3))
SET DIC("DR")=DIC("DR")_";.04////"_IBSURF(3)
+131 IF $DATA(IBSURF(4))
SET DIC("DR")=DIC("DR")_";.05////"_IBSURF(4)
+132 IF $DATA(IBSURF(5))
SET DIC("DR")=DIC("DR")_";.06////"_IBSURF(5)
+133 IF $GET(IBDENHD)
SET DIC("DR")=DIC("DR")_";.07////"_IBDENHD
+134 DO FILE^DICN
KILL DIC,DO,DD,DA,DR
+135 QUIT
End DoDot:2
+136 IF $GET(IBTSTAT)'=""
IF $GET(IBTON)
Begin DoDot:2
+137 SET DIC="^DGCR(399,"_IBIFN_",""DEN1"","
SET DIC(0)="L"
SET DA(1)=IBIFN
SET X=IBTON
SET DLAYGO=399.096
KILL DD,DO
DO FILE^DICN
KILL DO,DD,DLAYGO
+138 SET IBTNUM=+Y
+139 SET DR=".02////"_IBTSTAT
+140 SET DIE=DIC
SET DA=IBTNUM
DO ^DIE
KILL DIE,DIC,DA,DINUM,DO,DD,DR
End DoDot:2
+141 ;JWS;IB*2.0*592;end
+142 SET DA(1)=IBIFN
SET DA=IBPROCP
SET DIE="^DGCR(399,"_IBIFN_",""CP"","
+143 DO ORAL^IBCU72
WRITE !
End DoDot:1
+144 LOCK ^DGCR(399,IBIFN):1
+145 KILL DIE,DIC,DR,DA,IBPROCP
+146 QUIT
+147 ;
CPRT if $Y+6>IOSL
DO SCR
if DGU="^"
QUIT
+1 NEW IBCPTNM,IBNBM,IBMODS,J,IBZ,IBDATE
+2 SET IBDATE=$$BDATE^IBACSV($GET(IBIFN))
+3 SET IBNBM=""
SET IBCPTNM=$$CPT^ICPTCOD(DGCPT,IBDATE)
if IBCPTNM'>0
QUIT
+4 WRITE !,DGCNT,")",?5,$PIECE(IBCPTNM,U,2),?13,$EXTRACT($PIECE(IBCPTNM,U,3),1,24),?39,$EXTRACT($PIECE($GET(^SC(+$PIECE(DGNOD,U,9),0)),U,1),1,15),?56,$$FMTE^XLFDT(DGDAT,2)
+5 IF +DGBIL
IF +$PIECE($GET(DGNOD),U,6)
SET IBNBM=" *ON BILL/"_$EXTRACT($PIECE(DGNOD,U,7),1,4)_"*"
+6 IF IBNBM=""
IF DGBIL
SET IBNBM=" *ON THIS BILL*"
+7 IF IBNBM=""
IF +$PIECE($GET(DGNOD),U,6)
SET IBNBM=" "_$EXTRACT($PIECE(DGNOD,U,7),1,12)
+8 WRITE ?64,IBNBM
+9 ;
+10 SET IBMODS=$PIECE($GET(DGNOD),U,10)
FOR J=1:1
SET IBZ=$PIECE(IBMODS,",",J)
if IBZ=""
QUIT
SET IBZ=$$MOD^ICPTMOD(IBZ,"I",IBDATE)
WRITE !,?13,$PIECE(IBZ,U,2),?18,$PIECE(IBZ,U,3)
+11 QUIT
CHDR WRITE @IOF,!,?15,"<<CURRENT PROCEDURAL TERMINOLOGY CODES>>",!!,?10,"LISTING FROM VISIT DATES WITH ASSOCIATED CPT CODES",!,?22,"IN OUTPT ENCOUNTERS FILE",!
+1 KILL ^TMP("IBVIS",$JOB)
+2 SET L=""
SET $PIECE(L,"=",80)=""
WRITE !,L,!,"NO.",?5,"CODE",?13,"SHORT NAME",?39,"CLINIC",?56,"DATE",!,L,!
KILL L
+3 QUIT
ADDMOD(IBIFN,IBY,IBMOD) ; Add modifier(s) from PCE procedure to CPT code mult
+1 NEW DIE,DR,DIC,DA,DO,DD,IBS,IBM
+2 FOR IBS=1:1:$LENGTH(IBMOD,",")
SET DA(2)=IBIFN
SET DA(1)=IBY
SET X=$ORDER(^DGCR(399,DA(2),"CP",DA(1),"MOD","B",""),-1)+1
SET IBM=$PIECE(IBMOD,",",IBS)
IF IBM'=""
Begin DoDot:1
+3 if '$DATA(^DGCR(399,DA(2),"CP",DA(1),"MOD"))
SET DIC("P")=$$GETSPEC^IBEFUNC(399.0304,16)
+4 SET DIC(0)="L"
SET DIC="^DGCR(399,"_IBIFN_",""CP"","_IBY_",""MOD"","
SET DLAYGO=399.30416
SET DIC("DR")=".02////"_IBM
+5 DO FILE^DICN
KILL DIC,DO,DD
End DoDot:1
+6 QUIT
+7 ;
DSPPRC(CPTNM,NOD,DX) ; display summary of procedure being added
+1 NEW IBI,IBL,IBMODS,IBMOD,IBPRVTYP,IBPRV,IBDATE,IBP,IBDXT
+2 IF $GET(CPTNM)=""!($GET(NOD)="")
QUIT
+3 SET IBMODS=$PIECE(NOD,U,10)
SET IBPRVTYP=""
SET IBPRV=""
+4 IF +$PIECE(NOD,U,8)
SET IBPRV=$PIECE($GET(^VA(200,+$PIECE(NOD,U,8),0)),U,1)
SET IBPRVTYP=$PIECE($$PRVTYP^IBCRU6(+$PIECE(NOD,U,8)),U,3)
SET IBL=$SELECT(($LENGTH(IBPRVTYP)+$LENGTH(IBPRV))>32:"",1:" - ")
+5 ;
+6 WRITE !!?4,"Adding CPT Procedure: ",$PIECE(CPTNM,U,2),?34,$PIECE(CPTNM,U,3)
+7 SET IBDATE=$$BDATE^IBACSV($GET(IBIFN))
+8 IF IBMODS'=""
FOR IBI=1:1
SET IBMOD=$PIECE(IBMODS,",",IBI)
if 'IBMOD
QUIT
SET IBMOD=$$MOD^ICPTMOD(IBMOD,"I",IBDATE)
WRITE !,?34,$PIECE(IBMOD,U,2)," - ",$EXTRACT($PIECE(IBMOD,U,3),1,40)
+9 WRITE !,?34,"Visit: ",$$FMTE^XLFDT(+$PIECE(NOD,U,2),2),", ",$EXTRACT($PIECE($GET(^SC(+$PIECE(NOD,U,9),0)),U,1),1,29)
+10 IF IBPRV'=""
WRITE !,?34,"Provider: ",$EXTRACT(IBPRV,1,35)
IF IBPRVTYP'=""
if IBL=""
WRITE !,?44
WRITE IBL,IBPRVTYP
+11 IF DX
FOR IBP=1:1
if '$PIECE(DX,"^",IBP)
QUIT
SET IBDXT=$$ICD9^IBACSV($PIECE(DX,"^",IBP),+$PIECE(NOD,U,2))
WRITE !,?34,"Assoc Dx: ",$EXTRACT($PIECE(IBDXT,"^")_" "_$PIECE(IBDXT,"^",3),1,35)
+12 WRITE !
+13 QUIT
+14 ;
VST(IBQUERY) ;Procedures for outpatient visits ... If IBQUERY is defined
+1 ; on entry, the QUERY OBJECT defined by this value will be used for
+2 ; loop to extract procedures for visits, otherwise, a new QUERY will be opened
+3 ; If passed by reference, IBQUERY will be ret'd as the new QUERY ref #
+4 SET DGCNT=0
IF $ORDER(^DGCR(399,IBIFN,"OP",0))
FOR V=0:0
SET V=$ORDER(^DGCR(399,IBIFN,"OP",V))
if 'V
QUIT
SET (IBOPV1,IBOPV2)=V
DO PROC(.IBQUERY)
+5 IF $ORDER(^DGCR(399,IBIFN,"OP",0))
KILL ^TMP("IBVIS",$JOB)
GOTO VSTQ
+6 SET IBOPV1=$PIECE(^DGCR(399,IBIFN,"U"),"^")
SET IBOPV2=$PIECE(^("U"),"^",2)
+7 DO PROC(.IBQUERY)
KILL ^TMP("IBVIS",$JOB)
VSTQ QUIT
+1 ;
WRNO if '$ORDER(^UTILITY($JOB,"CPT-CNT",0))
WRITE !,"NO CPT CODES ON FILE FOR THE ",$SELECT($ORDER(^DGCR(399,IBIFN,"OP",0)):"VISIT DATES ON THIS BILL",1:"PERIOD THAT THIS STATEMENT COVERS")
+1 QUIT
SCR if DGU="^"
QUIT
IF $EXTRACT(IOST,1,2)["C-"
IF $Y+6>IOSL
FOR Y=$Y:1:IOSL-5
WRITE !
+1 IF $TEST
READ !,"Press return to continue or ""^"" to exit display ",DGU:DTIME
if DGU'="^"
DO CHDR
+2 QUIT
HLP WRITE !!,"Enter a number between 1 and ",DGCNT1," or a range of numbers separated with commas",!,"or dashes, e.g., 1,3,5 or 2-4,8"
+1 WRITE !,"The number(s) must appear as a selectable number in the sequential list."
READ H:5
KILL H
QUIT
CPT SET DA(1)=IBIFN
SET IBCCPTZ=$PIECE(^DGCR(399,DA(1),0),U,9)
SET IBCCPTX=$SELECT($DATA(^DGCR(399,DA(1),"C"))&IBCCPTZ:1,1:0)
+1 KILL DIK,DGTE,I1
QUIT
+2 ;
PROC(IBQUERY) ; -find outpatient procedures, flag if billable
+1 ; - ^utility($j,cpt-cnt,count)=code^date^on bill^is BASC^divis^nb^nb mess^provider^clinic^mod,mod^Opt Enc Ptr
+2 ; - ^utility($j,cpt-cnt,count,"dx")=assoc dx(1)^assoc dx(2)^assoc dx(3)^assoc dx(4)
+3 NEW IBVAL,IBCBK,IBFILTER
+4 SET IBVAL("DFN")=DFN
SET IBVAL("BDT")=IBOPV1
SET IBVAL("EDT")=(IBOPV2+.99)
+5 ; Must be a billable appt type and outpt enctr status of CHECKED OUT
+6 SET IBFILTER=""
+7 SET IBCBK="I '$P(Y0,U,6),$P(Y0,U,7),$$DSP^IBEFUNC($P(Y0,U,10),+Y0),'$D(^TMP(""IBVIS"",$J,+$P(Y0,U,5))) S ^TMP(""IBVIS"",$J,+$P(Y0,U,5))="""" D EXTPROC^IBCCPT(IBIFN,Y,Y0,.DGCNT)"
+8 DO SCAN^IBSDU("PATIENT/DATE",.IBVAL,IBFILTER,IBCBK,0,.IBQUERY)
KILL ^TMP("DIERR",$JOB)
+9 ;
+10 QUIT
EXTPROC(IBIFN,IBOE,IBOE0,IBCNT) ; Extract procedures for an encounter
+1 ; IBIFN = the ien of the bill
+2 ; IBOE0 = 0-node of the outpatient encounter file entry IBOE
+3 ; IBCNT extracted entry counter
+4 NEW I2,I7,IBCPT,IBCPTS,IBDIV,IBOED,IBZERR,Z,IBCPTDAT,IBCPTPRV,IBCLINIC,IBZ,IBONBILL,IBMODS,IBARR,IBDT,DFN,IBEX,IBDX,IBOEDP
+5 ; make sure i have this variable
+6 if $GET(IBOE0)=""
SET IBOE0=$$SCE^IBSDU(+IBOE)
+7 DO GETCPT^SDOE(IBOE,"IBCPTS","IBZERR")
+8 ;No procedures for this encounter
if '$ORDER(IBCPTS(0))
QUIT
+9 ; non-billable visit data source
IF '$$BDSRC^IBEFUNC3($PIECE($GET(IBOE0),U,5))
QUIT
+10 SET IBOED=$$NBOE^IBCU81(IBOE,IBOE0)
+11 SET I7=IBOE0\1
SET IBDIV=$PIECE(IBOE0,U,11)
+12 SET IBCLINIC=""
IF +$PIECE(IBOE0,U,4)
IF +$$CLNSCRN^IBCU(I7,+$PIECE(IBOE0,U,4))
SET IBCLINIC=+$PIECE(IBOE0,U,4)
+13 SET I2=0
FOR
SET I2=$ORDER(IBCPTS(I2))
if 'I2
QUIT
Begin DoDot:1
+14 SET IBCPT=$PIECE(IBCPTS(I2),U)
+15 SET IBCPTPRV=$PIECE($GET(IBCPTS(I2,12)),U,4)
+16 SET IBONBILL=0
SET IBZ=0
FOR
SET IBZ=$ORDER(^DGCR(399,IBIFN,"CP","B",IBCPT_";ICPT(",IBZ))
if 'IBZ
QUIT
IF $PIECE($GET(^DGCR(399,IBIFN,"CP",IBZ,0)),U,2)=I7
SET IBONBILL=1
+17 SET IBMODS=""
SET IBZ=0
FOR
SET IBZ=$ORDER(IBCPTS(I2,1,IBZ))
if 'IBZ
QUIT
SET IBMODS=IBMODS_$SELECT(IBMODS="":"",1:",")_+$GET(IBCPTS(I2,1,IBZ,0))
+18 ;
+19 ; look up of a procedure is non-billable and get assoc dx
+20 SET IBOEDP=IBOED
IF IBOEDP=""
SET IBOEDP=$$NBOEP^IBCCPT1(IBOE0,IBCPT,.IBDX)
IF IBOEDP'=""
SET IBOEDP=4_U_IBOEDP
+21 SET IBCPTDAT=IBCPT_U_I7_U_IBONBILL_U_0_U_IBDIV_U_$PIECE(IBOEDP,U,1)_U_$PIECE(IBOEDP,U,2)_U_IBCPTPRV_U_IBCLINIC_U_IBMODS_U_IBOE
+22 ;JWS;IB*2.0*592; IOC additional fields
+23 SET $PIECE(IBCPTDAT,U,15)=$PIECE(IBOE0,U,5)
+24 FOR Z=1:1:$PIECE(IBCPTS(I2),U,16)
SET IBCNT=IBCNT+1
SET ^UTILITY($JOB,"CPT-CNT",IBCNT)=IBCPTDAT
SET ^UTILITY($JOB,"CPT-CNT",IBCNT,"DX")=$GET(IBDX)
+25 KILL IBDX
End DoDot:1
+26 IF $ORDER(IBARR("CPT",0))
IF '$DATA(^UTILITY($JOB,"CPT",+IBOE0,0))
SET ^(0)="Y"
+27 QUIT
+28 ;
TOMANY(DATE) ; - returns 1 if more than 1 visit date on bill (for basc)
+1 if '$DATA(DATE)
GOTO TOMANYQ
+2 SET DGVCNT=+$PIECE($GET(^DGCR(399,IBIFN,"OP",0)),"^",4)
+3 IF DGVCNT>1!(DGVCNT=1&('$DATA(^DGCR(399,IBIFN,"OP",DATE))))
KILL DGVCNT
QUIT 1
TOMANYQ QUIT 0
+1 ;
CHECK(IBPSCD,DGNOD) ;
+1 SET RET=1
+2 IF $$GET1^DIQ(9000010.18,IBPSCD_",",1204,"I")'=$PIECE(DGNOD,"^",8)
SET RET=0
+3 QUIT RET
+4 ;
