- IBCNS2 ;ALB/AAS - INSURANCE POLICY CALLS FROM FILE 399 DD ;22-JULY-91
- ;;2.0;INTEGRATED BILLING;**28,43,80,51,137,155,488,516**;21-MAR-94;Build 123
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- Q
- DD(IBX,IBDA,LEVEL) ; - called from input transform for field 111,112,113
- ; -- input ibx = x from input transform
- ; ibda = internal entry in 399
- ; level = 1=primary, 2=secondary, 3=tertiary
- ; -- output returns x=internal entry in 2.3121 (ins. Mult.) if valid
- ;
- N DFN,ACTIVE,INSDT
- D VAR
- S X=$$SEL(IBX,DFN,INSDT,ACTIVE)
- I +X<1 K X
- DDQ Q
- ;
- VAR S DFN=$P(^DGCR(399,IBDA,0),"^",2),ACTIVE=1,INSDT=$S(+$G(^DGCR(399,IBDA,"U")):+$G(^("U")),1:DT)
- Q
- ;
- SEL(IBX,DFN,INSDT,ACTIVE) ; -- Select insurance policy
- ; -- Input IBX = x from input transform
- ; DFN = patient
- ; INSDT = (optional) Active date of ins. (default = dt)
- ; ACTIVE = (optional) 1 if want active (default)
- ; = 2 if want all ins returned
- ;
- ; -- Output = pointer to 36 ^ pointer to 2.3121 ^ pointer to 355.3
- ;
- N I,J,Y,DA,DE,DQ,DR,DIC,DIE,DIR,DIV,IBSEL,IBDD,IBD
- S IBSEL=1,Y=""
- I '$G(ACTIVE) S ACTIVE=1
- S:'$G(INSDT) INSDT=DT
- I '$G(DFN) G SELQ
- D BLD
- ;
- ; -- call DIC to choose from list
- ;WCJ*IB*2.0*488;Display COB on picklist when partial match on more than one entry
- ;everything else should continue to work as before
- N IBOUT,IBSEL2
- S IBX=$$UP^XLFSTR(IBX)
- I IBX?1A.E D S IBX=$S($G(IBOUT):"^",$G(IBSEL2):IBSEL2,1:IBX)
- . N X,Y,ERROR,TARGET,I,G
- . ;IB*2.0*516/TAZ - Use HIPAA compliant fields
- . ;D LIST^DIC(2.312,","_DFN_",",".01;.2;3;8;1;16;.18;21",,9999,,IBX,,"I $D(IBDD(+Y))",,"TARGET","ERROR")
- . D LIST^DIC(2.312,","_DFN_",",".01;.2;3;8;7.02;16;.18;21",,9999,,IBX,,"I $D(IBDD(+Y))",,"TARGET","ERROR") ;516 - baa : add 7.02
- . I $D(ERROR) S IBOUT=1 Q ; should not hit this. used more during test
- . I '$D(TARGET) S IBOUT=1 Q ; no partial matches
- . I +$G(TARGET("DILIST",0))<2 Q ; only one match so work as before
- . D DSPTHM ; display them
- . S DIR(0)="N^1:"_+$G(TARGET("DILIST",0)) ;allow select of 1 to as many matches
- . D ^DIR
- . I $G(DIRUT) S IBOUT=1 Q ; user ^, timed out, or entered null
- . S IBX="`"_$G(TARGET("DILIST",2,+Y))
- . W !
- . Q
- ;WCJ*IB*2.0*488
- ;
- S X=IBX
- S DIC="^DPT("_DFN_",.312,",DIC(0)="EQMN"
- S DIC("S")="I $D(IBDD(+Y))" ; add not other selection
- S DIC("W")="W $P(^DIC(36,+^(0),0),U)_"" Group: ""_$$GRP^IBCNS($P(^DPT(DFN,.312,+Y,0),U,18))"
- D ^DIC
- SELQ Q +Y
- ;
- ;WCJ*IB*2.0*488;
- DSPTHM ; display the insurance companies and useful information
- W !,?4,"Insurance",?18,"COB",?23,"Subscriber ID",?37,"Group #",?49,"Eff Date",?62,"Exp Date"
- N I
- F I=1:1 Q:'$D(TARGET("DILIST","ID",I)) D
- . W !,I,?4,$E($G(TARGET("DILIST","ID",I,.01)),1,12)
- . W ?18,"(",$$LOW^XLFSTR($E($G(TARGET("DILIST","ID",I,.2)),1)),")"
- . ;IB*2.0*516/TAZ - Use HIPAA compliant fields
- . ;W ?23,$E($G(TARGET("DILIST","ID",I,1)),1,12)
- . W ?23,$E($G(TARGET("DILIST","ID",I,7.02)),1,12)
- . W ?37,$E($G(TARGET("DILIST","ID",I,21)),1,10)
- . W ?49,$G(TARGET("DILIST","ID",I,8))
- . W ?62,$G(TARGET("DILIST","ID",I,3))
- Q
- ;WCJ*IB*2.0*488;
- ;
- BLD K IBD,IBDD
- S (IBDD,IBCDFN)=0 F S IBCDFN=$O(^DPT(DFN,.312,IBCDFN)) Q:'IBCDFN I $D(^DPT(DFN,.312,IBCDFN,0)) D CHK(IBCDFN,ACTIVE,INSDT)
- Q
- ;
- CHK(IBCDFN,ACTIVE,INSDT) ; -- see if active
- N X,X1
- S X=$G(^DPT(DFN,.312,IBCDFN,0))
- S IBDD(IBCDFN)=+X_"^"_IBCDFN_"^"_$P(X,"^",18)
- I ACTIVE=2 G CHKQ
- S X1=$G(^DIC(36,+X,0)) I X1="" G CQ ;ins co entry doesn't exist
- I $P(X,"^",8) G:INSDT<$P(X,"^",8) CQ ;effective date later than care
- I $P(X,"^",4) G:INSDT>$P(X,"^",4) CQ ;care after expiration date
- I $P($G(^IBA(355.3,+$P(X,"^",18),0)),"^",11) G CQ ;plan is inactive
- G:$P(X1,"^",5) CQ ; ;ins company inactive
- ;G:$P(X1,"^",2)="N" CQ ; ;ins company will not reimburse
- G CHKQ
- CQ K IBDD(IBCDFN)
- CHKQ S:$D(IBDD(IBCDFN)) IBDD=IBDD+1,IBD(IBDD)=IBCDFN
- Q
- ;
- ;
- DDHELP(IBDA,LEVEL) ; -- Executable help
- ; -- write out list to choose from
- N DFN,ACTIVE,INSDT,I,IBINS
- D VAR,BLD
- ;
- I $G(IBDD)=0 W !,"No Insurance Policies to Select From" G DDHQ
- ;
- I '$D(IOM) D HOME^%ZIS
- N IBDTIN
- S IBDTIN=$G(INSDT)
- W ! D HDR^IBCNS
- S I=0 F S I=$O(IBD(I)) Q:'I D
- .;IB*2.0*516/TAZ - Use HIPAA compliant fields
- .;S IBINS=$G(^DPT(DFN,.312,$G(IBD(I)),0)) ; 516 - baa
- .S IBINS=$$ZND^IBCNS1(DFN,$G(IBD(I))) ; 516 - baa
- .D D1^IBCNS
- DDHQ Q
- ;
- TRANS(IBDA,Y) ; -- output transform
- N DFN,ACTIVE,INSDT
- D VAR
- S Y=$P($G(^DIC(36,+$P($G(^DPT(DFN,.312,+$G(Y),0)),U),0)),U)
- Q Y
- ;
- INSCO(IBDA,IBCDFN) ; -- return pointer value of 36 from pt. file
- N DFN,ACTIVE,INSDT
- D VAR
- S Y=+$G(^DPT(DFN,.312,IBCDFN,0))
- Q Y_$S(Y>0:"^"_$P($G(^DIC(36,+Y,0)),"^"),1:"")
- ;
- IX(DA,XREF) ; -- create i1, aic xrefs for fields 112, 113, 114
- ;
- ;IB*2.0*516/TAZ - Set up I17, I27 or I37 nodes
- N DFN
- S DFN=$P($G(^DGCR(399,DA,0)),"^",2)
- S ^DGCR(399,DA,XREF)=$$ZND^IBCNS1(DFN,X,399)
- I ",I1,I2,I3,"[(","_XREF_","),$G(^DPT(DFN,.312,+X,7))'="" S ^DGCR(399,DA,XREF_"7")=$G(^DPT(DFN,.312,+X,7))
- S ^DGCR(399,DA,"AIC",+$G(^DPT(DFN,.312,+X,0)))=""
- Q
- ;
- KIX(DA,XREF) ; -- kill logic for above xref
- K ^DGCR(399,DA,XREF)
- I ",I1,I2,I3,"[(","_XREF_",") K ^DGCR(399,DA,XREF_"7")
- K ^DGCR(399,DA,"AIC",+$G(^DPT($P($G(^DGCR(399,DA,0)),"^",2),.312,+X,0)))
- Q
- ;
- BPP(IBDA,IBMCR) ; Find Bill Payer Policy based on Payer Sequence and the P/S/T payers assigned to the bill,Ins Co must reimburse
- ; IBMCR = flag that says include MEDICARE WNR
- ; returns - Bill Payer Policy (ifn of policy entry in patient file)
- ; - null if either no Payer Sequence or there is no policy defined for the payer sequence
- ; or the policy defined by the payer sequence Will Not Reimburse and is not MEDICARE
- ;
- N IBI,IBX,IBY,IBP,IBC,IBM0 S IBX="",(IBP,IBC)=0
- S IBMCR=+$G(IBMCR)
- S IBY=$$COBN^IBCEF(+IBDA) I IBY S IBY=IBY+11
- I IBY S IBM0=$G(^DGCR(399,+IBDA,"M")),IBP=$P(IBM0,U,IBY)
- I IBP S IBY=IBY-11,(IBI,IBY)=$P(IBM0,U,IBY) I +IBY S IBC=$P($G(^DIC(36,+IBY,0)),U,2)
- I IBP,IBI,$S(IBC'="N":1,'IBMCR:0,1:$$MCRWNR^IBEFUNC(+IBY)) S IBX=IBP
- Q IBX
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNS2 6204 printed Jan 18, 2025@03:17:56 Page 2
- IBCNS2 ;ALB/AAS - INSURANCE POLICY CALLS FROM FILE 399 DD ;22-JULY-91
- +1 ;;2.0;INTEGRATED BILLING;**28,43,80,51,137,155,488,516**;21-MAR-94;Build 123
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- +4 QUIT
- DD(IBX,IBDA,LEVEL) ; - called from input transform for field 111,112,113
- +1 ; -- input ibx = x from input transform
- +2 ; ibda = internal entry in 399
- +3 ; level = 1=primary, 2=secondary, 3=tertiary
- +4 ; -- output returns x=internal entry in 2.3121 (ins. Mult.) if valid
- +5 ;
- +6 NEW DFN,ACTIVE,INSDT
- +7 DO VAR
- +8 SET X=$$SEL(IBX,DFN,INSDT,ACTIVE)
- +9 IF +X<1
- KILL X
- DDQ QUIT
- +1 ;
- VAR SET DFN=$PIECE(^DGCR(399,IBDA,0),"^",2)
- SET ACTIVE=1
- SET INSDT=$SELECT(+$GET(^DGCR(399,IBDA,"U")):+$GET(^("U")),1:DT)
- +1 QUIT
- +2 ;
- SEL(IBX,DFN,INSDT,ACTIVE) ; -- Select insurance policy
- +1 ; -- Input IBX = x from input transform
- +2 ; DFN = patient
- +3 ; INSDT = (optional) Active date of ins. (default = dt)
- +4 ; ACTIVE = (optional) 1 if want active (default)
- +5 ; = 2 if want all ins returned
- +6 ;
- +7 ; -- Output = pointer to 36 ^ pointer to 2.3121 ^ pointer to 355.3
- +8 ;
- +9 NEW I,J,Y,DA,DE,DQ,DR,DIC,DIE,DIR,DIV,IBSEL,IBDD,IBD
- +10 SET IBSEL=1
- SET Y=""
- +11 IF '$GET(ACTIVE)
- SET ACTIVE=1
- +12 if '$GET(INSDT)
- SET INSDT=DT
- +13 IF '$GET(DFN)
- GOTO SELQ
- +14 DO BLD
- +15 ;
- +16 ; -- call DIC to choose from list
- +17 ;WCJ*IB*2.0*488;Display COB on picklist when partial match on more than one entry
- +18 ;everything else should continue to work as before
- +19 NEW IBOUT,IBSEL2
- +20 SET IBX=$$UP^XLFSTR(IBX)
- +21 IF IBX?1A.E
- Begin DoDot:1
- +22 NEW X,Y,ERROR,TARGET,I,G
- +23 ;IB*2.0*516/TAZ - Use HIPAA compliant fields
- +24 ;D LIST^DIC(2.312,","_DFN_",",".01;.2;3;8;1;16;.18;21",,9999,,IBX,,"I $D(IBDD(+Y))",,"TARGET","ERROR")
- +25 ;516 - baa : add 7.02
- DO LIST^DIC(2.312,","_DFN_",",".01;.2;3;8;7.02;16;.18;21",,9999,,IBX,,"I $D(IBDD(+Y))",,"TARGET","ERROR")
- +26 ; should not hit this. used more during test
- IF $DATA(ERROR)
- SET IBOUT=1
- QUIT
- +27 ; no partial matches
- IF '$DATA(TARGET)
- SET IBOUT=1
- QUIT
- +28 ; only one match so work as before
- IF +$GET(TARGET("DILIST",0))<2
- QUIT
- +29 ; display them
- DO DSPTHM
- +30 ;allow select of 1 to as many matches
- SET DIR(0)="N^1:"_+$GET(TARGET("DILIST",0))
- +31 DO ^DIR
- +32 ; user ^, timed out, or entered null
- IF $GET(DIRUT)
- SET IBOUT=1
- QUIT
- +33 SET IBX="`"_$GET(TARGET("DILIST",2,+Y))
- +34 WRITE !
- +35 QUIT
- End DoDot:1
- SET IBX=$SELECT($GET(IBOUT):"^",$GET(IBSEL2):IBSEL2,1:IBX)
- +36 ;WCJ*IB*2.0*488
- +37 ;
- +38 SET X=IBX
- +39 SET DIC="^DPT("_DFN_",.312,"
- SET DIC(0)="EQMN"
- +40 ; add not other selection
- SET DIC("S")="I $D(IBDD(+Y))"
- +41 SET DIC("W")="W $P(^DIC(36,+^(0),0),U)_"" Group: ""_$$GRP^IBCNS($P(^DPT(DFN,.312,+Y,0),U,18))"
- +42 DO ^DIC
- SELQ QUIT +Y
- +1 ;
- +2 ;WCJ*IB*2.0*488;
- DSPTHM ; display the insurance companies and useful information
- +1 WRITE !,?4,"Insurance",?18,"COB",?23,"Subscriber ID",?37,"Group #",?49,"Eff Date",?62,"Exp Date"
- +2 NEW I
- +3 FOR I=1:1
- if '$DATA(TARGET("DILIST","ID",I))
- QUIT
- Begin DoDot:1
- +4 WRITE !,I,?4,$EXTRACT($GET(TARGET("DILIST","ID",I,.01)),1,12)
- +5 WRITE ?18,"(",$$LOW^XLFSTR($EXTRACT($GET(TARGET("DILIST","ID",I,.2)),1)),")"
- +6 ;IB*2.0*516/TAZ - Use HIPAA compliant fields
- +7 ;W ?23,$E($G(TARGET("DILIST","ID",I,1)),1,12)
- +8 WRITE ?23,$EXTRACT($GET(TARGET("DILIST","ID",I,7.02)),1,12)
- +9 WRITE ?37,$EXTRACT($GET(TARGET("DILIST","ID",I,21)),1,10)
- +10 WRITE ?49,$GET(TARGET("DILIST","ID",I,8))
- +11 WRITE ?62,$GET(TARGET("DILIST","ID",I,3))
- End DoDot:1
- +12 QUIT
- +13 ;WCJ*IB*2.0*488;
- +14 ;
- BLD KILL IBD,IBDD
- +1 SET (IBDD,IBCDFN)=0
- FOR
- SET IBCDFN=$ORDER(^DPT(DFN,.312,IBCDFN))
- if 'IBCDFN
- QUIT
- IF $DATA(^DPT(DFN,.312,IBCDFN,0))
- DO CHK(IBCDFN,ACTIVE,INSDT)
- +2 QUIT
- +3 ;
- CHK(IBCDFN,ACTIVE,INSDT) ; -- see if active
- +1 NEW X,X1
- +2 SET X=$GET(^DPT(DFN,.312,IBCDFN,0))
- +3 SET IBDD(IBCDFN)=+X_"^"_IBCDFN_"^"_$PIECE(X,"^",18)
- +4 IF ACTIVE=2
- GOTO CHKQ
- +5 ;ins co entry doesn't exist
- SET X1=$GET(^DIC(36,+X,0))
- IF X1=""
- GOTO CQ
- +6 ;effective date later than care
- IF $PIECE(X,"^",8)
- if INSDT<$PIECE(X,"^",8)
- GOTO CQ
- +7 ;care after expiration date
- IF $PIECE(X,"^",4)
- if INSDT>$PIECE(X,"^",4)
- GOTO CQ
- +8 ;plan is inactive
- IF $PIECE($GET(^IBA(355.3,+$PIECE(X,"^",18),0)),"^",11)
- GOTO CQ
- +9 ; ;ins company inactive
- if $PIECE(X1,"^",5)
- GOTO CQ
- +10 ;G:$P(X1,"^",2)="N" CQ ; ;ins company will not reimburse
- +11 GOTO CHKQ
- CQ KILL IBDD(IBCDFN)
- CHKQ if $DATA(IBDD(IBCDFN))
- SET IBDD=IBDD+1
- SET IBD(IBDD)=IBCDFN
- +1 QUIT
- +2 ;
- +3 ;
- DDHELP(IBDA,LEVEL) ; -- Executable help
- +1 ; -- write out list to choose from
- +2 NEW DFN,ACTIVE,INSDT,I,IBINS
- +3 DO VAR
- DO BLD
- +4 ;
- +5 IF $GET(IBDD)=0
- WRITE !,"No Insurance Policies to Select From"
- GOTO DDHQ
- +6 ;
- +7 IF '$DATA(IOM)
- DO HOME^%ZIS
- +8 NEW IBDTIN
- +9 SET IBDTIN=$GET(INSDT)
- +10 WRITE !
- DO HDR^IBCNS
- +11 SET I=0
- FOR
- SET I=$ORDER(IBD(I))
- if 'I
- QUIT
- Begin DoDot:1
- +12 ;IB*2.0*516/TAZ - Use HIPAA compliant fields
- +13 ;S IBINS=$G(^DPT(DFN,.312,$G(IBD(I)),0)) ; 516 - baa
- +14 ; 516 - baa
- SET IBINS=$$ZND^IBCNS1(DFN,$GET(IBD(I)))
- +15 DO D1^IBCNS
- End DoDot:1
- DDHQ QUIT
- +1 ;
- TRANS(IBDA,Y) ; -- output transform
- +1 NEW DFN,ACTIVE,INSDT
- +2 DO VAR
- +3 SET Y=$PIECE($GET(^DIC(36,+$PIECE($GET(^DPT(DFN,.312,+$GET(Y),0)),U),0)),U)
- +4 QUIT Y
- +5 ;
- INSCO(IBDA,IBCDFN) ; -- return pointer value of 36 from pt. file
- +1 NEW DFN,ACTIVE,INSDT
- +2 DO VAR
- +3 SET Y=+$GET(^DPT(DFN,.312,IBCDFN,0))
- +4 QUIT Y_$SELECT(Y>0:"^"_$PIECE($GET(^DIC(36,+Y,0)),"^"),1:"")
- +5 ;
- IX(DA,XREF) ; -- create i1, aic xrefs for fields 112, 113, 114
- +1 ;
- +2 ;IB*2.0*516/TAZ - Set up I17, I27 or I37 nodes
- +3 NEW DFN
- +4 SET DFN=$PIECE($GET(^DGCR(399,DA,0)),"^",2)
- +5 SET ^DGCR(399,DA,XREF)=$$ZND^IBCNS1(DFN,X,399)
- +6 IF ",I1,I2,I3,"[(","_XREF_",")
- IF $GET(^DPT(DFN,.312,+X,7))'=""
- SET ^DGCR(399,DA,XREF_"7")=$GET(^DPT(DFN,.312,+X,7))
- +7 SET ^DGCR(399,DA,"AIC",+$GET(^DPT(DFN,.312,+X,0)))=""
- +8 QUIT
- +9 ;
- KIX(DA,XREF) ; -- kill logic for above xref
- +1 KILL ^DGCR(399,DA,XREF)
- +2 IF ",I1,I2,I3,"[(","_XREF_",")
- KILL ^DGCR(399,DA,XREF_"7")
- +3 KILL ^DGCR(399,DA,"AIC",+$GET(^DPT($PIECE($GET(^DGCR(399,DA,0)),"^",2),.312,+X,0)))
- +4 QUIT
- +5 ;
- BPP(IBDA,IBMCR) ; Find Bill Payer Policy based on Payer Sequence and the P/S/T payers assigned to the bill,Ins Co must reimburse
- +1 ; IBMCR = flag that says include MEDICARE WNR
- +2 ; returns - Bill Payer Policy (ifn of policy entry in patient file)
- +3 ; - null if either no Payer Sequence or there is no policy defined for the payer sequence
- +4 ; or the policy defined by the payer sequence Will Not Reimburse and is not MEDICARE
- +5 ;
- +6 NEW IBI,IBX,IBY,IBP,IBC,IBM0
- SET IBX=""
- SET (IBP,IBC)=0
- +7 SET IBMCR=+$GET(IBMCR)
- +8 SET IBY=$$COBN^IBCEF(+IBDA)
- IF IBY
- SET IBY=IBY+11
- +9 IF IBY
- SET IBM0=$GET(^DGCR(399,+IBDA,"M"))
- SET IBP=$PIECE(IBM0,U,IBY)
- +10 IF IBP
- SET IBY=IBY-11
- SET (IBI,IBY)=$PIECE(IBM0,U,IBY)
- IF +IBY
- SET IBC=$PIECE($GET(^DIC(36,+IBY,0)),U,2)
- +11 IF IBP
- IF IBI
- IF $SELECT(IBC'="N":1,'IBMCR:0,1:$$MCRWNR^IBEFUNC(+IBY))
- SET IBX=IBP
- +12 QUIT IBX