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

IBCEU4.m

Go to the documentation of this file.
  1. IBCEU4 ;ALB/TMP - EDI UTILITIES ;02-OCT-96
  1. ;;2.0;INTEGRATED BILLING;**51,137,210,155,290,403,461,665**;21-MAR-94;Build 28
  1. ;;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;
  1. TESTFLD ; Entrypoint to call to test the output the formatter will
  1. ; produce for a specific entry in file 364.7
  1. ;
  1. N X,Y,DIC,IBCT
  1. K IBXDATA,IBXSAVE
  1. S IBCT=0
  1. F W !,$S(IBCT:"Another ",1:""),"Bill: " S DIC="^DGCR(399,",DIC(0)="AEMQ" D ^DIC Q:Y<0 D
  1. . S IBCT=1
  1. . K ^TMP($J),^TMP("IBXSAVE",$J),^TMP("IBXDATA",$J),IBXSAVE,IBXDATA
  1. . D FLDS(+Y)
  1. . F R !!,"VARIABLE TO DISPLAY (IBXDATA): ",X:DTIME Q:X["^" S:X="" X="IBXDATA" D
  1. .. I $S($E(X,$L(X))'=")"&($L(X,"(")>1):1,1:$L(X,"(")'=$L(X,")")) W !,"BAD VARIABLE NAME" Q
  1. .. I '$D(@X) W " *** NO DATA TO DISPLAY" Q
  1. .. N S S S=X
  1. .. W !,X," = ",$G(@X)
  1. .. F S X=$Q(@X) Q:X'[S W !,X," = ",@X
  1. .. W !
  1. Q
  1. ;
  1. FLDS(IBIFN) ; Extract fields for bill IBIFN
  1. N X,Y,DIC,IB1,IBI,IBAR,IBXPG,IBXLN,IBXCOL,IBXREC,Z,Z0
  1. W !,"Remember to run this for flds that set up pre-requisite data (if any) first",!
  1. ;
  1. S IB1=1
  1. F W !,$S('IB1:"Another ",1:""),"Form Field: " S DIC="^IBA(364.7,",DIC(0)="AEMQZ" D ^DIC Q:Y<0 D
  1. . S IB1=0
  1. . N IBZXX,IBXIEN
  1. . ; Execute data element logic for fld
  1. . S IBI=+Y,Z=$P($G(^IBA(364.5,+$P(Y(0),U,3),0)),U)
  1. . S Z0=$G(^IBA(364.6,+Y(0),0))
  1. . S IBAR=$G(^IBA(364.5,+$P(Y(0),U,3),2)) S:IBAR="" IBAR="IBXDATA"
  1. . S IBXPG=$P(Z0,U,4),IBXLN=$P(Z0,U,5),IBXCOL=$P(Z0,U,8),IBXREC=1
  1. . D F^IBCEF(Z,"IBZXX","",IBIFN)
  1. . Q:'$D(IBZXX)
  1. . K @IBAR
  1. . M @IBAR=IBZXX
  1. . I $G(^IBA(364.7,IBI,1))'="" S IBXIEN=IBIFN X ^IBA(364.7,IBI,1)
  1. . D CLEAN^DILF
  1. Q
  1. ;
  1. DATE(X) ; Convert date in YYYYMMDD or YYMMDD format to MM DD YYYY or MM DD YY
  1. N Z
  1. S Z=X
  1. I $L(X)=8 S Z=$E(X,5,6)_" "_$E(X,7,8)_" "_$E(X,1,4)
  1. I $L(X)=6 S Z=$E(X,3,4)_" "_$E(X,5,6)_" "_$E(X,1,2)
  1. Q Z
  1. ;
  1. MCRSPEC(IBIFN,MCR,IBPIEN) ; Returns specialty code for a provider on bill
  1. ; IBIFN = bill ien (file 399)
  1. ; MCR = 1 if 2-digit MCR code should be returned 0 or null=3 digit code
  1. ; IBPIEN = vp of the provider for which to get the
  1. ; specialty, otherwise it returns specialty code for the 'required'
  1. ; provider on bill (default is file 200 if no file designated)
  1. ;
  1. N IBZ,IBDT
  1. S IBZ="99" ;default if none found
  1. S IBDT=$P($G(^DGCR(399,+IBIFN,"U")),U,1) ; use statement from date
  1. I '$G(IBPIEN) D F^IBCEF("N-SPECIALTY CODE","IBZ",,IBIFN)
  1. I $G(IBPIEN) S:$P(IBPIEN,";",2)="" IBPIEN=IBPIEN_";VA(200," S IBZ=$$SPEC^IBCEU(IBPIEN,IBDT)
  1. I '$G(MCR) S IBZ="0"_IBZ
  1. Q IBZ
  1. ;
  1. ECODE(IBP,CD) ; Function returns 1 if procedure ien IBP is an E-code (in ICD-9 only)
  1. ; Added some code to handle ICD-10. While they no longer start with E, they are still (E)xternal Cause of Injury codes
  1. ; CD = returned = the external code, if passed by reference
  1. N Q,Z,IBZ S IBZ=0
  1. S Z=$$ICD9^IBACSV(+IBP),CD=$P(Z,U,1)
  1. I $E(Z)="E",$P(Z,U,19)'=30 S IBZ=1
  1. I "VWXY"[$E(Z),$P(Z,U,19)=30 S IBZ=1 ;WCJ;IB*2.0*665
  1. Q IBZ
  1. ;
  1. BOX82NM(IBIFN,IBZSAVE) ; Returns the data to be printed in form locators 82
  1. ; and 83 on the UB92 for bill ien IBIFN, based on the providers on the
  1. ; bill
  1. ; Pass array IBZSAVE by reference
  1. N Z,IBZ,IBCT
  1. ;
  1. D F^IBCEF("N-ALL PROVIDERS","IBZ",,IBIFN)
  1. F Z=1:1:6 S IBZSAVE("PRV-82",Z)=""
  1. ; Find Providers and store them (if found) in this order:
  1. ; Attending/Rendering, Operating, Referring, Other
  1. F Z=4,2,1,9 D
  1. . S IBCT=$S(Z=4:0,1:IBCT) Q:IBCT>4
  1. . I Z=4,$$FT^IBCEF(IBIFN)=2 S Z=3 ; Find rendering for HCFA 1500
  1. . I $S(Z=4!(Z=3):0,1:'$O(IBZ(Z,0))) Q
  1. . S IBCT=IBCT+1
  1. . I Z=4,$G(IBZ(4,1))="",$$FT^IBCEF(IBIFN)=3,'$D(^DGCR(399,IBIFN,"PRV")) S IBZ(Z,1)="DEPT OF VETERANS AFFAIRS" ;Default for old bills w/o prv
  1. . I $O(IBZ(Z,1,1)) S IBZSAVE("PRV-82",IBCT)=$G(IBZ(Z,1,2))_" "_$G(IBZ(Z,1,3))
  1. . S IBCT=IBCT+1,IBZSAVE("PRV-82",IBCT)=$P($G(IBZ(Z,1,1)),U)_" "_$P($G(IBZ(Z,1)),U)
  1. Q
  1. ;
  1. STATOK(IBIFN,VALST) ; Returns 1 if status of bill IBIFN is one of the valid
  1. ; status codes in VALST
  1. N OK,Z
  1. S OK=0
  1. I $G(VALST)'="" S OK=$L(VALST,$P($G(^DGCR(399,IBIFN,0)),U,13))>1
  1. Q OK
  1. ;
  1. RXPRLOOK(IBX) ; Do a FM lookup of procedures for RX that can be linked
  1. ; to a specific revenue code (ones that are not already soft-linked)
  1. ; Function returns ien of the 'CP' node multiple for the selected proc
  1. ; OR "" if none selected or selection is invalid
  1. ;
  1. ; IBX = the procedure code
  1. ;
  1. N IBZ,IBMAX,IBEACH,IBMANY,IBHLP,IBNEXT,Z
  1. S IBMAX=50,IBEACH=5,IBHLP=0
  1. K ^TMP("DILIST",$J),^TMP("DIERR",$J),^TMP("DIHELP",$J),^TMP("IBLIST",$J)
  1. ;
  1. S IBZ=IBX
  1. I IBX?1"?".E,'$D(DIQUIET) D
  1. . I IBX?2"?".E S IBMAX=50,IBEACH=20 D RXPRHLP(IBMAX,.IBNEXT) S IBHLP=1
  1. . S IBX=""
  1. . ;
  1. I IBX'="" D
  1. . S:$L(IBX)<5 IBX="`"_IBX
  1. . D FIND^DIC(399.0304,","_DA(1)_",","@;.01E","A",IBX,IBMAX,,"I '$$LINKED^IBCEU4(.DA,Y)")
  1. . D XFER(0)
  1. ;
  1. S IBMANY=($G(^TMP("IBLIST",$J,0))>1)
  1. I IBMANY D ;More than one match found
  1. . I $D(DIQUIET) S ^TMP("IBLIST",$J,0)=0,IBX="" Q
  1. . N IB1,IB2,IBSEL,IBGOT,IBCNT,Q,Q1
  1. . S (IBGOT,IB1,IB2)=0
  1. . F S IB1=$O(^TMP("IBLIST",$J,2,IB1)) Q:'IB1 D Q:IBGOT
  1. .. S IB2=IB2+1
  1. .. S Q=$J("",5)_$S('IBHLP:$E(IB2_$J("",5),1,5),1:"")_^TMP("IBLIST",$J,2,IB1)
  1. .. F Q1=0:0 S Q1=$O(^TMP("IBLIST",$J,"ID",IB1,Q1)) Q:'Q1 D
  1. ... I $G(^TMP("IBLIST",$J,"ID",IB1,Q1))'="" S Q=Q_" "_^TMP("IBLIST",$J,"ID",IB1,Q1) Q
  1. ... I $G(^TMP("IBLIST",$J,"ID",IB1,Q1,"E"))'="" S Q=Q_" "_^TMP("IBLIST",$J,"ID",IB1,Q1,"E")
  1. .. S IBSEL($S(IB2#IBEACH:IB2#IBEACH,1:IBEACH))=Q
  1. .. I '$O(^TMP("IBLIST",$J,2,IB1))!'(IB1#IBEACH) D
  1. ... M DIR("A")=IBSEL K IBSEL
  1. ... I 'IBHLP D
  1. .... S:$O(^TMP("IBLIST",$J,2,IB1)) DIR("A",6)="Press <RETURN> to see more, '^' to exit this list, OR"
  1. .... S DIR("A")="SELECT 1-"_IB2_": "
  1. .... S DIR(0)="NAO^1:"_IB2_":0"
  1. .... S DIR("?")="Enter your selection for procedure from 1 to "_IB2
  1. ... I IBHLP D
  1. .... I $S(IB2'=+$G(^TMP("IBLIST",$J,0)):1,1:$P($G(^(0)),U,3)) S DIR("A")="'^' TO STOP: ",DIR(0)="EA" Q
  1. .... S Z=0 F S Z=$O(DIR("A",Z)) Q:'Z W !,DIR("A",Z)
  1. .... S Y="^" K DIR W ! Q
  1. ... I $D(DIR("A")) D ^DIR K DIR
  1. ... I IBHLP S Y=$S(Y=1:"",1:"^")
  1. ... I Y="" D Q
  1. .... I $O(^TMP("IBLIST",$J,2,IB1)) Q
  1. .... S IBX=""
  1. .... W:'IBHLP !
  1. .... I $P($G(^TMP("IBLIST",$J,0)),U,3),IB1'<IBMAX D
  1. ..... I 'IBHLP W !!,"There were more than ",IBMAX," matches found. Please try again with more specific input",! Q
  1. ..... D RXPRHLP(IBMAX,.IBNEXT)
  1. ... I Y["^" S IBX="",IBGOT=1 Q
  1. ... I Y>0 S IBGOT=1,IBX=$G(^TMP("IBLIST",$J,2,+Y)) D RECALL^DILFD(399.0304,+IBX_",",DUZ)
  1. . I 'IBGOT S ^TMP("IBLIST",$J,0)=0
  1. I 'IBMANY,$G(^TMP("IBLIST",$J,0)) D
  1. . N Q,Q1
  1. . S Q=^TMP("IBLIST",$J,2,1)
  1. . F Q1=0:0 S Q1=$O(^TMP("IBLIST",$J,"ID",1,Q1)) Q:'Q1 D
  1. .. I $G(^TMP("IBLIST",$J,"ID",1,Q1))'="" S Q=Q_" "_^TMP("IBLIST",$J,"ID",1,Q1) Q
  1. .. I $G(^TMP("IBLIST",$J,"ID",1,Q1,"E"))'="" S Q=Q_" "_^TMP("IBLIST",$J,"ID",1,Q1,"E")
  1. . D EN^DDIOL($J("",16)_Q) S IBX=$G(^TMP("IBLIST",$J,2,1)) D RECALL^DILFD(399.0304,+IBX_",",DUZ)
  1. ;
  1. D CLEAN^DILF
  1. K ^TMP("IBLIST",$J)
  1. Q IBX
  1. ;
  1. RXPRHLP(IBMAX,IBNEXT) ; Get list for ?? help
  1. ;
  1. ; IBMAX = The maximum # of entries to extract at once
  1. ; IBNEXT = Contains the value of the index to start at
  1. ;
  1. N IBQ,IBZ
  1. S IBQ=+$O(^TMP("IBLIST",$J,2,""),-1),IBZ=","_DA(1)_","
  1. D LIST^DIC(399.0304,IBZ,"@;.01EI;1E",,IBMAX,.IBNEXT,,"B","I '$$LINKED^IBCEU4(.DA,Y)"),XFER(IBQ)
  1. Q
  1. ;
  1. LINKED(DA,Y) ; Function returns 1 if proc already linked to an RX rev code
  1. ; DA = the DA array from the RC multiple
  1. ; Y = the ien of the CP multiple
  1. N Z
  1. S Z=+$O(^DGCR(399,DA(1),"RC","ACP",Y,0))
  1. Q $S(Z:Z'=DA,1:0)
  1. ;
  1. XFER(IBQ) ; Transfer DILIST to IBLIST array
  1. ; IBQ = the number of entries already found
  1. N Z,IBZ
  1. S (Z,IBZ)=0
  1. F S Z=$O(^TMP("DILIST",$J,2,Z)) Q:'Z S IBZ=IBZ+1,^TMP("IBLIST",$J,2,IBZ+IBQ)=^TMP("DILIST",$J,2,Z) M ^TMP("IBLIST",$J,"ID",IBZ+IBQ)=^TMP("DILIST",$J,"ID",Z)
  1. ;
  1. I $D(^TMP("DILIST",$J,0)) S ^TMP("IBLIST",$J,0)=^TMP("DILIST",$J,0)
  1. S $P(^TMP("IBLIST",$J,0),U)=IBQ+IBZ
  1. Q
  1. ;
  1. NOREV(DA,IBRX) ; Returns 1 if no other revenue code on bill DA(1)
  1. ; is linked to prescription entry IBRX
  1. N X,Z
  1. S X=1,Z=0 F S Z=$O(^DGCR(399,DA(1),"RC",Z)) Q:'Z I DA'=Z,$P($G(^(Z,0)),U,11)=IBRX S X=0 Q
  1. Q X
  1. ;
  1. ASKRX(DA) ; Returns the selected RX entry in file 362.4
  1. N DIR,X,Y
  1. S DIR(0)="PAO^IBA(362.4,"
  1. S DIR("A")=" RX: ",DIR("B")=$P($G(^IBA(362.4,+$P($G(^DGCR(399,DA(1),"RC",DA,0)),U,11),0)),U)
  1. S DIR("S")="I $P(^(0),U,2)=DA(1),$$NOREV^IBCEU4(.DA,Y)"
  1. D ^DIR K DIR
  1. Q $S(Y>0:+Y,1:"")
  1. ;
  1. SLF(IBIFN) ; Returns 1 if Attending/Rendering provider id is SLF000
  1. N IB,IBZ
  1. S IB=0
  1. D F^IBCEF("N-ATT/REND PROVIDER ID","IBZ",,IBIFN)
  1. S:$G(IBZ)="SLF000" IB=1
  1. Q IB
  1. ;
  1. GETPOA(IBDX,PRTFLG) ; returns POA indicator for a given DX
  1. ; IBDX - ien in file 362.3
  1. ; PRTFLG - 1 if POA is fetched for printed form, 0 otherwise
  1. N POA
  1. S POA=""
  1. S:+IBDX>0 POA=$P($G(^IBA(362.3,IBDX,0)),U,4)
  1. ; on UB-04 print "" instead of "1" for blank.
  1. I PRTFLG,POA="1" S POA=""
  1. Q POA