- 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/IBCVA1.m
r613 r623 1 IBCVA1 2 ;;2.0;INTEGRATED BILLING;**52,80,109,51,137,210,349,371**;21-MAR-94;Build 57 3 4 5 6 7 8 4 9 10 11 EN4 12 INP 13 14 OCC 15 16 17 18 19 20 21 22 23 24 COND 25 26 27 28 29 30 31 32 33 34 5 35 36 EN5 37 38 REVC 39 40 41 42 43 44 SOCC 45 46 47 48 CONDN 49 50 51 PROCX 52 53 54 55 56 57 58 59 60 PROC 61 62 63 64 65 66 67 68 69 70 71 72 73 PROCQ 74 75 ALLPROC(IBIFN,IBPROC) 76 77 78 79 80 81 82 83 84 85 86 87 VC 88 89 90 91 . S IBVC(+IBY)=$P(IBZ,U,2)_U_$P(IBZ,U,1)_U_$S($P(IBY,U,2)="":"",+$P(IBZ,U,12):$J($P(IBY,U,2),0,2),1:$P(IBY,U,2))_U_$P(IBZ,U,12)92 93 94 SETMODS(IBMOD,IBZ,IBXSAVE) 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 1 IBCVA1 ;ALB/MJB - SET MCCR VARIABLES CONT. ;09 JUN 88 14:49 2 ;;2.0;INTEGRATED BILLING;**52,80,109,51,137,210,349**;21-MAR-94;Build 46 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 ;MAP TO DGCRVA1 6 ; 7 Q 8 4 ;Event variables set 9 D 1234^IBCVA 10 Q:'$D(IBBT) 11 EN4 I $E(IBBT,2)>2 G OCC 12 INP D INP^IBCSC4 13 ;NOTE (12/1/93): IBDI AND IBDIN ARRAYS WERE NOT UPDATED WITH NEW DX LOCATIONS BECAUSE THEY DO NOT SEEM TO BE USED ANYWHERE 14 OCC I $D(^DGCR(399,IBIFN,"C")) D 15 . N IBDATE,IBC 16 . S IBDATE=$$BDATE^IBACSV(IBIFN) ; The date of service 17 . S IBC=^DGCR(399,IBIFN,"C") 18 . F I=14:1:18 S IBDI(I)=$P(IBC,U,I) Q:IBDI(I)="" D 19 .. S IBDIN(I)=IBDI(I) 20 .. S IBDI(I)=$P($$ICD9^IBACSV(IBDI(I),IBDATE),U,3) 21 K IBO S:'$D(^DGCR(399,IBIFN,"OC")) IBO="" G:$D(IBO) COND S IBNO=$P(^DGCR(399,IBIFN,"OC",0),U,3),IBOC=0 22 S C=0 F I=0:1 S IBOC=$O(^DGCR(399,IBIFN,"OC",I)) Q:IBOC'?1N.N!(C=5) I $D(^DGCR(399,IBIFN,"OC",I)) S C=C+1 D SOCC 23 ; 24 COND S IBCC=0,D=0 F I=0:0 S IBCC=$O(^DGCR(399,IBIFN,"CC",IBCC)) Q:IBCC=""!(D=5) I $D(^DGCR(399,IBIFN,"CC",IBCC,0)) S D=D+1,IBCC(D)=$P(^DGCR(399,IBIFN,"CC",IBCC,0),"^",1) D CONDN 25 ; 26 D PROC 27 ; 28 ;Q:'$D(^DGCR(399,IBIFN,"C")) F I=0,"C" S IB(I)=$S($D(^DGCR(399,IBIFN,I)):^(I),1:"") 29 ;I $P(IB(0),"^",9)=4 F I=1:1:3 S:$P(IB("C"),"^",I)'="" IBCPT(I)=$P(IB("C"),"^",I) 30 ;I $P(IB(0),"^",9)=9 F I=4:1:6 S:$P(IB("C"),"^",I)'="" IBICD(I)=$P(IB("C"),"^",I) 31 ;I $P(IB(0),"^",9)=5 F I=7:1:9 S:$P(IB("C"),"^",I)]"" IBHC(I)=$P(IB("C"),"^",I),IBHCN(I)=$S($D(^ICPT(IBHC(I),0)):$P(^(0),"^",1),1:"") 32 Q 33 ; 34 5 ;Billing variables set 35 D 123^IBCVA 36 EN5 I '$D(IBIP) G REVC 37 S IBLS=$S($P(IB("U"),U,15)]"":$P(IB("U"),U,15),1:0),IBBS=$S($P(IB("U"),U,11)]"":$P(IB("U"),U,11),1:IBU) I IBBS'=IBU S IBBS=$P(^DGCR(399.1,IBBS,0),"^",1) 38 REVC S IBREV=0 F I=1:1 S IBREV=$O(^DGCR(399,IBIFN,"RC",IBREV)) Q:IBREV'?1.N S IBREVC(I)=^DGCR(399,IBIFN,"RC",IBREV,0) 39 S IBTF=$P(IB(0),U,26),IBTF=$S(IBTF=1:"ADMIT THRU DISCHARGE",IBTF=2:"FIRST CLAIM",IBTF=3:"CONTINUING CLAIM",IBTF=4:"LAST CLAIM",IBTF=5:"LATE CHARGE(S)",IBTF=6:"ADJUSTMENT",IBTF=7:"REPLACEMENT",IBTF=8:"CANCEL",IBTF=0:"ZERO CLAIM",1:"") 40 S IBBTP1=$E($$EXPAND^IBTRE(399,.24,$P(IB(0),U,24)),1,29) 41 S IBBTP2=$E($$EXPAND^IBTRE(399,.25,+$P(IB(0),U,25)),1,26) 42 S IBBTP3=IBTF 43 Q 44 SOCC S IBO(C)=$P(^DGCR(399,IBIFN,"OC",IBOC,0),"^",1),IBO(C)=$P(^DGCR(399.1,IBO(C),0),"^",2),IBOCN(C)=$P(^(0),"^",1) 45 S IBOCD(C)=$P(^DGCR(399,IBIFN,"OC",IBOC,0),"^",2),IBOCD2(C)=$P(^DGCR(399,IBIFN,"OC",IBOC,0),"^",4) Q 46 Q 47 ; 48 CONDN S IBCC(D)=$P($G(^DGCR(399.1,+IBCC(D),0)),U,2),IBCCN(D)=$P($G(^(0)),U,1) 49 Q 50 ; 51 PROCX ; Entrypoint from output formatter 52 N IBIFN,IBZ 53 S IBIFN=$G(IBXIEN) 54 D PROC 55 D F^IBCEF("N-PROCEDURE CODING METHD","IBZ",,IBIFN) 56 I IBZ="" K IBPROC S IBPROC=0 Q 57 S Z=0 F S Z=$O(IBPROC(Z)) Q:'Z I $P(IBPROC(Z),U)'[$S(IBZ=9:";ICD",1:";ICP") K IBPROC(Z) S IBPROC=IBPROC-1 58 Q 59 ; 60 PROC ; -build array of procedures in IBPROC 61 N IBHCFA,IBMOD,I,J,X,X1 62 S IBHCFA=($$FT^IBCEF(IBIFN)=2) 63 K IBPROC S IBPROC=0 64 I '$D(IB("C")) S IB("C")=$G(^DGCR(399,IBIFN,"C")) 65 S:'$D(IB(0)) IB(0)=$G(^DGCR(399,IBIFN,0)) S J=$P($G(IB(0)),"^",9) 66 I IB("C")'="" F I=1:1:9 I $P(IB("C"),"^",I)'="" S IBPROC(I)=$P(IB("C"),"^",I)_";"_$S(I<4:"ICPT(",I<7:"ICD0(",1:"ICPT(")_"^"_$P(IB("C"),"^",$S(I#3:10+(I#3),1:13)),IBPROC=IBPROC+1 67 I $D(^DGCR(399,IBIFN,"CP")) S X=0 F I=100:1 S X=$O(^DGCR(399,IBIFN,"CP",X)) Q:'X S X1=$G(^(X,0)) Q:'X1 D 68 . S IBMOD=$$GETMOD^IBEFUNC(IBIFN,X) 69 . I $TR(IBMOD,",")'="" S $P(X1,U,15)=IBMOD 70 . S IBPROC($S($P(X1,"^",4):$P(X1,"^",4),1:I))=X1 71 . I IBHCFA S IBPROC($S($P(X1,"^",4):$P(X1,"^",4),1:I),"AUX")=$G(^DGCR(399,IBIFN,"CP",X,"AUX")) 72 . S IBPROC=IBPROC+1 73 PROCQ Q 74 ; 75 ALLPROC(IBIFN,IBPROC) ; Returns all procedures for bill IBIFN in array IBPROC 76 ; IBPROC = # of procedures found 77 ; IBPROC(prnt order)=0-node of 'CP' entry with piece 15 = the 78 ; modifiers separated by commas 79 ; IBPROC(prnt order,"AUX")="AUX" node of 'CP' entry for CMS-1500 forms 80 ; Pass IBPROC by reference 81 ; 82 N IB 83 K IBPROC 84 D PROC 85 Q 86 ; 87 VC ;returns a bills value codes, IBIFN must be defined: IBVC=count,IBVC(VIFN)=CODE ^ NAME ^ VALUE ^ $$? 88 N IBY,IBX,IBZ S IBVC=0 Q:'$D(^DGCR(399,IBIFN,"CV")) 89 S IBX=0 F S IBX=$O(^DGCR(399,IBIFN,"CV",IBX)) Q:'IBX S IBY=$G(^DGCR(399,IBIFN,"CV",IBX,0)) I +IBY D 90 . S IBVC=IBVC+1,IBZ=$G(^DGCR(399.1,+IBY,0)) Q:IBZ="" 91 . S IBVC(+IBY)=$P(IBZ,U,2)_U_$P(IBZ,U,1)_U_$S(+$P(IBZ,U,12):$J($P(IBY,U,2),0,2),1:$P(IBY,U,2))_U_$P(IBZ,U,12) 92 Q 93 ; 94 SETMODS(IBMOD,IBZ,IBXSAVE) ; Set modifiers into IBXSAVE 95 ; IBMOD = the list of modifier iens for the proc, separated by commas 96 ; IBZ = the line counter to return the data in 97 ; 98 ; Output Formatter utility 99 ; 100 ; Variables passed by reference, returned 101 ; IBXSAVE("PROCMODS",IBZ) = Formatter 'save' array for modifiers 102 ; 103 N Q,IBQ 104 I $L(IBMOD) F Q=1:1:$L(IBMOD,",") I $P(IBMOD,",",Q)'="" D 105 . S IBQ=$$MOD^ICPTMOD(+$P(IBMOD,",",Q),"I") 106 . S IBXSAVE("PROCMODS",IBZ)=$G(IBXSAVE("PROCMODS",IBZ))_$P(IBQ,U,2)_"," 107 S Q=$L($G(IBXSAVE("PROCMODS",IBZ))) 108 I 'Q S IBXSAVE("PROCMODS",IBZ)="" 109 I Q S IBXSAVE("PROCMODS",IBZ)=$E(IBXSAVE("PROCMODS",IBZ),1,Q-1) 110 Q 111 ;
Note:
See TracChangeset
for help on using the changeset viewer.
