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

IBCNS2.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. Q
  1. DD(IBX,IBDA,LEVEL) ; - called from input transform for field 111,112,113
  1. ; -- input ibx = x from input transform
  1. ; ibda = internal entry in 399
  1. ; level = 1=primary, 2=secondary, 3=tertiary
  1. ; -- output returns x=internal entry in 2.3121 (ins. Mult.) if valid
  1. ;
  1. N DFN,ACTIVE,INSDT
  1. D VAR
  1. S X=$$SEL(IBX,DFN,INSDT,ACTIVE)
  1. I +X<1 K X
  1. DDQ Q
  1. ;
  1. VAR S DFN=$P(^DGCR(399,IBDA,0),"^",2),ACTIVE=1,INSDT=$S(+$G(^DGCR(399,IBDA,"U")):+$G(^("U")),1:DT)
  1. Q
  1. ;
  1. SEL(IBX,DFN,INSDT,ACTIVE) ; -- Select insurance policy
  1. ; -- Input IBX = x from input transform
  1. ; DFN = patient
  1. ; INSDT = (optional) Active date of ins. (default = dt)
  1. ; ACTIVE = (optional) 1 if want active (default)
  1. ; = 2 if want all ins returned
  1. ;
  1. ; -- Output = pointer to 36 ^ pointer to 2.3121 ^ pointer to 355.3
  1. ;
  1. N I,J,Y,DA,DE,DQ,DR,DIC,DIE,DIR,DIV,IBSEL,IBDD,IBD
  1. S IBSEL=1,Y=""
  1. I '$G(ACTIVE) S ACTIVE=1
  1. S:'$G(INSDT) INSDT=DT
  1. I '$G(DFN) G SELQ
  1. D BLD
  1. ;
  1. ; -- call DIC to choose from list
  1. ;WCJ*IB*2.0*488;Display COB on picklist when partial match on more than one entry
  1. ;everything else should continue to work as before
  1. N IBOUT,IBSEL2
  1. S IBX=$$UP^XLFSTR(IBX)
  1. I IBX?1A.E D S IBX=$S($G(IBOUT):"^",$G(IBSEL2):IBSEL2,1:IBX)
  1. . N X,Y,ERROR,TARGET,I,G
  1. . ;IB*2.0*516/TAZ - Use HIPAA compliant fields
  1. . ;D LIST^DIC(2.312,","_DFN_",",".01;.2;3;8;1;16;.18;21",,9999,,IBX,,"I $D(IBDD(+Y))",,"TARGET","ERROR")
  1. . 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
  1. . I $D(ERROR) S IBOUT=1 Q ; should not hit this. used more during test
  1. . I '$D(TARGET) S IBOUT=1 Q ; no partial matches
  1. . I +$G(TARGET("DILIST",0))<2 Q ; only one match so work as before
  1. . D DSPTHM ; display them
  1. . S DIR(0)="N^1:"_+$G(TARGET("DILIST",0)) ;allow select of 1 to as many matches
  1. . D ^DIR
  1. . I $G(DIRUT) S IBOUT=1 Q ; user ^, timed out, or entered null
  1. . S IBX="`"_$G(TARGET("DILIST",2,+Y))
  1. . W !
  1. . Q
  1. ;WCJ*IB*2.0*488
  1. ;
  1. S X=IBX
  1. S DIC="^DPT("_DFN_",.312,",DIC(0)="EQMN"
  1. S DIC("S")="I $D(IBDD(+Y))" ; add not other selection
  1. S DIC("W")="W $P(^DIC(36,+^(0),0),U)_"" Group: ""_$$GRP^IBCNS($P(^DPT(DFN,.312,+Y,0),U,18))"
  1. D ^DIC
  1. SELQ Q +Y
  1. ;
  1. ;WCJ*IB*2.0*488;
  1. DSPTHM ; display the insurance companies and useful information
  1. W !,?4,"Insurance",?18,"COB",?23,"Subscriber ID",?37,"Group #",?49,"Eff Date",?62,"Exp Date"
  1. N I
  1. F I=1:1 Q:'$D(TARGET("DILIST","ID",I)) D
  1. . W !,I,?4,$E($G(TARGET("DILIST","ID",I,.01)),1,12)
  1. . W ?18,"(",$$LOW^XLFSTR($E($G(TARGET("DILIST","ID",I,.2)),1)),")"
  1. . ;IB*2.0*516/TAZ - Use HIPAA compliant fields
  1. . ;W ?23,$E($G(TARGET("DILIST","ID",I,1)),1,12)
  1. . W ?23,$E($G(TARGET("DILIST","ID",I,7.02)),1,12)
  1. . W ?37,$E($G(TARGET("DILIST","ID",I,21)),1,10)
  1. . W ?49,$G(TARGET("DILIST","ID",I,8))
  1. . W ?62,$G(TARGET("DILIST","ID",I,3))
  1. Q
  1. ;WCJ*IB*2.0*488;
  1. ;
  1. BLD K IBD,IBDD
  1. 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)
  1. Q
  1. ;
  1. CHK(IBCDFN,ACTIVE,INSDT) ; -- see if active
  1. N X,X1
  1. S X=$G(^DPT(DFN,.312,IBCDFN,0))
  1. S IBDD(IBCDFN)=+X_"^"_IBCDFN_"^"_$P(X,"^",18)
  1. I ACTIVE=2 G CHKQ
  1. S X1=$G(^DIC(36,+X,0)) I X1="" G CQ ;ins co entry doesn't exist
  1. I $P(X,"^",8) G:INSDT<$P(X,"^",8) CQ ;effective date later than care
  1. I $P(X,"^",4) G:INSDT>$P(X,"^",4) CQ ;care after expiration date
  1. I $P($G(^IBA(355.3,+$P(X,"^",18),0)),"^",11) G CQ ;plan is inactive
  1. G:$P(X1,"^",5) CQ ; ;ins company inactive
  1. ;G:$P(X1,"^",2)="N" CQ ; ;ins company will not reimburse
  1. G CHKQ
  1. CQ K IBDD(IBCDFN)
  1. CHKQ S:$D(IBDD(IBCDFN)) IBDD=IBDD+1,IBD(IBDD)=IBCDFN
  1. Q
  1. ;
  1. ;
  1. DDHELP(IBDA,LEVEL) ; -- Executable help
  1. ; -- write out list to choose from
  1. N DFN,ACTIVE,INSDT,I,IBINS
  1. D VAR,BLD
  1. ;
  1. I $G(IBDD)=0 W !,"No Insurance Policies to Select From" G DDHQ
  1. ;
  1. I '$D(IOM) D HOME^%ZIS
  1. N IBDTIN
  1. S IBDTIN=$G(INSDT)
  1. W ! D HDR^IBCNS
  1. S I=0 F S I=$O(IBD(I)) Q:'I D
  1. .;IB*2.0*516/TAZ - Use HIPAA compliant fields
  1. .;S IBINS=$G(^DPT(DFN,.312,$G(IBD(I)),0)) ; 516 - baa
  1. .S IBINS=$$ZND^IBCNS1(DFN,$G(IBD(I))) ; 516 - baa
  1. .D D1^IBCNS
  1. DDHQ Q
  1. ;
  1. TRANS(IBDA,Y) ; -- output transform
  1. N DFN,ACTIVE,INSDT
  1. D VAR
  1. S Y=$P($G(^DIC(36,+$P($G(^DPT(DFN,.312,+$G(Y),0)),U),0)),U)
  1. Q Y
  1. ;
  1. INSCO(IBDA,IBCDFN) ; -- return pointer value of 36 from pt. file
  1. N DFN,ACTIVE,INSDT
  1. D VAR
  1. S Y=+$G(^DPT(DFN,.312,IBCDFN,0))
  1. Q Y_$S(Y>0:"^"_$P($G(^DIC(36,+Y,0)),"^"),1:"")
  1. ;
  1. IX(DA,XREF) ; -- create i1, aic xrefs for fields 112, 113, 114
  1. ;
  1. ;IB*2.0*516/TAZ - Set up I17, I27 or I37 nodes
  1. N DFN
  1. S DFN=$P($G(^DGCR(399,DA,0)),"^",2)
  1. S ^DGCR(399,DA,XREF)=$$ZND^IBCNS1(DFN,X,399)
  1. I ",I1,I2,I3,"[(","_XREF_","),$G(^DPT(DFN,.312,+X,7))'="" S ^DGCR(399,DA,XREF_"7")=$G(^DPT(DFN,.312,+X,7))
  1. S ^DGCR(399,DA,"AIC",+$G(^DPT(DFN,.312,+X,0)))=""
  1. Q
  1. ;
  1. KIX(DA,XREF) ; -- kill logic for above xref
  1. K ^DGCR(399,DA,XREF)
  1. I ",I1,I2,I3,"[(","_XREF_",") K ^DGCR(399,DA,XREF_"7")
  1. K ^DGCR(399,DA,"AIC",+$G(^DPT($P($G(^DGCR(399,DA,0)),"^",2),.312,+X,0)))
  1. Q
  1. ;
  1. 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
  1. ; returns - Bill Payer Policy (ifn of policy entry in patient file)
  1. ; - null if either no Payer Sequence or there is no policy defined for the payer sequence
  1. ; or the policy defined by the payer sequence Will Not Reimburse and is not MEDICARE
  1. ;
  1. N IBI,IBX,IBY,IBP,IBC,IBM0 S IBX="",(IBP,IBC)=0
  1. S IBMCR=+$G(IBMCR)
  1. S IBY=$$COBN^IBCEF(+IBDA) I IBY S IBY=IBY+11
  1. I IBY S IBM0=$G(^DGCR(399,+IBDA,"M")),IBP=$P(IBM0,U,IBY)
  1. I IBP S IBY=IBY-11,(IBI,IBY)=$P(IBM0,U,IBY) I +IBY S IBC=$P($G(^DIC(36,+IBY,0)),U,2)
  1. I IBP,IBI,$S(IBC'="N":1,'IBMCR:0,1:$$MCRWNR^IBEFUNC(+IBY)) S IBX=IBP
  1. Q IBX