source: FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCCPT.m@ 985

Last change on this file since 985 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 9.1 KB
Line 
1IBCCPT ;ALB/LDB - MCCR OUTPATIENT VISITS LISTING CONT. ;29 MAY 90
2 ;;2.0;INTEGRATED BILLING;**55,62,52,91,106,125,51,148,174,182,245,266,260,339**;21-MAR-94;Build 2
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 ;MAP TO DGCRCPT
6 ;
7EN1(IBQUERY,IBHLP) ;
8 K DIR
9EN D:$D(DIR) HLP W @IOF S DGU=0 K DGCPT,^UTILITY($J) D VST(.IBQUERY)
10 D CHDR,WRNO
11 N ICPTVDT S ICPTVDT=$$BDATE^IBACSV($G(IBIFN)) ; Code Text Version
12 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
13 I DGU'="^" F Y=$Y:1:IOSL-6 W !
14OK1 K Y Q:'$D(^UTILITY($J,"CPT-CNT"))!($D(DIR))!($G(IBHLP))
15OK 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: "
16 D ^DIR K DIR I 'Y D Q1^IBCOPV1 Q
17 S IBFT=+$P(^DGCR(399,IBIFN,0),"^",19)
18OK2 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
19 I +Y,'% W !,"Respond 'Y'es to include these codes in the bill.",!,"Respond 'N'o to reselect." G OK2
20 I +Y,%=2 G OK
21 ;
22FILE S DGCPT1=Y,(DGCNT,DGCNT2)=0
23 S DIE="^DGCR(399,",DA=IBIFN,DR=".09///5" D ^DIE K DR,DA,DIE
24 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
25 D Q1^IBCOPV1 Q
26 ;
27FILE1 ; file procedures, if BASC, only for 1 visit date
28 K DGNOADD S (X,DINUM)=$P(DGNOD,"^",2) D VFILE1^IBCOPV1 K DINUM,X
29 N IBCPTNM S IBCPTNM=$$CPT^ICPTCOD(+DGNOD,+$P(DGNOD,U,2))
30 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
31 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
32 D DSPPRC(IBCPTNM,DGNOD,$G(DGNOD("DX")))
33 ;
34 S:'$D(^DGCR(399,IBIFN,"CP",0)) DIC("P")=$$GETSPEC^IBEFUNC(399,304)
35 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")
36 ;
37 S DR="1///"_$P(DGNOD,"^",2)
38 I +$P(DGNOD,"^",8) S DR=DR_";18///`"_+$P(DGNOD,"^",8)
39 I +$P(DGNOD,"^",9) S DR=DR_";6///`"_+$P(DGNOD,"^",9)
40 I +$P(DGNOD,"^",5) S DR=DR_";5////"_+$P(DGNOD,"^",5)
41 I +$P(DGNOD,"^",11) S DR=DR_";20////"_+$P(DGNOD,"^",11)
42 ;
43 ; file assoc dx if exists from pce
44 D:$G(DGNOD("DX")) ADDDX^IBCCPT1(IBIFN,IBPROCP,DGNOD("DX"),.DR)
45 ;
46 S DIE=DIC D ^DIE
47 D:$P(DGNOD,U,10)'="" ADDMOD(IBIFN,IBPROCP,$P(DGNOD,U,10))
48 ;
49 S DR="16"
50 I '$P(DGNOD,"^",8) S DR=DR_";18"
51 I '$P(DGNOD,"^",9) S DR=DR_";6"
52 I '$P(DGNOD,"^",5) S DR=DR_";5"
53 S:IBFT=2 DR=DR_";8;9;17//NO"
54 S DIE=DIC D ^DIE
55 ;
56 S DR=$$SPCUNIT^IBCU7(IBIFN,IBPROCP) I DR'="" D ^DIE ; miles/minutes/hours
57 ;
58 ; DSS QuadraMed Interface: CPT Sequence and Diagnosis Linkage for Single CPT
59 I $$QMED^IBCU1("DX^VEJDIBE1",IBIFN) D DX^VEJDIBE1(IBIFN,IBPROCP)
60 ;
61 Q:$D(Y)
62 D DX^IBCU72(IBIFN,IBPROCP):IBFT=2
63 I IBFT=2 S X=$$ADDTNL^IBCU7(IBIFN,.DA)
64 L ^DGCR(399,IBIFN):1
65 K DIE,DIC,DR,DA,IBPROCP
66 Q
67 ;
68CPRT D:$Y+6>IOSL SCR Q:DGU="^"
69 N IBCPTNM,IBNBM,IBMODS,J,IBZ,IBDATE
70 S IBDATE=$$BDATE^IBACSV($G(IBIFN))
71 S IBNBM="",IBCPTNM=$$CPT^ICPTCOD(DGCPT,IBDATE) Q:IBCPTNM'>0
72 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)
73 I +DGBIL,+$P($G(DGNOD),U,6) S IBNBM=" *ON BILL/"_$E($P(DGNOD,U,7),1,4)_"*"
74 I IBNBM="",DGBIL S IBNBM=" *ON THIS BILL*"
75 I IBNBM="",+$P($G(DGNOD),U,6) S IBNBM=" "_$E($P(DGNOD,U,7),1,12)
76 W ?64,IBNBM
77 ;
78 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)
79 Q
80CHDR W @IOF,!,?15,"<<CURRENT PROCEDURAL TERMINOLOGY CODES>>",!!,?10,"LISTING FROM VISIT DATES WITH ASSOCIATED CPT CODES",!,?22,"IN OUTPT ENCOUNTERS FILE",!
81 K ^TMP("IBVIS",$J)
82 S L="",$P(L,"=",80)="" W !,L,!,"NO.",?5,"CODE",?13,"SHORT NAME",?39,"CLINIC",?56,"DATE",!,L,! K L
83 Q
84ADDMOD(IBIFN,IBY,IBMOD) ; Add modifier(s) from PCE procedure to CPT code mult
85 N DIE,DR,DIC,DA,DO,DD,IBS,IBM
86 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
87 . S:'$D(^DGCR(399,DA(2),"CP",DA(1),"MOD")) DIC("P")=$$GETSPEC^IBEFUNC(399.0304,16)
88 . S DIC(0)="L",DIC="^DGCR(399,"_IBIFN_",""CP"","_IBY_",""MOD"",",DLAYGO=399.30416,DIC("DR")=".02////"_IBM
89 . D FILE^DICN K DIC,DO,DD
90 Q
91 ;
92DSPPRC(CPTNM,NOD,DX) ; display summary of procedure being added
93 N IBI,IBL,IBMODS,IBMOD,IBPRVTYP,IBPRV,IBDATE,IBP,IBDXT
94 I $G(CPTNM)=""!($G(NOD)="") Q
95 S IBMODS=$P(NOD,U,10),IBPRVTYP="",IBPRV=""
96 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:" - ")
97 ;
98 W !!?4,"Adding CPT Procedure: ",$P(CPTNM,U,2),?34,$P(CPTNM,U,3)
99 S IBDATE=$$BDATE^IBACSV($G(IBIFN))
100 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)
101 W !,?34,"Visit: ",$$FMTE^XLFDT(+$P(NOD,U,2),2),", ",$E($P($G(^SC(+$P(NOD,U,9),0)),U,1),1,29)
102 I IBPRV'="" W !,?34,"Provider: ",$E(IBPRV,1,35) I IBPRVTYP'="" W:IBL="" !,?44 W IBL,IBPRVTYP
103 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)
104 W !
105 Q
106 ;
107VST(IBQUERY) ;Procedures for outpatient visits ... If IBQUERY is defined
108 ; on entry, the QUERY OBJECT defined by this value will be used for
109 ; loop to extract procedures for visits, otherwise, a new QUERY will be opened
110 ; If passed by reference, IBQUERY will be ret'd as the new QUERY ref #
111 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)
112 I $O(^DGCR(399,IBIFN,"OP",0)) K ^TMP("IBVIS",$J) G VSTQ
113 S IBOPV1=$P(^DGCR(399,IBIFN,"U"),"^"),IBOPV2=$P(^("U"),"^",2)
114 D PROC(.IBQUERY) K ^TMP("IBVIS",$J)
115VSTQ Q
116 ;
117WRNO 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")
118 Q
119SCR Q:DGU="^" I $E(IOST,1,2)["C-",$Y+6>IOSL F Y=$Y:1:IOSL-5 W !
120 I R !,"Press return to continue or ""^"" to exit display ",DGU:DTIME D:DGU'="^" CHDR
121 Q
122HLP 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"
123 W !,"The number(s) must appear as a selectable number in the sequential list." R H:5 K H Q
124CPT 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)
125 K DIK,DGTE,I1 Q
126 ;
127PROC(IBQUERY) ; -find outpatient procedures, flag if billable
128 ; - ^utility($j,cpt-cnt,count)=code^date^on bill^is BASC^divis^nb^nb mess^provider^clinic^mod,mod^Opt Enc Ptr
129 ; - ^utility($j,cpt-cnt,count,"dx")=assoc dx(1)^assoc dx(2)^assoc dx(3)^assoc dx(4)
130 N IBVAL,IBCBK,IBFILTER
131 S IBVAL("DFN")=DFN,IBVAL("BDT")=IBOPV1,IBVAL("EDT")=(IBOPV2+.99)
132 ; Must be a billable appt type and outpt enctr status of CHECKED OUT
133 S IBFILTER=""
134 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)"
135 D SCAN^IBSDU("PATIENT/DATE",.IBVAL,IBFILTER,IBCBK,0,.IBQUERY) K ^TMP("DIERR",$J)
136 ;
137 Q
138EXTPROC(IBIFN,IBOE,IBOE0,IBCNT) ; Extract procedures for an encounter
139 ; IBIFN = the ien of the bill
140 ; IBOE0 = 0-node of the outpatient encounter file entry IBOE
141 ; IBCNT extracted entry counter
142 N I2,I7,IBCPT,IBCPTS,IBDIV,IBOED,IBZERR,Z,IBCPTDAT,IBCPTPRV,IBCLINIC,IBZ,IBONBILL,IBMODS,IBARR,IBDT,DFN,IBEX,IBDX,IBOEDP
143 ; make sure i have this variable
144 S:$G(IBOE0)="" IBOE0=$$SCE^IBSDU(+IBOE)
145 D GETCPT^SDOE(IBOE,"IBCPTS","IBZERR")
146 Q:'$O(IBCPTS(0)) ;No procedures for this encounter
147 I '$$BDSRC^IBEFUNC3($P($G(IBOE0),U,5)) Q ; non-billable visit data source
148 S IBOED=$$NBOE^IBCU81(IBOE,IBOE0)
149 S I7=IBOE0\1,IBDIV=$P(IBOE0,U,11)
150 S IBCLINIC="" I +$P(IBOE0,U,4),+$$CLNSCRN^IBCU(I7,+$P(IBOE0,U,4)) S IBCLINIC=+$P(IBOE0,U,4)
151 S I2=0 F S I2=$O(IBCPTS(I2)) Q:'I2 D
152 . S IBCPT=$P(IBCPTS(I2),U)
153 . S IBCPTPRV=$P($G(IBCPTS(I2,12)),U,4)
154 . 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
155 . 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))
156 . ;
157 . ; look up of a procedure is non-billable and get assoc dx
158 . S IBOEDP=IBOED I IBOEDP="" S IBOEDP=$$NBOEP^IBCCPT1(IBOE0,IBCPT,.IBDX) I IBOEDP'="" S IBOEDP=4_U_IBOEDP
159 . 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
160 . 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)
161 . K IBDX
162 I $O(IBARR("CPT",0)),'$D(^UTILITY($J,"CPT",+IBOE0,0)) S ^(0)="Y"
163 Q
164 ;
165TOMANY(DATE) ; - returns 1 if more than 1 visit date on bill (for basc)
166 G TOMANYQ:'$D(DATE)
167 S DGVCNT=+$P($G(^DGCR(399,IBIFN,"OP",0)),"^",4)
168 I DGVCNT>1!(DGVCNT=1&('$D(^DGCR(399,IBIFN,"OP",DATE)))) K DGVCNT Q 1
169TOMANYQ Q 0
170 ;
Note: See TracBrowser for help on using the repository browser.