- 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 Jan 18, 2025@03:10: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 ;