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 Oct 16, 2024@18:21:15 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
