Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBCCPT

IBCCPT.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. ;MAP TO DGCRCPT
  1. ;
  1. EN1(IBQUERY,IBHLP) ;
  1. ;JWS;IB*2.0*592;
  1. N IBUSED
  1. K DIR
  1. EN D:$D(DIR) HLP W @IOF S DGU=0 K DGCPT,^UTILITY($J) D VST(.IBQUERY)
  1. D CHDR,WRNO
  1. N ICPTVDT S ICPTVDT=$$BDATE^IBACSV($G(IBIFN)) ; Code Text Version
  1. 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
  1. I DGU'="^" F Y=$Y:1:IOSL-6 W !
  1. OK1 K Y Q:'$D(^UTILITY($J,"CPT-CNT"))!($D(DIR))!($G(IBHLP))
  1. 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: "
  1. D ^DIR K DIR I 'Y D Q1^IBCOPV1 Q
  1. S IBFT=+$P(^DGCR(399,IBIFN,0),"^",19)
  1. 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
  1. I +Y,'% W !,"Respond 'Y'es to include these codes in the bill.",!,"Respond 'N'o to reselect." G OK2
  1. I +Y,%=2 G OK
  1. ;
  1. FILE S DGCPT1=Y,(DGCNT,DGCNT2)=0
  1. S DIE="^DGCR(399,",DA=IBIFN,DR=".09///5" D ^DIE K DR,DA,DIE
  1. 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
  1. D Q1^IBCOPV1 Q
  1. ;
  1. 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
  1. N IBTON,IBSURF,IBTSTAT,IBPSCDS,IBDENHD
  1. N IBDICSAV ; IB*2.0*432 BI
  1. K DGNOADD S (X,DINUM)=$P(DGNOD,"^",2) D VFILE1^IBCOPV1 K DINUM,X
  1. N IBCPTNM S IBCPTNM=$$CPT^ICPTCOD(+DGNOD,+$P(DGNOD,U,2))
  1. 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
  1. 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
  1. D DSPPRC(IBCPTNM,DGNOD,$G(DGNOD("DX")))
  1. ;
  1. S:'$D(^DGCR(399,IBIFN,"CP",0)) DIC("P")=$$GETSPEC^IBEFUNC(399,304)
  1. ; IB*2.0*432 BI
  1. ;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")
  1. 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")
  1. S DR="1///"_$P(DGNOD,"^",2)
  1. I +$P(DGNOD,"^",8) S DR=DR_";18///`"_+$P(DGNOD,"^",8)
  1. I +$P(DGNOD,"^",9) S DR=DR_";6///`"_+$P(DGNOD,"^",9)
  1. I +$P(DGNOD,"^",5) S DR=DR_";5////"_+$P(DGNOD,"^",5)
  1. I +$P(DGNOD,"^",11) S DR=DR_";20////"_+$P(DGNOD,"^",11)
  1. ;
  1. ; file assoc dx if exists from pce
  1. D:$G(DGNOD("DX")) ADDDX^IBCCPT1(IBIFN,IBPROCP,DGNOD("DX"),.DR)
  1. ;
  1. S DIC=IBDICSAV ; IB*2.0*432 BI
  1. S DIE=DIC D ^DIE
  1. D:$P(DGNOD,U,10)'="" ADDMOD(IBIFN,IBPROCP,$P(DGNOD,U,10))
  1. ;
  1. ; (CPT MODIFIER SEQUENCE).
  1. ;K DR
  1. ;S DR="16"
  1. ;S DIC=IBDICSAV ; IB*2.0*432 BI
  1. ;S DIE=DIC D ^DIE ; DEM;432 - DR=16 (CPT MODIFIER SEQUENCE)
  1. K DA
  1. S DA(1)=IBIFN,DA=IBPROCP ;WCJ;IB*2.0*742;
  1. D EN^IBCU7C(IBPROCP) ;WCJ;IB*2.0*742;
  1. ;
  1. ;JWS;IB*2.0*592; add Dental fields - IOC issue
  1. I IBFT=7 D
  1. . N IBDENH0,STOP,IBDENH,IBVST,IBPSC,IBPSC2,TARGET0
  1. . ;JWS;IB*2.0*592;IOC additional fields
  1. . S IBVST=$P(DGNOD,"^",15) ;DGNOD[15] = visit ien to ^AUPNVSIT to get dental data.
  1. . ;IA# 2051, 6870, 6871
  1. . ;S IBDENH=$$FIND1^DIC(228.1,,"QX",IBVST,"AV")
  1. . D FIND^DIC(228.1,,"IX","QXP",IBVST,,"AV",,,"TARGET0")
  1. . I +$G(TARGET0("DILIST",0)) S IBDENH0=0 F S IBDENH0=$O(TARGET0("DILIST",IBDENH0)) Q:'IBDENH0 D I $G(STOP) Q
  1. .. S IBDENH=$P($G(TARGET0("DILIST",IBDENH0,0)),"^")
  1. .. I IBDENH D
  1. ... N TARGET,TARGET1,IBDENHD0,IBPSCD0,IBPSCD S (IBDENHD0,STOP)=0
  1. ... ;IA# 2051, 6870, 6871
  1. ... D FIND^DIC(228.2,,"IX","QXP",IBDENH,,"AG",,,"TARGET")
  1. ... I +$G(TARGET("DILIST",0)) F S IBDENHD0=$O(TARGET("DILIST",IBDENHD0)) Q:'IBDENHD0 D I STOP Q
  1. .... S IBDENHD=$P(TARGET("DILIST",IBDENHD0,0),"^")
  1. .... ;IA# 2056, 6870, 6871
  1. .... S IBPSC=$$GET1^DIQ(228.2,IBDENHD_",",.04)
  1. .... ;;S IBPROV=$$GET1^DIQ(228.2,IBDENHD_",",.03,"I") ;provider linked to dental transaction
  1. .... I IBPSC'=$$GET1^DIQ(81,$P(DGNOD,"^")_",",.01) Q
  1. .... I $D(^DGCR(399,"ADT",IBDENHD)) Q
  1. .... I $D(IBUSED("D",IBDENHD)) Q
  1. .... S IBUSED("D",IBDENHD)=""
  1. .... ;attempt to pull in the Not Otherwise Classified proc description from the Provider Narrative
  1. .... ;IA# 2051
  1. .... D FIND^DIC(9000010.18,,"IX","QXP",IBVST,,"AD",,,"TARGET1")
  1. .... S IBPSCD0=0,IBPSCDS=""
  1. .... ;IA# 2056
  1. .... 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
  1. ..... S IBUSED(IBPSCD)="",IBPSCDS=$$GET1^DIQ(9000010.18,IBPSCD_",",.04,"E") Q
  1. .... S IBPSC2=$$GET1^DIQ(399.0304,IBPROCP_","_IBIFN_",",.01,"I") I $$GET1^DIQ(81,$P(IBPSC2,";")_",",.01)'=IBPSC Q
  1. .... S STOP=1
  1. .... I '$$NOCPROC^IBCU7("^"_IBPSC2,IBPSC,IBDT) S IBPSCDS=""
  1. .... ;IA# 2056, 6870, 6871
  1. .... S IBTON=$$GET1^DIQ(228.2,IBDENHD_",",.15)
  1. .... S IBSURF=$$GET1^DIQ(228.2,IBDENHD_",",.16)
  1. .... S IBTSTAT=$$GET1^DIQ(228.2,IBDENHD_",",.09),IBTSTAT=$S(IBTSTAT="cndMissing":"M",1:"")
  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
  1. .... Q
  1. ... I '$G(STOP) S IBDENHD=""
  1. ... Q
  1. .. Q
  1. . I $G(IBPSC2)["ICPT",$$NOCPROC^IBCU7("^"_$G(IBPSC2),$G(IBPSC),$G(IBDT)) D
  1. .. S DA=IBPROCP,DA(1)=IBIFN ; The line# on the bill/claim.
  1. .. S DR="51//"_IBPSCDS ; Field# for PROCEDURE DESCRIPTION
  1. .. D ^DIE
  1. .. Q
  1. . ;JWS;IB*2.0*592;end
  1. K DR
  1. S DR=""
  1. 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.
  1. S IBLNPRV("IBCCPT")=$P($G(^VA(200,+$P(DGNOD,U,8),0)),U,1) ; DEM;432 - Flag for call to routine EN^IBCU7B.
  1. D EN^IBCU7B ; DEM;432 - Call to line level provider user input.
  1. K IBLNPRV("IBCCPT") ; DEM;432 - Kill flag after return from EN^IBCU7B.
  1. S DA=IBPROCP ; DEM;432 - DA=IBPROCP before call to EN^IBCU7B.
  1. K DR
  1. ;
  1. I IBFT=3,'$$INPAT^IBCEF(IBIFN) D
  1. . S DR=""
  1. . D ATTACH^IBCU7
  1. . K DR
  1. ;
  1. S DR=""
  1. I '$P(DGNOD,"^",8) S DR=$S(DR'="":DR_";18",1:18) ; DEM;432 - Added $SELECT since DR can equal field or NULL.
  1. I '$P(DGNOD,"^",9) S DR=$S(DR'="":DR_";6",1:6) ; DEM;432 - Added $SELECT since DR can equal field or NULL.
  1. I '$P(DGNOD,"^",5) S DR=$S(DR'="":DR_";5",1:5) ; DEM;432 - Added $SELECT since DR can equal field or NULL.
  1. ;
  1. 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.
  1. ;JWS;IB*2.0*592;IOC change, prompt for POS, + dental fields.
  1. I IBFT=7 S DR=$S(DR'="":DR_";6;5//"_$$DEFDIV^IBCU7(IBIFN)_";8;3",1:"6;5//"_$$DEFDIV^IBCU7(IBIFN)_";8;3")
  1. S DIC=IBDICSAV ; IB*2.0*432 BI
  1. I DR'="" S DIE=DIC D ^DIE ; DEM;432 - Added contion of DR'="".
  1. S DR=$$SPCUNIT^IBCU7(IBIFN,IBPROCP) I DR'="" D ^DIE ; miles/minutes/hours
  1. ;
  1. ; DSS QuadraMed Interface: CPT Sequence and Diagnosis Linkage for Single CPT
  1. I $$QMED^IBCU1("DX^VEJDIBE1",IBIFN) D DX^VEJDIBE1(IBIFN,IBPROCP)
  1. ;
  1. Q:$D(Y)
  1. ;JWS;IB*2.0*592; IOC changes - prompt for diagnosis code links to procedure code
  1. I IBFT=2!(IBFT=7) D DX^IBCU72(IBIFN,IBPROCP)
  1. I IBFT=2 S X=$$ADDTNL^IBCU7(IBIFN,.DA)
  1. ;JWS;IB*2.0*592;IOC additional questions
  1. I IBFT=7 D
  1. . K DR S DR=""
  1. . I $G(IBPSCDS)'="" S DR="51////"_IBPSCDS
  1. . I DR'="" D ^DIE K DIE,DIC,DA,DINUM,DO,DD,DR
  1. . ;JWS;IB*2.0*592;start;Add tooth # and surfaces to procedure line
  1. . ;JWS;IB*2.0*592;allow for tooth # without surface
  1. . I $G(IBTON)'="" K DA,DR,DIC,DLAYGO D
  1. .. S DIC(0)="L",DIC="^DGCR(399,"_IBIFN_",""CP"","_IBPROCP_",""DEN1"",",DLAYGO=399.30491
  1. .. S DA(2)=IBIFN,DA(1)=IBPROCP
  1. .. S DIC("DR")=".01////"_IBTON_$S($D(IBSURF(1)):";.02////"_$G(IBSURF(1)),1:"")
  1. .. S X=IBTON
  1. .. I $D(IBSURF(2)) S DIC("DR")=DIC("DR")_";.03////"_IBSURF(2)
  1. .. I $D(IBSURF(3)) S DIC("DR")=DIC("DR")_";.04////"_IBSURF(3)
  1. .. I $D(IBSURF(4)) S DIC("DR")=DIC("DR")_";.05////"_IBSURF(4)
  1. .. I $D(IBSURF(5)) S DIC("DR")=DIC("DR")_";.06////"_IBSURF(5)
  1. .. I $G(IBDENHD) S DIC("DR")=DIC("DR")_";.07////"_IBDENHD
  1. .. D FILE^DICN K DIC,DO,DD,DA,DR
  1. .. Q
  1. . I $G(IBTSTAT)'="",$G(IBTON) D
  1. .. 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
  1. .. S IBTNUM=+Y
  1. .. S DR=".02////"_IBTSTAT
  1. .. S DIE=DIC,DA=IBTNUM D ^DIE K DIE,DIC,DA,DINUM,DO,DD,DR
  1. . ;JWS;IB*2.0*592;end
  1. . S DA(1)=IBIFN,DA=IBPROCP,DIE="^DGCR(399,"_IBIFN_",""CP"","
  1. . D ORAL^IBCU72 W !
  1. L ^DGCR(399,IBIFN):1
  1. K DIE,DIC,DR,DA,IBPROCP
  1. Q
  1. ;
  1. CPRT D:$Y+6>IOSL SCR Q:DGU="^"
  1. N IBCPTNM,IBNBM,IBMODS,J,IBZ,IBDATE
  1. S IBDATE=$$BDATE^IBACSV($G(IBIFN))
  1. S IBNBM="",IBCPTNM=$$CPT^ICPTCOD(DGCPT,IBDATE) Q:IBCPTNM'>0
  1. 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)
  1. I +DGBIL,+$P($G(DGNOD),U,6) S IBNBM=" *ON BILL/"_$E($P(DGNOD,U,7),1,4)_"*"
  1. I IBNBM="",DGBIL S IBNBM=" *ON THIS BILL*"
  1. I IBNBM="",+$P($G(DGNOD),U,6) S IBNBM=" "_$E($P(DGNOD,U,7),1,12)
  1. W ?64,IBNBM
  1. ;
  1. 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)
  1. Q
  1. CHDR W @IOF,!,?15,"<<CURRENT PROCEDURAL TERMINOLOGY CODES>>",!!,?10,"LISTING FROM VISIT DATES WITH ASSOCIATED CPT CODES",!,?22,"IN OUTPT ENCOUNTERS FILE",!
  1. K ^TMP("IBVIS",$J)
  1. S L="",$P(L,"=",80)="" W !,L,!,"NO.",?5,"CODE",?13,"SHORT NAME",?39,"CLINIC",?56,"DATE",!,L,! K L
  1. Q
  1. ADDMOD(IBIFN,IBY,IBMOD) ; Add modifier(s) from PCE procedure to CPT code mult
  1. N DIE,DR,DIC,DA,DO,DD,IBS,IBM
  1. 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
  1. . S:'$D(^DGCR(399,DA(2),"CP",DA(1),"MOD")) DIC("P")=$$GETSPEC^IBEFUNC(399.0304,16)
  1. . S DIC(0)="L",DIC="^DGCR(399,"_IBIFN_",""CP"","_IBY_",""MOD"",",DLAYGO=399.30416,DIC("DR")=".02////"_IBM
  1. . D FILE^DICN K DIC,DO,DD
  1. Q
  1. ;
  1. DSPPRC(CPTNM,NOD,DX) ; display summary of procedure being added
  1. N IBI,IBL,IBMODS,IBMOD,IBPRVTYP,IBPRV,IBDATE,IBP,IBDXT
  1. I $G(CPTNM)=""!($G(NOD)="") Q
  1. S IBMODS=$P(NOD,U,10),IBPRVTYP="",IBPRV=""
  1. 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:" - ")
  1. ;
  1. W !!?4,"Adding CPT Procedure: ",$P(CPTNM,U,2),?34,$P(CPTNM,U,3)
  1. S IBDATE=$$BDATE^IBACSV($G(IBIFN))
  1. 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)
  1. W !,?34,"Visit: ",$$FMTE^XLFDT(+$P(NOD,U,2),2),", ",$E($P($G(^SC(+$P(NOD,U,9),0)),U,1),1,29)
  1. I IBPRV'="" W !,?34,"Provider: ",$E(IBPRV,1,35) I IBPRVTYP'="" W:IBL="" !,?44 W IBL,IBPRVTYP
  1. 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)
  1. W !
  1. Q
  1. ;
  1. VST(IBQUERY) ;Procedures for outpatient visits ... If IBQUERY is defined
  1. ; on entry, the QUERY OBJECT defined by this value will be used for
  1. ; loop to extract procedures for visits, otherwise, a new QUERY will be opened
  1. ; If passed by reference, IBQUERY will be ret'd as the new QUERY ref #
  1. 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)
  1. I $O(^DGCR(399,IBIFN,"OP",0)) K ^TMP("IBVIS",$J) G VSTQ
  1. S IBOPV1=$P(^DGCR(399,IBIFN,"U"),"^"),IBOPV2=$P(^("U"),"^",2)
  1. D PROC(.IBQUERY) K ^TMP("IBVIS",$J)
  1. VSTQ Q
  1. ;
  1. 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")
  1. Q
  1. SCR Q:DGU="^" I $E(IOST,1,2)["C-",$Y+6>IOSL F Y=$Y:1:IOSL-5 W !
  1. I R !,"Press return to continue or ""^"" to exit display ",DGU:DTIME D:DGU'="^" CHDR
  1. Q
  1. 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"
  1. W !,"The number(s) must appear as a selectable number in the sequential list." R H:5 K H Q
  1. 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)
  1. K DIK,DGTE,I1 Q
  1. ;
  1. 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
  1. ; - ^utility($j,cpt-cnt,count,"dx")=assoc dx(1)^assoc dx(2)^assoc dx(3)^assoc dx(4)
  1. N IBVAL,IBCBK,IBFILTER
  1. S IBVAL("DFN")=DFN,IBVAL("BDT")=IBOPV1,IBVAL("EDT")=(IBOPV2+.99)
  1. ; Must be a billable appt type and outpt enctr status of CHECKED OUT
  1. S IBFILTER=""
  1. 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)"
  1. D SCAN^IBSDU("PATIENT/DATE",.IBVAL,IBFILTER,IBCBK,0,.IBQUERY) K ^TMP("DIERR",$J)
  1. ;
  1. Q
  1. EXTPROC(IBIFN,IBOE,IBOE0,IBCNT) ; Extract procedures for an encounter
  1. ; IBIFN = the ien of the bill
  1. ; IBOE0 = 0-node of the outpatient encounter file entry IBOE
  1. ; IBCNT extracted entry counter
  1. N I2,I7,IBCPT,IBCPTS,IBDIV,IBOED,IBZERR,Z,IBCPTDAT,IBCPTPRV,IBCLINIC,IBZ,IBONBILL,IBMODS,IBARR,IBDT,DFN,IBEX,IBDX,IBOEDP
  1. ; make sure i have this variable
  1. S:$G(IBOE0)="" IBOE0=$$SCE^IBSDU(+IBOE)
  1. D GETCPT^SDOE(IBOE,"IBCPTS","IBZERR")
  1. Q:'$O(IBCPTS(0)) ;No procedures for this encounter
  1. I '$$BDSRC^IBEFUNC3($P($G(IBOE0),U,5)) Q ; non-billable visit data source
  1. S IBOED=$$NBOE^IBCU81(IBOE,IBOE0)
  1. S I7=IBOE0\1,IBDIV=$P(IBOE0,U,11)
  1. S IBCLINIC="" I +$P(IBOE0,U,4),+$$CLNSCRN^IBCU(I7,+$P(IBOE0,U,4)) S IBCLINIC=+$P(IBOE0,U,4)
  1. S I2=0 F S I2=$O(IBCPTS(I2)) Q:'I2 D
  1. . S IBCPT=$P(IBCPTS(I2),U)
  1. . S IBCPTPRV=$P($G(IBCPTS(I2,12)),U,4)
  1. . 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
  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))
  1. . ;
  1. . ; look up of a procedure is non-billable and get assoc dx
  1. . S IBOEDP=IBOED I IBOEDP="" S IBOEDP=$$NBOEP^IBCCPT1(IBOE0,IBCPT,.IBDX) I IBOEDP'="" S IBOEDP=4_U_IBOEDP
  1. . 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
  1. . ;JWS;IB*2.0*592; IOC additional fields
  1. . S $P(IBCPTDAT,U,15)=$P(IBOE0,U,5)
  1. . 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)
  1. . K IBDX
  1. I $O(IBARR("CPT",0)),'$D(^UTILITY($J,"CPT",+IBOE0,0)) S ^(0)="Y"
  1. Q
  1. ;
  1. TOMANY(DATE) ; - returns 1 if more than 1 visit date on bill (for basc)
  1. G TOMANYQ:'$D(DATE)
  1. S DGVCNT=+$P($G(^DGCR(399,IBIFN,"OP",0)),"^",4)
  1. I DGVCNT>1!(DGVCNT=1&('$D(^DGCR(399,IBIFN,"OP",DATE)))) K DGVCNT Q 1
  1. TOMANYQ Q 0
  1. ;
  1. CHECK(IBPSCD,DGNOD) ;
  1. S RET=1
  1. I $$GET1^DIQ(9000010.18,IBPSCD_",",1204,"I")'=$P(DGNOD,"^",8) S RET=0
  1. Q RET
  1. ;