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