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