Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBCVA1

IBCVA1.m

Go to the documentation of this file.
  1. IBCVA1 ;ALB/MJB - SET MCCR VARIABLES CONT. ;09 JUN 88 14:49
  1. ;;2.0;INTEGRATED BILLING;**52,80,109,51,137,210,349,371**;21-MAR-94;Build 57
  1. ;;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;
  1. ;MAP TO DGCRVA1
  1. ;
  1. Q
  1. 4 ;Event variables set
  1. D 1234^IBCVA
  1. Q:'$D(IBBT)
  1. EN4 I $E(IBBT,2)>2 G OCC
  1. INP D INP^IBCSC4
  1. ;NOTE (12/1/93): IBDI AND IBDIN ARRAYS WERE NOT UPDATED WITH NEW DX LOCATIONS BECAUSE THEY DO NOT SEEM TO BE USED ANYWHERE
  1. OCC I $D(^DGCR(399,IBIFN,"C")) D
  1. . N IBDATE,IBC
  1. . S IBDATE=$$BDATE^IBACSV(IBIFN) ; The date of service
  1. . S IBC=^DGCR(399,IBIFN,"C")
  1. . F I=14:1:18 S IBDI(I)=$P(IBC,U,I) Q:IBDI(I)="" D
  1. .. S IBDIN(I)=IBDI(I)
  1. .. S IBDI(I)=$P($$ICD9^IBACSV(IBDI(I),IBDATE),U,3)
  1. 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
  1. 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
  1. ;
  1. 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
  1. ;
  1. D PROC
  1. ;
  1. ;Q:'$D(^DGCR(399,IBIFN,"C")) F I=0,"C" S IB(I)=$S($D(^DGCR(399,IBIFN,I)):^(I),1:"")
  1. ;I $P(IB(0),"^",9)=4 F I=1:1:3 S:$P(IB("C"),"^",I)'="" IBCPT(I)=$P(IB("C"),"^",I)
  1. ;I $P(IB(0),"^",9)=9 F I=4:1:6 S:$P(IB("C"),"^",I)'="" IBICD(I)=$P(IB("C"),"^",I)
  1. ;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:"")
  1. Q
  1. ;
  1. 5 ;Billing variables set
  1. D 123^IBCVA
  1. EN5 I '$D(IBIP) G REVC
  1. 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)
  1. 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)
  1. 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:"")
  1. S IBBTP1=$E($$EXPAND^IBTRE(399,.24,$P(IB(0),U,24)),1,29)
  1. S IBBTP2=$E($$EXPAND^IBTRE(399,.25,+$P(IB(0),U,25)),1,26)
  1. S IBBTP3=IBTF
  1. Q
  1. 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)
  1. S IBOCD(C)=$P(^DGCR(399,IBIFN,"OC",IBOC,0),"^",2),IBOCD2(C)=$P(^DGCR(399,IBIFN,"OC",IBOC,0),"^",4) Q
  1. Q
  1. ;
  1. CONDN S IBCC(D)=$P($G(^DGCR(399.1,+IBCC(D),0)),U,2),IBCCN(D)=$P($G(^(0)),U,1)
  1. Q
  1. ;
  1. PROCX ; Entrypoint from output formatter
  1. N IBIFN,IBZ
  1. S IBIFN=$G(IBXIEN)
  1. D PROC
  1. D F^IBCEF("N-PROCEDURE CODING METHD","IBZ",,IBIFN)
  1. I IBZ="" K IBPROC S IBPROC=0 Q
  1. 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
  1. Q
  1. ;
  1. PROC ; -build array of procedures in IBPROC
  1. N IBHCFA,IBMOD,I,J,X,X1
  1. S IBHCFA=($$FT^IBCEF(IBIFN)=2)
  1. K IBPROC S IBPROC=0
  1. I '$D(IB("C")) S IB("C")=$G(^DGCR(399,IBIFN,"C"))
  1. S:'$D(IB(0)) IB(0)=$G(^DGCR(399,IBIFN,0)) S J=$P($G(IB(0)),"^",9)
  1. 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
  1. 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
  1. . S IBMOD=$$GETMOD^IBEFUNC(IBIFN,X)
  1. . I $TR(IBMOD,",")'="" S $P(X1,U,15)=IBMOD
  1. . S IBPROC($S($P(X1,"^",4):$P(X1,"^",4),1:I))=X1
  1. . I IBHCFA S IBPROC($S($P(X1,"^",4):$P(X1,"^",4),1:I),"AUX")=$G(^DGCR(399,IBIFN,"CP",X,"AUX"))
  1. . S IBPROC=IBPROC+1
  1. PROCQ Q
  1. ;
  1. ALLPROC(IBIFN,IBPROC) ; Returns all procedures for bill IBIFN in array IBPROC
  1. ; IBPROC = # of procedures found
  1. ; IBPROC(prnt order)=0-node of 'CP' entry with piece 15 = the
  1. ; modifiers separated by commas
  1. ; IBPROC(prnt order,"AUX")="AUX" node of 'CP' entry for CMS-1500 forms
  1. ; Pass IBPROC by reference
  1. ;
  1. N IB
  1. K IBPROC
  1. D PROC
  1. Q
  1. ;
  1. VC ;returns a bills value codes, IBIFN must be defined: IBVC=count,IBVC(VIFN)=CODE ^ NAME ^ VALUE ^ $$?
  1. N IBY,IBX,IBZ S IBVC=0 Q:'$D(^DGCR(399,IBIFN,"CV"))
  1. 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
  1. . S IBVC=IBVC+1,IBZ=$G(^DGCR(399.1,+IBY,0)) Q:IBZ=""
  1. . 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)
  1. Q
  1. ;
  1. SETMODS(IBMOD,IBZ,IBXSAVE) ; Set modifiers into IBXSAVE
  1. ; IBMOD = the list of modifier iens for the proc, separated by commas
  1. ; IBZ = the line counter to return the data in
  1. ;
  1. ; Output Formatter utility
  1. ;
  1. ; Variables passed by reference, returned
  1. ; IBXSAVE("PROCMODS",IBZ) = Formatter 'save' array for modifiers
  1. ;
  1. N Q,IBQ
  1. I $L(IBMOD) F Q=1:1:$L(IBMOD,",") I $P(IBMOD,",",Q)'="" D
  1. . S IBQ=$$MOD^ICPTMOD(+$P(IBMOD,",",Q),"I")
  1. . S IBXSAVE("PROCMODS",IBZ)=$G(IBXSAVE("PROCMODS",IBZ))_$P(IBQ,U,2)_","
  1. S Q=$L($G(IBXSAVE("PROCMODS",IBZ)))
  1. I 'Q S IBXSAVE("PROCMODS",IBZ)=""
  1. I Q S IBXSAVE("PROCMODS",IBZ)=$E(IBXSAVE("PROCMODS",IBZ),1,Q-1)
  1. Q
  1. ;