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

IBCU1.m

Go to the documentation of this file.
  1. IBCU1 ;ALB/MRL - BILLING UTILITY ROUTINE (CONTINUED) ;01 JUN 88 12:00
  1. ;;2.0;INTEGRATED BILLING;**27,52,106,138,51,182,210,266,309,320,347,405,592,665**;21-MAR-94;Build 28
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. ;MAP TO DGCRU1
  1. ;
  1. ;procedure doesn't appear to be used (6/4/93), if it is used, what for??
  1. ;where would multiple provider numbers comde from? ARH
  1. ;BCH ;Blue Cross/Shield Help
  1. W ! S IB01=$P($G(^IBE(350.9,1,1)),"^",6)
  1. I IB01]"" W "CHOOSE FROM",!!?4,"1 - ",$P(IB01,"^",6) F IB00=2,3 I $P(IB01,"^",$S(IB00=2:14,1:15))]"" W !?4,IB00," - ",$P(IB01,"^",$S(IB00=2:14,1:15))
  1. W:IB01']"" "NO BLUE CROSS/SHIELD PROVIDER NUMBERS IDENTIFIED TO SELECT FROM!" W ! W:IB01]"" !,"OR " W "ENTER BLUE CROSS/SHIELD PROVIDER # (BETWEEN 3-13 CHARACTERS)",! K IB00,IB01 Q
  1. ;
  1. RCD ;Revenue Code Display
  1. Q:'$D(^DGCR(399,IBIFN,"RC"))
  1. W @IOF,!,"Revenue Code Listing",?34,"Units",?45,"Charge" W:$$FT^IBCEF(IBIFN)=3 ?56,"Non-Cov"
  1. S DGIFN=0 F IBI=0:0 S DGIFN=$O(^DGCR(399,IBIFN,"RC",DGIFN)) Q:'DGIFN I $D(^DGCR(399,IBIFN,"RC",DGIFN,0)) S Z=^(0) D DISRC
  1. W !
  1. I $D(DIC(0)) S DIC(0)=DIC(0)_"N"
  1. Q
  1. ;JWS;IB*2.0*665;US40781;changed ?4 to ?6 for display of >99 line count
  1. DISRC N Z0 W !?1,DGIFN,?6,$P(^DGCR(399.2,+Z,0),"^"),"-",$E($P(^DGCR(399.2,+Z,0),"^",2),1,19)
  1. I +$P(Z,U,6) W ?28,$P($$CPT^ICPTCOD(+$P(Z,U,6)),U,2)
  1. W ?36,$P(Z,"^",3),?40 S X=$P(Z,"^",2),X2="2$" D COMMA^%DTC W X
  1. I $$FT^IBCEF(IBIFN)=3,$P(Z,U,9)'="" S X=$P(Z,U,9),X2="2$" D COMMA^%DTC W ?51,X
  1. I $D(^DGCR(399.1,+$P(Z,"^",5),0)) W ?64,$E($P(^(0),"^"),1,15)
  1. I $S($P(Z,U,15):1,1:$P(Z,U,10)=3) D
  1. . W !,?5,"(Rx: ",$S($P(Z,U,11):$P($G(^IBA(362.4,$P(Z,U,11),0)),U),1:"Link Missing")," Procedure "_$S($P(Z,U,15):"#"_$P(Z,U,15)_" "_$$CPTNM^IBCRBH1(IBIFN,4,$P(Z,U,15)),1:"Link Missing"),")"
  1. Q
  1. ;
  1. RVCPRC(IBIFN,IBD0) ; returns 1 if CHAMPVA rate type + 2 if CMS-1500, 0 otherwise
  1. ; IBD0 - zero node of bill if available, not required
  1. N X S X=0
  1. I $G(IBD0)="" S IBD0=$G(^DGCR(399,+$G(IBIFN),0))
  1. I $P($G(^DGCR(399.3,+$P(IBD0,U,7),0)),U,1)="CHAMPVA" S X=X+1
  1. I $P(IBD0,U,19)=2 S X=X+2
  1. Q X
  1. ;
  1. ORDNXT(IFN) ;CALLED BY TRIGGER ON (362.3,.02) THAT SETS DX PRINT ORDER (362.3,.03),
  1. ;returns the highest print order used on the bill plus 3, returns 3 if no existing print order
  1. ;used for the default print order so that dx's can be printed in order of entry without any input by the user,
  1. ;3 is added to allow spaces for additions, changes, moves
  1. N X,Y S X="" I $D(^DGCR(399,+$G(IFN),0)) S X=3,Y=0 F S Y=$O(^IBA(362.3,"AO",+IFN,Y)) Q:'Y S X=Y+3
  1. Q X
  1. ;
  1. ORDDUP(ORD,DIFN) ;returns true if print order ORD is already defined for a bill (not same entry)
  1. N IBX,IBY S IBY=0
  1. I +$G(ORD) S IBX=$G(^IBA(362.3,+$G(DIFN),0)) I +IBX,+$P(IBX,U,3)'=ORD,$D(^IBA(362.3,"AO",+$P(IBX,U,2),+ORD)) S IBY=1
  1. Q IBY
  1. ;
  1. DXDUP(DX,DIFN,IFN) ;returns true if DX is already defined for a bill (not same entry)
  1. ;either DIFN or IFN can be passed, both are not needed, DIFN is needed during edit so can reenter the same dx
  1. N IBX,IBY S IBY=0 I +$G(DX),'$G(IFN) S IBX=$G(^IBA(362.3,+$G(DIFN),0)),IFN=+$P(IBX,U,2)
  1. I +$G(DX),$D(^IBA(362.3,"AIFN"_+IFN,+DX)),$O(^IBA(362.3,"AIFN"_+IFN,+DX,0))'=+$G(DIFN) S IBY=1
  1. Q IBY
  1. ;
  1. DXBSTAT(DIFN,IFN) ;returns a diagnosis' bill status (either DIFN or IFN can be passed, both are not needed)
  1. N IBX,IBY I '$G(IFN) S IBX=$G(^IBA(362.3,+$G(DIFN),0)),IFN=+$P(IBX,U,2)
  1. S IBY=+$P($G(^DGCR(399,+IFN,0)),U,13)
  1. Q IBY
  1. ;
  1. RXSTAT(DRUG,PIFN,FILLDT) ; returns status/definition of rx
  1. ; returns: ORIGINAL ^ RELEASED/RETURNED TO STOCK ^ DRUG DEA
  1. N IBX,IBY,IBZ,IBLN,IBNUM S IBLN="",DRUG=+$G(DRUG),PIFN=+$G(PIFN),FILLDT=+$G(FILLDT)
  1. ;
  1. S IBX=$$RXSEC^IBRXUTL($$FILE^IBRXUTL(PIFN,2),PIFN),IBZ="" I IBX'="",$P(IBX,U,2)=$G(FILLDT) D I IBZ'="" S $P(IBLN,U,2)=IBZ
  1. . S IBLN="ORG"
  1. . ;I +$G(^PS(59.7,1,49.99))<6 Q
  1. . I '$P(IBX,U,13) S IBZ="NR"
  1. . I +$P(IBX,U,15) S:IBZ'="" IBZ=IBZ_"-" S IBZ=IBZ_"RTS"
  1. ;
  1. I IBLN="" S IBNUM=$$RFLNUM^IBRXUTL(PIFN,FILLDT,1),IBX=$$ZEROSUB^IBRXUTL($$FILE^IBRXUTL(PIFN,2),PIFN,IBNUM),IBZ="" I IBX'="" D I IBZ'="" S $P(IBLN,U,2)=IBZ
  1. . ;I +$G(^PS(59.7,1,49.99))<6 Q
  1. . I '$P(IBX,U,18) S IBZ="NR"
  1. . I +$P(IBX,U,16) S:IBZ'="" IBZ=IBZ_"-" S IBZ=IBZ_"RTS"
  1. ;
  1. D ZERO^IBRXUTL(DRUG)
  1. S IBX=$G(^TMP($J,"IBDRUG",0)) I IBX'="" S IBY=$G(^TMP($J,"IBDRUG",DRUG,3)),IBZ="" D I IBZ'="" S $P(IBLN,U,3)=IBZ
  1. . I IBY["9" S IBZ="OTC"
  1. . I IBY["I" S:IBZ'="" IBZ=IBZ_"-" S IBZ=IBZ_"INV"
  1. . I IBY["S" S:IBZ'="" IBZ=IBZ_"-" S IBZ=IBZ_"SUP"
  1. . I IBY["N" S:IBZ'="" IBZ=IBZ_"-" S IBZ=IBZ_"NUT"
  1. K ^TMP($J,"IBDRUG")
  1. Q IBLN
  1. ;
  1. PRVLIC(NPIFN,IBDT,ARR,STIFN) ; returns the Provider License data from the New Person file active on a date
  1. ; Input: NPIFN = pointer to file 200, IBDT = date to check (if none passed then all returned)
  1. ; ARR = array pass by reference (optional), STIFN = state to return as value of function (optional)
  1. ; Output: ARR(X) = license state (ifn) ^ license ^ expiration date (200,541)
  1. ; return value = license data of state requested or if no state passed in then count found
  1. N IBX,IBY,IBLN,IBCNT S IBX=0,IBCNT=0 K ARR
  1. I +$G(NPIFN) S IBY=0 F S IBY=$O(^VA(200,NPIFN,"PS1",IBY)) Q:'IBY D
  1. . S IBLN=$G(^VA(200,NPIFN,"PS1",IBY,0))
  1. . I +$G(IBDT),+$P(IBLN,U,3),$P(IBLN,U,3)<IBDT Q
  1. . I +$G(STIFN),+STIFN=+IBLN S IBX=IBLN
  1. . S IBCNT=IBCNT+1,ARR(IBCNT)=IBLN
  1. S ARR=IBCNT I '$G(STIFN) S IBX=IBCNT
  1. Q IBX
  1. ;
  1. DELPR(IB,IBX) ; Deletes the corresponding RX proc when the RX pointer is
  1. ; deleted
  1. ; IB = the ien of the bill in file 399
  1. ; IBX = the ien of the entry in the procedure multiple to be deleted
  1. ;
  1. N DA,DIK,X,Y
  1. S DA(1)=IB,DA=IBX
  1. I $D(^DGCR(399,DA(1),"CP",DA,0)) S DIK="^DGCR(399,"_DA(1)_",""CP""," D ^DIK
  1. Q
  1. ;
  1. MODHLP(DA) ; Executable modifier help 399.042 .14
  1. ; DA = iens of the current entry DA(1) = file 399 ien
  1. ; DA = file 399.042 ien
  1. N Z,IBZ,DIC,IBDATE
  1. S IBDATE=$$BDATE^IBACSV(+$G(DA(1))) ; The date of service
  1. I $P($G(^DGCR(399,+$G(DA(1)),"RC",+$G(DA),0)),U,14)'="" S Z=$P(^(0),U,14) D
  1. . N Q
  1. . S Q=1
  1. . S IBZ(1)="Current modifier"_$S($P(Z,";",2)'="":"s are:",1:"is:")
  1. . I $P(Z,";")'="" S Q=Q+1,IBZ(Q)=" "_$P(Z,";")_" "_$P($$MOD^ICPTMOD($P(Z,";"),"E",IBDATE),U,3)
  1. . I $P(Z,";",2)'="" S Q=Q+1,IBZ(Q)=" "_$P(Z,";",2)_" "_$P($$MOD^ICPTMOD($P(Z,";",2),"E",IBDATE),U,3)
  1. . S Q=Q+1,IBZ(Q)=" "
  1. . D EN^DDIOL(.IBZ)
  1. ;
  1. S DIC="^DIC(81.3,",DIC(0)="E"
  1. S DIC("S")="I $$MODP^ICPTMOD($P($G(^DGCR(399,DA(1),""RC"",DA,0)),U,6),Y,""I"",IBDATE)>0"
  1. S DIC("W")="W ?14,$P($$MOD^ICPTMOD(Y,""I"",IBDATE),U,3)"
  1. D ^DIC
  1. Q
  1. ;
  1. QMED(IBRTN,IBIFN) ; DSS QuadraMed Interface: DSS/QuadraMed Available
  1. ; return 1 if QuadraMed Interface is On and available for the type of bill
  1. ; - routine must exist on the system (interface is 'On')
  1. ; Input: IBRTN = tag^routine, if it exists then Interface is 'On'
  1. ; IBIFN = Bill IFN, bill to check if appropriate for sending to QuadraMed
  1. ;
  1. N IBON S IBON=0
  1. I +$G(IBIFN),$G(IBRTN)'="",$T(@IBRTN)'="" S IBON=1
  1. Q IBON
  1. ;
  1. ATTREND(IBIFN,IBIFN1,FIELD) ; This function is called from Mumps Cross References in the claim file 399 and
  1. ; also the PROVIDER subfile 399.0222.
  1. ;
  1. ; IBIFN = IEN to claim file
  1. ; IBIFN1 = IEN to provider sub-file in claim file
  1. ; FIELD = Field in sub-file being modified (the triggering event). If field has no value, all 6 fields are
  1. ; possibly updated
  1. ;
  1. ; The following fields are the "triggering" events
  1. ; File 399
  1. ; #19 FORM TYPE - This triggers all 6 fields (122, 123, 124, 128, 129, 130).
  1. ;
  1. ; Sub-File 399.0222
  1. ; #.05 PRIMARY INS CO ID NUMBER triggers 122
  1. ; #.06 SECONDARY INS CO ID NUMBER triggers 123
  1. ; #.07 TERTIARY INS CO ID NUMBER triggers 124
  1. ; #.12 PRIM INS PROVIDER ID TYPE triggers 128
  1. ; #.13 SEC INS PROVIDER ID TYPE triggers 129
  1. ; #.14 TERT INS PROVIDER ID TYPE triggers 130
  1. ;
  1. ; The following fields are the ones being "triggered"
  1. ; #122 PRIMARY PROVIDER #
  1. ; #123 SECONDARY PROVIDER #
  1. ; #124 TERTIARY PROVIDER #
  1. ; #128 PRIMARY ID QUALIFER
  1. ; #129 SECONDARY ID QUALIFIER
  1. ; #130 TERTIARY ID QUALIFIER
  1. ;
  1. Q:$G(IBPRCOB) ; this is set when creating an MRA scondary claim. Don't want to be changing the data on
  1. ; a secondary claim
  1. ;
  1. N FT,DATA,I,PC,INS,IFUNC,ATTRENDD,IBDR
  1. S FT=$$FT^IBCEF(IBIFN)
  1. Q:'FT
  1. ;
  1. S IFUNC=$O(^DGCR(399,IBIFN,"PRV","B",$S(FT=3:4,1:3),""))
  1. I $G(IBIFN1),$G(IFUNC)'=IBIFN1 Q ; if called from subfile, quits if att/rend provider was not the one being modified
  1. S ATTRENDD=$S('$G(IFUNC):"",1:$G(^DGCR(399,IBIFN,"PRV",IFUNC,0)))
  1. ;
  1. ;JWS;IB*2.0*592;Dental form 7
  1. S PC=$S(FT=2:6,FT=3:8,FT=7:16,1:"") ; get the correct piece from the ins co dictionary
  1. Q:'+PC
  1. ;
  1. F I="I1","I2","I3" D
  1. . S INS=$P($G(^DGCR(399,IBIFN,I)),U)
  1. . Q:'+INS
  1. . Q:'$P($G(^DIC(36,INS,4)),U,PC)
  1. . D:I="I1"
  1. .. S:".05"[FIELD IBDR(399,IBIFN_",",122)=$S($P(ATTRENDD,U,5)]"":$P(ATTRENDD,U,5),1:"@")
  1. .. S:".12"[FIELD IBDR(399,IBIFN_",",128)=$S($P(ATTRENDD,U,12)]"":$P(ATTRENDD,U,12),1:"@")
  1. . D:I="I2"
  1. .. S:".06"[FIELD IBDR(399,IBIFN_",",123)=$S($P(ATTRENDD,U,6)]"":$P(ATTRENDD,U,6),1:"@")
  1. .. S:".13"[FIELD IBDR(399,IBIFN_",",129)=$S($P(ATTRENDD,U,13)]"":$P(ATTRENDD,U,13),1:"@")
  1. . D:I="I3"
  1. .. S:".07"[FIELD IBDR(399,IBIFN_",",124)=$S($P(ATTRENDD,U,7)]"":$P(ATTRENDD,U,7),1:"@")
  1. .. S:".14"[FIELD IBDR(399,IBIFN_",",130)=$S($P(ATTRENDD,U,14)]"":$P(ATTRENDD,U,14),1:"@")
  1. ;
  1. I $O(IBDR(0)) D FILE^DIE("","IBDR")
  1. Q