IBJDF61 ;ALB/RB - MISC. BILLS FOLLOW-UP REPORT (COMPILE) ;15-APR-00
;;2.0;INTEGRATED BILLING;**123,159,356,618**;21-MAR-94;Build 61
;;Per VHA Directive 6402, this routine should not be modified.
;
ST ; - Tasked entry point.
K IB,IBCAT,^TMP("IBJDF6P",$J),^TMP("IBJDF6D",$J) S IBQ=0
N IBPDFLG ;Patient (1) or Debtor (0) flag
;
; - Set selected categories for report.
; IB*2.0*618 - Added Community Care Misc. Categories
I IBSEL[",1," S IBCAT(21)=1 ; MEDICARE
I IBSEL[",2," S IBCAT(7)=2 ; NO-FAULT AUTO ACCIDENT
I IBSEL[",3," D ; COMMUNITY CARE NO-FAULT AUTO
. S IBCAT(52)=3
. S IBCAT(55)=3
. S IBCAT(58)=3
I IBSEL[",4," S IBCAT(10)=4 ; TORT FEASOR
I IBSEL[",5," D ; COMMUNITY CARE TORT FEASOR
. S IBCAT(53)=5
. S IBCAT(56)=5
. S IBCAT(59)=5
I IBSEL[6 S IBCAT(6)=6 ; WORKMEN'S COMP
I IBSEL[7 D ; COMMUNITY CARE NO-FAULT AUTO
. S IBCAT(54)=7
. S IBCAT(57)=7
. S IBCAT(60)=7
I IBSEL[8 S IBCAT(16)=8 ; CURRENT EMPLOYEE
I IBSEL[9 S IBCAT(15)=9 ; EX-EMPLOYEE
I IBSEL[10 S IBCAT(13)=10 ; FEDERAL AGENCIES-REFUND
I IBSEL[11 S IBCAT(14)=11 ; FEDERAL AGENCIES-REIMBURSEMENT
I IBSEL[12 S IBCAT(12)=12 ; MILITARY
I IBSEL[13 S IBCAT(20)=13 ; INTERAGENCY
I IBSEL[14 S IBCAT(17)=14 ; VENDOR
;
; Initialize the Summary Information
S IBCAT="" F S IBCAT=$O(IBCAT(IBCAT)) Q:IBCAT="" D
. S IBDIV=0
. I IBSDV,$$CATCHK(IBCAT) D Q ;IB*2.0*618
. . F S IBDIV=$O(VAUTD(IBDIV)) Q:IBDIV="" D INIT^IBJDF63
. D INIT^IBJDF63
;
; - 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("Miscellaneous Bills Follow-Up Report")
. S IBAR=$G(^PRCA(430,IBA,0)) Q:'IBAR
. S IBCAT=+$P(IBAR,U,2) Q:'$D(IBCAT(IBCAT)) ; Invalid AR category.
. S IBCAT1=IBCAT(IBCAT),IBPDFLG=$$CATCHK(IBCAT)
. I IBPDFLG,'$D(^DGCR(399,IBA,0)) Q ; No claim.
. I IBPDFLG,$P($G(^DGCR(399,IBA,0)),U,13)=7 Q ; Cancelled claim.
. ;
. ; - Get division, if necessary.
. I (IBCAT1>7),(IBCAT1<15) S IBDIV=0 ;IB*2.0*618
. E D
. . I 'IBSDV S IBDIV=0
. . E S IBDIV=$$DIV^IBJDF51(IBA)
. ;
. I IBSDV,IBDIV,'VAUTD Q:'$D(VAUTD(IBDIV)) ; Not a selected division.
. ;
. ; - Get patient or debtor for report.
. I IBRPT="D" S IBPTDB=$$PTDB(IBA) Q:IBPTDB=""
. ;
. ; - Check the receivable age, if necessary.
. I IBRPT="D",IBSMN D I (IBARD)<IBSMN!(IBARD>IBSMX) Q
. . 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 IBRPT="D",IBSAM,IBBA<IBSAM Q
. ;
. ; - Get stats for summary
. I '$G(IBEXCEL) D EN^IBJDF63 Q:IBRPT="S"
. ;
. ; - Get remaining AR/claim info and set indexes for detailed report.
. S (IBFR,IBLP,IBOI,IBTO,IBCLM)="",IBIN=0
. S IBBN=$P(IBAR,U),IBOR=$P(IBAR,U,3),IBDP=$P(IBAR,U,10)
. I IBPDFLG D Q:'IBI!('IBCLM) ;IB*2.0*618
. . S IBI=+$G(^DGCR(399,IBA,"MP")) Q:'IBI ; Get primary ins carrier.
. . S IBIN=$P($G(^DIC(36,IBI,0)),U)_"@@"_IBI,DFN=$P($P(IBPTDB,U),"@@",2)
. . S IBDP=$P(IBAR,U,10),IBCLM=$$CLMACT^IBJD(IBA,IBCAT) Q:IBCLM=""
. . S IBR=$S(+IBCLM=1:$G(^IB($P(IBCLM,U,2),0)),+IBCLM=2:$G(^DGCR(399,IBA,"U")),1:IBDP)
. . S IBFR=$P(IBR,U,$S(+IBCLM=1:14,1:1)),IBTO=$P(IBR,U,$S(+IBCLM=1:15,+IBCLM=2:2,1:1))
. . S IBOI=$$OTH(DFN,$P(IBIN,"@@",2),IBFR) ; Get other insurance carrier.
. . I $G(IBEXCEL) Q
. . I '($D(^TMP("IBJDF6P",$J,IBDIV,IBCAT,IBIN,$P(IBPTDB,U)))#10) D
. . . S ^TMP("IBJDF6P",$J,IBDIV,IBCAT,IBIN,$P(IBPTDB,U))=$P(IBPTDB,U,2)_" "_$P(IBPTDB,U,6)_U_$P(IBPTDB,U,3,4)_U_IBOI
. . S ^TMP("IBJDF6P",$J,IBDIV,IBCAT,IBIN,$P(IBPTDB,U),IBBN)=IBDP_U_IBFR_U_IBTO_U_IBOR_U_IBBA
. I 'IBPDFLG D
. . S IBLP=+$P($$PYMT^IBJD1(IBA),U,2)
. . I '($D(^TMP("IBJDF6D",$J,IBDIV,IBCAT,0,$P(IBPTDB,U)))#10) D
. . . S ^TMP("IBJDF6D",$J,IBDIV,IBCAT,0,$P(IBPTDB,U))=$P(IBPTDB,U,2)_" "_$P(IBPTDB,U,6)
. . S ^TMP("IBJDF6D",$J,IBDIV,IBCAT,0,$P(IBPTDB,U),IBBN)=IBDP_U_$P(IBPTDB,U,5)_U_IBOR_U_IBLP_U_IBBA
. ;
. I '$G(IBEXCEL) D:IBSH COM Q
. ;
. ; - Set up and write line for Excel document.
. S IBDIV=$P($G(^DG(40.8,$S('IBDIV:+$$PRIM^VASITE(),1:IBDIV),0)),U)
. S IBEXCEL1=IBDIV_U_$P($G(^PRCA(430.2,IBCAT,0)),U,2)_U_$S(IBIN=0:"",1:$P(IBIN,"@@"))
. S IBEXCEL1=IBEXCEL1_U_$P(IBPTDB,U,2)_U_$S($P(IBPTDB,"^",6)="*":"E",1:"")_U_$TR($P(IBPTDB,U,4),"-")
. S IBEXCEL1=IBEXCEL1_U_$P(IBPTDB,U,3)_U_IBOI_U_IBBN_U_$$DT^IBJD(IBDP,1)
. S IBEXCEL1=IBEXCEL1_U_$$DT^IBJD(IBFR,1)_U_$$DT^IBJD(IBTO,1)_U_IBOR
. S IBEXCEL1=IBEXCEL1_U_IBLP_U_IBBA_U
. I IBSH D COM ; This will capture the Last Comment Date
. S IBD=$$FMDIFF^XLFDT(DT,$S('$P(IBEXCEL1,U,17):IBDP,1:$G(DAT)))
. S IBEXCEL1=IBEXCEL1_U_IBD W !,IBEXCEL1 K IBD,IBEXCEL1
;
I 'IBQ,'$G(IBEXCEL) D EN^IBJDF62 ; Print the report.
;
ENQ K ^TMP("IBJDF6P",$J),^TMP("IBJDF6D",$J)
I $D(ZTQUEUED) S ZTREQ="@" G ENQ1
;
D ^%ZISC
ENQ1 K IBA,IBA1,IBAR,IBARD,IBCAT,IBCAT1,IBDIV,IBD,IBI,IBIN,IBQ,IBR,IBOI,IBBA
K IBBN,IBCLM,IBDP,IBEXCEL,IBFR,IBLP,IBOR,IBPTDB,IBTO,IBTYP,COM
K COM1,DAT,DFN,J,X,X1,X2,Y,Z
Q
;
PTDB(X) ; - Find Patient/Debtor and decide to include the AR.
; Input: X=Pointer to the AR in file #430 plus all IBS* variables
; Output: Y=Sort key (name or last 4) and Patient/Debtor IEN(file #2)
; ^ Patient/Debtor name (1st 25 chars) ^ Age ^ SSN
; ^ Processed by (File #200) ^ Current VA Employee? (*=Yes)
N AGE,ALL,ARZ,CAT,DEB,DA,DFN,DIC,DIQ,DR,END,IBZ,INI,KEY,NAME,PRC,SSN
N VA,VADM,VAERR,Y,IBPTFLG
;
S Y="" I '$G(X) G PDQ
S DFN=0,ARZ=$G(^PRCA(430,X,0)),CAT=$P(ARZ,"^",2)
S (NAME,AGE,SSN,PRC)=""
;
; - Look for Patient (Medicare,Tort Feasor,Work's Comp,No-Fault Auto Acc)
S IBPTFLG=$$CATCHK(CAT) ;IB*2.0*618
I IBPTFLG D I 'DFN S Y="" G PDQ
. I '$D(^DGCR(399,X,0)) Q
. S IBZ=^DGCR(399,X,0),DFN=+$P(IBZ,"^",2)
. S INI=IBSNF,END=IBSNL,ALL=IBSNA
. D DEM^VADPT S NAME=VADM(1),SSN=$P(VADM(2),"^",2),AGE=VADM(4)
. S KEY=$S(IBSN="N":NAME,1:$P(SSN,"-",3))
. ; - Look for Debtor (All the other Categories)
I 'IBPTFLG D I 'DFN S Y="" G PDQ
. S DIC="^PRCA(430,",DA=X,DR="9;97",DIQ="DEB" D EN^DIQ1
. S DFN=+$P(ARZ,"^",9) I 'DFN Q
. S NAME=$G(DEB(430,DA,9)),PRC=$G(DEB(430,DA,97)),KEY=NAME
. S DIC="^RCD(340,",DA=DFN,DR="110",DIQ="DEB" D EN^DIQ1
. S SSN=$G(DEB(340,DA,110)) S:SSN=-1 SSN=""
. S INI=IBSDF,END=IBSDL,ALL=IBSDA
;
I (INI'="@"&('DFN)) S Y="" G PDQ
I ALL="ALL"&('DFN)!(ALL="NULL"&(DFN)) S Y="" G PDQ
I INI="@",END="zzzzz" G PDC
I INI]KEY!(KEY]END) S Y="" G PDQ
;
S KEY=KEY_"@@"_DFN
PDC S Y=KEY_U_$E(NAME,1,25)_U_AGE_U_SSN_U_PRC_U_$$VAEMP(+$TR(SSN,"-"))
PDQ Q Y
;
PHDL ; - Print the header line for the Excel spreadsheet
N X
S X="Division^Cat.^Prim.Ins.Carrier^Patient/Debtor^VA Empl.?^SSN^Age^"
S X=X_"Other Ins.Carrier^Bill #^Dt Bill prep.^Bill From Dt^Bill To Dt^"
S X=X_"Orig.Amt^Lst Pymt Amt^Curr.Bal.^Lst Comm.Dt^Days Lst Comm."
W !,X
Q
;
VAEMP(SSN) ; - Check if the Patient/Debtor is a current VA Employee
; Input: SSN - Patient/Debtor Social Security Number
;Output: VAEMP - "*":Current VA Employee / "":Not a Current VA Employee
;
N IEN I 'SSN Q ""
S IEN=+$O(^PRSPC("SSN",SSN,0)) Q:'IEN ""
I $P($G(^PRSPC(IEN,1)),U,33)'="Y" Q "*"
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 22 chars.) or null
N Y S Y="" G:'$G(DFN)!('$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 $G(INS),+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,22)
;
OTHQ Q Y
;
COM ; - Get bill comments.
N IBGLB,DAT,IBA1,IBC,COM,COM1,X1,X2
;
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 IBGLB=$S(IBCAT1<8:"IBJDF6P",1:"IBJDF6D") ;IB*2.0*618
. . S ^TMP(IBGLB,$J,IBDIV,IBCAT,IBIN,$P(IBPTDB,U),IBBN,IBA1,X1)=COM(X1)
;
Q
CATCHK(IBCAT) ; Check to see if the AR Category should be a patient or Debtor Category
; Output: 1 - Patient, 0 - Debtor (default)
Q:IBCAT=6 1 ;Worker's Comp
Q:IBCAT=7 1 ;No Fault
Q:IBCAT=10 1 ;Tort
Q:IBCAT=21 1 ;Medicare
I (IBCAT>51),(IBCAT<61) Q 1 ; a WC, TORT or NF category for Community Care
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBJDF61 9576 printed Dec 13, 2024@02:22:58 Page 2
IBJDF61 ;ALB/RB - MISC. BILLS FOLLOW-UP REPORT (COMPILE) ;15-APR-00
+1 ;;2.0;INTEGRATED BILLING;**123,159,356,618**;21-MAR-94;Build 61
+2 ;;Per VHA Directive 6402, this routine should not be modified.
+3 ;
ST ; - Tasked entry point.
+1 KILL IB,IBCAT,^TMP("IBJDF6P",$JOB),^TMP("IBJDF6D",$JOB)
SET IBQ=0
+2 ;Patient (1) or Debtor (0) flag
NEW IBPDFLG
+3 ;
+4 ; - Set selected categories for report.
+5 ; IB*2.0*618 - Added Community Care Misc. Categories
+6 ; MEDICARE
IF IBSEL[",1,"
SET IBCAT(21)=1
+7 ; NO-FAULT AUTO ACCIDENT
IF IBSEL[",2,"
SET IBCAT(7)=2
+8 ; COMMUNITY CARE NO-FAULT AUTO
IF IBSEL[",3,"
Begin DoDot:1
+9 SET IBCAT(52)=3
+10 SET IBCAT(55)=3
+11 SET IBCAT(58)=3
End DoDot:1
+12 ; TORT FEASOR
IF IBSEL[",4,"
SET IBCAT(10)=4
+13 ; COMMUNITY CARE TORT FEASOR
IF IBSEL[",5,"
Begin DoDot:1
+14 SET IBCAT(53)=5
+15 SET IBCAT(56)=5
+16 SET IBCAT(59)=5
End DoDot:1
+17 ; WORKMEN'S COMP
IF IBSEL[6
SET IBCAT(6)=6
+18 ; COMMUNITY CARE NO-FAULT AUTO
IF IBSEL[7
Begin DoDot:1
+19 SET IBCAT(54)=7
+20 SET IBCAT(57)=7
+21 SET IBCAT(60)=7
End DoDot:1
+22 ; CURRENT EMPLOYEE
IF IBSEL[8
SET IBCAT(16)=8
+23 ; EX-EMPLOYEE
IF IBSEL[9
SET IBCAT(15)=9
+24 ; FEDERAL AGENCIES-REFUND
IF IBSEL[10
SET IBCAT(13)=10
+25 ; FEDERAL AGENCIES-REIMBURSEMENT
IF IBSEL[11
SET IBCAT(14)=11
+26 ; MILITARY
IF IBSEL[12
SET IBCAT(12)=12
+27 ; INTERAGENCY
IF IBSEL[13
SET IBCAT(20)=13
+28 ; VENDOR
IF IBSEL[14
SET IBCAT(17)=14
+29 ;
+30 ; Initialize the Summary Information
+31 SET IBCAT=""
FOR
SET IBCAT=$ORDER(IBCAT(IBCAT))
if IBCAT=""
QUIT
Begin DoDot:1
+32 SET IBDIV=0
+33 ;IB*2.0*618
IF IBSDV
IF $$CATCHK(IBCAT)
Begin DoDot:2
+34 FOR
SET IBDIV=$ORDER(VAUTD(IBDIV))
if IBDIV=""
QUIT
DO INIT^IBJDF63
End DoDot:2
QUIT
+35 DO INIT^IBJDF63
End DoDot:1
+36 ;
+37 ; - Print the header line for the Excel spreadsheet
+38 IF $GET(IBEXCEL)
DO PHDL
+39 ;
+40 ; - Find data required for the report.
+41 SET IBA=0
FOR
SET IBA=$ORDER(^PRCA(430,"AC",16,IBA))
if 'IBA
QUIT
Begin DoDot:1
+42 IF IBA#100=0
Begin DoDot:2
+43 SET IBQ=$$STOP^IBOUTL("Miscellaneous Bills Follow-Up Report")
End DoDot:2
if IBQ
QUIT
+44 SET IBAR=$GET(^PRCA(430,IBA,0))
if 'IBAR
QUIT
+45 ; Invalid AR category.
SET IBCAT=+$PIECE(IBAR,U,2)
if '$DATA(IBCAT(IBCAT))
QUIT
+46 SET IBCAT1=IBCAT(IBCAT)
SET IBPDFLG=$$CATCHK(IBCAT)
+47 ; No claim.
IF IBPDFLG
IF '$DATA(^DGCR(399,IBA,0))
QUIT
+48 ; Cancelled claim.
IF IBPDFLG
IF $PIECE($GET(^DGCR(399,IBA,0)),U,13)=7
QUIT
+49 ;
+50 ; - Get division, if necessary.
+51 ;IB*2.0*618
IF (IBCAT1>7)
IF (IBCAT1<15)
SET IBDIV=0
+52 IF '$TEST
Begin DoDot:2
+53 IF 'IBSDV
SET IBDIV=0
+54 IF '$TEST
SET IBDIV=$$DIV^IBJDF51(IBA)
End DoDot:2
+55 ;
+56 ; Not a selected division.
IF IBSDV
IF IBDIV
IF 'VAUTD
if '$DATA(VAUTD(IBDIV))
QUIT
+57 ;
+58 ; - Get patient or debtor for report.
+59 IF IBRPT="D"
SET IBPTDB=$$PTDB(IBA)
if IBPTDB=""
QUIT
+60 ;
+61 ; - Check the receivable age, if necessary.
+62 IF IBRPT="D"
IF IBSMN
Begin DoDot:2
+63 SET IBARD=+$$ACT^IBJDF2(IBA)
if IBARD
SET IBARD=$$FMDIFF^XLFDT(DT,IBARD)
End DoDot:2
IF (IBARD)<IBSMN!(IBARD>IBSMX)
QUIT
+64 ;
+65 ; - Check the minimum balance amount, if necessary.
+66 SET IBBA=0
FOR X=1:1:5
SET IBBA=IBBA+$PIECE($GET(^PRCA(430,IBA,7)),U,X)
+67 IF IBRPT="D"
IF IBSAM
IF IBBA<IBSAM
QUIT
+68 ;
+69 ; - Get stats for summary
+70 IF '$GET(IBEXCEL)
DO EN^IBJDF63
if IBRPT="S"
QUIT
+71 ;
+72 ; - Get remaining AR/claim info and set indexes for detailed report.
+73 SET (IBFR,IBLP,IBOI,IBTO,IBCLM)=""
SET IBIN=0
+74 SET IBBN=$PIECE(IBAR,U)
SET IBOR=$PIECE(IBAR,U,3)
SET IBDP=$PIECE(IBAR,U,10)
+75 ;IB*2.0*618
IF IBPDFLG
Begin DoDot:2
+76 ; Get primary ins carrier.
SET IBI=+$GET(^DGCR(399,IBA,"MP"))
if 'IBI
QUIT
+77 SET IBIN=$PIECE($GET(^DIC(36,IBI,0)),U)_"@@"_IBI
SET DFN=$PIECE($PIECE(IBPTDB,U),"@@",2)
+78 SET IBDP=$PIECE(IBAR,U,10)
SET IBCLM=$$CLMACT^IBJD(IBA,IBCAT)
if IBCLM=""
QUIT
+79 SET IBR=$SELECT(+IBCLM=1:$GET(^IB($PIECE(IBCLM,U,2),0)),+IBCLM=2:$GET(^DGCR(399,IBA,"U")),1:IBDP)
+80 SET IBFR=$PIECE(IBR,U,$SELECT(+IBCLM=1:14,1:1))
SET IBTO=$PIECE(IBR,U,$SELECT(+IBCLM=1:15,+IBCLM=2:2,1:1))
+81 ; Get other insurance carrier.
SET IBOI=$$OTH(DFN,$PIECE(IBIN,"@@",2),IBFR)
+82 IF $GET(IBEXCEL)
QUIT
+83 IF '($DATA(^TMP("IBJDF6P",$JOB,IBDIV,IBCAT,IBIN,$PIECE(IBPTDB,U)))#10)
Begin DoDot:3
+84 SET ^TMP("IBJDF6P",$JOB,IBDIV,IBCAT,IBIN,$PIECE(IBPTDB,U))=$PIECE(IBPTDB,U,2)_" "_$PIECE(IBPTDB,U,6)_U_$PIECE(IBPTDB,U,3,4)_U_IBOI
End DoDot:3
+85 SET ^TMP("IBJDF6P",$JOB,IBDIV,IBCAT,IBIN,$PIECE(IBPTDB,U),IBBN)=IBDP_U_IBFR_U_IBTO_U_IBOR_U_IBBA
End DoDot:2
if 'IBI!('IBCLM)
QUIT
+86 IF 'IBPDFLG
Begin DoDot:2
+87 SET IBLP=+$PIECE($$PYMT^IBJD1(IBA),U,2)
+88 IF '($DATA(^TMP("IBJDF6D",$JOB,IBDIV,IBCAT,0,$PIECE(IBPTDB,U)))#10)
Begin DoDot:3
+89 SET ^TMP("IBJDF6D",$JOB,IBDIV,IBCAT,0,$PIECE(IBPTDB,U))=$PIECE(IBPTDB,U,2)_" "_$PIECE(IBPTDB,U,6)
End DoDot:3
+90 SET ^TMP("IBJDF6D",$JOB,IBDIV,IBCAT,0,$PIECE(IBPTDB,U),IBBN)=IBDP_U_$PIECE(IBPTDB,U,5)_U_IBOR_U_IBLP_U_IBBA
End DoDot:2
+91 ;
+92 IF '$GET(IBEXCEL)
if IBSH
DO COM
QUIT
+93 ;
+94 ; - Set up and write line for Excel document.
+95 SET IBDIV=$PIECE($GET(^DG(40.8,$SELECT('IBDIV:+$$PRIM^VASITE(),1:IBDIV),0)),U)
+96 SET IBEXCEL1=IBDIV_U_$PIECE($GET(^PRCA(430.2,IBCAT,0)),U,2)_U_$SELECT(IBIN=0:"",1:$PIECE(IBIN,"@@"))
+97 SET IBEXCEL1=IBEXCEL1_U_$PIECE(IBPTDB,U,2)_U_$SELECT($PIECE(IBPTDB,"^",6)="*":"E",1:"")_U_$TRANSLATE($PIECE(IBPTDB,U,4),"-")
+98 SET IBEXCEL1=IBEXCEL1_U_$PIECE(IBPTDB,U,3)_U_IBOI_U_IBBN_U_$$DT^IBJD(IBDP,1)
+99 SET IBEXCEL1=IBEXCEL1_U_$$DT^IBJD(IBFR,1)_U_$$DT^IBJD(IBTO,1)_U_IBOR
+100 SET IBEXCEL1=IBEXCEL1_U_IBLP_U_IBBA_U
+101 ; This will capture the Last Comment Date
IF IBSH
DO COM
+102 SET IBD=$$FMDIFF^XLFDT(DT,$SELECT('$PIECE(IBEXCEL1,U,17):IBDP,1:$GET(DAT)))
+103 SET IBEXCEL1=IBEXCEL1_U_IBD
WRITE !,IBEXCEL1
KILL IBD,IBEXCEL1
End DoDot:1
if IBQ
QUIT
+104 ;
+105 ; Print the report.
IF 'IBQ
IF '$GET(IBEXCEL)
DO EN^IBJDF62
+106 ;
ENQ KILL ^TMP("IBJDF6P",$JOB),^TMP("IBJDF6D",$JOB)
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
GOTO ENQ1
+2 ;
+3 DO ^%ZISC
ENQ1 KILL IBA,IBA1,IBAR,IBARD,IBCAT,IBCAT1,IBDIV,IBD,IBI,IBIN,IBQ,IBR,IBOI,IBBA
+1 KILL IBBN,IBCLM,IBDP,IBEXCEL,IBFR,IBLP,IBOR,IBPTDB,IBTO,IBTYP,COM
+2 KILL COM1,DAT,DFN,J,X,X1,X2,Y,Z
+3 QUIT
+4 ;
PTDB(X) ; - Find Patient/Debtor and decide to include the AR.
+1 ; Input: X=Pointer to the AR in file #430 plus all IBS* variables
+2 ; Output: Y=Sort key (name or last 4) and Patient/Debtor IEN(file #2)
+3 ; ^ Patient/Debtor name (1st 25 chars) ^ Age ^ SSN
+4 ; ^ Processed by (File #200) ^ Current VA Employee? (*=Yes)
+5 NEW AGE,ALL,ARZ,CAT,DEB,DA,DFN,DIC,DIQ,DR,END,IBZ,INI,KEY,NAME,PRC,SSN
+6 NEW VA,VADM,VAERR,Y,IBPTFLG
+7 ;
+8 SET Y=""
IF '$GET(X)
GOTO PDQ
+9 SET DFN=0
SET ARZ=$GET(^PRCA(430,X,0))
SET CAT=$PIECE(ARZ,"^",2)
+10 SET (NAME,AGE,SSN,PRC)=""
+11 ;
+12 ; - Look for Patient (Medicare,Tort Feasor,Work's Comp,No-Fault Auto Acc)
+13 ;IB*2.0*618
SET IBPTFLG=$$CATCHK(CAT)
+14 IF IBPTFLG
Begin DoDot:1
+15 IF '$DATA(^DGCR(399,X,0))
QUIT
+16 SET IBZ=^DGCR(399,X,0)
SET DFN=+$PIECE(IBZ,"^",2)
+17 SET INI=IBSNF
SET END=IBSNL
SET ALL=IBSNA
+18 DO DEM^VADPT
SET NAME=VADM(1)
SET SSN=$PIECE(VADM(2),"^",2)
SET AGE=VADM(4)
+19 SET KEY=$SELECT(IBSN="N":NAME,1:$PIECE(SSN,"-",3))
+20 ; - Look for Debtor (All the other Categories)
End DoDot:1
IF 'DFN
SET Y=""
GOTO PDQ
+21 IF 'IBPTFLG
Begin DoDot:1
+22 SET DIC="^PRCA(430,"
SET DA=X
SET DR="9;97"
SET DIQ="DEB"
DO EN^DIQ1
+23 SET DFN=+$PIECE(ARZ,"^",9)
IF 'DFN
QUIT
+24 SET NAME=$GET(DEB(430,DA,9))
SET PRC=$GET(DEB(430,DA,97))
SET KEY=NAME
+25 SET DIC="^RCD(340,"
SET DA=DFN
SET DR="110"
SET DIQ="DEB"
DO EN^DIQ1
+26 SET SSN=$GET(DEB(340,DA,110))
if SSN=-1
SET SSN=""
+27 SET INI=IBSDF
SET END=IBSDL
SET ALL=IBSDA
End DoDot:1
IF 'DFN
SET Y=""
GOTO PDQ
+28 ;
+29 IF (INI'="@"&('DFN))
SET Y=""
GOTO PDQ
+30 IF ALL="ALL"&('DFN)!(ALL="NULL"&(DFN))
SET Y=""
GOTO PDQ
+31 IF INI="@"
IF END="zzzzz"
GOTO PDC
+32 IF INI]KEY!(KEY]END)
SET Y=""
GOTO PDQ
+33 ;
+34 SET KEY=KEY_"@@"_DFN
PDC SET Y=KEY_U_$EXTRACT(NAME,1,25)_U_AGE_U_SSN_U_PRC_U_$$VAEMP(+$TRANSLATE(SSN,"-"))
PDQ QUIT Y
+1 ;
PHDL ; - Print the header line for the Excel spreadsheet
+1 NEW X
+2 SET X="Division^Cat.^Prim.Ins.Carrier^Patient/Debtor^VA Empl.?^SSN^Age^"
+3 SET X=X_"Other Ins.Carrier^Bill #^Dt Bill prep.^Bill From Dt^Bill To Dt^"
+4 SET X=X_"Orig.Amt^Lst Pymt Amt^Curr.Bal.^Lst Comm.Dt^Days Lst Comm."
+5 WRITE !,X
+6 QUIT
+7 ;
VAEMP(SSN) ; - Check if the Patient/Debtor is a current VA Employee
+1 ; Input: SSN - Patient/Debtor Social Security Number
+2 ;Output: VAEMP - "*":Current VA Employee / "":Not a Current VA Employee
+3 ;
+4 NEW IEN
IF 'SSN
QUIT ""
+5 SET IEN=+$ORDER(^PRSPC("SSN",SSN,0))
if 'IEN
QUIT ""
+6 IF $PIECE($GET(^PRSPC(IEN,1)),U,33)'="Y"
QUIT "*"
+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 22 chars.) or null
+5 NEW Y
SET Y=""
if '$GET(DFN)!('$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 $GET(INS)
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,22)
End DoDot:1
if Y]""
QUIT
+10 ;
OTHQ QUIT Y
+1 ;
COM ; - Get bill comments.
+1 NEW IBGLB,DAT,IBA1,IBC,COM,COM1,X1,X2
+2 ;
+3 SET DAT=0
SET IBA1=$SELECT(IBSH1="M":999999999,1:0)
+4 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
+5 SET IBC=$GET(^PRCA(433,IBA1,1))
if 'IBC
QUIT
+6 ; Comment age not minimum.
IF $GET(IBSH2)
IF $$FMDIFF^XLFDT(DT,+IBC)<IBSH2
QUIT
+7 ; Not decrease/comment transact.
IF $PIECE(IBC,U,2)'=35
IF $PIECE(IBC,U,2)'=45
QUIT
+8 SET DAT=$SELECT(IBC:+IBC\1,1:+$PIECE(IBC,U,9)\1)
+9 IF $GET(IBEXCEL)
IF IBSH1="M"
SET IBEXCEL1=IBEXCEL1_$$DT^IBJD(DAT,1)
QUIT
+10 ;
+11 ; - Append brief and transaction comments.
+12 KILL COM,COM1
SET COM(0)=DAT
SET X1=0
+13 SET COM1(1)=$PIECE($GET(^PRCA(433,IBA1,5)),U,2)
+14 SET COM1(2)=$EXTRACT($PIECE($GET(^PRCA(433,IBA1,8)),U,6),1,70)
+15 SET COM(1)=COM1(1)_$SELECT(COM1(1)]""&(COM1(2)]""):"|",1:"")_COM1(2)
+16 IF COM(1)]""
SET COM(1)="**"_COM(1)_"**"
SET X1=1
+17 ;
+18 ; - Get main comments.
+19 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)
+20 ;
+21 SET X1=""
FOR
SET X1=$ORDER(COM(X1))
if X1=""
QUIT
Begin DoDot:2
+22 ;IB*2.0*618
SET IBGLB=$SELECT(IBCAT1<8:"IBJDF6P",1:"IBJDF6D")
+23 SET ^TMP(IBGLB,$JOB,IBDIV,IBCAT,IBIN,$PIECE(IBPTDB,U),IBBN,IBA1,X1)=COM(X1)
End DoDot:2
End DoDot:1
IF IBSH1="M"
IF DAT
QUIT
+24 ;
+25 QUIT
CATCHK(IBCAT) ; Check to see if the AR Category should be a patient or Debtor Category
+1 ; Output: 1 - Patient, 0 - Debtor (default)
+2 ;Worker's Comp
if IBCAT=6
QUIT 1
+3 ;No Fault
if IBCAT=7
QUIT 1
+4 ;Tort
if IBCAT=10
QUIT 1
+5 ;Medicare
if IBCAT=21
QUIT 1
+6 ; a WC, TORT or NF category for Community Care
IF (IBCAT>51)
IF (IBCAT<61)
QUIT 1
+7 QUIT 0
