- 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 Jan 18, 2025@03:13:48 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