- IBJDF11 ;ALB/CPM - THIRD PARTY FOLLOW-UP REPORT (COMPILE) ;09-JAN-97
- ;;2.0;INTEGRATED BILLING;**69,80,118,128,204,205,227,451,530,554,568,618,663,739**;21-MAR-94;Build 3
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- DQ ; - Tasked entry point.
- K ^TMP("IBJDF1",$J) S IBQ=0
- ;
- ; - Collect divisions when running the job for all divisions.
- I IBSD,VAUTD S J=0 F S J=$O(^DG(40.8,J)) Q:'J S VAUTD(J)=""
- ;
- ; - Find data required for the report.
- S IBA=0 F S IBA=$O(^PRCA(430,"AC",16,IBA)) Q:'IBA D Q:IBQ
- .;
- .I IBA#100=0 S IBQ=$$STOP^IBOUTL("Third Party Follow-Up Report") Q:IBQ
- .;
- .;**IB*2.0*618 - Moved ahead of RI Bill check to ensure
- .; claim exists before checking rate types
- .; on Community Care Categories.
- .I '$D(^DGCR(399,IBA,0)) Q ; No corresponding claim to this AR.
- .;
- .S IBAR=$G(^PRCA(430,IBA,0))
- .;
- .;**IB*2.0*618 - Change add new AR Categories and AR Category/
- .; Rate Types
- .S IBARNUM=$$GET1^DIQ(430.2,$P(IBAR,U,2)_",",6) ; Get AR Cat Num
- .Q:'$$CHKARNUM(IBARNUM) ;Confirm RI Bill, quit if not
- .;
- .; - Determine whether bill is inpatient, outpatient, or RX refill.
- .S IBTYP=$P($G(^DGCR(399,IBA,0)),U,5),IBTYP=$S(IBTYP>2:2,1:1)
- .S:$D(^IBA(362.4,"C",IBA)) IBTYP=3
- .I $P(IBAR,U,2)=45 S IBTYP=4 ;IB*2*554/DRF Look for Non-VA
- .I $P(IBAR,U,2)>47,($P(IBAR,U,2)<52) S IBTYP=4 ;IB*2.0*6 - Community Care third party
- .I IBSEL'[IBTYP,IBSEL'[5 Q
- .;
- .; - Check the receivable age, if necessary.
- .I IBSMN S:"Aa"[IBSDATE IBARD=$$ACT^IBJDF2(IBA) S:"Dd"[IBSDATE IBARD=$$DATE1^IBJDF2(IBA) Q:'IBARD S:IBARD IBARD=$$FMDIFF^XLFDT(DT,IBARD) I IBARD<IBSMN!(IBARD>IBSMX) Q
- .;
- .; - Check the minimum dollar amount, if necessary.
- .S IBWBA=+$G(^PRCA(430,IBA,7)) I IBSAM,IBWBA<IBSAM Q
- .;
- .; - Get division, if necessary.
- .I 'IBSD S IBDIV=0
- .E S IBDIV=$$DIV^IBJDF2(IBA) I 'IBDIV S IBDIV=+$$PRIM^VASITE()
- .I IBSD,'VAUTD Q:'$D(VAUTD(IBDIV)) ; Not a selected division.
- .;
- .; - Exclude receivables referred to Regional Counsel, if necessary.
- .S IBWRC=$G(^PRCA(430,IBA,6)) I 'IBSRC,$P(IBWRC,U,4) Q
- .S IBWRC=$S('$P(IBWRC,U,4):"",$P(IBWRC,U,22):$P(IBWRC,U,22),1:$P(IBWRC,U,4))
- .;
- .; - Get the insurance carrier and exclude claim, if necessary.
- .S IBWIN=$$INS(IBA) I IBWIN="" Q
- .;
- .; - Get the claim patient and exclude claim, if necessary.
- .S IBWPT=$$PAT(IBA) I IBWPT="" Q
- .;
- .; - Get remaining claim information.
- .; IB*2.0*451 - get 1st/3rd party payment EEOB indicator for bill
- .S IBPFLAG=$$EEOB^IBOA31(IBA)
- .S IBWDP=$P(IBAR,U,10)
- .;IB*2.0*530 Add indicator for rejects - External Bill # (.01) value is passed in, not IEN
- .S IBWBN=$G(IBPFLAG)_$S(+$$BILLREJ^IBJTU6($P($G(^DGCR(399,IBA,0)),U)):"c",1:"")_$P(IBAR,U) ; flag bill # when applicable
- .S IBBU=$G(^DGCR(399,IBA,"U")),IBWFR=+IBBU,IBWTO=$P(IBBU,U,2)
- .S IBWSC=$$OTH($P(IBWPT,U,5),$P(IBWIN,"@@",2),IBWFR),IBWOR=$P(IBAR,U,3)
- .S IBWSI=$P($G(^DPT(+$P(IBWPT,U,5),.312,+$P($G(^DGCR(399,IBA,"MP")),U,2),0)),U,2)
- .;
- .; - Set up main report index.
- .F X=IBTYP,5 I IBSEL[X D
- ..S ^TMP("IBJDF1",$J,IBDIV,X,IBWIN,$P(IBWPT,U)_"@@"_$P(IBWPT,U,5),IBWDP_"@@"_IBWBN)=$P(IBWPT,U,2)_" ("_$P(IBWPT,U,4)_")"_U_$P(IBWPT,U,3)_U_IBWSC_U_IBWFR_U_IBWTO_U_IBWOR_U_IBWBA_"~"_IBWRC_U_IBWSI
- .;
- .; - Add bill comment history, if necessary.
- .I IBSH D
- ..S X=0 F S X=$O(^PRCA(433,"C",IBA,X)) Q:'X D
- ...S Y=$G(^PRCA(433,X,1))
- ...I $P(Y,U,2)'=35,$P(Y,U,2)'=45 Q ; Not a decrease/comment transact.
- ...S DAT=$S(Y:+Y\1,1:+$P(Y,U,9)\1)
- ...;
- ...; - Append brief and transaction comments.
- ...K COM,COM1 S COM(0)=DAT,X1=0
- ...S COM1(1)=$P($G(^PRCA(433,X,5)),U,2),COM1(2)=$E($P($G(^(8)),U,6),1,70)
- ...S COM(1)=COM1(1)_$S(COM1(1)]""&(COM1(2)]""):"|",1:"")_COM1(2)
- ...I COM(1)]"" S COM(1)="**"_COM(1)_"**",X1=1
- ...;
- ...; - Get main comments.
- ...S X2=0 F S X2=$O(^PRCA(433,X,7,X2)) Q:'X2 S COM($S(X1:X2+1,1:X2))=^(X2,0)
- ...;
- ...S X1="" F S X1=$O(COM(X1)) Q:X1="" F X2=IBTYP,4 I IBSEL[X2 D
- ....S ^TMP("IBJDF1",$J,IBDIV,X2,IBWIN,$P(IBWPT,U)_"@@"_$P(IBWPT,U,5),IBWDP_"@@"_IBWBN,X,X1)=COM(X1)
- ;
- I 'IBQ D EN^IBJDF12 ; Print the report.
- ;
- CHKARNUM(IBCAT) ; Check for Reimbursable insurance
- ;
- Q:IBCAT=21 1 ;Reimbursable Insurance - Third Party
- ;
- ;All Non VA care AR Categories, Emergency/Humanitarian, and Ineligible Hospital
- I (IBCAT>46),(IBCAT<54) Q 1 ;Fee Reimbursable Insurance - Third Party
- Q 0
- ;
- ENQ K ^TMP("IBJDF1",$J)
- I $D(ZTQUEUED) S ZTREQ="@" G ENQ1
- ;
- D ^%ZISC
- ENQ1 K IBA,IBAR,IBARD,IBBU,IBDIV,IBQ,IBIO,IBWRC,IBWPT,IBWDP,IBWIN,IBWBN
- K IBTYP,IBWSC,IBWSI,IBWFR,IBWTO,IBWOR,IBWBA,COM,COM1,DAT,VAUTD,IBARNUM
- K X,X1,X2,Y,Z
- Q
- ;
- INS(X) ; - Find the Insurance company and decide to include the claim.
- ; Input: X=Pointer to the claim/AR in file #399/#430
- ; plus all variable input in IBS*
- ; Output: Y=Insurance Company name and pointer to file #36
- ;
- N Y,Z,Z1 S Y=""
- I '$G(X) G INSQ
- S Z=+$G(^DGCR(399,X,"MP")),Z1=$P($G(^DIC(36,Z,0)),U)
- I $G(IBSI) G INSQ:'$D(IBSI(Z)),INSC
- I IBSIF'="@",'Z G INSQ
- I $D(IBSIA) G:IBSIA="ALL"&('Z) INSQ G:IBSIA="NULL"&(Z) INSQ
- I Z1="" S Z1="UNKNOWN" G INSC
- I $G(IBSIA)="ALL" G INSC
- I IBSIF="@",IBSIL="zzzzz" G INSC
- I IBSIF]Z1!(Z1]IBSIL) G INSQ
- ;
- INSC S Y=Z1_"@@"_Z
- INSQ Q Y
- ;
- PAT(X) ; - Find the claim patient and decide to include the claim.
- ; Input: X=Pointer to the claim/AR in file #399/#430
- ; plus all variable input in IBS*
- ; Output: Y=1^2^3^4^5, where
- ; 1 => sort key (name or last four)
- ; 2 => patient name
- ; 3 => patient ssn
- ; 4 => patient age
- ; 5 => patient pointer to file #2
- ;
- N AGE,DFN,DOB,KEY,Y,Z S Y=""
- I '$G(X) G PATQ
- S DFN=+$P($G(^DGCR(399,X,0)),U,2),Z=$G(^DPT(DFN,0))
- S KEY=$S(IBSN="N":$P(Z,U),1:$E($P(Z,U,9),6,9))
- ;
- I IBSNF'="@",'DFN G PATQ
- I $D(IBSNA) G:IBSNA="ALL"&('DFN) PATQ G:IBSNA="NULL"&(DFN) PATQ
- I KEY="" S Y="UNK^UNK^UNK^UNK^UNK" G PATQ
- I $G(IBSNA)="ALL" G PATC
- I IBSNF="@",IBSNL="zzzzz" G PATC
- I IBSNF]KEY!(KEY]IBSNL) G PATQ
- ;
- PATC ; - Find all patient data.
- S DOB=$P(Z,U,3)
- S AGE=$S('DOB:"UNK",1:$E(DT,1,3)-$E(DOB,1,3)-($E(DT,4,7)<$E(DOB,4,7)))
- S Y=KEY_U_$E($P(Z,U),1,17)_U_$P(Z,U,9)_U_AGE_U_DFN
- PATQ Q Y
- ;
- OTH(DFN,INS,DS) ; - Find a patient's other valid insurance carrier (if any).
- ; Input: DFN=Pointer to the patient in file #2
- ; INS=Pointer to the patient's primary carrier in file #36
- ; DS=Date of service for validity check
- ; Output: Valid insurance carrier (1st 13 chars.) or null
- ;
- N Y S Y="" I '$G(DFN)!('$G(DS)) G OTHQ
- S Z=0 F S Z=$O(^DPT(DFN,.312,Z)) Q:'Z S X=$G(^(Z,0)) D:X Q:Y]""
- .I $G(INS),+X=INS Q
- .S X1=$G(^DIC(36,+X,0)) I X1="" Q
- .I $P(X1,U,2)'="N",$$CHK^IBCNS1(X,DS) S Y=$E($P(X1,U),1,13)
- ;
- OTHQ Q Y
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBJDF11 6849 printed Feb 18, 2025@23:49:07 Page 2
- IBJDF11 ;ALB/CPM - THIRD PARTY FOLLOW-UP REPORT (COMPILE) ;09-JAN-97
- +1 ;;2.0;INTEGRATED BILLING;**69,80,118,128,204,205,227,451,530,554,568,618,663,739**;21-MAR-94;Build 3
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- DQ ; - Tasked entry point.
- +1 KILL ^TMP("IBJDF1",$JOB)
- SET IBQ=0
- +2 ;
- +3 ; - Collect divisions when running the job for all divisions.
- +4 IF IBSD
- IF VAUTD
- SET J=0
- FOR
- SET J=$ORDER(^DG(40.8,J))
- if 'J
- QUIT
- SET VAUTD(J)=""
- +5 ;
- +6 ; - Find data required for the report.
- +7 SET IBA=0
- FOR
- SET IBA=$ORDER(^PRCA(430,"AC",16,IBA))
- if 'IBA
- QUIT
- Begin DoDot:1
- +8 ;
- +9 IF IBA#100=0
- SET IBQ=$$STOP^IBOUTL("Third Party Follow-Up Report")
- if IBQ
- QUIT
- +10 ;
- +11 ;**IB*2.0*618 - Moved ahead of RI Bill check to ensure
- +12 ; claim exists before checking rate types
- +13 ; on Community Care Categories.
- +14 ; No corresponding claim to this AR.
- IF '$DATA(^DGCR(399,IBA,0))
- QUIT
- +15 ;
- +16 SET IBAR=$GET(^PRCA(430,IBA,0))
- +17 ;
- +18 ;**IB*2.0*618 - Change add new AR Categories and AR Category/
- +19 ; Rate Types
- +20 ; Get AR Cat Num
- SET IBARNUM=$$GET1^DIQ(430.2,$PIECE(IBAR,U,2)_",",6)
- +21 ;Confirm RI Bill, quit if not
- if '$$CHKARNUM(IBARNUM)
- QUIT
- +22 ;
- +23 ; - Determine whether bill is inpatient, outpatient, or RX refill.
- +24 SET IBTYP=$PIECE($GET(^DGCR(399,IBA,0)),U,5)
- SET IBTYP=$SELECT(IBTYP>2:2,1:1)
- +25 if $DATA(^IBA(362.4,"C",IBA))
- SET IBTYP=3
- +26 ;IB*2*554/DRF Look for Non-VA
- IF $PIECE(IBAR,U,2)=45
- SET IBTYP=4
- +27 ;IB*2.0*6 - Community Care third party
- IF $PIECE(IBAR,U,2)>47
- IF ($PIECE(IBAR,U,2)<52)
- SET IBTYP=4
- +28 IF IBSEL'[IBTYP
- IF IBSEL'[5
- QUIT
- +29 ;
- +30 ; - Check the receivable age, if necessary.
- +31 IF IBSMN
- if "Aa"[IBSDATE
- SET IBARD=$$ACT^IBJDF2(IBA)
- if "Dd"[IBSDATE
- SET IBARD=$$DATE1^IBJDF2(IBA)
- if 'IBARD
- QUIT
- if IBARD
- SET IBARD=$$FMDIFF^XLFDT(DT,IBARD)
- IF IBARD<IBSMN!(IBARD>IBSMX)
- QUIT
- +32 ;
- +33 ; - Check the minimum dollar amount, if necessary.
- +34 SET IBWBA=+$GET(^PRCA(430,IBA,7))
- IF IBSAM
- IF IBWBA<IBSAM
- QUIT
- +35 ;
- +36 ; - Get division, if necessary.
- +37 IF 'IBSD
- SET IBDIV=0
- +38 IF '$TEST
- SET IBDIV=$$DIV^IBJDF2(IBA)
- IF 'IBDIV
- SET IBDIV=+$$PRIM^VASITE()
- +39 ; Not a selected division.
- IF IBSD
- IF 'VAUTD
- if '$DATA(VAUTD(IBDIV))
- QUIT
- +40 ;
- +41 ; - Exclude receivables referred to Regional Counsel, if necessary.
- +42 SET IBWRC=$GET(^PRCA(430,IBA,6))
- IF 'IBSRC
- IF $PIECE(IBWRC,U,4)
- QUIT
- +43 SET IBWRC=$SELECT('$PIECE(IBWRC,U,4):"",$PIECE(IBWRC,U,22):$PIECE(IBWRC,U,22),1:$PIECE(IBWRC,U,4))
- +44 ;
- +45 ; - Get the insurance carrier and exclude claim, if necessary.
- +46 SET IBWIN=$$INS(IBA)
- IF IBWIN=""
- QUIT
- +47 ;
- +48 ; - Get the claim patient and exclude claim, if necessary.
- +49 SET IBWPT=$$PAT(IBA)
- IF IBWPT=""
- QUIT
- +50 ;
- +51 ; - Get remaining claim information.
- +52 ; IB*2.0*451 - get 1st/3rd party payment EEOB indicator for bill
- +53 SET IBPFLAG=$$EEOB^IBOA31(IBA)
- +54 SET IBWDP=$PIECE(IBAR,U,10)
- +55 ;IB*2.0*530 Add indicator for rejects - External Bill # (.01) value is passed in, not IEN
- +56 ; flag bill # when applicable
- SET IBWBN=$GET(IBPFLAG)_$SELECT(+$$BILLREJ^IBJTU6($PIECE($GET(^DGCR(399,IBA,0)),U)):"c",1:"")_$PIECE(IBAR,U)
- +57 SET IBBU=$GET(^DGCR(399,IBA,"U"))
- SET IBWFR=+IBBU
- SET IBWTO=$PIECE(IBBU,U,2)
- +58 SET IBWSC=$$OTH($PIECE(IBWPT,U,5),$PIECE(IBWIN,"@@",2),IBWFR)
- SET IBWOR=$PIECE(IBAR,U,3)
- +59 SET IBWSI=$PIECE($GET(^DPT(+$PIECE(IBWPT,U,5),.312,+$PIECE($GET(^DGCR(399,IBA,"MP")),U,2),0)),U,2)
- +60 ;
- +61 ; - Set up main report index.
- +62 FOR X=IBTYP,5
- IF IBSEL[X
- Begin DoDot:2
- +63 SET ^TMP("IBJDF1",$JOB,IBDIV,X,IBWIN,$PIECE(IBWPT,U)_"@@"_$PIECE(IBWPT,U,5),IBWDP_"@@"_IBWBN)=$PIECE(IBWPT,U,2)_" ("_$PIECE(IBWPT,U,4)_")"_U_$PIECE(IBWPT,U,3)_U_IBWSC_U_IBWFR_U_IBWTO_U_IBWOR_U_IBWBA_"~"_IBWRC_U_IBWSI
- End DoDot:2
- +64 ;
- +65 ; - Add bill comment history, if necessary.
- +66 IF IBSH
- Begin DoDot:2
- +67 SET X=0
- FOR
- SET X=$ORDER(^PRCA(433,"C",IBA,X))
- if 'X
- QUIT
- Begin DoDot:3
- +68 SET Y=$GET(^PRCA(433,X,1))
- +69 ; Not a decrease/comment transact.
- IF $PIECE(Y,U,2)'=35
- IF $PIECE(Y,U,2)'=45
- QUIT
- +70 SET DAT=$SELECT(Y:+Y\1,1:+$PIECE(Y,U,9)\1)
- +71 ;
- +72 ; - Append brief and transaction comments.
- +73 KILL COM,COM1
- SET COM(0)=DAT
- SET X1=0
- +74 SET COM1(1)=$PIECE($GET(^PRCA(433,X,5)),U,2)
- SET COM1(2)=$EXTRACT($PIECE($GET(^(8)),U,6),1,70)
- +75 SET COM(1)=COM1(1)_$SELECT(COM1(1)]""&(COM1(2)]""):"|",1:"")_COM1(2)
- +76 IF COM(1)]""
- SET COM(1)="**"_COM(1)_"**"
- SET X1=1
- +77 ;
- +78 ; - Get main comments.
- +79 SET X2=0
- FOR
- SET X2=$ORDER(^PRCA(433,X,7,X2))
- if 'X2
- QUIT
- SET COM($SELECT(X1:X2+1,1:X2))=^(X2,0)
- +80 ;
- +81 SET X1=""
- FOR
- SET X1=$ORDER(COM(X1))
- if X1=""
- QUIT
- FOR X2=IBTYP,4
- IF IBSEL[X2
- Begin DoDot:4
- +82 SET ^TMP("IBJDF1",$JOB,IBDIV,X2,IBWIN,$PIECE(IBWPT,U)_"@@"_$PIECE(IBWPT,U,5),IBWDP_"@@"_IBWBN,X,X1)=COM(X1)
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- if IBQ
- QUIT
- +83 ;
- +84 ; Print the report.
- IF 'IBQ
- DO EN^IBJDF12
- +85 ;
- CHKARNUM(IBCAT) ; Check for Reimbursable insurance
- +1 ;
- +2 ;Reimbursable Insurance - Third Party
- if IBCAT=21
- QUIT 1
- +3 ;
- +4 ;All Non VA care AR Categories, Emergency/Humanitarian, and Ineligible Hospital
- +5 ;Fee Reimbursable Insurance - Third Party
- IF (IBCAT>46)
- IF (IBCAT<54)
- QUIT 1
- +6 QUIT 0
- +7 ;
- ENQ KILL ^TMP("IBJDF1",$JOB)
- +1 IF $DATA(ZTQUEUED)
- SET ZTREQ="@"
- GOTO ENQ1
- +2 ;
- +3 DO ^%ZISC
- ENQ1 KILL IBA,IBAR,IBARD,IBBU,IBDIV,IBQ,IBIO,IBWRC,IBWPT,IBWDP,IBWIN,IBWBN
- +1 KILL IBTYP,IBWSC,IBWSI,IBWFR,IBWTO,IBWOR,IBWBA,COM,COM1,DAT,VAUTD,IBARNUM
- +2 KILL X,X1,X2,Y,Z
- +3 QUIT
- +4 ;
- INS(X) ; - Find the Insurance company and decide to include the claim.
- +1 ; Input: X=Pointer to the claim/AR in file #399/#430
- +2 ; plus all variable input in IBS*
- +3 ; Output: Y=Insurance Company name and pointer to file #36
- +4 ;
- +5 NEW Y,Z,Z1
- SET Y=""
- +6 IF '$GET(X)
- GOTO INSQ
- +7 SET Z=+$GET(^DGCR(399,X,"MP"))
- SET Z1=$PIECE($GET(^DIC(36,Z,0)),U)
- +8 IF $GET(IBSI)
- if '$DATA(IBSI(Z))
- GOTO INSQ
- GOTO INSC
- +9 IF IBSIF'="@"
- IF 'Z
- GOTO INSQ
- +10 IF $DATA(IBSIA)
- if IBSIA="ALL"&('Z)
- GOTO INSQ
- if IBSIA="NULL"&(Z)
- GOTO INSQ
- +11 IF Z1=""
- SET Z1="UNKNOWN"
- GOTO INSC
- +12 IF $GET(IBSIA)="ALL"
- GOTO INSC
- +13 IF IBSIF="@"
- IF IBSIL="zzzzz"
- GOTO INSC
- +14 IF IBSIF]Z1!(Z1]IBSIL)
- GOTO INSQ
- +15 ;
- INSC SET Y=Z1_"@@"_Z
- INSQ QUIT Y
- +1 ;
- PAT(X) ; - Find the claim patient and decide to include the claim.
- +1 ; Input: X=Pointer to the claim/AR in file #399/#430
- +2 ; plus all variable input in IBS*
- +3 ; Output: Y=1^2^3^4^5, where
- +4 ; 1 => sort key (name or last four)
- +5 ; 2 => patient name
- +6 ; 3 => patient ssn
- +7 ; 4 => patient age
- +8 ; 5 => patient pointer to file #2
- +9 ;
- +10 NEW AGE,DFN,DOB,KEY,Y,Z
- SET Y=""
- +11 IF '$GET(X)
- GOTO PATQ
- +12 SET DFN=+$PIECE($GET(^DGCR(399,X,0)),U,2)
- SET Z=$GET(^DPT(DFN,0))
- +13 SET KEY=$SELECT(IBSN="N":$PIECE(Z,U),1:$EXTRACT($PIECE(Z,U,9),6,9))
- +14 ;
- +15 IF IBSNF'="@"
- IF 'DFN
- GOTO PATQ
- +16 IF $DATA(IBSNA)
- if IBSNA="ALL"&('DFN)
- GOTO PATQ
- if IBSNA="NULL"&(DFN)
- GOTO PATQ
- +17 IF KEY=""
- SET Y="UNK^UNK^UNK^UNK^UNK"
- GOTO PATQ
- +18 IF $GET(IBSNA)="ALL"
- GOTO PATC
- +19 IF IBSNF="@"
- IF IBSNL="zzzzz"
- GOTO PATC
- +20 IF IBSNF]KEY!(KEY]IBSNL)
- GOTO PATQ
- +21 ;
- PATC ; - Find all patient data.
- +1 SET DOB=$PIECE(Z,U,3)
- +2 SET AGE=$SELECT('DOB:"UNK",1:$EXTRACT(DT,1,3)-$EXTRACT(DOB,1,3)-($EXTRACT(DT,4,7)<$EXTRACT(DOB,4,7)))
- +3 SET Y=KEY_U_$EXTRACT($PIECE(Z,U),1,17)_U_$PIECE(Z,U,9)_U_AGE_U_DFN
- PATQ QUIT Y
- +1 ;
- OTH(DFN,INS,DS) ; - Find a patient's other valid insurance carrier (if any).
- +1 ; Input: DFN=Pointer to the patient in file #2
- +2 ; INS=Pointer to the patient's primary carrier in file #36
- +3 ; DS=Date of service for validity check
- +4 ; Output: Valid insurance carrier (1st 13 chars.) or null
- +5 ;
- +6 NEW Y
- SET Y=""
- IF '$GET(DFN)!('$GET(DS))
- GOTO OTHQ
- +7 SET Z=0
- FOR
- SET Z=$ORDER(^DPT(DFN,.312,Z))
- if 'Z
- QUIT
- SET X=$GET(^(Z,0))
- if X
- Begin DoDot:1
- +8 IF $GET(INS)
- IF +X=INS
- QUIT
- +9 SET X1=$GET(^DIC(36,+X,0))
- IF X1=""
- QUIT
- +10 IF $PIECE(X1,U,2)'="N"
- IF $$CHK^IBCNS1(X,DS)
- SET Y=$EXTRACT($PIECE(X1,U),1,13)
- End DoDot:1
- if Y]""
- QUIT
- +11 ;
- OTHQ QUIT Y