source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCU7.m@ 1306

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

revised back to 6/30/08 version
File size: 7.7 KB
RevLine 
[623]1IBCU7 ;ALB/AAS - INTERCEPT SCREEN INPUT OF PROCEDURE CODES ;29-OCT-91
2 ;;2.0;INTEGRATED BILLING;**62,52,106,125,51,137,210,245,228,260,348**;21-MAR-94;Build 5
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ;MAP TO DGCRU7
6 ;
7CHKX ; -interception of input x from Additional Procedure input
8 G:X=" " CHKXQ
9 I $$INPAT^IBCEF(DA(1)),'$P($G(^IBE(350.9,1,1)),"^",15),X'?1A1N D G CHKXQ
10 . K X
11 . D EN^DDIOL("Site param does not allow entry of non-PTF procedures") ;Fileman error here will be: The previous error occurred when performing an action specified in a Pre-lookup transform (7.5 node).
12 G:'$D(^UTILITY($J,"IB")) CHKXQ
13 S M=($A($E(X,1))-64),S=+$E(X,2) Q:'$G(^UTILITY($J,"IB",M,S)) S X="`"_+^(S)
14 I $D(DGPROCDT),DGPROCDT'=$P($G(^UTILITY($J,"IB",M,1)),"^",2) S DGPROCDT=$P(^(1),"^",2) W !!,"Procedure Date: " S Y=DGPROCDT X ^DD("DD") W Y,!
15CHKXQ Q
16 ;
17CODMUL ;Date oriented entry of procedure
18DELASK I $D(IBZ20),IBZ20,IBZ20'=$P(^DGCR(399,IBIFN,0),U,9) S %=2 W !,"SINCE THE PROCEDURE CODING METHOD HAS BEEN CHANGED, DO YOU WANT TO DELETE ALL",!,"PROCEDURE CODES IN THIS BILL"
19 I D YN^DICN Q:%=-1 D:%=1 DELADD I %Y?1."?" W !!,"If you answer 'Yes', all procedure codes will be DELETED from this bill.",! G DELASK
20 K %,%Y,DA,IBZ20,DIK ;W !,"Procedure Entry:"
21 ;
22CODDT I $D(IBIFN),$D(^DGCR(399,IBIFN,0)),$P(^(0),U,9) S DIC("V")=$S($P(^(0),U,9)=9:"I +Y(0)=80.1",$P(^(0),U,9)=4!($P(^(0),U,9)=5):"I +Y(0)=81",1:"")
23 I $P($G(^DGCR(399,IBIFN,0)),"^",5)<3 S IBZTYPE=1 I $P($G(^UTILITY($J,"IB",1,1)),"^",2) S DGPROCDT=$P(^(1),"^",2) D ASKCOD
24 S X=$$PRCDIV^IBCU71(IBIFN) I +X W !!,$P(X,U,2),!
25 N Z,Z0 S Z=$G(^DGCR(399,IBIFN,"U")),Z0=$$FMTE^XLFDT($P(Z,U),"2D")_"-"_$$FMTE^XLFDT($P(Z,U,2),"2D")
26 W !,"Select PROCEDURE DATE"_$S($TR(Z0,"-")'="":" ("_Z0_")",1:"")_": " R X:DTIME G:'$T!("^"[X) CODQ D:X["?" CODHLP
27 S IBEX=0 D ; Get procedure date
28 . I X=" ",$D(DGPROCDT),DGPROCDT?7N S Y=DGPROCDT D D^DIQ W " (",Y,")" Q
29 . I X=" ",+$P($G(^DGCR(399,IBIFN,"OP",0)),"^",4) S (DGPROCDT,Y)=$O(^DGCR(399,IBIFN,"OP",0)) D D^DIQ W " (",Y,")" Q
30 . S %DT="EXP",%DT(0)=-DT D ^%DT K %DT I Y<1 S IBEX=1 Q
31 . I '$$OPV2^IBCU41(Y,IBIFN,1) S IBEX=1 Q
32 . S:'$G(IBZTYPE) X=$$OPV^IBCU41(Y,IBIFN) S DGPROCDT=Y
33 I 'IBEX D ASKCOD,ADDCPT^IBCU71:$D(DGCPT)
34 K IBEX
35 G CODDT
36 ;
37ASKCOD N Z,Z0,DA,IBACT,IBQUIT
38 K DGCPT
39 S DGCPT=0,DGCPTUP=$P($G(^IBE(350.9,1,1)),"^",19),DGADDVST=0,IBFT=$P($G(^DGCR(399,IBIFN,0)),"^",19)
40 I '$D(^DGCR(399,IBIFN,"CP",0)) S ^DGCR(399,IBIFN,"CP",0)=U_$$GETSPEC^IBEFUNC(399,304)
41 ;
42 F S IBQUIT=0 D Q:IBQUIT
43 . S DIC("A")=" Select PROCEDURE: "
44 . S DIC="^DGCR(399,"_IBIFN_",""CP"","
45 . S DIC(0)="AEQMNL"
46 . S DIC("S")="I '$D(DIV(""S""))&($P(^(0),U,2)=DGPROCDT)"
47 . S DIC("DR")="1///^S X=DGPROCDT"
48 . S DA(1)=IBIFN,DLAYGO=399
49 . W ! D ^DIC I Y<1 S IBQUIT=1 Q
50 . ; If we just added inactive code - it must be deleted.
51 . S IBACT=0 ; Active flag
52 . I Y["ICD0" S IBACT=$$ICD0ACT^IBACSV(+$P(Y,U,2),DGPROCDT)
53 . I Y["ICPT" S IBACT=$$CPTACT^IBACSV(+$P(Y,U,2),DGPROCDT)
54 . S DGCPTNEW=$P(Y,"^",3) ;Was the procedure just added?
55 . I DGCPTNEW,'IBACT D DELPROC Q
56 . I 'IBACT W !,*7,"Warning: Procedure code is inactive on this date",!
57 . I DGCPTNEW,$D(^UTILITY($J,"IB")),$$INPAT^IBCEF(IBIFN),Y["ICPT(" D DATA^IBCU74(Y)
58 . S DGADDVST=$S(DGCPTNEW:1,$D(DGADDVST):DGADDVST,1:0)
59 . N IBPRV,IBPRVO,IBPRVN
60 . S IBPRVO=$$MAINPRV^IBCEU(IBIFN),IBPRV=$P(IBPRVO,U,3),IBPRVN=(IBPRVO["IBA(355.93,"),IBPRV=$S(IBPRV="":"",'IBPRVN:$P(IBPRVO,U),1:"")
61 . I IBPRV="",'IBPRVN D
62 .. S IBPRV=0 F S IBPRV=$O(^DGCR(399,IBIFN,"CP",IBPRV)) S:'IBPRV IBPRV="" Q:'IBPRV S Z=$P($G(^(IBPRV,0)),U,18) I Z S IBPRV=$P($G(^VA(200,Z,0)),U) Q
63 . S DR="" I Y["ICPT" S DR="16"_$S(IBPRVN:";18///@",1:";18//"_IBPRV)_";6;5//"_$$DEFDIV(IBIFN)_";"
64 . S DR=".01;"_DR_$S(IBFT=2:"8;9;17//NO;",1:"")_3,DIE=DIC,(IBPROCP,DA)=+Y D ^DIE Q:'$D(DA)!($E($G(Y))=U)
65 . ;
66 . S DR=$$SPCUNIT(IBIFN,IBPROCP) I DR'="" D ^DIE ; miles/minutes/hours
67 . ;
68 . I IBFT=2 D
69 .. D DX^IBCU72(IBIFN,IBPROCP)
70 .. S X=$$ADDTNL(IBIFN,.DA)
71 . Q:$$INPAT^IBCEF(IBIFN) ;only outpatient bills
72 . ;add procedures to array for download to PCE: dgcpt(assoc clinic,cpt,'provider^first dx^modifiers',cnt)=""
73 . S DGPROC=$G(^DGCR(399,IBIFN,"CP",+DA,0))
74 . S X=$P(DGPROC,U,18)_U_+$G(^IBA(362.3,+$P(DGPROC,U,11),0))_U_$P(DGPROC,U,15)
75 . I 'DGCPTNEW,$P(DGPROC,"^",7)="" S DGCPTNEW=2
76 . I DGCPTUP,DGCPTNEW S DGCPT=DGCPT+1 I $P(DGPROC,"^",7) S DGCPT($P(DGPROC,"^",7),+DGPROC,X,DGCPT)=""
77 . ; add visit date to bill
78 . I DGADDVST S (X,DINUM)=DGPROCDT D VFILE1^IBCOPV1 K DINUM,X,DGNOADD,DGADDVST
79 ; Delete modifers with only a sequence #, no code
80 S Z=0 F S Z=$O(^DGCR(399,IBIFN,"CP",Z)) Q:'Z S Z0=0 F S Z0=$O(^DGCR(399,IBIFN,"CP",Z,"MOD",Z0)) Q:'Z0 I $P($G(^(Z0,0)),U,2)="" S DA(2)=IBIFN,DA(1)=Z,DA=Z0,DIK="^DGCR(399,"_DA(2)_",""CP"","_DA(1)_",""MOD""," D ^DIK
81 Q
82CODQ K %DT,DGPROC,DIC,DIE,DR,DGPROCDT,IBPROCP,DLAYGO
83 K IBFT,DGNOADD,DGADDVST,DGCPT,DGCPTUP,IBZTYPE,DGCPTNEW
84 Q
85 ;
86DELPROC ; Remove the selected procedure, because of inactive status (cancel selection)
87 W !!,*7,"The Procedure code is inactive on ",$$DAT1^IBOUTL(DGPROCDT),"."
88 W !,"Please select another Procedure."
89 S DA(1)=IBIFN,DA=+Y,DIK="^DGCR(399,"_IBIFN_",""CP"","
90 D ^DIK
91 Q
92 ;
93DELADD N Z,Z0,DA,DIK,X,Y
94 S DA(1)=IBIFN
95 ;Delete references to proc on rev codes
96 S Z=0 F S Z=$O(^DGCR(399,IBIFN,"RC",Z)) Q:'Z S Z0=$G(^(Z,0)) I Z0'="",$P(Z0,U,15)!$S($P(Z0,U,10)=3:$P(Z0,U,11),1:0) S DIE="^DGCR(399,"_DA(1)_",""RC"",",DA=Z,DR=".11///@;.15///@"_$S($P(Z0,U,8):"",1:";.08////1") D ^DIE
97 S DIK="^DGCR(399,"_DA(1)_",""CP""," F DA=0:0 S DA=$O(^DGCR(399,DA(1),"CP",DA)) Q:'DA D ^DIK
98 S DGRVRCAL=1
99 Q
100 ;
101DTMES ;Message if procedure date not in date range
102 Q:'$D(IBIFN) Q:'$D(^DGCR(399,IBIFN,"U")) S DGNODUU=^("U")
103 G:X'<$P(DGNODUU,"^")&(X'>$P(DGNODUU,"^",2)) DTMESQ
104 W *7,!!?3,"Date must be within STATEMENT COVERS FROM and STATEMENT COVERS TO period."
105 S Y=$P(DGNODUU,"^") X ^DD("DD")
106 W !?3,"Enter a date between ",Y," and " S Y=$P(DGNODUU,"^",2) X ^DD("DD") W Y,!
107 K X,Y
108DTMESQ K DGNODUU Q
109 ;
110CODHLP ;Display Additional Procedure codes
111 N I,J,Y,IBMOD
112 I '$O(^DGCR(399,IBIFN,"CP",0)) W !!?5,"No Codes Entered!",! Q
113 F I=0:0 S I=$O(^DGCR(399,IBIFN,"CP",I)) Q:'I S Y=$G(^(I,0)) S Z=$$PRCNM^IBCSCH1($P(Y,"^",1),$P(Y,"^",2)) W !?5,$E($P(Z,"^",2),1,28),?35,"- ",$P(Z,"^") D
114 . N IBY
115 . S IBY=$P(Y,U,2)
116 . S IBMOD=$$GETMOD^IBEFUNC(IBIFN,I,1)
117 . I IBMOD'="" S IBMOD="/"_IBMOD W IBMOD
118 . W ?60,"Date: " S Y=IBY D DT^DIQ
119 ;
120 K Z Q
121 ;
122DICV I $D(IBIFN),$D(^DGCR(399,IBIFN,0)),$P(^(0),U,9) S DIC("V")=$S($P(^(0),U,9)=9:"I +Y(0)=80.1",$P(^(0),U,9)=4!($P(^(0),U,9)=5):"I +Y(0)=81",1:"")
123 Q
124 ;
125DEFDIV(IBIFN) ; Find default division for bill IBIFN
126 Q $P($G(^DG(40.8,+$P($G(^DGCR(399,IBIFN,0)),U,22),0)),U)
127 ;
128ADDTNL(IBIFN,DA) ;
129 N DR,IBOK,X,Y,DIR
130 S IBOK=1
131 S DR="19;50.09;50.08" D ^DIE
132 I $D(Y) S IBOK=0 G ADDTNLQ
133 S DIR("B")="NO",DIR("A")="EDIT CMS-1500 SPECIAL PROGRAM FIELDS and BOX 19?: ",DIR("A",1)=" ",DIR(0)="YA"
134 S DIR("?",1)="Respond YES only if you need to add/edit data for chiropractic visits,"
135 S DIR("?")="EPSDT care, or if billing for HOSPICE and attending is not a hospice employee."
136 D ^DIR K DIR
137 I Y'=1 S IBOK=0 G ADDTNLQ
138 S DR="W !,"" <<EPSDT>>"";50.07;W !!,"" <<HOSPICE>>"";50.03;W !!,"" <<CHIROPRACTIC>>"";50.04;50.02;50.05;50.06"
139 D ^DIE
140 W !
141ADDTNLQ Q IBOK
142 ;
143XTRA1(Y) ;
144 K Y
145 Q
146 ;
147SPCUNIT(IBIFN,DA) ; return fields for special units if applicable, in DR form
148 N IB0,IBCPT,IBDR,IBCT,IBFT,DFN S IBDR=""
149 S IB0=$G(^DGCR(399,+$G(IBIFN),0)),IBCT=$P(IB0,U,27),IBFT=$P(IB0,U,19),DFN=$P(IB0,U,2)
150 S IBCPT=$G(^DGCR(399,+$G(IBIFN),"CP",+$G(DA),0)) I IBCPT'["ICPT" G SPCUNTQ
151 I +$$ITMUNIT^IBCRU4(+IBCPT,5,IBCT) S IBDR="15;" D SROMIN^IBCU74(IBIFN,DA) G SPCUNTQ ; minutes
152 I +$$ITMUNIT^IBCRU4(+IBCPT,4,IBCT) S IBDR="21;" G SPCUNTQ ; miles
153 I +$$ITMUNIT^IBCRU4(+IBCPT,6,IBCT) S IBDR="22//"_$$OBSHOUR^IBCU74(DFN,$P(IBCPT,U,2))_";" G SPCUNTQ ; hours
154 I +IBFT=2,$P($G(^IBE(353.2,+$P(IBCPT,U,10),0)),U,2)="ANESTHESIA" S IBDR="15;" ; minutes
155SPCUNTQ Q IBDR
Note: See TracBrowser for help on using the repository browser.