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

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

initial load of FOIAVistA 6/30/08 version

File size: 5.5 KB
Line 
1IBCD3 ;ALB/ARH - AUTOMATED BILLER (ADD NEW BILL - CREATE BILL ENTRY) ;9/5/93
2 ;;2.0;INTEGRATED BILLING;**14,55,52,91,106,125,51,148,160,137,210,245,260**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ;Called by IBCD2,IBACUS2
6 ;
7EN(IBQUERY) ;
8 N IBI,IBX,IBY,I,X,X1,X2,IBAC,IBCPY K IBDR,IBDR222 S IBAC=1
9 S X=$P($T(WHERE),";;",2),X2=$P($T(WHERE+1),";;",2) F I=0:0 S I=$O(IB(I)) Q:'I S X1=$P($E(X,$F(X,I)+1,999),";",1) S:X1="" X1=$P($E(X2,$F(X2,I)+1,999),";",1) I $D(IB(I))=1 S $P(IBDR($P(X1,"^",1)),"^",$P(X1,"^",2))=IB(I)
10 F I=0,"C","M","M1","S","U","U1","U2" I $D(IBDR(I)) S ^DGCR(399,IBIFN,I)=IBDR(I)
11 S $P(^DGCR(399,0),"^",3)=IBIFN,$P(^(0),"^",4)=$P(^(0),"^",4)+1
12 S DIK="^DGCR(399,",DA=IBIFN D IX1^DIK K DA,DIK ; set cross-references
13 ;
14 ; Set the attending/rendering provider into provider multiple
15 I $G(IB("PRV",.01))'="" D
16 . S DIC("DR")="",I=.01
17 . N IBV
18 . F S I=$O(IB("PRV",I)) Q:'I I IB("PRV",I)'="" S IBV(I)=IB("PRV",I),DIC("DR")=DIC("DR")_$S(DIC("DR")="":"",1:";")_I_"////^S X=IBV("_I_")"
19 . S DIC="^DGCR(399,"_IBIFN_",""PRV"",",DIC(0)="L",DLAYGO=399,DA(1)=IBIFN,X=IB("PRV",.01)
20 . K DO,DD D FILE^DICN K DO,DD,DLAYGO,DA,DIC
21 ;
22 ; Set the occurrence span codes for leave/pass days
23 I $O(IB("OC",0)) D
24 . N I,I1
25 . S I1=0 F S I1=$O(IB("OC",I1)) Q:'I1 D
26 .. S I=0,DIC("DR")=""
27 .. F S I=$O(IB("OC",I1,I)) Q:'I S DIC("DR")=DIC("DR")_$S(DIC("DR")="":"",1:";")_I_"////"_IB("OC",I1,I)
28 .. S DIC="^DGCR(399,"_IBIFN_",""OC"",",DIC(0)="L",DLAYGO=399,DA(1)=IBIFN,DIC("P")=$$GETSPEC^IBEFUNC(399,41),X=IB("OC")
29 .. K DO,DD D FILE^DICN K DO,DD,DLAYGO,DA,DIC
30 ;
31 ; file rx refills, default CPT and Dx if defined
32 I $D(IB(362.4))>2 D G END
33 . N IBZ
34 . S IBRX=0 F S IBRX=$O(IB(362.4,IBRX)) Q:'IBRX S IBY="" F S IBY=$O(IB(362.4,IBRX,IBY)) Q:IBY="" D
35 .. S IBX=IB(362.4,IBRX,IBY) Q:IBX=""
36 .. S IBZ=$$ADD^IBCSC5A($P(IBX,U),IBIFN,$P(IBX,U,4),$P(IBX,U,2),+IBRX,$P(IBX,U,3)_U_$P(IBX,U,5)_U_$P(IBX,U,6))
37 ;
38 ;file outpatient visit dates and find/store outpatient procedures and dx
39 ;NOTE: If IBQUERY is defined at this point, it will be used to perform
40 ; the scan for outpatient procedures
41 I '$$INPAT^IBCEF(IBIFN) D G END
42 . I $D(IB(43))>2 D
43 .. S ^DGCR(399,IBIFN,"OP",0)="^399.043DA^" S IBX=0 F S IBX=$O(IB(43,IBX)) Q:'IBX D
44 ... S DIC="^DGCR(399,"_IBIFN_",""OP"",",DIC(0)="L",DA(1)=IBIFN,(DINUM,X)=IBX,DLAYGO=399.043 K DD,DO D FILE^DICN K DIC,DA,DINUM,DO,DD,DLAYGO
45 . ;
46 . D VST^IBCCPT(.IBQUERY) I $D(^UTILITY($J,"CPT-CNT")) D
47 .. N IBPRX
48 .. S DIC("P")=$$GETSPEC^IBEFUNC(399,304)
49 .. S IBY=0 F S IBY=$O(^UTILITY($J,"CPT-CNT",IBY)) Q:'IBY S IBX=^(IBY) I '$P(IBX,U,6) D
50 ... S IBPRX(+$P(IBX,U,8))=""
51 ... S DIC="^DGCR(399,"_IBIFN_",""CP"",",DIC(0)="L",DA(1)=IBIFN,X=+IBX_";ICPT(",DLAYGO=399 K DD,DO D FILE^DICN K DO,DD,DLAYGO Q:Y'>0
52 ... ;
53 ... S IBCPY=+Y
54 ... ;
55 ... ; add dx to 362.3 for associations if they exist
56 ... I $G(^UTILITY($J,"CPT-CNT",IBY,"DX")) D ADDDX^IBCCPT1(IBIFN,IBCPY,^("DX"),.IBDR) I $L($G(IBDR)) S IBDR=IBDR_";"
57 ... ;
58 ... ;
59 ... S DR=$G(IBDR)_"1////"_$P(IBX,U,2)_$S(+$P(IBX,U,8):";18////"_+$P(IBX,U,8),1:"") K IBDR
60 ... S DR=DR_$S(+$P(IBX,U,9):";6////"_+$P(IBX,U,9),1:"")_$S(+$P(IBX,U,5):";5////"_+$P(IBX,U,5),1:"")
61 ... S DR=DR_$S(+$P(IBX,U,11):";20////"_+$P(IBX,U,11),1:"")
62 ... S DIE=DIC,DA=+IBCPY D ^DIE K DIE,DIC,DA,DINUM,DO,DD
63 ... I $P(IBX,U,10) D ADDMOD^IBCCPT(IBIFN,IBCPY,$P(IBX,U,10)) ;Modifiers
64 .. I $O(IBPRX(""))=$O(IBPRX(""),-1),$O(IBPRX(0)) D
65 ... ;If only 1 provider - make it the rendering
66 ... S IB("PRV",.02)=+$O(IBPRX(0))_";VA(200,",IB("PRV",.01)=3
67 . K DGCNT,V,IBOPV1,IBOPV2,I,DGDIV,I1,DGNOD,DGCPTS,I7,I2,DGCPT,^UTILITY($J,"CPT-CNT")
68 . ;
69 . D OPTDX^IBCSC4D(DFN,IB(151),IB(152),.IBDX) I +IBDX D K IBDX
70 .. S IBY=0 F S IBY=$O(IBDX(IBY)) Q:IBY="" S IBX=IBDX(IBY) I '$P(IBX,U,5) D
71 ... I '$D(^DGCR(399,"AOPV",DFN,(+$P(IBX,U,4)\1),IBIFN)) Q
72 ... S DIC("DR")=".02////"_IBIFN,DIC="^IBA(362.3,",DIC(0)="L",X=+IBX,DLAYGO=362.3 K DD,DO D FILE^DICN
73 ... K DIE,DIC,DA,DLAYGO,DO,DD
74 ;
75 ;store inpatient diagnosis and procedures, default admit dx to first dx found
76 I $$INPAT^IBCEF(IBIFN) D G END
77 . I $G(^TMP("IBDX",$J))=IB(.08) D K ^TMP("IBDX",$J)
78 .. N IBXDEF S IBXDEF=0
79 .. S (IBI,IBX)="" F S IBX=$O(^TMP("IBDX",$J,IBX)) Q:'IBX S IBY=0 F S IBY=$O(^TMP("IBDX",$J,IBX,IBY)) Q:'IBY D
80 ... S IBZ=^TMP("IBDX",$J,IBX,IBY) Q:($$ICD9^IBACSV(+IBZ)="") S IBI=IBI+1
81 ... S DIC("DR")=".02////"_IBIFN_";.03////"_IBI,DIC="^IBA(362.3,",DIC(0)="L",X=+IBZ,DLAYGO=362.3 K DD,DO D FILE^DICN
82 ... K DIE,DIC,DA,DLAYGO,DO,DD
83 ... I Y>0,'IBXDEF S IBXDEF=1,DR="215////"_+IBZ,DIE="^DGCR(399,",DA=IBIFN D ^DIE
84 . ;
85 . D IPRC^IBCD4(+IB(.08),IB(151),IB(152)) I $D(^TMP("IBIPRC",$J)) D K ^TMP("IBIPRC",$J)
86 .. S ^DGCR(399,IBIFN,"CP",0)="^399.0304AVI^"
87 .. S IBX=0 F S IBX=$O(^TMP("IBIPRC",$J,IBX)) Q:'IBX D
88 ... S IBY=^TMP("IBIPRC",$J,IBX) F IBI=1:1 S IBZ=$P(IBY,U,IBI) Q:'IBZ D
89 .... S DIC="^DGCR(399,"_IBIFN_",""CP"",",DIC(0)="L",DA(1)=IBIFN,X=+IBZ_";ICD0(",DLAYGO=399.0304 K DD,DO D FILE^DICN
90 .... I Y>0 S DIE=DIC,DA=+Y,DR="1////"_(IBX\1) D ^DIE K DIE,DIC,DA,DLAYGO,DO,DD
91 ;
92END S IBX="1^Billing Record #"_$P(^DGCR(399,+IBIFN,0),"^",1)_" established for "_$P($G(^DPT(IBDFN,0)),U,1)
93 ;
94 S IBAUTO=1,DGPTUPDT="" I '$G(IBCHTRN) D PROC^IBCU7A(IBIFN) D ^IBCU6 ; auto calculate/store revenue codes
95 ;
96Q K %,%DT,IBDR,X1,X2,X3,X4,Y,DGDIRA,DGDIRB,DGDIR0,DIR,DGRVRCAL,DIC,DA,DR,DINUM,DGPTUPDT,DGXRF1,IBCHK,IBINDT,IBIDS,DLAYGO
97 Q
98 ;
99WHERE ;;.01^0^1;.02^0^2;.03^0^3;.04^0^4;.05^0^5;.06^0^6;.07^0^7;.08^0^8;.09^0^9;.11^0^11;.17^0^17;.16^0^16;.18^0^18;.19^0^19;.2^0^20;.22^0^22;.27^0^27;112^M^12;151^U^1;152^U^2;155^U^5;101^M^1;158^U^8;159^U^9;160^U^10;161^U^11;162^U^12;
100 ;;217^U2^3;221^U2^7;
Note: See TracBrowser for help on using the repository browser.