IBJDF51 ;ALB/RB - CHAMPVA/TRICARE FOLLOW-UP REPORT (COMPILE) ;15-APR-00
;;2.0;INTEGRATED BILLING;**123,185,240,356,452,516,618,739**;21-MAR-94;Build 3
;;Per VA Directive 6402, this routine should not be modified.
;
ST ; - Tasked entry point.
K IB,^TMP("IBJDF5",$J) S IBQ=0
;
; - Set selected categories for report.
I IBSEL[1 S IBCAT(31)=1
I IBSEL[2 S IBCAT(19)=2
; IB*2.0*618 - Add new TriCare Categories
I IBSEL[3 D
. S IBCAT(30)=3
. F IBI=75:1:80 S IBCAT(IBI)=3
I IBSEL[4 S IBCAT(32)=4
I IBSEL[5 S IBCAT(29)=5
I IBSEL[6 S IBCAT(28)=6
;
; Initialize the Summary Information
S IBCAT="" F S IBCAT=$O(IBCAT(IBCAT)) Q:IBCAT="" D
. S IBDIV=0
. I IBSD,IBCAT'=31 D Q
. . F S IBDIV=$O(VAUTD(IBDIV)) Q:IBDIV="" D INIT^IBJDF53
. D INIT^IBJDF53
;
; - Print the header line for the Excel spreadsheet
I $G(IBEXCEL) D PHDL
;
; - 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 D Q:IBQ
. . S IBQ=$$STOP^IBOUTL("CHAMPVA/TRICARE Follow-Up Report")
. S IBAR=$G(^PRCA(430,IBA,0)) Q:'IBAR
. I $P($G(^DGCR(399,IBA,0)),U,13)=7 Q ; Cancelled claim.
. S IBCAT=+$P(IBAR,U,2) Q:'$D(IBCAT(IBCAT)) ; Invalid AR category.
. S IBCAT1=IBCAT(IBCAT)
. ;
. ; - Get division, if necessary.
. I IBCAT1=1 S IBDIV=0 ; CHAMPVA/TRICARE Patient
. ;
. I IBCAT1'=1 D ; Others
. . I 'IBSD S IBDIV=0 Q
. . S IBDIV=$$DIV(IBA)
. ;
. I IBSD,IBDIV,'VAUTD Q:'$D(VAUTD(IBDIV)) ; Not a selected division.
. ;
. ; - Determine whether AR has corresponding IB action or claim and
. ; whether action/claim is inpatient, outpatient, or RX refill.
. S IBAC=$$CLMACT^IBJD(IBA,IBCAT) Q:IBAC=""!(+IBAC=3)
. I +IBAC=1 D
. . S X=$P($G(^IB($P(IBAC,U,2),0)),U,3)
. . S X=$P($G(^IBE(350.1,X,0)),U)
. . S IBTYP=$S(X["RX":3,X["OPT":2,1:1)
. I +IBAC'=1 D
. . S IBTYP=$S($P($G(^DGCR(399,IBA,0)),U,5)>2:2,1:1)
. . I $D(^IBA(362.4,"C",IBA)) S IBTYP=3
. ;
. I IBSEL1'[IBTYP,IBSEL1'[4 Q
. ;
. I IBRPT="D" S IBPT=$$PAT(IBA) Q:IBPT="" ; Get patient info.
. ;
. I '$G(IBEXCEL) D EN^IBJDF53 Q:IBRPT="S" ; Get stats for summary.
. ;
. ; - Get insurance info.
. S (IBI,IBIN)=0
. I $G(^DGCR(399,IBA,"MP")) D I 'IBI Q
. . S IBI=+$G(^DGCR(399,IBA,"MP")) I 'IBI S IBIN="*** UNKNOWN ***" Q
. . S IBIN=$P($G(^DIC(36,IBI,0)),U)_"@@"_IBI
. ;
. ; - Check the receivable age, if necessary.
. I IBSMN D Q:IBARD<IBSMN!(IBARD>IBSMX)
. . S IBARD=+$$ACT^IBJDF2(IBA) S:IBARD IBARD=$$FMDIFF^XLFDT(DT,IBARD)
. ;
. ; - Check the minimum balance amount, if necessary.
. S IBBA=0 F X=1:1:5 S IBBA=IBBA+$P($G(^PRCA(430,IBA,7)),U,X)
. I IBSAM,IBBA<IBSAM Q
. ;
. ; - Get remaining AR/claim information.
. S IBDP=$P(IBAR,U,10),X=$$CLMACT^IBJD(IBA,IBCAT) Q:X=""
. S IBBU=$S(+IBAC=1:$G(^IB($P(IBAC,U,2),0)),1:$G(^DGCR(399,IBA,"U")))
. S IBFR=$P(IBBU,U,$S(+IBAC=1:14,1:1))
. S IBTO=$P(IBBU,U,$S(+IBAC=1:15,1:2))
. S DFN=$P(IBPT,U,5),IBSID=$$SID(DFN,IBI)
. S IBOI=$$OTH(DFN,IBI,IBFR),IBVA=$$VA^IBJD1(DFN)
. S IBBN=$P(IBAR,U),IBOR=$P(IBAR,U,3)
. ;
. ; - Set up indexes for detail report.
. I $G(IBEXCEL) D Q
. . S IBDIV=$P($G(^DG(40.8,$S('IBDIV:+$$PRIM^VASITE(),1:IBDIV),0)),U)
. . ;
. . S IBEXCEL1=$P(IBPT,U,2)_U_IBVA_U_$P(IBPT,U,3)_U ;IB*2.0*739
. . S IBEXCEL1=IBEXCEL1_U_$S(IBIN=0:"",1:$E($P(IBIN,"@@"),1,12))_U_$E(IBOI,1,12)
. . S IBEXCEL1=IBEXCEL1_U_$$DT^IBJD(IBDP,1)_U_$$DT^IBJD(IBFR,1)
. . S IBEXCEL1=IBEXCEL1_U_$$DT^IBJD(IBTO,1)_U_IBSID_U_IBBN_U_IBOR
. . S IBEXCEL1=IBEXCEL1_U_IBBA_U_$P($G(^PRCA(430.2,IBCAT,0)),U,2)
. . S IBEXCEL1=IBEXCEL1_U_$E("IOR",IBTYP)_U
. . I IBSH D COM ; This will capture the Last Comment Date
. . S IBD=$$FMDIFF^XLFDT(DT,$S('$P(IBEXCEL1,U,16):IBDP,1:$G(DAT)))
. . S IBEXCEL1=IBEXCEL1_U_IBD_U_$E(IBDIV,1,12) W !,IBEXCEL1 K IBD,IBEXCEL1
. ;
. S IBKEY=$P(IBPT,U)_"@@"_$S($G(IBPT):IBDP,1:IBFR_"/"_IBTO)
. F X=IBTYP,4 I IBSEL1[X D
. . I '($D(^TMP("IBJDF5",$J,IBDIV,IBCAT,X,IBIN,IBKEY))#10) D
. . . S ^TMP("IBJDF5",$J,IBDIV,IBCAT,X,IBIN,IBKEY)=$P(IBPT,U,2)_" "_IBVA_U_$P(IBPT,U,3,4)_U_IBOI
. . S ^TMP("IBJDF5",$J,IBDIV,IBCAT,X,IBIN,IBKEY,IBBN)=IBDP_U_IBFR_U_IBTO_U_IBOR_U_IBBA_U_IBSID
. . I IBSH D COM
;
I 'IBQ,'$G(IBEXCEL) D EN^IBJDF52 ; Print the report.
;
ENQ K ^TMP("IBJDF5",$J)
I $D(ZTQUEUED) S ZTREQ="@" G ENQ1
;
D ^%ZISC
ENQ1 K IB,IBA,IBA1,IBAR,IBARD,IBBU,IBC,IBCAT,IBCAT1,IBDIV,IBD,IBI,IBQ,IBPT
K IBDP,IBKEY,IBVA,IBAC,IBBA,IBBN,IBFR,IBIN,IBOI,IBOR,IBSID,IBTO,IBTYP,IBI
K COM,COM1,DAT,DFN,J,X,X1,X2,Y,Z D KVA^VADPT
Q
;
PAT(IBDA) ; - Find the claim patient and decide to include the claim.
; Input: IBDA=Pointer to the claim/AR in file #399/#430 plus all
; variable input in IBS*
; Output: Y=Sort key (name or last 4)_@@_patient IEN to file #2
; ^ Patient name ^ Age ^ SSN ^ Patient IEN to file #2
N AGE,ALL,ARZ,DA,DBTR,DFN,DIC,DIQ,DOB,DR,END,IBZ,INI,KEY,NAME,RCZ,SSN
N VADM,Y,Z
;
S Y="" G:'$G(IBDA) PATQ
S DFN=0,(NAME,AGE,SSN)="",ARZ=$G(^PRCA(430,IBDA,0))
;
; - Look for Patient (Corresponding Claim in IB)
I $D(^DGCR(399,IBDA,0)) D I 'DFN S Y="" G PATQ
. S IBZ=^DGCR(399,IBDA,0),DFN=+$P(IBZ,"^",2)
. D DEM^VADPT S NAME=VADM(1),SSN=$P(VADM(2),"^",2),AGE=VADM(4)
;
; - Look for Debtor (No corresponding Claim in IB)
I '$D(^DGCR(399,IBDA,0)) D I 'DFN S Y="" G PATQ
. S DBTR=+$P(ARZ,"^",9) I 'DBTR Q
. S RCZ=$G(^RCD(340,DBTR,0)),DFN=+RCZ
. I $P(RCZ,"^")["DPT" D
. . D DEM^VADPT S NAME=VADM(1),SSN=$P(VADM(2),"^",2),AGE=VADM(4)
. I $P(RCZ,"^")'["DPT" D
. . S DIC="^PRCA(430,",DA=IBDA,DR=9,DIQ="DEB" D EN^DIQ1
. . S NAME=$G(DEB(430,DA,9)),KEY=NAME
. . S DIC="^RCD(340,",DA=DBTR,DR=110,DIQ="DEB" D EN^DIQ1
. . S SSN=$G(DEB(340,DA,110))
. . I SSN S SSN=$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9)
;
S KEY=$S(IBSN="N":NAME,1:+$P(SSN,"-",3))
S INI=IBSNF,END=IBSNL,ALL=IBSNA
I (INI'="@"&('DFN)) S Y="" G PATQ
I ALL="ALL"&('DFN)!(ALL="NULL"&(DFN)) S Y="" G PATQ
I INI="@",END="zzzzz" G PATC
I INI]KEY!(KEY]END) S Y="" G PATQ
;
PATC ; - Find all patient data.
S Y=KEY_"@@"_DFN_U_$E(NAME,1,25)_U_AGE_U_SSN_"^"_DFN
PATQ Q Y
;
DIV(CLM) ;Find the default division of the bill.
S DIV=$P($G(^DGCR(399,CLM,0)),"^",22)
QDIV S:'DIV DIV=$$PRIM^VASITE() S:DIV'>0 DIV=0
Q DIV
SID(DFN,INS) ; - Find the subscriber ID for a bill (if any).
; Input: DFN=Pointer to the patient in file #2
; INS=Pointer to the patient's primary carrier in file #36
; Output: Subscriber ID no. or null
N X,Y,Z S Y="" G:'$G(DFN)!('$G(INS)) SIDQ
S Z=0 F S Z=$O(^DPT(DFN,.312,Z)) Q:'Z S X=$G(^(Z,0)) D Q:Y]""
.;IB*2.0*516/TAZ - Use HIPAA compliant Sub ID
.I +X=INS S Y=$E($$GET1^DIQ(2.312,Z_","_DFN_",",7.02),1,16)
;
SIDQ Q Y
;
PHDL ; - Print the header line for the Excel spreadsheet
N X
S X="Patient^VA Empl.?^Age^^Prim.Ins.Carrier^Other Ins.Carrier^" ;IB*2.0*739
S X=X_"Dt Bill prep.^Bill From Dt^Bill To Dt^Subsc.ID^Bill #^"
S X=X_"Orig.Amt^Curr.Bal.^Cat.^Bill Type^Lst Comm.Dt^Days Lst Comm.^"
S X=X_"Division"
W !,X
Q
;
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 (first 15 chars.) or null
N X,X1,Y,Z S Y="" G:'$G(DFN)!('$G(INS))!('$G(DS)) OTHQ
S Z=0 F S Z=$O(^DPT(DFN,.312,Z)) Q:'Z S X=$G(^(Z,0)) D:X Q:Y]""
.I +X=INS Q
.S X1=$G(^DIC(36,+X,0)) Q:X1=""
.I $P(X1,U,2)'="N",$$CHK^IBCNS1(X,DS) S Y=$E($P(X1,U),1,15)
;
OTHQ Q Y
;
COM ; - Get bill comments.
S DAT=0,IBA1=$S(IBSH1="M":999999999,1:0)
F S IBA1=$S(IBSH1="M":$O(^PRCA(433,"C",IBA,IBA1),-1),1:$O(^PRCA(433,"C",IBA,IBA1))) Q:'IBA1 D I IBSH1="M",DAT Q
.S IBC=$G(^PRCA(433,IBA1,1)) Q:'IBC
.I $G(IBSH2),$$FMDIFF^XLFDT(DT,+IBC)<IBSH2 Q ; Comment age not minimum.
.I $P(IBC,U,2)'=35,$P(IBC,U,2)'=45 Q ; Not decrease/comment transact.
.S DAT=$S(IBC:+IBC\1,1:+$P(IBC,U,9)\1)
.I $G(IBEXCEL),IBSH1="M" S IBEXCEL1=IBEXCEL1_$$DT^IBJD(DAT,1) Q
.;
.; - Append brief and transaction comments.
.K COM,COM1 S COM(0)=DAT,X1=0
.S COM1(1)=$P($G(^PRCA(433,IBA1,5)),U,2)
.S COM1(2)=$E($P($G(^PRCA(433,IBA1,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,IBA1,7,X2)) Q:'X2 S COM($S(X1:X2+1,1:X2))=^(X2,0)
.;
.S X1="" F S X1=$O(COM(X1)) Q:X1="" D
..S ^TMP("IBJDF5",$J,IBDIV,IBCAT,X,IBIN,IBKEY,IBBN,IBA1,X1)=COM(X1)
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBJDF51 8727 printed Nov 22, 2024@17:32:57 Page 2
IBJDF51 ;ALB/RB - CHAMPVA/TRICARE FOLLOW-UP REPORT (COMPILE) ;15-APR-00
+1 ;;2.0;INTEGRATED BILLING;**123,185,240,356,452,516,618,739**;21-MAR-94;Build 3
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
ST ; - Tasked entry point.
+1 KILL IB,^TMP("IBJDF5",$JOB)
SET IBQ=0
+2 ;
+3 ; - Set selected categories for report.
+4 IF IBSEL[1
SET IBCAT(31)=1
+5 IF IBSEL[2
SET IBCAT(19)=2
+6 ; IB*2.0*618 - Add new TriCare Categories
+7 IF IBSEL[3
Begin DoDot:1
+8 SET IBCAT(30)=3
+9 FOR IBI=75:1:80
SET IBCAT(IBI)=3
End DoDot:1
+10 IF IBSEL[4
SET IBCAT(32)=4
+11 IF IBSEL[5
SET IBCAT(29)=5
+12 IF IBSEL[6
SET IBCAT(28)=6
+13 ;
+14 ; Initialize the Summary Information
+15 SET IBCAT=""
FOR
SET IBCAT=$ORDER(IBCAT(IBCAT))
if IBCAT=""
QUIT
Begin DoDot:1
+16 SET IBDIV=0
+17 IF IBSD
IF IBCAT'=31
Begin DoDot:2
+18 FOR
SET IBDIV=$ORDER(VAUTD(IBDIV))
if IBDIV=""
QUIT
DO INIT^IBJDF53
End DoDot:2
QUIT
+19 DO INIT^IBJDF53
End DoDot:1
+20 ;
+21 ; - Print the header line for the Excel spreadsheet
+22 IF $GET(IBEXCEL)
DO PHDL
+23 ;
+24 ; - Find data required for the report.
+25 SET IBA=0
FOR
SET IBA=$ORDER(^PRCA(430,"AC",16,IBA))
if 'IBA
QUIT
Begin DoDot:1
+26 IF IBA#100=0
Begin DoDot:2
+27 SET IBQ=$$STOP^IBOUTL("CHAMPVA/TRICARE Follow-Up Report")
End DoDot:2
if IBQ
QUIT
+28 SET IBAR=$GET(^PRCA(430,IBA,0))
if 'IBAR
QUIT
+29 ; Cancelled claim.
IF $PIECE($GET(^DGCR(399,IBA,0)),U,13)=7
QUIT
+30 ; Invalid AR category.
SET IBCAT=+$PIECE(IBAR,U,2)
if '$DATA(IBCAT(IBCAT))
QUIT
+31 SET IBCAT1=IBCAT(IBCAT)
+32 ;
+33 ; - Get division, if necessary.
+34 ; CHAMPVA/TRICARE Patient
IF IBCAT1=1
SET IBDIV=0
+35 ;
+36 ; Others
IF IBCAT1'=1
Begin DoDot:2
+37 IF 'IBSD
SET IBDIV=0
QUIT
+38 SET IBDIV=$$DIV(IBA)
End DoDot:2
+39 ;
+40 ; Not a selected division.
IF IBSD
IF IBDIV
IF 'VAUTD
if '$DATA(VAUTD(IBDIV))
QUIT
+41 ;
+42 ; - Determine whether AR has corresponding IB action or claim and
+43 ; whether action/claim is inpatient, outpatient, or RX refill.
+44 SET IBAC=$$CLMACT^IBJD(IBA,IBCAT)
if IBAC=""!(+IBAC=3)
QUIT
+45 IF +IBAC=1
Begin DoDot:2
+46 SET X=$PIECE($GET(^IB($PIECE(IBAC,U,2),0)),U,3)
+47 SET X=$PIECE($GET(^IBE(350.1,X,0)),U)
+48 SET IBTYP=$SELECT(X["RX":3,X["OPT":2,1:1)
End DoDot:2
+49 IF +IBAC'=1
Begin DoDot:2
+50 SET IBTYP=$SELECT($PIECE($GET(^DGCR(399,IBA,0)),U,5)>2:2,1:1)
+51 IF $DATA(^IBA(362.4,"C",IBA))
SET IBTYP=3
End DoDot:2
+52 ;
+53 IF IBSEL1'[IBTYP
IF IBSEL1'[4
QUIT
+54 ;
+55 ; Get patient info.
IF IBRPT="D"
SET IBPT=$$PAT(IBA)
if IBPT=""
QUIT
+56 ;
+57 ; Get stats for summary.
IF '$GET(IBEXCEL)
DO EN^IBJDF53
if IBRPT="S"
QUIT
+58 ;
+59 ; - Get insurance info.
+60 SET (IBI,IBIN)=0
+61 IF $GET(^DGCR(399,IBA,"MP"))
Begin DoDot:2
+62 SET IBI=+$GET(^DGCR(399,IBA,"MP"))
IF 'IBI
SET IBIN="*** UNKNOWN ***"
QUIT
+63 SET IBIN=$PIECE($GET(^DIC(36,IBI,0)),U)_"@@"_IBI
End DoDot:2
IF 'IBI
QUIT
+64 ;
+65 ; - Check the receivable age, if necessary.
+66 IF IBSMN
Begin DoDot:2
+67 SET IBARD=+$$ACT^IBJDF2(IBA)
if IBARD
SET IBARD=$$FMDIFF^XLFDT(DT,IBARD)
End DoDot:2
if IBARD<IBSMN!(IBARD>IBSMX)
QUIT
+68 ;
+69 ; - Check the minimum balance amount, if necessary.
+70 SET IBBA=0
FOR X=1:1:5
SET IBBA=IBBA+$PIECE($GET(^PRCA(430,IBA,7)),U,X)
+71 IF IBSAM
IF IBBA<IBSAM
QUIT
+72 ;
+73 ; - Get remaining AR/claim information.
+74 SET IBDP=$PIECE(IBAR,U,10)
SET X=$$CLMACT^IBJD(IBA,IBCAT)
if X=""
QUIT
+75 SET IBBU=$SELECT(+IBAC=1:$GET(^IB($PIECE(IBAC,U,2),0)),1:$GET(^DGCR(399,IBA,"U")))
+76 SET IBFR=$PIECE(IBBU,U,$SELECT(+IBAC=1:14,1:1))
+77 SET IBTO=$PIECE(IBBU,U,$SELECT(+IBAC=1:15,1:2))
+78 SET DFN=$PIECE(IBPT,U,5)
SET IBSID=$$SID(DFN,IBI)
+79 SET IBOI=$$OTH(DFN,IBI,IBFR)
SET IBVA=$$VA^IBJD1(DFN)
+80 SET IBBN=$PIECE(IBAR,U)
SET IBOR=$PIECE(IBAR,U,3)
+81 ;
+82 ; - Set up indexes for detail report.
+83 IF $GET(IBEXCEL)
Begin DoDot:2
+84 SET IBDIV=$PIECE($GET(^DG(40.8,$SELECT('IBDIV:+$$PRIM^VASITE(),1:IBDIV),0)),U)
+85 ;
+86 ;IB*2.0*739
SET IBEXCEL1=$PIECE(IBPT,U,2)_U_IBVA_U_$PIECE(IBPT,U,3)_U
+87 SET IBEXCEL1=IBEXCEL1_U_$SELECT(IBIN=0:"",1:$EXTRACT($PIECE(IBIN,"@@"),1,12))_U_$EXTRACT(IBOI,1,12)
+88 SET IBEXCEL1=IBEXCEL1_U_$$DT^IBJD(IBDP,1)_U_$$DT^IBJD(IBFR,1)
+89 SET IBEXCEL1=IBEXCEL1_U_$$DT^IBJD(IBTO,1)_U_IBSID_U_IBBN_U_IBOR
+90 SET IBEXCEL1=IBEXCEL1_U_IBBA_U_$PIECE($GET(^PRCA(430.2,IBCAT,0)),U,2)
+91 SET IBEXCEL1=IBEXCEL1_U_$EXTRACT("IOR",IBTYP)_U
+92 ; This will capture the Last Comment Date
IF IBSH
DO COM
+93 SET IBD=$$FMDIFF^XLFDT(DT,$SELECT('$PIECE(IBEXCEL1,U,16):IBDP,1:$GET(DAT)))
+94 SET IBEXCEL1=IBEXCEL1_U_IBD_U_$EXTRACT(IBDIV,1,12)
WRITE !,IBEXCEL1
KILL IBD,IBEXCEL1
End DoDot:2
QUIT
+95 ;
+96 SET IBKEY=$PIECE(IBPT,U)_"@@"_$SELECT($GET(IBPT):IBDP,1:IBFR_"/"_IBTO)
+97 FOR X=IBTYP,4
IF IBSEL1[X
Begin DoDot:2
+98 IF '($DATA(^TMP("IBJDF5",$JOB,IBDIV,IBCAT,X,IBIN,IBKEY))#10)
Begin DoDot:3
+99 SET ^TMP("IBJDF5",$JOB,IBDIV,IBCAT,X,IBIN,IBKEY)=$PIECE(IBPT,U,2)_" "_IBVA_U_$PIECE(IBPT,U,3,4)_U_IBOI
End DoDot:3
+100 SET ^TMP("IBJDF5",$JOB,IBDIV,IBCAT,X,IBIN,IBKEY,IBBN)=IBDP_U_IBFR_U_IBTO_U_IBOR_U_IBBA_U_IBSID
+101 IF IBSH
DO COM
End DoDot:2
End DoDot:1
if IBQ
QUIT
+102 ;
+103 ; Print the report.
IF 'IBQ
IF '$GET(IBEXCEL)
DO EN^IBJDF52
+104 ;
ENQ KILL ^TMP("IBJDF5",$JOB)
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
GOTO ENQ1
+2 ;
+3 DO ^%ZISC
ENQ1 KILL IB,IBA,IBA1,IBAR,IBARD,IBBU,IBC,IBCAT,IBCAT1,IBDIV,IBD,IBI,IBQ,IBPT
+1 KILL IBDP,IBKEY,IBVA,IBAC,IBBA,IBBN,IBFR,IBIN,IBOI,IBOR,IBSID,IBTO,IBTYP,IBI
+2 KILL COM,COM1,DAT,DFN,J,X,X1,X2,Y,Z
DO KVA^VADPT
+3 QUIT
+4 ;
PAT(IBDA) ; - Find the claim patient and decide to include the claim.
+1 ; Input: IBDA=Pointer to the claim/AR in file #399/#430 plus all
+2 ; variable input in IBS*
+3 ; Output: Y=Sort key (name or last 4)_@@_patient IEN to file #2
+4 ; ^ Patient name ^ Age ^ SSN ^ Patient IEN to file #2
+5 NEW AGE,ALL,ARZ,DA,DBTR,DFN,DIC,DIQ,DOB,DR,END,IBZ,INI,KEY,NAME,RCZ,SSN
+6 NEW VADM,Y,Z
+7 ;
+8 SET Y=""
if '$GET(IBDA)
GOTO PATQ
+9 SET DFN=0
SET (NAME,AGE,SSN)=""
SET ARZ=$GET(^PRCA(430,IBDA,0))
+10 ;
+11 ; - Look for Patient (Corresponding Claim in IB)
+12 IF $DATA(^DGCR(399,IBDA,0))
Begin DoDot:1
+13 SET IBZ=^DGCR(399,IBDA,0)
SET DFN=+$PIECE(IBZ,"^",2)
+14 DO DEM^VADPT
SET NAME=VADM(1)
SET SSN=$PIECE(VADM(2),"^",2)
SET AGE=VADM(4)
End DoDot:1
IF 'DFN
SET Y=""
GOTO PATQ
+15 ;
+16 ; - Look for Debtor (No corresponding Claim in IB)
+17 IF '$DATA(^DGCR(399,IBDA,0))
Begin DoDot:1
+18 SET DBTR=+$PIECE(ARZ,"^",9)
IF 'DBTR
QUIT
+19 SET RCZ=$GET(^RCD(340,DBTR,0))
SET DFN=+RCZ
+20 IF $PIECE(RCZ,"^")["DPT"
Begin DoDot:2
+21 DO DEM^VADPT
SET NAME=VADM(1)
SET SSN=$PIECE(VADM(2),"^",2)
SET AGE=VADM(4)
End DoDot:2
+22 IF $PIECE(RCZ,"^")'["DPT"
Begin DoDot:2
+23 SET DIC="^PRCA(430,"
SET DA=IBDA
SET DR=9
SET DIQ="DEB"
DO EN^DIQ1
+24 SET NAME=$GET(DEB(430,DA,9))
SET KEY=NAME
+25 SET DIC="^RCD(340,"
SET DA=DBTR
SET DR=110
SET DIQ="DEB"
DO EN^DIQ1
+26 SET SSN=$GET(DEB(340,DA,110))
+27 IF SSN
SET SSN=$EXTRACT(SSN,1,3)_"-"_$EXTRACT(SSN,4,5)_"-"_$EXTRACT(SSN,6,9)
End DoDot:2
End DoDot:1
IF 'DFN
SET Y=""
GOTO PATQ
+28 ;
+29 SET KEY=$SELECT(IBSN="N":NAME,1:+$PIECE(SSN,"-",3))
+30 SET INI=IBSNF
SET END=IBSNL
SET ALL=IBSNA
+31 IF (INI'="@"&('DFN))
SET Y=""
GOTO PATQ
+32 IF ALL="ALL"&('DFN)!(ALL="NULL"&(DFN))
SET Y=""
GOTO PATQ
+33 IF INI="@"
IF END="zzzzz"
GOTO PATC
+34 IF INI]KEY!(KEY]END)
SET Y=""
GOTO PATQ
+35 ;
PATC ; - Find all patient data.
+1 SET Y=KEY_"@@"_DFN_U_$EXTRACT(NAME,1,25)_U_AGE_U_SSN_"^"_DFN
PATQ QUIT Y
+1 ;
DIV(CLM) ;Find the default division of the bill.
+1 SET DIV=$PIECE($GET(^DGCR(399,CLM,0)),"^",22)
QDIV if 'DIV
SET DIV=$$PRIM^VASITE()
if DIV'>0
SET DIV=0
+1 QUIT DIV
SID(DFN,INS) ; - Find the subscriber ID for a bill (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 ; Output: Subscriber ID no. or null
+4 NEW X,Y,Z
SET Y=""
if '$GET(DFN)!('$GET(INS))
GOTO SIDQ
+5 SET Z=0
FOR
SET Z=$ORDER(^DPT(DFN,.312,Z))
if 'Z
QUIT
SET X=$GET(^(Z,0))
Begin DoDot:1
+6 ;IB*2.0*516/TAZ - Use HIPAA compliant Sub ID
+7 IF +X=INS
SET Y=$EXTRACT($$GET1^DIQ(2.312,Z_","_DFN_",",7.02),1,16)
End DoDot:1
if Y]""
QUIT
+8 ;
SIDQ QUIT Y
+1 ;
PHDL ; - Print the header line for the Excel spreadsheet
+1 NEW X
+2 ;IB*2.0*739
SET X="Patient^VA Empl.?^Age^^Prim.Ins.Carrier^Other Ins.Carrier^"
+3 SET X=X_"Dt Bill prep.^Bill From Dt^Bill To Dt^Subsc.ID^Bill #^"
+4 SET X=X_"Orig.Amt^Curr.Bal.^Cat.^Bill Type^Lst Comm.Dt^Days Lst Comm.^"
+5 SET X=X_"Division"
+6 WRITE !,X
+7 QUIT
+8 ;
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 (first 15 chars.) or null
+5 NEW X,X1,Y,Z
SET Y=""
if '$GET(DFN)!('$GET(INS))!('$GET(DS))
GOTO OTHQ
+6 SET Z=0
FOR
SET Z=$ORDER(^DPT(DFN,.312,Z))
if 'Z
QUIT
SET X=$GET(^(Z,0))
if X
Begin DoDot:1
+7 IF +X=INS
QUIT
+8 SET X1=$GET(^DIC(36,+X,0))
if X1=""
QUIT
+9 IF $PIECE(X1,U,2)'="N"
IF $$CHK^IBCNS1(X,DS)
SET Y=$EXTRACT($PIECE(X1,U),1,15)
End DoDot:1
if Y]""
QUIT
+10 ;
OTHQ QUIT Y
+1 ;
COM ; - Get bill comments.
+1 SET DAT=0
SET IBA1=$SELECT(IBSH1="M":999999999,1:0)
+2 FOR
SET IBA1=$SELECT(IBSH1="M":$ORDER(^PRCA(433,"C",IBA,IBA1),-1),1:$ORDER(^PRCA(433,"C",IBA,IBA1)))
if 'IBA1
QUIT
Begin DoDot:1
+3 SET IBC=$GET(^PRCA(433,IBA1,1))
if 'IBC
QUIT
+4 ; Comment age not minimum.
IF $GET(IBSH2)
IF $$FMDIFF^XLFDT(DT,+IBC)<IBSH2
QUIT
+5 ; Not decrease/comment transact.
IF $PIECE(IBC,U,2)'=35
IF $PIECE(IBC,U,2)'=45
QUIT
+6 SET DAT=$SELECT(IBC:+IBC\1,1:+$PIECE(IBC,U,9)\1)
+7 IF $GET(IBEXCEL)
IF IBSH1="M"
SET IBEXCEL1=IBEXCEL1_$$DT^IBJD(DAT,1)
QUIT
+8 ;
+9 ; - Append brief and transaction comments.
+10 KILL COM,COM1
SET COM(0)=DAT
SET X1=0
+11 SET COM1(1)=$PIECE($GET(^PRCA(433,IBA1,5)),U,2)
+12 SET COM1(2)=$EXTRACT($PIECE($GET(^PRCA(433,IBA1,8)),U,6),1,70)
+13 SET COM(1)=COM1(1)_$SELECT(COM1(1)]""&(COM1(2)]""):"|",1:"")_COM1(2)
+14 IF COM(1)]""
SET COM(1)="**"_COM(1)_"**"
SET X1=1
+15 ;
+16 ; - Get main comments.
+17 SET X2=0
FOR
SET X2=$ORDER(^PRCA(433,IBA1,7,X2))
if 'X2
QUIT
SET COM($SELECT(X1:X2+1,1:X2))=^(X2,0)
+18 ;
+19 SET X1=""
FOR
SET X1=$ORDER(COM(X1))
if X1=""
QUIT
Begin DoDot:2
+20 SET ^TMP("IBJDF5",$JOB,IBDIV,IBCAT,X,IBIN,IBKEY,IBBN,IBA1,X1)=COM(X1)
End DoDot:2
End DoDot:1
IF IBSH1="M"
IF DAT
QUIT
+21 ;
+22 QUIT
