- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCU7.m
r613 r623 1 IBCU7 2 ;;2.0;INTEGRATED BILLING;**62,52,106,125,51,137,210,245,228,260,348,371**;21-MAR-94;Build 57 3 ;;Per VHA Directive 2004-038, this routine should not be modified.4 5 6 7 CHKX 8 9 10 11 12 13 14 15 CHKXQ 16 17 CODMUL 18 DELASK 19 20 21 22 CODDT 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 ASKCOD 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 CODQ 83 84 85 86 DELPROC 87 88 89 90 91 92 93 DELADD 94 95 96 97 98 99 100 101 DTMES 102 103 104 105 106 107 108 DTMESQ 109 110 CODHLP 111 112 113 114 115 116 117 118 119 120 121 122 DICV 123 124 125 DEFDIV(IBIFN) 126 127 128 ADDTNL(IBIFN,DA) 129 130 131 132 133 134 135 136 137 138 S DR="W !,"" <<EPSDT>>"";50.07;W !!,"" <<HOSPICE>>"";50.03"139 140 141 ADDTNLQ 142 143 XTRA1(Y) 144 145 146 147 SPCUNIT(IBIFN,DA) 148 149 150 151 152 153 154 155 SPCUNTQ 1 IBCU7 ;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 ; 7 CHKX ; -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,! 15 CHKXQ Q 16 ; 17 CODMUL ;Date oriented entry of procedure 18 DELASK 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 ; 22 CODDT 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 ; 37 ASKCOD 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 82 CODQ K %DT,DGPROC,DIC,DIE,DR,DGPROCDT,IBPROCP,DLAYGO 83 K IBFT,DGNOADD,DGADDVST,DGCPT,DGCPTUP,IBZTYPE,DGCPTNEW 84 Q 85 ; 86 DELPROC ; 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 ; 93 DELADD 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 ; 101 DTMES ;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 108 DTMESQ K DGNODUU Q 109 ; 110 CODHLP ;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 ; 122 DICV 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 ; 125 DEFDIV(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 ; 128 ADDTNL(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 ! 141 ADDTNLQ Q IBOK 142 ; 143 XTRA1(Y) ; 144 K Y 145 Q 146 ; 147 SPCUNIT(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 155 SPCUNTQ Q IBDR
Note:
See TracChangeset
for help on using the changeset viewer.
